source/cluster/wham/src-M/energy_p_new.F

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'sizesclu.dat'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15 #ifdef MPL
  16       include 'COMMON.INFO'
  17       external d_vadd
  18       integer ready
  19 #endif
  20       include 'COMMON.FFIELD'
  21       include 'COMMON.DERIV'
  22       include 'COMMON.INTERACT'
  23       include 'COMMON.SBRIDGE'
  24       include 'COMMON.CHAIN'
  25       include 'COMMON.SHIELD'
  26       include 'COMMON.CONTROL'
  27       double precision fact(6)
  28 cd      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  29 cd    print *,'nnt=',nnt,' nct=',nct
  30 C
  31 C Compute the side-chain and electrostatic interaction energy
  32 C
  33       goto (101,102,103,104,105) ipot
  34 C Lennard-Jones potential.
  35   101 call elj(evdw,evdw_t)
  36 cd    print '(a)','Exit ELJ'
  37       goto 106
  38 C Lennard-Jones-Kihara potential (shifted).
  39   102 call eljk(evdw,evdw_t)
  40       goto 106
  41 C Berne-Pechukas potential (dilated LJ, angular dependence).
  42   103 call ebp(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne potential (shifted LJ, angular dependence).
  45   104 call egb(evdw,evdw_t)
  46       goto 106
  47 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  48   105 call egbv(evdw,evdw_t)
  49 C
  50 C Calculate electrostatic (H-bonding) energy of the main chain.
  51 C
  52   106 continue
  53 C      write(iout,*) "shield_mode",shield_mode,ethetacnstr
  54       if (shield_mode.eq.1) then
  55        call set_shield_fac
  56       else if  (shield_mode.eq.2) then
  57        call set_shield_fac2
  58       endif
  59       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  60 C
  61 C Calculate excluded-volume interaction energy between peptide groups
  62 C and side chains.
  63 C
  64       call escp(evdw2,evdw2_14)
  65 c
  66 c Calculate the bond-stretching energy
  67 c
  68       call ebond(estr)
  69 c      write (iout,*) "estr",estr
  70 C
  71 C Calculate the disulfide-bridge and other energy and the contributions
  72 C from other distance constraints.
  73 cd    print *,'Calling EHPB'
  74       call edis(ehpb)
  75 cd    print *,'EHPB exitted succesfully.'
  76 C
  77 C Calculate the virtual-bond-angle energy.
  78 C
  79       call ebend(ebe,ethetacnstr)
  80 cd    print *,'Bend energy finished.'
  81 C
  82 C Calculate the SC local energy.
  83 C
  84       call esc(escloc)
  85 cd    print *,'SCLOC energy finished.'
  86 C
  87 C Calculate the virtual-bond torsional energy.
  88 C
  89 cd    print *,'nterm=',nterm
  90       call etor(etors,edihcnstr,fact(1))
  91 C
  92 C 6/23/01 Calculate double-torsional energy
  93 C
  94       call etor_d(etors_d,fact(2))
  95 C
  96 C 21/5/07 Calculate local sicdechain correlation energy
  97 C
  98       call eback_sc_corr(esccor)
  99
 100       if (wliptran.gt.0) then
 101         call Eliptransfer(eliptran)
 102       endif
 103
 104 C
 105 C 12/1/95 Multi-body terms
 106 C
 107       n_corr=0
 108       n_corr1=0
 109       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 110      &    .or. wturn6.gt.0.0d0) then
 111 c         print *,"calling multibody_eello"
 112          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 113 c         write (*,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 114 c         print *,ecorr,ecorr5,ecorr6,eturn6
 115       else
 116          ecorr=0.0d0
 117          ecorr5=0.0d0
 118          ecorr6=0.0d0
 119          eturn6=0.0d0
 120       endif
 121       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 122          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 123       endif
 124
 125 c      write(iout,*) "TEST_ENE",constr_homology
 126       if (constr_homology.ge.1) then
 127         call e_modeller(ehomology_constr)
 128       else
 129         ehomology_constr=0.0d0
 130       endif
 131 c      write(iout,*) "TEST_ENE",ehomology_constr
 132
 133
 134       write (iout,*) "ft(6)",fact(6),wliptran,eliptran
 135 #ifdef SPLITELE
 136       if (shield_mode.gt.0) then
 137       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 138      & +welec*fact(1)*ees
 139      & +fact(1)*wvdwpp*evdw1
 140      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 141      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 142      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 143      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 144      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 145      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 146      & +wliptran*eliptran
 147       else
 148       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 149      & +wvdwpp*evdw1
 150      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 151      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 152      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 153      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 154      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 155      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 156      & +wliptran*eliptran
 157       endif
 158 #else
 159       if (shield_mode.gt.0) then
 160       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 161      & +welec*fact(1)*(ees+evdw1)
 162      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 163      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 164      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 165      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 166      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 167      & +wbond*estr+wsccor*fact(1)*esccor+ehomology_constr
 168      & +wliptran*eliptran
 169       else
 170       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 171      & +welec*fact(1)*(ees+evdw1)
 172      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 173      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 174      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 175      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 176      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 177      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 178      & +wliptran*eliptran
 179       endif
 180 #endif
 181
 182       energia(0)=etot
 183       energia(1)=evdw
 184 #ifdef SCP14
 185       energia(2)=evdw2-evdw2_14
 186       energia(17)=evdw2_14
 187 #else
 188       energia(2)=evdw2
 189       energia(17)=0.0d0
 190 #endif
 191 #ifdef SPLITELE
 192       energia(3)=ees
 193       energia(16)=evdw1
 194 #else
 195       energia(3)=ees+evdw1
 196       energia(16)=0.0d0
 197 #endif
 198       energia(4)=ecorr
 199       energia(5)=ecorr5
 200       energia(6)=ecorr6
 201       energia(7)=eel_loc
 202       energia(8)=eello_turn3
 203       energia(9)=eello_turn4
 204       energia(10)=eturn6
 205       energia(11)=ebe
 206       energia(12)=escloc
 207       energia(13)=etors
 208       energia(14)=etors_d
 209       energia(15)=ehpb
 210       energia(18)=estr
 211       energia(19)=esccor
 212       energia(20)=edihcnstr
 213       energia(24)=ehomology_constr
 214       energia(21)=evdw_t
 215 c      energia(24)=ethetacnstr
 216       energia(22)=eliptran
 217 c detecting NaNQ
 218 #ifdef ISNAN
 219 #ifdef AIX
 220       if (isnan(etot).ne.0) energia(0)=1.0d+99
 221 #else
 222       if (isnan(etot)) energia(0)=1.0d+99
 223 #endif
 224 #else
 225       i=0
 226 #ifdef WINPGI
 227       idumm=proc_proc(etot,i)
 228 #else
 229       call proc_proc(etot,i)
 230 #endif
 231       if(i.eq.1)energia(0)=1.0d+99
 232 #endif
 233 #ifdef MPL
 234 c     endif
 235 #endif
 236       if (calc_grad) then
 237 C
 238 C Sum up the components of the Cartesian gradient.
 239 C
 240 #ifdef SPLITELE
 241       do i=1,nct
 242         do j=1,3
 243       if (shield_mode.eq.0) then
 244           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 245      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 246      &                wbond*gradb(j,i)+
 247      &                wstrain*ghpbc(j,i)+
 248      &                wcorr*fact(3)*gradcorr(j,i)+
 249      &                wel_loc*fact(2)*gel_loc(j,i)+
 250      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 251      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 252      &                wcorr5*fact(4)*gradcorr5(j,i)+
 253      &                wcorr6*fact(5)*gradcorr6(j,i)+
 254      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 255      &                wsccor*fact(2)*gsccorc(j,i)
 256      &               +wliptran*gliptranc(j,i)
 257           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 258      &                  wbond*gradbx(j,i)+
 259      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 260      &                  wsccor*fact(2)*gsccorx(j,i)
 261      &                 +wliptran*gliptranx(j,i)
 262         else
 263           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 264      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 265      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 266      &                wbond*gradb(j,i)+
 267      &                wstrain*ghpbc(j,i)+
 268      &                wcorr*fact(3)*gradcorr(j,i)+
 269      &                wel_loc*fact(2)*gel_loc(j,i)+
 270      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 271      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 272      &                wcorr5*fact(4)*gradcorr5(j,i)+
 273      &                wcorr6*fact(5)*gradcorr6(j,i)+
 274      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 275      &                wsccor*fact(2)*gsccorc(j,i)
 276      &               +wliptran*gliptranc(j,i)
 277      &                 +welec*gshieldc(j,i)
 278      &                 +welec*gshieldc_loc(j,i)
 279      &                 +wcorr*gshieldc_ec(j,i)
 280      &                 +wcorr*gshieldc_loc_ec(j,i)
 281      &                 +wturn3*gshieldc_t3(j,i)
 282      &                 +wturn3*gshieldc_loc_t3(j,i)
 283      &                 +wturn4*gshieldc_t4(j,i)
 284      &                 +wturn4*gshieldc_loc_t4(j,i)
 285      &                 +wel_loc*gshieldc_ll(j,i)
 286      &                 +wel_loc*gshieldc_loc_ll(j,i)
 287
 288           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 289      &                 +fact(1)*wscp*gradx_scp(j,i)+
 290      &                  wbond*gradbx(j,i)+
 291      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 292      &                  wsccor*fact(2)*gsccorx(j,i)
 293      &                 +wliptran*gliptranx(j,i)
 294      &                 +welec*gshieldx(j,i)
 295      &                 +wcorr*gshieldx_ec(j,i)
 296      &                 +wturn3*gshieldx_t3(j,i)
 297      &                 +wturn4*gshieldx_t4(j,i)
 298      &                 +wel_loc*gshieldx_ll(j,i)
 299
 300
 301         endif
 302         enddo
 303 #else
 304        do i=1,nct
 305         do j=1,3
 306                 if (shield_mode.eq.0) then
 307           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 308      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 309      &                wbond*gradb(j,i)+
 310      &                wcorr*fact(3)*gradcorr(j,i)+
 311      &                wel_loc*fact(2)*gel_loc(j,i)+
 312      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 313      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 314      &                wcorr5*fact(4)*gradcorr5(j,i)+
 315      &                wcorr6*fact(5)*gradcorr6(j,i)+
 316      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 317      &                wsccor*fact(2)*gsccorc(j,i)
 318      &               +wliptran*gliptranc(j,i)
 319           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 320      &                  wbond*gradbx(j,i)+
 321      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 322      &                  wsccor*fact(1)*gsccorx(j,i)
 323      &                 +wliptran*gliptranx(j,i)
 324               else
 325           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 326      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 327      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 328      &                wbond*gradb(j,i)+
 329      &                wcorr*fact(3)*gradcorr(j,i)+
 330      &                wel_loc*fact(2)*gel_loc(j,i)+
 331      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 332      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 333      &                wcorr5*fact(4)*gradcorr5(j,i)+
 334      &                wcorr6*fact(5)*gradcorr6(j,i)+
 335      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 336      &                wsccor*fact(2)*gsccorc(j,i)
 337      &               +wliptran*gliptranc(j,i)
 338           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 339      &                  fact(1)*wscp*gradx_scp(j,i)+
 340      &                  wbond*gradbx(j,i)+
 341      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 342      &                  wsccor*fact(1)*gsccorx(j,i)
 343      &                 +wliptran*gliptranx(j,i)
 344          endif
 345         enddo
 346 #endif
 347       enddo
 348
 349
 350       do i=1,nres-3
 351         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 352      &   +wcorr5*fact(4)*g_corr5_loc(i)
 353      &   +wcorr6*fact(5)*g_corr6_loc(i)
 354      &   +wturn4*fact(3)*gel_loc_turn4(i)
 355      &   +wturn3*fact(2)*gel_loc_turn3(i)
 356      &   +wturn6*fact(5)*gel_loc_turn6(i)
 357      &   +wel_loc*fact(2)*gel_loc_loc(i)
 358 c     &   +wsccor*fact(1)*gsccor_loc(i)
 359 c ROZNICA Z WHAMem
 360       enddo
 361       endif
 362       if (dyn_ss) call dyn_set_nss
 363       return
 364       end
 365 C------------------------------------------------------------------------
 366       subroutine enerprint(energia,fact)
 367       implicit real*8 (a-h,o-z)
 368       include 'DIMENSIONS'
 369       include 'sizesclu.dat'
 370       include 'COMMON.IOUNITS'
 371       include 'COMMON.FFIELD'
 372       include 'COMMON.SBRIDGE'
 373       double precision energia(0:max_ene),fact(6)
 374       etot=energia(0)
 375       evdw=energia(1)+fact(6)*energia(21)
 376 #ifdef SCP14
 377       evdw2=energia(2)+energia(17)
 378 #else
 379       evdw2=energia(2)
 380 #endif
 381       ees=energia(3)
 382 #ifdef SPLITELE
 383       evdw1=energia(16)
 384 #endif
 385       ecorr=energia(4)
 386       ecorr5=energia(5)
 387       ecorr6=energia(6)
 388       eel_loc=energia(7)
 389       eello_turn3=energia(8)
 390       eello_turn4=energia(9)
 391       eello_turn6=energia(10)
 392       ebe=energia(11)
 393       escloc=energia(12)
 394       etors=energia(13)
 395       etors_d=energia(14)
 396       ehpb=energia(15)
 397       esccor=energia(19)
 398       edihcnstr=energia(20)
 399       estr=energia(18)
 400       ehomology_constr=energia(24)
 401 c      ethetacnstr=energia(24)
 402 #ifdef SPLITELE
 403       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 404      &  wvdwpp,
 405      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 406      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 407      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 408      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 409      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 410      &  esccor,wsccor*fact(1),edihcnstr,ehomology_constr,ebr*nss,
 411      &  etot
 412    10 format (/'Virtual-chain energies:'//
 413      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 414      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 415      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 416      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 417      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 418      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 419      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 420      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 421      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 422      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 423      & ' (SS bridges & dist. cnstr.)'/
 424      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 425      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 426      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 427      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 428      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 429      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 430      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 431      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 432      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 433      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 434      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 435      & 'ETOT=  ',1pE16.6,' (total)')
 436 #else
 437       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 438      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 439      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 440      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 441      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 442      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 443      &  edihcnstr,ehomology_constr,ebr*nss,
 444      &  etot
 445    10 format (/'Virtual-chain energies:'//
 446      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 447      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 448      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 449      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 450      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 451      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 452      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 453      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 454      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 455      & ' (SS bridges & dist. cnstr.)'/
 456      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 457      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 458      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 459      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 460      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 461      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 462      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 463      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 464      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 465      & 'H_CONS=',1pE16.6,' (Homology model constraints energy)'/
 466      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 467      & 'ETOT=  ',1pE16.6,' (total)')
 468 #endif
 469       return
 470       end
 471 C-----------------------------------------------------------------------
 472       subroutine elj(evdw,evdw_t)
 473 C
 474 C This subroutine calculates the interaction energy of nonbonded side chains
 475 C assuming the LJ potential of interaction.
 476 C
 477       implicit real*8 (a-h,o-z)
 478       include 'DIMENSIONS'
 479       include 'sizesclu.dat'
 480       include "DIMENSIONS.COMPAR"
 481       parameter (accur=1.0d-10)
 482       include 'COMMON.GEO'
 483       include 'COMMON.VAR'
 484       include 'COMMON.LOCAL'
 485       include 'COMMON.CHAIN'
 486       include 'COMMON.DERIV'
 487       include 'COMMON.INTERACT'
 488       include 'COMMON.TORSION'
 489       include 'COMMON.SBRIDGE'
 490       include 'COMMON.NAMES'
 491       include 'COMMON.IOUNITS'
 492       include 'COMMON.CONTACTS'
 493       dimension gg(3)
 494       integer icant
 495       external icant
 496 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 497 c ROZNICA DODANE Z WHAM
 498 c      do i=1,210
 499 c        do j=1,2
 500 c          eneps_temp(j,i)=0.0d0
 501 c        enddo
 502 c      enddo
 503 cROZNICA
 504
 505       evdw=0.0D0
 506       evdw_t=0.0d0
 507       do i=iatsc_s,iatsc_e
 508         itypi=iabs(itype(i))
 509         if (itypi.eq.ntyp1) cycle
 510         itypi1=iabs(itype(i+1))
 511         xi=c(1,nres+i)
 512         yi=c(2,nres+i)
 513         zi=c(3,nres+i)
 514 C Change 12/1/95
 515         num_conti=0
 516 C
 517 C Calculate SC interaction energy.
 518 C
 519         do iint=1,nint_gr(i)
 520 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 521 cd   &                  'iend=',iend(i,iint)
 522           do j=istart(i,iint),iend(i,iint)
 523             itypj=iabs(itype(j))
 524             if (itypj.eq.ntyp1) cycle
 525             xj=c(1,nres+j)-xi
 526             yj=c(2,nres+j)-yi
 527             zj=c(3,nres+j)-zi
 528 C Change 12/1/95 to calculate four-body interactions
 529             rij=xj*xj+yj*yj+zj*zj
 530             rrij=1.0D0/rij
 531 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 532             eps0ij=eps(itypi,itypj)
 533             fac=rrij**expon2
 534             e1=fac*fac*aa
 535             e2=fac*bb
 536             evdwij=e1+e2
 537             ij=icant(itypi,itypj)
 538 c ROZNICA z WHAM
 539 c            eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 540 c            eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 541 c
 542
 543 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 544 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 545 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 546 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 547 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 548 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 549             if (bb.gt.0.0d0) then
 550               evdw=evdw+evdwij
 551             else
 552               evdw_t=evdw_t+evdwij
 553             endif
 554             if (calc_grad) then
 555 C
 556 C Calculate the components of the gradient in DC and X
 557 C
 558             fac=-rrij*(e1+evdwij)
 559             gg(1)=xj*fac
 560             gg(2)=yj*fac
 561             gg(3)=zj*fac
 562             do k=1,3
 563               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 564               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 565             enddo
 566             do k=i,j-1
 567               do l=1,3
 568                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 569               enddo
 570             enddo
 571             endif
 572 C
 573 C 12/1/95, revised on 5/20/97
 574 C
 575 C Calculate the contact function. The ith column of the array JCONT will
 576 C contain the numbers of atoms that make contacts with the atom I (of numbers
 577 C greater than I). The arrays FACONT and GACONT will contain the values of
 578 C the contact function and its derivative.
 579 C
 580 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 581 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 582 C Uncomment next line, if the correlation interactions are contact function only
 583             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 584               rij=dsqrt(rij)
 585               sigij=sigma(itypi,itypj)
 586               r0ij=rs0(itypi,itypj)
 587 C
 588 C Check whether the SC's are not too far to make a contact.
 589 C
 590               rcut=1.5d0*r0ij
 591               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 592 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 593 C
 594               if (fcont.gt.0.0D0) then
 595 C If the SC-SC distance if close to sigma, apply spline.
 596 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 597 cAdam &             fcont1,fprimcont1)
 598 cAdam           fcont1=1.0d0-fcont1
 599 cAdam           if (fcont1.gt.0.0d0) then
 600 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 601 cAdam             fcont=fcont*fcont1
 602 cAdam           endif
 603 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 604 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 605 cga             do k=1,3
 606 cga               gg(k)=gg(k)*eps0ij
 607 cga             enddo
 608 cga             eps0ij=-evdwij*eps0ij
 609 C Uncomment for AL's type of SC correlation interactions.
 610 cadam           eps0ij=-evdwij
 611                 num_conti=num_conti+1
 612                 jcont(num_conti,i)=j
 613                 facont(num_conti,i)=fcont*eps0ij
 614                 fprimcont=eps0ij*fprimcont/rij
 615                 fcont=expon*fcont
 616 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 617 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 618 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 619 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 620                 gacont(1,num_conti,i)=-fprimcont*xj
 621                 gacont(2,num_conti,i)=-fprimcont*yj
 622                 gacont(3,num_conti,i)=-fprimcont*zj
 623 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 624 cd              write (iout,'(2i3,3f10.5)')
 625 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 626               endif
 627             endif
 628           enddo      ! j
 629         enddo        ! iint
 630 C Change 12/1/95
 631         num_cont(i)=num_conti
 632       enddo          ! i
 633       if (calc_grad) then
 634       do i=1,nct
 635         do j=1,3
 636           gvdwc(j,i)=expon*gvdwc(j,i)
 637           gvdwx(j,i)=expon*gvdwx(j,i)
 638         enddo
 639       enddo
 640       endif
 641 C******************************************************************************
 642 C
 643 C                              N O T E !!!
 644 C
 645 C To save time, the factor of EXPON has been extracted from ALL components
 646 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 647 C use!
 648 C
 649 C******************************************************************************
 650       return
 651       end
 652 C-----------------------------------------------------------------------------
 653       subroutine eljk(evdw,evdw_t)
 654 C
 655 C This subroutine calculates the interaction energy of nonbonded side chains
 656 C assuming the LJK potential of interaction.
 657 C
 658       implicit real*8 (a-h,o-z)
 659       include 'DIMENSIONS'
 660       include 'sizesclu.dat'
 661       include "DIMENSIONS.COMPAR"
 662       include 'COMMON.GEO'
 663       include 'COMMON.VAR'
 664       include 'COMMON.LOCAL'
 665       include 'COMMON.CHAIN'
 666       include 'COMMON.DERIV'
 667       include 'COMMON.INTERACT'
 668       include 'COMMON.IOUNITS'
 669       include 'COMMON.NAMES'
 670       dimension gg(3)
 671       logical scheck
 672       integer icant
 673       external icant
 674 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 675       evdw=0.0D0
 676       evdw_t=0.0d0
 677       do i=iatsc_s,iatsc_e
 678         itypi=iabs(itype(i))
 679         if (itypi.eq.ntyp1) cycle
 680         itypi1=iabs(itype(i+1))
 681         xi=c(1,nres+i)
 682         yi=c(2,nres+i)
 683         zi=c(3,nres+i)
 684 C
 685 C Calculate SC interaction energy.
 686 C
 687         do iint=1,nint_gr(i)
 688           do j=istart(i,iint),iend(i,iint)
 689             itypj=iabs(itype(j))
 690             if (itypj.eq.ntyp1) cycle
 691             xj=c(1,nres+j)-xi
 692             yj=c(2,nres+j)-yi
 693             zj=c(3,nres+j)-zi
 694             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 695             fac_augm=rrij**expon
 696             e_augm=augm(itypi,itypj)*fac_augm
 697             r_inv_ij=dsqrt(rrij)
 698             rij=1.0D0/r_inv_ij
 699             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 700             fac=r_shift_inv**expon
 701             e1=fac*fac*aa
 702             e2=fac*bb
 703             evdwij=e_augm+e1+e2
 704             ij=icant(itypi,itypj)
 705 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 706 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 707 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 708 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 709 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 710 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 711 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 712             if (bb.gt.0.0d0) then
 713               evdw=evdw+evdwij
 714             else
 715               evdw_t=evdw_t+evdwij
 716             endif
 717             if (calc_grad) then
 718 C
 719 C Calculate the components of the gradient in DC and X
 720 C
 721             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 722             gg(1)=xj*fac
 723             gg(2)=yj*fac
 724             gg(3)=zj*fac
 725             do k=1,3
 726               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 727               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 728             enddo
 729             do k=i,j-1
 730               do l=1,3
 731                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 732               enddo
 733             enddo
 734             endif
 735           enddo      ! j
 736         enddo        ! iint
 737       enddo          ! i
 738       if (calc_grad) then
 739       do i=1,nct
 740         do j=1,3
 741           gvdwc(j,i)=expon*gvdwc(j,i)
 742           gvdwx(j,i)=expon*gvdwx(j,i)
 743         enddo
 744       enddo
 745       endif
 746       return
 747       end
 748 C-----------------------------------------------------------------------------
 749       subroutine ebp(evdw,evdw_t)
 750 C
 751 C This subroutine calculates the interaction energy of nonbonded side chains
 752 C assuming the Berne-Pechukas potential of interaction.
 753 C
 754       implicit real*8 (a-h,o-z)
 755       include 'DIMENSIONS'
 756       include 'sizesclu.dat'
 757       include "DIMENSIONS.COMPAR"
 758       include 'COMMON.GEO'
 759       include 'COMMON.VAR'
 760       include 'COMMON.LOCAL'
 761       include 'COMMON.CHAIN'
 762       include 'COMMON.DERIV'
 763       include 'COMMON.NAMES'
 764       include 'COMMON.INTERACT'
 765       include 'COMMON.IOUNITS'
 766       include 'COMMON.CALC'
 767       common /srutu/ icall
 768 c     double precision rrsave(maxdim)
 769       logical lprn
 770       integer icant
 771       external icant
 772       evdw=0.0D0
 773       evdw_t=0.0d0
 774 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 775 c     if (icall.eq.0) then
 776 c       lprn=.true.
 777 c     else
 778         lprn=.false.
 779 c     endif
 780       ind=0
 781       do i=iatsc_s,iatsc_e
 782         itypi=iabs(itype(i))
 783         if (itypi.eq.ntyp1) cycle
 784         itypi1=iabs(itype(i+1))
 785         xi=c(1,nres+i)
 786         yi=c(2,nres+i)
 787         zi=c(3,nres+i)
 788         dxi=dc_norm(1,nres+i)
 789         dyi=dc_norm(2,nres+i)
 790         dzi=dc_norm(3,nres+i)
 791         dsci_inv=vbld_inv(i+nres)
 792 C
 793 C Calculate SC interaction energy.
 794 C
 795         do iint=1,nint_gr(i)
 796           do j=istart(i,iint),iend(i,iint)
 797             ind=ind+1
 798             itypj=iabs(itype(j))
 799             if (itypj.eq.ntyp1) cycle
 800             dscj_inv=vbld_inv(j+nres)
 801             chi1=chi(itypi,itypj)
 802             chi2=chi(itypj,itypi)
 803             chi12=chi1*chi2
 804             chip1=chip(itypi)
 805             chip2=chip(itypj)
 806             chip12=chip1*chip2
 807             alf1=alp(itypi)
 808             alf2=alp(itypj)
 809             alf12=0.5D0*(alf1+alf2)
 810 C For diagnostics only!!!
 811 c           chi1=0.0D0
 812 c           chi2=0.0D0
 813 c           chi12=0.0D0
 814 c           chip1=0.0D0
 815 c           chip2=0.0D0
 816 c           chip12=0.0D0
 817 c           alf1=0.0D0
 818 c           alf2=0.0D0
 819 c           alf12=0.0D0
 820             xj=c(1,nres+j)-xi
 821             yj=c(2,nres+j)-yi
 822             zj=c(3,nres+j)-zi
 823             dxj=dc_norm(1,nres+j)
 824             dyj=dc_norm(2,nres+j)
 825             dzj=dc_norm(3,nres+j)
 826             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 827 cd          if (icall.eq.0) then
 828 cd            rrsave(ind)=rrij
 829 cd          else
 830 cd            rrij=rrsave(ind)
 831 cd          endif
 832             rij=dsqrt(rrij)
 833 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 834             call sc_angular
 835 C Calculate whole angle-dependent part of epsilon and contributions
 836 C to its derivatives
 837             fac=(rrij*sigsq)**expon2
 838             e1=fac*fac*aa
 839             e2=fac*bb
 840             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 841             eps2der=evdwij*eps3rt
 842             eps3der=evdwij*eps2rt
 843             evdwij=evdwij*eps2rt*eps3rt
 844             ij=icant(itypi,itypj)
 845             aux=eps1*eps2rt**2*eps3rt**2
 846             if (bb.gt.0.0d0) then
 847               evdw=evdw+evdwij
 848             else
 849               evdw_t=evdw_t+evdwij
 850             endif
 851             if (calc_grad) then
 852             if (lprn) then
 853             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 854             epsi=bb**2/aa
 855 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 856 cd     &        restyp(itypi),i,restyp(itypj),j,
 857 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 858 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 859 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 860 cd     &        evdwij
 861             endif
 862 C Calculate gradient components.
 863             e1=e1*eps1*eps2rt**2*eps3rt**2
 864             fac=-expon*(e1+evdwij)
 865             sigder=fac/sigsq
 866             fac=rrij*fac
 867 C Calculate radial part of the gradient
 868             gg(1)=xj*fac
 869             gg(2)=yj*fac
 870             gg(3)=zj*fac
 871 C Calculate the angular part of the gradient and sum add the contributions
 872 C to the appropriate components of the Cartesian gradient.
 873             call sc_grad
 874             endif
 875           enddo      ! j
 876         enddo        ! iint
 877       enddo          ! i
 878 c     stop
 879       return
 880       end
 881 C-----------------------------------------------------------------------------
 882       subroutine egb(evdw,evdw_t)
 883 C
 884 C This subroutine calculates the interaction energy of nonbonded side chains
 885 C assuming the Gay-Berne potential of interaction.
 886 C
 887       implicit real*8 (a-h,o-z)
 888       include 'DIMENSIONS'
 889       include 'sizesclu.dat'
 890       include "DIMENSIONS.COMPAR"
 891       include 'COMMON.GEO'
 892       include 'COMMON.VAR'
 893       include 'COMMON.LOCAL'
 894       include 'COMMON.CHAIN'
 895       include 'COMMON.DERIV'
 896       include 'COMMON.NAMES'
 897       include 'COMMON.INTERACT'
 898       include 'COMMON.IOUNITS'
 899       include 'COMMON.CALC'
 900       include 'COMMON.SBRIDGE'
 901       logical lprn
 902       common /srutu/icall
 903       integer icant
 904       external icant
 905       integer xshift,yshift,zshift
 906       logical energy_dec /.false./
 907 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 908       evdw=0.0D0
 909       evdw_t=0.0d0
 910       lprn=.false.
 911 c      if (icall.gt.0) lprn=.true.
 912       ind=0
 913       do i=iatsc_s,iatsc_e
 914         itypi=iabs(itype(i))
 915         if (itypi.eq.ntyp1) cycle
 916         itypi1=iabs(itype(i+1))
 917         xi=c(1,nres+i)
 918         yi=c(2,nres+i)
 919         zi=c(3,nres+i)
 920           xi=mod(xi,boxxsize)
 921           if (xi.lt.0) xi=xi+boxxsize
 922           yi=mod(yi,boxysize)
 923           if (yi.lt.0) yi=yi+boxysize
 924           zi=mod(zi,boxzsize)
 925           if (zi.lt.0) zi=zi+boxzsize
 926        if ((zi.gt.bordlipbot)
 927      &.and.(zi.lt.bordliptop)) then
 928 C the energy transfer exist
 929         if (zi.lt.buflipbot) then
 930 C what fraction I am in
 931          fracinbuf=1.0d0-
 932      &        ((zi-bordlipbot)/lipbufthick)
 933 C lipbufthick is thickenes of lipid buffore
 934          sslipi=sscalelip(fracinbuf)
 935          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
 936         elseif (zi.gt.bufliptop) then
 937          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
 938          sslipi=sscalelip(fracinbuf)
 939          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
 940         else
 941          sslipi=1.0d0
 942          ssgradlipi=0.0
 943         endif
 944        else
 945          sslipi=0.0d0
 946          ssgradlipi=0.0
 947        endif
 948         dxi=dc_norm(1,nres+i)
 949         dyi=dc_norm(2,nres+i)
 950         dzi=dc_norm(3,nres+i)
 951         dsci_inv=vbld_inv(i+nres)
 952 C
 953 C Calculate SC interaction energy.
 954 C
 955         do iint=1,nint_gr(i)
 956           do j=istart(i,iint),iend(i,iint)
 957             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
 958
 959 c              write(iout,*) "PRZED ZWYKLE", evdwij
 960               call dyn_ssbond_ene(i,j,evdwij)
 961 c              write(iout,*) "PO ZWYKLE", evdwij
 962
 963               evdw=evdw+evdwij
 964               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 965      &                        'evdw',i,j,evdwij,' ss'
 966 C triple bond artifac removal
 967              do k=j+1,iend(i,iint)
 968 C search over all next residues
 969               if (dyn_ss_mask(k)) then
 970 C check if they are cysteins
 971 C              write(iout,*) 'k=',k
 972
 973 c              write(iout,*) "PRZED TRI", evdwij
 974                evdwij_przed_tri=evdwij
 975               call triple_ssbond_ene(i,j,k,evdwij)
 976 c               if(evdwij_przed_tri.ne.evdwij) then
 977 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
 978 c               endif
 979
 980 c              write(iout,*) "PO TRI", evdwij
 981 C call the energy function that removes the artifical triple disulfide
 982 C bond the soubroutine is located in ssMD.F
 983               evdw=evdw+evdwij
 984               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
 985      &                        'evdw',i,j,evdwij,'tss'
 986               endif!dyn_ss_mask(k)
 987              enddo! k
 988             ELSE
 989             ind=ind+1
 990             itypj=iabs(itype(j))
 991             if (itypj.eq.ntyp1) cycle
 992             dscj_inv=vbld_inv(j+nres)
 993             sig0ij=sigma(itypi,itypj)
 994             chi1=chi(itypi,itypj)
 995             chi2=chi(itypj,itypi)
 996             chi12=chi1*chi2
 997             chip1=chip(itypi)
 998             chip2=chip(itypj)
 999             chip12=chip1*chip2
1000             alf1=alp(itypi)
1001             alf2=alp(itypj)
1002             alf12=0.5D0*(alf1+alf2)
1003 C For diagnostics only!!!
1004 c           chi1=0.0D0
1005 c           chi2=0.0D0
1006 c           chi12=0.0D0
1007 c           chip1=0.0D0
1008 c           chip2=0.0D0
1009 c           chip12=0.0D0
1010 c           alf1=0.0D0
1011 c           alf2=0.0D0
1012 c           alf12=0.0D0
1013             xj=c(1,nres+j)
1014             yj=c(2,nres+j)
1015             zj=c(3,nres+j)
1016           xj=mod(xj,boxxsize)
1017           if (xj.lt.0) xj=xj+boxxsize
1018           yj=mod(yj,boxysize)
1019           if (yj.lt.0) yj=yj+boxysize
1020           zj=mod(zj,boxzsize)
1021           if (zj.lt.0) zj=zj+boxzsize
1022        if ((zj.gt.bordlipbot)
1023      &.and.(zj.lt.bordliptop)) then
1024 C the energy transfer exist
1025         if (zj.lt.buflipbot) then
1026 C what fraction I am in
1027          fracinbuf=1.0d0-
1028      &        ((zj-bordlipbot)/lipbufthick)
1029 C lipbufthick is thickenes of lipid buffore
1030          sslipj=sscalelip(fracinbuf)
1031          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1032         elseif (zj.gt.bufliptop) then
1033          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1034          sslipj=sscalelip(fracinbuf)
1035          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1036         else
1037          sslipj=1.0d0
1038          ssgradlipj=0.0
1039         endif
1040        else
1041          sslipj=0.0d0
1042          ssgradlipj=0.0
1043        endif
1044       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1045      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1046       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1047      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1048 C      write(iout,*) "czy jest 0", bb-bb_lip(itypi,itypj),
1049 C     & bb-bb_aq(itypi,itypj)
1050       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1051       xj_safe=xj
1052       yj_safe=yj
1053       zj_safe=zj
1054       subchap=0
1055       do xshift=-1,1
1056       do yshift=-1,1
1057       do zshift=-1,1
1058           xj=xj_safe+xshift*boxxsize
1059           yj=yj_safe+yshift*boxysize
1060           zj=zj_safe+zshift*boxzsize
1061           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1062           if(dist_temp.lt.dist_init) then
1063             dist_init=dist_temp
1064             xj_temp=xj
1065             yj_temp=yj
1066             zj_temp=zj
1067             subchap=1
1068           endif
1069        enddo
1070        enddo
1071        enddo
1072        if (subchap.eq.1) then
1073           xj=xj_temp-xi
1074           yj=yj_temp-yi
1075           zj=zj_temp-zi
1076        else
1077           xj=xj_safe-xi
1078           yj=yj_safe-yi
1079           zj=zj_safe-zi
1080        endif
1081             dxj=dc_norm(1,nres+j)
1082             dyj=dc_norm(2,nres+j)
1083             dzj=dc_norm(3,nres+j)
1084 c            write (iout,*) i,j,xj,yj,zj
1085             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1086             rij=dsqrt(rrij)
1087             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1088             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1089             if (sss.le.0.0d0) cycle
1090 C Calculate angle-dependent terms of energy and contributions to their
1091 C derivatives.
1092             call sc_angular
1093             sigsq=1.0D0/sigsq
1094             sig=sig0ij*dsqrt(sigsq)
1095             rij_shift=1.0D0/rij-sig+sig0ij
1096 C I hate to put IF's in the loops, but here don't have another choice!!!!
1097             if (rij_shift.le.0.0D0) then
1098               evdw=1.0D20
1099               return
1100             endif
1101             sigder=-sig*sigsq
1102 c---------------------------------------------------------------
1103             rij_shift=1.0D0/rij_shift
1104             fac=rij_shift**expon
1105             e1=fac*fac*aa
1106             e2=fac*bb
1107             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1108             eps2der=evdwij*eps3rt
1109             eps3der=evdwij*eps2rt
1110             evdwij=evdwij*eps2rt*eps3rt
1111             if (bb.gt.0) then
1112               evdw=evdw+evdwij*sss
1113             else
1114               evdw_t=evdw_t+evdwij*sss
1115             endif
1116             ij=icant(itypi,itypj)
1117             aux=eps1*eps2rt**2*eps3rt**2
1118 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1119 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1120 c     &         aux*e2/eps(itypi,itypj)
1121 c            if (lprn) then
1122             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1123             epsi=bb**2/aa
1124 C#define DEBUG
1125 #ifdef DEBUG
1126 C            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1127 C     &        restyp(itypi),i,restyp(itypj),j,
1128 C     &        epsi,sigm,chi1,chi2,chip1,chip2,
1129 C     &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1130 C     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1131 C     &        evdwij
1132              write (iout,*) "pratial sum", evdw,evdw_t,e1,e2,fac,aa
1133 #endif
1134 C#undef DEBUG
1135 c            endif
1136             if (calc_grad) then
1137 C Calculate gradient components.
1138             e1=e1*eps1*eps2rt**2*eps3rt**2
1139             fac=-expon*(e1+evdwij)*rij_shift
1140             sigder=fac*sigder
1141             fac=rij*fac
1142             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1143             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1144      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1145      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1146      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1147             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1148             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1149 C Calculate the radial part of the gradient
1150             gg(1)=xj*fac
1151             gg(2)=yj*fac
1152             gg(3)=zj*fac
1153 C Calculate angular part of the gradient.
1154             call sc_grad
1155             endif
1156             ENDIF    ! dyn_ss
1157           enddo      ! j
1158         enddo        ! iint
1159       enddo          ! i
1160       return
1161       end
1162 C-----------------------------------------------------------------------------
1163       subroutine egbv(evdw,evdw_t)
1164 C
1165 C This subroutine calculates the interaction energy of nonbonded side chains
1166 C assuming the Gay-Berne-Vorobjev potential of interaction.
1167 C
1168       implicit real*8 (a-h,o-z)
1169       include 'DIMENSIONS'
1170       include 'sizesclu.dat'
1171       include "DIMENSIONS.COMPAR"
1172       include 'COMMON.GEO'
1173       include 'COMMON.VAR'
1174       include 'COMMON.LOCAL'
1175       include 'COMMON.CHAIN'
1176       include 'COMMON.DERIV'
1177       include 'COMMON.NAMES'
1178       include 'COMMON.INTERACT'
1179       include 'COMMON.IOUNITS'
1180       include 'COMMON.CALC'
1181       common /srutu/ icall
1182       logical lprn
1183       integer icant
1184       external icant
1185       evdw=0.0D0
1186       evdw_t=0.0d0
1187 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1188       evdw=0.0D0
1189       lprn=.false.
1190 c      if (icall.gt.0) lprn=.true.
1191       ind=0
1192       do i=iatsc_s,iatsc_e
1193         itypi=iabs(itype(i))
1194         if (itypi.eq.ntyp1) cycle
1195         itypi1=iabs(itype(i+1))
1196         xi=c(1,nres+i)
1197         yi=c(2,nres+i)
1198         zi=c(3,nres+i)
1199         dxi=dc_norm(1,nres+i)
1200         dyi=dc_norm(2,nres+i)
1201         dzi=dc_norm(3,nres+i)
1202         dsci_inv=vbld_inv(i+nres)
1203 C returning the ith atom to box
1204           xi=mod(xi,boxxsize)
1205           if (xi.lt.0) xi=xi+boxxsize
1206           yi=mod(yi,boxysize)
1207           if (yi.lt.0) yi=yi+boxysize
1208           zi=mod(zi,boxzsize)
1209           if (zi.lt.0) zi=zi+boxzsize
1210        if ((zi.gt.bordlipbot)
1211      &.and.(zi.lt.bordliptop)) then
1212 C the energy transfer exist
1213         if (zi.lt.buflipbot) then
1214 C what fraction I am in
1215          fracinbuf=1.0d0-
1216      &        ((zi-bordlipbot)/lipbufthick)
1217 C lipbufthick is thickenes of lipid buffore
1218          sslipi=sscalelip(fracinbuf)
1219          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1220         elseif (zi.gt.bufliptop) then
1221          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1222          sslipi=sscalelip(fracinbuf)
1223          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1224         else
1225          sslipi=1.0d0
1226          ssgradlipi=0.0
1227         endif
1228        else
1229          sslipi=0.0d0
1230          ssgradlipi=0.0
1231        endif
1232 C
1233 C Calculate SC interaction energy.
1234 C
1235         do iint=1,nint_gr(i)
1236           do j=istart(i,iint),iend(i,iint)
1237             ind=ind+1
1238             itypj=iabs(itype(j))
1239             if (itypj.eq.ntyp1) cycle
1240             dscj_inv=vbld_inv(j+nres)
1241             sig0ij=sigma(itypi,itypj)
1242             r0ij=r0(itypi,itypj)
1243             chi1=chi(itypi,itypj)
1244             chi2=chi(itypj,itypi)
1245             chi12=chi1*chi2
1246             chip1=chip(itypi)
1247             chip2=chip(itypj)
1248             chip12=chip1*chip2
1249             alf1=alp(itypi)
1250             alf2=alp(itypj)
1251             alf12=0.5D0*(alf1+alf2)
1252 C For diagnostics only!!!
1253 c           chi1=0.0D0
1254 c           chi2=0.0D0
1255 c           chi12=0.0D0
1256 c           chip1=0.0D0
1257 c           chip2=0.0D0
1258 c           chip12=0.0D0
1259 c           alf1=0.0D0
1260 c           alf2=0.0D0
1261 c           alf12=0.0D0
1262             xj=c(1,nres+j)
1263             yj=c(2,nres+j)
1264             zj=c(3,nres+j)
1265 C returning jth atom to box
1266           xj=mod(xj,boxxsize)
1267           if (xj.lt.0) xj=xj+boxxsize
1268           yj=mod(yj,boxysize)
1269           if (yj.lt.0) yj=yj+boxysize
1270           zj=mod(zj,boxzsize)
1271           if (zj.lt.0) zj=zj+boxzsize
1272        if ((zj.gt.bordlipbot)
1273      &.and.(zj.lt.bordliptop)) then
1274 C the energy transfer exist
1275         if (zj.lt.buflipbot) then
1276 C what fraction I am in
1277          fracinbuf=1.0d0-
1278      &        ((zj-bordlipbot)/lipbufthick)
1279 C lipbufthick is thickenes of lipid buffore
1280          sslipj=sscalelip(fracinbuf)
1281          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1282         elseif (zj.gt.bufliptop) then
1283          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1284          sslipj=sscalelip(fracinbuf)
1285          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1286         else
1287          sslipj=1.0d0
1288          ssgradlipj=0.0
1289         endif
1290        else
1291          sslipj=0.0d0
1292          ssgradlipj=0.0
1293        endif
1294       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1295      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1296       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1297      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1298 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1299 C checking the distance
1300       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1301       xj_safe=xj
1302       yj_safe=yj
1303       zj_safe=zj
1304       subchap=0
1305 C finding the closest
1306       do xshift=-1,1
1307       do yshift=-1,1
1308       do zshift=-1,1
1309           xj=xj_safe+xshift*boxxsize
1310           yj=yj_safe+yshift*boxysize
1311           zj=zj_safe+zshift*boxzsize
1312           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1313           if(dist_temp.lt.dist_init) then
1314             dist_init=dist_temp
1315             xj_temp=xj
1316             yj_temp=yj
1317             zj_temp=zj
1318             subchap=1
1319           endif
1320        enddo
1321        enddo
1322        enddo
1323        if (subchap.eq.1) then
1324           xj=xj_temp-xi
1325           yj=yj_temp-yi
1326           zj=zj_temp-zi
1327        else
1328           xj=xj_safe-xi
1329           yj=yj_safe-yi
1330           zj=zj_safe-zi
1331        endif
1332             dxj=dc_norm(1,nres+j)
1333             dyj=dc_norm(2,nres+j)
1334             dzj=dc_norm(3,nres+j)
1335             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1336             rij=dsqrt(rrij)
1337 C Calculate angle-dependent terms of energy and contributions to their
1338 C derivatives.
1339             call sc_angular
1340             sigsq=1.0D0/sigsq
1341             sig=sig0ij*dsqrt(sigsq)
1342             rij_shift=1.0D0/rij-sig+r0ij
1343 C I hate to put IF's in the loops, but here don't have another choice!!!!
1344             if (rij_shift.le.0.0D0) then
1345               evdw=1.0D20
1346               return
1347             endif
1348             sigder=-sig*sigsq
1349 c---------------------------------------------------------------
1350             rij_shift=1.0D0/rij_shift
1351             fac=rij_shift**expon
1352             e1=fac*fac*aa
1353             e2=fac*bb
1354             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1355             eps2der=evdwij*eps3rt
1356             eps3der=evdwij*eps2rt
1357             fac_augm=rrij**expon
1358             e_augm=augm(itypi,itypj)*fac_augm
1359             evdwij=evdwij*eps2rt*eps3rt
1360             if (bb.gt.0.0d0) then
1361               evdw=evdw+evdwij+e_augm
1362             else
1363               evdw_t=evdw_t+evdwij+e_augm
1364             endif
1365             ij=icant(itypi,itypj)
1366             aux=eps1*eps2rt**2*eps3rt**2
1367 c            if (lprn) then
1368 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1369 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1370 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1371 c     &        restyp(itypi),i,restyp(itypj),j,
1372 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1373 c     &        chi1,chi2,chip1,chip2,
1374 c     &        eps1,eps2rt**2,eps3rt**2,
1375 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1376 c     &        evdwij+e_augm
1377 c            endif
1378             if (calc_grad) then
1379 C Calculate gradient components.
1380             e1=e1*eps1*eps2rt**2*eps3rt**2
1381             fac=-expon*(e1+evdwij)*rij_shift
1382             sigder=fac*sigder
1383             fac=rij*fac-2*expon*rrij*e_augm
1384 C Calculate the radial part of the gradient
1385             gg(1)=xj*fac
1386             gg(2)=yj*fac
1387             gg(3)=zj*fac
1388 C Calculate angular part of the gradient.
1389             call sc_grad
1390             endif
1391           enddo      ! j
1392         enddo        ! iint
1393       enddo          ! i
1394       return
1395       end
1396 C-----------------------------------------------------------------------------
1397       subroutine sc_angular
1398 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1399 C om12. Called by ebp, egb, and egbv.
1400       implicit none
1401       include 'COMMON.CALC'
1402       erij(1)=xj*rij
1403       erij(2)=yj*rij
1404       erij(3)=zj*rij
1405       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1406       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1407       om12=dxi*dxj+dyi*dyj+dzi*dzj
1408       chiom12=chi12*om12
1409 C Calculate eps1(om12) and its derivative in om12
1410       faceps1=1.0D0-om12*chiom12
1411       faceps1_inv=1.0D0/faceps1
1412       eps1=dsqrt(faceps1_inv)
1413 C Following variable is eps1*deps1/dom12
1414       eps1_om12=faceps1_inv*chiom12
1415 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1416 C and om12.
1417       om1om2=om1*om2
1418       chiom1=chi1*om1
1419       chiom2=chi2*om2
1420       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1421       sigsq=1.0D0-facsig*faceps1_inv
1422       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1423       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1424       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1425 C Calculate eps2 and its derivatives in om1, om2, and om12.
1426       chipom1=chip1*om1
1427       chipom2=chip2*om2
1428       chipom12=chip12*om12
1429       facp=1.0D0-om12*chipom12
1430       facp_inv=1.0D0/facp
1431       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1432 C Following variable is the square root of eps2
1433       eps2rt=1.0D0-facp1*facp_inv
1434 C Following three variables are the derivatives of the square root of eps
1435 C in om1, om2, and om12.
1436       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1437       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1438       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1439 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1440       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1441 C Calculate whole angle-dependent part of epsilon and contributions
1442 C to its derivatives
1443       return
1444       end
1445 C----------------------------------------------------------------------------
1446       subroutine sc_grad
1447       implicit real*8 (a-h,o-z)
1448       include 'DIMENSIONS'
1449       include 'sizesclu.dat'
1450       include 'COMMON.CHAIN'
1451       include 'COMMON.DERIV'
1452       include 'COMMON.CALC'
1453       double precision dcosom1(3),dcosom2(3)
1454       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1455       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1456       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1457      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1458       do k=1,3
1459         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1460         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1461       enddo
1462       do k=1,3
1463         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1464       enddo
1465       do k=1,3
1466         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
1467      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1468      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1469         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipi(k)
1470      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1471      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1472       enddo
1473 C
1474 C Calculate the components of the gradient in DC and X
1475 C
1476       do k=i,j-1
1477         do l=1,3
1478           gvdwc(l,k)=gvdwc(l,k)+gg(l)+gg_lipi(l)
1479         enddo
1480       enddo
1481       do l=1,3
1482          gvdwc(l,j)=gvdwc(l,j)+gg_lipj(l)
1483       enddo
1484       return
1485       end
1486 c------------------------------------------------------------------------------
1487       subroutine vec_and_deriv
1488       implicit real*8 (a-h,o-z)
1489       include 'DIMENSIONS'
1490       include 'sizesclu.dat'
1491       include 'COMMON.IOUNITS'
1492       include 'COMMON.GEO'
1493       include 'COMMON.VAR'
1494       include 'COMMON.LOCAL'
1495       include 'COMMON.CHAIN'
1496       include 'COMMON.VECTORS'
1497       include 'COMMON.DERIV'
1498       include 'COMMON.INTERACT'
1499       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1500 C Compute the local reference systems. For reference system (i), the
1501 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1502 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1503       do i=1,nres-1
1504 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1505           if (i.eq.nres-1) then
1506 C Case of the last full residue
1507 C Compute the Z-axis
1508             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1509             costh=dcos(pi-theta(nres))
1510             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1511             do k=1,3
1512               uz(k,i)=fac*uz(k,i)
1513             enddo
1514             if (calc_grad) then
1515 C Compute the derivatives of uz
1516             uzder(1,1,1)= 0.0d0
1517             uzder(2,1,1)=-dc_norm(3,i-1)
1518             uzder(3,1,1)= dc_norm(2,i-1)
1519             uzder(1,2,1)= dc_norm(3,i-1)
1520             uzder(2,2,1)= 0.0d0
1521             uzder(3,2,1)=-dc_norm(1,i-1)
1522             uzder(1,3,1)=-dc_norm(2,i-1)
1523             uzder(2,3,1)= dc_norm(1,i-1)
1524             uzder(3,3,1)= 0.0d0
1525             uzder(1,1,2)= 0.0d0
1526             uzder(2,1,2)= dc_norm(3,i)
1527             uzder(3,1,2)=-dc_norm(2,i)
1528             uzder(1,2,2)=-dc_norm(3,i)
1529             uzder(2,2,2)= 0.0d0
1530             uzder(3,2,2)= dc_norm(1,i)
1531             uzder(1,3,2)= dc_norm(2,i)
1532             uzder(2,3,2)=-dc_norm(1,i)
1533             uzder(3,3,2)= 0.0d0
1534             endif
1535 C Compute the Y-axis
1536             facy=fac
1537             do k=1,3
1538               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1539             enddo
1540             if (calc_grad) then
1541 C Compute the derivatives of uy
1542             do j=1,3
1543               do k=1,3
1544                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1545      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1546                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1547               enddo
1548               uyder(j,j,1)=uyder(j,j,1)-costh
1549               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1550             enddo
1551             do j=1,2
1552               do k=1,3
1553                 do l=1,3
1554                   uygrad(l,k,j,i)=uyder(l,k,j)
1555                   uzgrad(l,k,j,i)=uzder(l,k,j)
1556                 enddo
1557               enddo
1558             enddo
1559             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1560             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1561             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1562             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1563             endif
1564           else
1565 C Other residues
1566 C Compute the Z-axis
1567             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1568             costh=dcos(pi-theta(i+2))
1569             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1570             do k=1,3
1571               uz(k,i)=fac*uz(k,i)
1572             enddo
1573             if (calc_grad) then
1574 C Compute the derivatives of uz
1575             uzder(1,1,1)= 0.0d0
1576             uzder(2,1,1)=-dc_norm(3,i+1)
1577             uzder(3,1,1)= dc_norm(2,i+1)
1578             uzder(1,2,1)= dc_norm(3,i+1)
1579             uzder(2,2,1)= 0.0d0
1580             uzder(3,2,1)=-dc_norm(1,i+1)
1581             uzder(1,3,1)=-dc_norm(2,i+1)
1582             uzder(2,3,1)= dc_norm(1,i+1)
1583             uzder(3,3,1)= 0.0d0
1584             uzder(1,1,2)= 0.0d0
1585             uzder(2,1,2)= dc_norm(3,i)
1586             uzder(3,1,2)=-dc_norm(2,i)
1587             uzder(1,2,2)=-dc_norm(3,i)
1588             uzder(2,2,2)= 0.0d0
1589             uzder(3,2,2)= dc_norm(1,i)
1590             uzder(1,3,2)= dc_norm(2,i)
1591             uzder(2,3,2)=-dc_norm(1,i)
1592             uzder(3,3,2)= 0.0d0
1593             endif
1594 C Compute the Y-axis
1595             facy=fac
1596             do k=1,3
1597               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1598             enddo
1599             if (calc_grad) then
1600 C Compute the derivatives of uy
1601             do j=1,3
1602               do k=1,3
1603                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1604      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1605                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1606               enddo
1607               uyder(j,j,1)=uyder(j,j,1)-costh
1608               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1609             enddo
1610             do j=1,2
1611               do k=1,3
1612                 do l=1,3
1613                   uygrad(l,k,j,i)=uyder(l,k,j)
1614                   uzgrad(l,k,j,i)=uzder(l,k,j)
1615                 enddo
1616               enddo
1617             enddo
1618             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1619             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1620             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1621             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1622           endif
1623           endif
1624       enddo
1625       if (calc_grad) then
1626       do i=1,nres-1
1627         vbld_inv_temp(1)=vbld_inv(i+1)
1628         if (i.lt.nres-1) then
1629           vbld_inv_temp(2)=vbld_inv(i+2)
1630         else
1631           vbld_inv_temp(2)=vbld_inv(i)
1632         endif
1633         do j=1,2
1634           do k=1,3
1635             do l=1,3
1636               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1637               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1638             enddo
1639           enddo
1640         enddo
1641       enddo
1642       endif
1643       return
1644       end
1645 C-----------------------------------------------------------------------------
1646       subroutine vec_and_deriv_test
1647       implicit real*8 (a-h,o-z)
1648       include 'DIMENSIONS'
1649       include 'sizesclu.dat'
1650       include 'COMMON.IOUNITS'
1651       include 'COMMON.GEO'
1652       include 'COMMON.VAR'
1653       include 'COMMON.LOCAL'
1654       include 'COMMON.CHAIN'
1655       include 'COMMON.VECTORS'
1656       dimension uyder(3,3,2),uzder(3,3,2)
1657 C Compute the local reference systems. For reference system (i), the
1658 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1659 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1660       do i=1,nres-1
1661           if (i.eq.nres-1) then
1662 C Case of the last full residue
1663 C Compute the Z-axis
1664             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1665             costh=dcos(pi-theta(nres))
1666             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1667 c            write (iout,*) 'fac',fac,
1668 c     &        1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1669             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1670             do k=1,3
1671               uz(k,i)=fac*uz(k,i)
1672             enddo
1673 C Compute the derivatives of uz
1674             uzder(1,1,1)= 0.0d0
1675             uzder(2,1,1)=-dc_norm(3,i-1)
1676             uzder(3,1,1)= dc_norm(2,i-1)
1677             uzder(1,2,1)= dc_norm(3,i-1)
1678             uzder(2,2,1)= 0.0d0
1679             uzder(3,2,1)=-dc_norm(1,i-1)
1680             uzder(1,3,1)=-dc_norm(2,i-1)
1681             uzder(2,3,1)= dc_norm(1,i-1)
1682             uzder(3,3,1)= 0.0d0
1683             uzder(1,1,2)= 0.0d0
1684             uzder(2,1,2)= dc_norm(3,i)
1685             uzder(3,1,2)=-dc_norm(2,i)
1686             uzder(1,2,2)=-dc_norm(3,i)
1687             uzder(2,2,2)= 0.0d0
1688             uzder(3,2,2)= dc_norm(1,i)
1689             uzder(1,3,2)= dc_norm(2,i)
1690             uzder(2,3,2)=-dc_norm(1,i)
1691             uzder(3,3,2)= 0.0d0
1692 C Compute the Y-axis
1693             do k=1,3
1694               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1695             enddo
1696             facy=fac
1697             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1698      &       (scalar(dc_norm(1,i-1),dc_norm(1,i-1))**2-
1699      &        scalar(dc_norm(1,i),dc_norm(1,i-1))**2))
1700             do k=1,3
1701 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1702               uy(k,i)=
1703 c     &        facy*(
1704      &        dc_norm(k,i-1)*scalar(dc_norm(1,i),dc_norm(1,i))
1705      &        -scalar(dc_norm(1,i),dc_norm(1,i-1))*dc_norm(k,i)
1706 c     &        )
1707             enddo
1708 c            write (iout,*) 'facy',facy,
1709 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1710             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1711             do k=1,3
1712               uy(k,i)=facy*uy(k,i)
1713             enddo
1714 C Compute the derivatives of uy
1715             do j=1,3
1716               do k=1,3
1717                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1718      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1719                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1720               enddo
1721 c              uyder(j,j,1)=uyder(j,j,1)-costh
1722 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1723               uyder(j,j,1)=uyder(j,j,1)
1724      &          -scalar(dc_norm(1,i),dc_norm(1,i-1))
1725               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1726      &          +uyder(j,j,2)
1727             enddo
1728             do j=1,2
1729               do k=1,3
1730                 do l=1,3
1731                   uygrad(l,k,j,i)=uyder(l,k,j)
1732                   uzgrad(l,k,j,i)=uzder(l,k,j)
1733                 enddo
1734               enddo
1735             enddo
1736             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1737             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1738             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1739             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1740           else
1741 C Other residues
1742 C Compute the Z-axis
1743             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1744             costh=dcos(pi-theta(i+2))
1745             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1746             fac=1.0d0/dsqrt(scalar(uz(1,i),uz(1,i)))
1747             do k=1,3
1748               uz(k,i)=fac*uz(k,i)
1749             enddo
1750 C Compute the derivatives of uz
1751             uzder(1,1,1)= 0.0d0
1752             uzder(2,1,1)=-dc_norm(3,i+1)
1753             uzder(3,1,1)= dc_norm(2,i+1)
1754             uzder(1,2,1)= dc_norm(3,i+1)
1755             uzder(2,2,1)= 0.0d0
1756             uzder(3,2,1)=-dc_norm(1,i+1)
1757             uzder(1,3,1)=-dc_norm(2,i+1)
1758             uzder(2,3,1)= dc_norm(1,i+1)
1759             uzder(3,3,1)= 0.0d0
1760             uzder(1,1,2)= 0.0d0
1761             uzder(2,1,2)= dc_norm(3,i)
1762             uzder(3,1,2)=-dc_norm(2,i)
1763             uzder(1,2,2)=-dc_norm(3,i)
1764             uzder(2,2,2)= 0.0d0
1765             uzder(3,2,2)= dc_norm(1,i)
1766             uzder(1,3,2)= dc_norm(2,i)
1767             uzder(2,3,2)=-dc_norm(1,i)
1768             uzder(3,3,2)= 0.0d0
1769 C Compute the Y-axis
1770             facy=fac
1771             facy=1.0d0/dsqrt(scalar(dc_norm(1,i),dc_norm(1,i))*
1772      &       (scalar(dc_norm(1,i+1),dc_norm(1,i+1))**2-
1773      &        scalar(dc_norm(1,i),dc_norm(1,i+1))**2))
1774             do k=1,3
1775 c              uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1776               uy(k,i)=
1777 c     &        facy*(
1778      &        dc_norm(k,i+1)*scalar(dc_norm(1,i),dc_norm(1,i))
1779      &        -scalar(dc_norm(1,i),dc_norm(1,i+1))*dc_norm(k,i)
1780 c     &        )
1781             enddo
1782 c            write (iout,*) 'facy',facy,
1783 c     &       1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1784             facy=1.0d0/dsqrt(scalar(uy(1,i),uy(1,i)))
1785             do k=1,3
1786               uy(k,i)=facy*uy(k,i)
1787             enddo
1788 C Compute the derivatives of uy
1789             do j=1,3
1790               do k=1,3
1791                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1792      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1793                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1794               enddo
1795 c              uyder(j,j,1)=uyder(j,j,1)-costh
1796 c              uyder(j,j,2)=1.0d0+uyder(j,j,2)
1797               uyder(j,j,1)=uyder(j,j,1)
1798      &          -scalar(dc_norm(1,i),dc_norm(1,i+1))
1799               uyder(j,j,2)=scalar(dc_norm(1,i),dc_norm(1,i))
1800      &          +uyder(j,j,2)
1801             enddo
1802             do j=1,2
1803               do k=1,3
1804                 do l=1,3
1805                   uygrad(l,k,j,i)=uyder(l,k,j)
1806                   uzgrad(l,k,j,i)=uzder(l,k,j)
1807                 enddo
1808               enddo
1809             enddo
1810             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1811             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1812             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1813             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1814           endif
1815       enddo
1816       do i=1,nres-1
1817         do j=1,2
1818           do k=1,3
1819             do l=1,3
1820               uygrad(l,k,j,i)=vblinv*uygrad(l,k,j,i)
1821               uzgrad(l,k,j,i)=vblinv*uzgrad(l,k,j,i)
1822             enddo
1823           enddo
1824         enddo
1825       enddo
1826       return
1827       end
1828 C-----------------------------------------------------------------------------
1829       subroutine check_vecgrad
1830       implicit real*8 (a-h,o-z)
1831       include 'DIMENSIONS'
1832       include 'sizesclu.dat'
1833       include 'COMMON.IOUNITS'
1834       include 'COMMON.GEO'
1835       include 'COMMON.VAR'
1836       include 'COMMON.LOCAL'
1837       include 'COMMON.CHAIN'
1838       include 'COMMON.VECTORS'
1839       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
1840       dimension uyt(3,maxres),uzt(3,maxres)
1841       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
1842       double precision delta /1.0d-7/
1843       call vec_and_deriv
1844 cd      do i=1,nres
1845 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
1846 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
1847 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
1848 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
1849 cd     &     (dc_norm(if90,i),if90=1,3)
1850 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
1851 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
1852 cd          write(iout,'(a)')
1853 cd      enddo
1854       do i=1,nres
1855         do j=1,2
1856           do k=1,3
1857             do l=1,3
1858               uygradt(l,k,j,i)=uygrad(l,k,j,i)
1859               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
1860             enddo
1861           enddo
1862         enddo
1863       enddo
1864       call vec_and_deriv
1865       do i=1,nres
1866         do j=1,3
1867           uyt(j,i)=uy(j,i)
1868           uzt(j,i)=uz(j,i)
1869         enddo
1870       enddo
1871       do i=1,nres
1872 cd        write (iout,*) 'i=',i
1873         do k=1,3
1874           erij(k)=dc_norm(k,i)
1875         enddo
1876         do j=1,3
1877           do k=1,3
1878             dc_norm(k,i)=erij(k)
1879           enddo
1880           dc_norm(j,i)=dc_norm(j,i)+delta
1881 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
1882 c          do k=1,3
1883 c            dc_norm(k,i)=dc_norm(k,i)/fac
1884 c          enddo
1885 c          write (iout,*) (dc_norm(k,i),k=1,3)
1886 c          write (iout,*) (erij(k),k=1,3)
1887           call vec_and_deriv
1888           do k=1,3
1889             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
1890             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
1891             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
1892             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
1893           enddo
1894 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1895 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
1896 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
1897         enddo
1898         do k=1,3
1899           dc_norm(k,i)=erij(k)
1900         enddo
1901 cd        do k=1,3
1902 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1903 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
1904 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
1905 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
1906 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
1907 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
1908 cd          write (iout,'(a)')
1909 cd        enddo
1910       enddo
1911       return
1912       end
1913 C--------------------------------------------------------------------------
1914       subroutine set_matrices
1915       implicit real*8 (a-h,o-z)
1916       include 'DIMENSIONS'
1917       include 'sizesclu.dat'
1918       include 'COMMON.IOUNITS'
1919       include 'COMMON.GEO'
1920       include 'COMMON.VAR'
1921       include 'COMMON.LOCAL'
1922       include 'COMMON.CHAIN'
1923       include 'COMMON.DERIV'
1924       include 'COMMON.INTERACT'
1925       include 'COMMON.CONTACTS'
1926       include 'COMMON.TORSION'
1927       include 'COMMON.VECTORS'
1928       include 'COMMON.FFIELD'
1929       double precision auxvec(2),auxmat(2,2)
1930 C
1931 C Compute the virtual-bond-torsional-angle dependent quantities needed
1932 C to calculate the el-loc multibody terms of various order.
1933 C
1934       do i=3,nres+1
1935         if (i .lt. nres+1) then
1936           sin1=dsin(phi(i))
1937           cos1=dcos(phi(i))
1938           sintab(i-2)=sin1
1939           costab(i-2)=cos1
1940           obrot(1,i-2)=cos1
1941           obrot(2,i-2)=sin1
1942           sin2=dsin(2*phi(i))
1943           cos2=dcos(2*phi(i))
1944           sintab2(i-2)=sin2
1945           costab2(i-2)=cos2
1946           obrot2(1,i-2)=cos2
1947           obrot2(2,i-2)=sin2
1948           Ug(1,1,i-2)=-cos1
1949           Ug(1,2,i-2)=-sin1
1950           Ug(2,1,i-2)=-sin1
1951           Ug(2,2,i-2)= cos1
1952           Ug2(1,1,i-2)=-cos2
1953           Ug2(1,2,i-2)=-sin2
1954           Ug2(2,1,i-2)=-sin2
1955           Ug2(2,2,i-2)= cos2
1956         else
1957           costab(i-2)=1.0d0
1958           sintab(i-2)=0.0d0
1959           obrot(1,i-2)=1.0d0
1960           obrot(2,i-2)=0.0d0
1961           obrot2(1,i-2)=0.0d0
1962           obrot2(2,i-2)=0.0d0
1963           Ug(1,1,i-2)=1.0d0
1964           Ug(1,2,i-2)=0.0d0
1965           Ug(2,1,i-2)=0.0d0
1966           Ug(2,2,i-2)=1.0d0
1967           Ug2(1,1,i-2)=0.0d0
1968           Ug2(1,2,i-2)=0.0d0
1969           Ug2(2,1,i-2)=0.0d0
1970           Ug2(2,2,i-2)=0.0d0
1971         endif
1972         if (i .gt. 3 .and. i .lt. nres+1) then
1973           obrot_der(1,i-2)=-sin1
1974           obrot_der(2,i-2)= cos1
1975           Ugder(1,1,i-2)= sin1
1976           Ugder(1,2,i-2)=-cos1
1977           Ugder(2,1,i-2)=-cos1
1978           Ugder(2,2,i-2)=-sin1
1979           dwacos2=cos2+cos2
1980           dwasin2=sin2+sin2
1981           obrot2_der(1,i-2)=-dwasin2
1982           obrot2_der(2,i-2)= dwacos2
1983           Ug2der(1,1,i-2)= dwasin2
1984           Ug2der(1,2,i-2)=-dwacos2
1985           Ug2der(2,1,i-2)=-dwacos2
1986           Ug2der(2,2,i-2)=-dwasin2
1987         else
1988           obrot_der(1,i-2)=0.0d0
1989           obrot_der(2,i-2)=0.0d0
1990           Ugder(1,1,i-2)=0.0d0
1991           Ugder(1,2,i-2)=0.0d0
1992           Ugder(2,1,i-2)=0.0d0
1993           Ugder(2,2,i-2)=0.0d0
1994           obrot2_der(1,i-2)=0.0d0
1995           obrot2_der(2,i-2)=0.0d0
1996           Ug2der(1,1,i-2)=0.0d0
1997           Ug2der(1,2,i-2)=0.0d0
1998           Ug2der(2,1,i-2)=0.0d0
1999           Ug2der(2,2,i-2)=0.0d0
2000         endif
2001         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2002           if (itype(i-2).le.ntyp) then
2003             iti = itortyp(itype(i-2))
2004           else
2005             iti=ntortyp+1
2006           endif
2007         else
2008           iti=ntortyp+1
2009         endif
2010         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2011           if (itype(i-1).le.ntyp) then
2012             iti1 = itortyp(itype(i-1))
2013           else
2014             iti1=ntortyp+1
2015           endif
2016         else
2017           iti1=ntortyp+1
2018         endif
2019 cd        write (iout,*) '*******i',i,' iti1',iti
2020 cd        write (iout,*) 'b1',b1(:,iti)
2021 cd        write (iout,*) 'b2',b2(:,iti)
2022 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2023 c        print *,"itilde1 i iti iti1",i,iti,iti1
2024         if (i .gt. iatel_s+2) then
2025           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2026           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2027           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2028           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2029           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2030           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2031           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2032         else
2033           do k=1,2
2034             Ub2(k,i-2)=0.0d0
2035             Ctobr(k,i-2)=0.0d0
2036             Dtobr2(k,i-2)=0.0d0
2037             do l=1,2
2038               EUg(l,k,i-2)=0.0d0
2039               CUg(l,k,i-2)=0.0d0
2040               DUg(l,k,i-2)=0.0d0
2041               DtUg2(l,k,i-2)=0.0d0
2042             enddo
2043           enddo
2044         endif
2045 c        print *,"itilde2 i iti iti1",i,iti,iti1
2046         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2047         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2048         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2049         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2050         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2051         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2052         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2053 c        print *,"itilde3 i iti iti1",i,iti,iti1
2054         do k=1,2
2055           muder(k,i-2)=Ub2der(k,i-2)
2056         enddo
2057         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2058           if (itype(i-1).le.ntyp) then
2059             iti1 = itortyp(itype(i-1))
2060           else
2061             iti1=ntortyp+1
2062           endif
2063         else
2064           iti1=ntortyp+1
2065         endif
2066         do k=1,2
2067           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2068         enddo
2069 C Vectors and matrices dependent on a single virtual-bond dihedral.
2070         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2071         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2072         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2073         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2074         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2075         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2076         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2077         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2078         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2079 cd        write (iout,*) 'i',i,' mu ',(mu(k,i-2),k=1,2),
2080 cd     &  ' mu1',(b1(k,i-2),k=1,2),' mu2',(Ub2(k,i-2),k=1,2)
2081       enddo
2082 C Matrices dependent on two consecutive virtual-bond dihedrals.
2083 C The order of matrices is from left to right.
2084       do i=2,nres-1
2085         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2086         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2087         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2088         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2089         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2090         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2091         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2092         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2093       enddo
2094 cd      do i=1,nres
2095 cd        iti = itortyp(itype(i))
2096 cd        write (iout,*) i
2097 cd        do j=1,2
2098 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2099 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2100 cd        enddo
2101 cd      enddo
2102       return
2103       end
2104 C--------------------------------------------------------------------------
2105       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2106 C
2107 C This subroutine calculates the average interaction energy and its gradient
2108 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2109 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2110 C The potential depends both on the distance of peptide-group centers and on
2111 C the orientation of the CA-CA virtual bonds.
2112 C
2113       implicit real*8 (a-h,o-z)
2114       include 'DIMENSIONS'
2115       include 'sizesclu.dat'
2116       include 'COMMON.CONTROL'
2117       include 'COMMON.IOUNITS'
2118       include 'COMMON.GEO'
2119       include 'COMMON.VAR'
2120       include 'COMMON.LOCAL'
2121       include 'COMMON.CHAIN'
2122       include 'COMMON.DERIV'
2123       include 'COMMON.INTERACT'
2124       include 'COMMON.CONTACTS'
2125       include 'COMMON.TORSION'
2126       include 'COMMON.VECTORS'
2127       include 'COMMON.FFIELD'
2128       include 'COMMON.SHIELD'
2129
2130       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2131      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2132       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2133      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2134       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1
2135 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2136       double precision scal_el /0.5d0/
2137 C 12/13/98
2138 C 13-go grudnia roku pamietnego...
2139       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2140      &                   0.0d0,1.0d0,0.0d0,
2141      &                   0.0d0,0.0d0,1.0d0/
2142 cd      write(iout,*) 'In EELEC'
2143 cd      do i=1,nloctyp
2144 cd        write(iout,*) 'Type',i
2145 cd        write(iout,*) 'B1',B1(:,i)
2146 cd        write(iout,*) 'B2',B2(:,i)
2147 cd        write(iout,*) 'CC',CC(:,:,i)
2148 cd        write(iout,*) 'DD',DD(:,:,i)
2149 cd        write(iout,*) 'EE',EE(:,:,i)
2150 cd      enddo
2151 cd      call check_vecgrad
2152 cd      stop
2153       if (icheckgrad.eq.1) then
2154         do i=1,nres-1
2155           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2156           do k=1,3
2157             dc_norm(k,i)=dc(k,i)*fac
2158           enddo
2159 c          write (iout,*) 'i',i,' fac',fac
2160         enddo
2161       endif
2162       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2163      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2164      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2165 cd      if (wel_loc.gt.0.0d0) then
2166         if (icheckgrad.eq.1) then
2167         call vec_and_deriv_test
2168         else
2169         call vec_and_deriv
2170         endif
2171         call set_matrices
2172       endif
2173 cd      do i=1,nres-1
2174 cd        write (iout,*) 'i=',i
2175 cd        do k=1,3
2176 cd          write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2177 cd        enddo
2178 cd        do k=1,3
2179 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2180 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2181 cd        enddo
2182 cd      enddo
2183       num_conti_hb=0
2184       ees=0.0D0
2185       evdw1=0.0D0
2186       eel_loc=0.0d0
2187       eello_turn3=0.0d0
2188       eello_turn4=0.0d0
2189       ind=0
2190       do i=1,nres
2191         num_cont_hb(i)=0
2192       enddo
2193 cd      print '(a)','Enter EELEC'
2194 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2195       do i=1,nres
2196         gel_loc_loc(i)=0.0d0
2197         gcorr_loc(i)=0.0d0
2198       enddo
2199       do i=iatel_s,iatel_e
2200            if (i.le.1) cycle
2201            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2202      &  .or. ((i+2).gt.nres)
2203      &  .or. ((i-1).le.0)
2204      &  .or. itype(i+2).eq.ntyp1
2205      &  .or. itype(i-1).eq.ntyp1
2206      &) cycle
2207 C         endif
2208         if (itel(i).eq.0) goto 1215
2209         dxi=dc(1,i)
2210         dyi=dc(2,i)
2211         dzi=dc(3,i)
2212         dx_normi=dc_norm(1,i)
2213         dy_normi=dc_norm(2,i)
2214         dz_normi=dc_norm(3,i)
2215         xmedi=c(1,i)+0.5d0*dxi
2216         ymedi=c(2,i)+0.5d0*dyi
2217         zmedi=c(3,i)+0.5d0*dzi
2218           xmedi=mod(xmedi,boxxsize)
2219           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2220           ymedi=mod(ymedi,boxysize)
2221           if (ymedi.lt.0) ymedi=ymedi+boxysize
2222           zmedi=mod(zmedi,boxzsize)
2223           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2224         num_conti=0
2225 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2226         do j=ielstart(i),ielend(i)
2227           if (j.le.1) cycle
2228           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2229      & .or.((j+2).gt.nres)
2230      & .or.((j-1).le.0)
2231      & .or.itype(j+2).eq.ntyp1
2232      & .or.itype(j-1).eq.ntyp1
2233      &) cycle
2234 C         endif
2235           if (itel(j).eq.0) goto 1216
2236           ind=ind+1
2237           iteli=itel(i)
2238           itelj=itel(j)
2239           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2240           aaa=app(iteli,itelj)
2241           bbb=bpp(iteli,itelj)
2242 C Diagnostics only!!!
2243 c         aaa=0.0D0
2244 c         bbb=0.0D0
2245 c         ael6i=0.0D0
2246 c         ael3i=0.0D0
2247 C End diagnostics
2248           ael6i=ael6(iteli,itelj)
2249           ael3i=ael3(iteli,itelj)
2250           dxj=dc(1,j)
2251           dyj=dc(2,j)
2252           dzj=dc(3,j)
2253           dx_normj=dc_norm(1,j)
2254           dy_normj=dc_norm(2,j)
2255           dz_normj=dc_norm(3,j)
2256           xj=c(1,j)+0.5D0*dxj
2257           yj=c(2,j)+0.5D0*dyj
2258           zj=c(3,j)+0.5D0*dzj
2259          xj=mod(xj,boxxsize)
2260           if (xj.lt.0) xj=xj+boxxsize
2261           yj=mod(yj,boxysize)
2262           if (yj.lt.0) yj=yj+boxysize
2263           zj=mod(zj,boxzsize)
2264           if (zj.lt.0) zj=zj+boxzsize
2265       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2266       xj_safe=xj
2267       yj_safe=yj
2268       zj_safe=zj
2269       isubchap=0
2270       do xshift=-1,1
2271       do yshift=-1,1
2272       do zshift=-1,1
2273           xj=xj_safe+xshift*boxxsize
2274           yj=yj_safe+yshift*boxysize
2275           zj=zj_safe+zshift*boxzsize
2276           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2277           if(dist_temp.lt.dist_init) then
2278             dist_init=dist_temp
2279             xj_temp=xj
2280             yj_temp=yj
2281             zj_temp=zj
2282             isubchap=1
2283           endif
2284        enddo
2285        enddo
2286        enddo
2287        if (isubchap.eq.1) then
2288           xj=xj_temp-xmedi
2289           yj=yj_temp-ymedi
2290           zj=zj_temp-zmedi
2291        else
2292           xj=xj_safe-xmedi
2293           yj=yj_safe-ymedi
2294           zj=zj_safe-zmedi
2295        endif
2296
2297           rij=xj*xj+yj*yj+zj*zj
2298             sss=sscale(sqrt(rij))
2299             sssgrad=sscagrad(sqrt(rij))
2300           rrmij=1.0D0/rij
2301           rij=dsqrt(rij)
2302           rmij=1.0D0/rij
2303           r3ij=rrmij*rmij
2304           r6ij=r3ij*r3ij
2305           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2306           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2307           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2308           fac=cosa-3.0D0*cosb*cosg
2309           ev1=aaa*r6ij*r6ij
2310 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2311           if (j.eq.i+2) ev1=scal_el*ev1
2312           ev2=bbb*r6ij
2313           fac3=ael6i*r6ij
2314           fac4=ael3i*r3ij
2315           evdwij=ev1+ev2
2316           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2317           el2=fac4*fac
2318           eesij=el1+el2
2319 c          write (iout,*) "i",i,iteli," j",j,itelj," eesij",eesij
2320 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2321           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2322           if (shield_mode.gt.0) then
2323 C          fac_shield(i)=0.4
2324 C          fac_shield(j)=0.6
2325 C#define DEBUG
2326 #ifdef DEBUG
2327           write(iout,*) "ees_compon",i,j,el1,el2,
2328      &    fac_shield(i),fac_shield(j)
2329 #endif
2330 C#undef DEBUG
2331           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2332           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2333           eesij=(el1+el2)
2334           ees=ees+eesij
2335           else
2336           fac_shield(i)=1.0
2337           fac_shield(j)=1.0
2338           eesij=(el1+el2)
2339           ees=ees+eesij
2340           endif
2341 C          ees=ees+eesij
2342           evdw1=evdw1+evdwij*sss
2343 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2344 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2345 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2346 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2347 C
2348 C Calculate contributions to the Cartesian gradient.
2349 C
2350 #ifdef SPLITELE
2351           facvdw=-6*rrmij*(ev1+evdwij)*sss
2352           facel=-3*rrmij*(el1+eesij)
2353           fac1=fac
2354           erij(1)=xj*rmij
2355           erij(2)=yj*rmij
2356           erij(3)=zj*rmij
2357           if (calc_grad) then
2358 *
2359 * Radial derivatives. First process both termini of the fragment (i,j)
2360 *
2361           ggg(1)=facel*xj
2362           ggg(2)=facel*yj
2363           ggg(3)=facel*zj
2364
2365           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2366      &  (shield_mode.gt.0)) then
2367 C          print *,i,j
2368           do ilist=1,ishield_list(i)
2369            iresshield=shield_list(ilist,i)
2370            do k=1,3
2371            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2372      &      *2.0
2373            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2374      &              rlocshield
2375      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2376             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2377 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2378 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2379 C             if (iresshield.gt.i) then
2380 C               do ishi=i+1,iresshield-1
2381 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2382 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2383 C
2384 C              enddo
2385 C             else
2386 C               do ishi=iresshield,i
2387 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2388 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2389 C
2390 C               enddo
2391 C              endif
2392 C           enddo
2393 C          enddo
2394            enddo
2395           enddo
2396           do ilist=1,ishield_list(j)
2397            iresshield=shield_list(ilist,j)
2398            do k=1,3
2399            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2400      &     *2.0
2401            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2402      &              rlocshield
2403      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2404            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2405            enddo
2406           enddo
2407
2408           do k=1,3
2409             gshieldc(k,i)=gshieldc(k,i)+
2410      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2411             gshieldc(k,j)=gshieldc(k,j)+
2412      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2413             gshieldc(k,i-1)=gshieldc(k,i-1)+
2414      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2415             gshieldc(k,j-1)=gshieldc(k,j-1)+
2416      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2417
2418            enddo
2419            endif
2420
2421           do k=1,3
2422             ghalf=0.5D0*ggg(k)
2423             gelc(k,i)=gelc(k,i)+ghalf
2424             gelc(k,j)=gelc(k,j)+ghalf
2425           enddo
2426 *
2427 * Loop over residues i+1 thru j-1.
2428 *
2429           do k=i+1,j-1
2430             do l=1,3
2431               gelc(l,k)=gelc(l,k)+ggg(l)
2432             enddo
2433           enddo
2434 C          ggg(1)=facvdw*xj
2435 C          ggg(2)=facvdw*yj
2436 C          ggg(3)=facvdw*zj
2437           if (sss.gt.0.0) then
2438           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2439           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2440           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2441           else
2442           ggg(1)=0.0
2443           ggg(2)=0.0
2444           ggg(3)=0.0
2445           endif
2446           do k=1,3
2447             ghalf=0.5D0*ggg(k)
2448             gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2449             gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2450           enddo
2451 *
2452 * Loop over residues i+1 thru j-1.
2453 *
2454           do k=i+1,j-1
2455             do l=1,3
2456               gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2457             enddo
2458           enddo
2459 #else
2460           facvdw=(ev1+evdwij)*sss
2461           facel=el1+eesij
2462           fac1=fac
2463           fac=-3*rrmij*(facvdw+facvdw+facel)
2464           erij(1)=xj*rmij
2465           erij(2)=yj*rmij
2466           erij(3)=zj*rmij
2467           if (calc_grad) then
2468 *
2469 * Radial derivatives. First process both termini of the fragment (i,j)
2470 *
2471           ggg(1)=fac*xj
2472           ggg(2)=fac*yj
2473           ggg(3)=fac*zj
2474           do k=1,3
2475             ghalf=0.5D0*ggg(k)
2476             gelc(k,i)=gelc(k,i)+ghalf
2477             gelc(k,j)=gelc(k,j)+ghalf
2478           enddo
2479 *
2480 * Loop over residues i+1 thru j-1.
2481 *
2482           do k=i+1,j-1
2483             do l=1,3
2484               gelc(l,k)=gelc(l,k)+ggg(l)
2485             enddo
2486           enddo
2487 #endif
2488 *
2489 * Angular part
2490 *
2491           ecosa=2.0D0*fac3*fac1+fac4
2492           fac4=-3.0D0*fac4
2493           fac3=-6.0D0*fac3
2494           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2495           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2496           do k=1,3
2497             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2498             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2499           enddo
2500 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2501 cd   &          (dcosg(k),k=1,3)
2502           do k=1,3
2503             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
2504      &      *fac_shield(i)**2*fac_shield(j)**2
2505           enddo
2506           do k=1,3
2507             ghalf=0.5D0*ggg(k)
2508             gelc(k,i)=gelc(k,i)+ghalf
2509      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2510      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2511      &           *fac_shield(i)**2*fac_shield(j)**2
2512
2513             gelc(k,j)=gelc(k,j)+ghalf
2514      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2515      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2516      &           *fac_shield(i)**2*fac_shield(j)**2
2517           enddo
2518           do k=i+1,j-1
2519             do l=1,3
2520               gelc(l,k)=gelc(l,k)+ggg(l)
2521             enddo
2522           enddo
2523           endif
2524
2525           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2526      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2527      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2528 C
2529 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2530 C   energy of a peptide unit is assumed in the form of a second-order
2531 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2532 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2533 C   are computed for EVERY pair of non-contiguous peptide groups.
2534 C
2535           if (j.lt.nres-1) then
2536             j1=j+1
2537             j2=j-1
2538           else
2539             j1=j-1
2540             j2=j-2
2541           endif
2542           kkk=0
2543           do k=1,2
2544             do l=1,2
2545               kkk=kkk+1
2546               muij(kkk)=mu(k,i)*mu(l,j)
2547             enddo
2548           enddo
2549 cd         write (iout,*) 'EELEC: i',i,' j',j
2550 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
2551 cd          write(iout,*) 'muij',muij
2552           ury=scalar(uy(1,i),erij)
2553           urz=scalar(uz(1,i),erij)
2554           vry=scalar(uy(1,j),erij)
2555           vrz=scalar(uz(1,j),erij)
2556           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2557           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2558           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2559           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2560 C For diagnostics only
2561 cd          a22=1.0d0
2562 cd          a23=1.0d0
2563 cd          a32=1.0d0
2564 cd          a33=1.0d0
2565           fac=dsqrt(-ael6i)*r3ij
2566 cd          write (2,*) 'fac=',fac
2567 C For diagnostics only
2568 cd          fac=1.0d0
2569           a22=a22*fac
2570           a23=a23*fac
2571           a32=a32*fac
2572           a33=a33*fac
2573 cd          write (iout,'(4i5,4f10.5)')
2574 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2575 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2576 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') (uy(k,i),k=1,3),
2577 cd     &      (uz(k,i),k=1,3),(uy(k,j),k=1,3),(uz(k,j),k=1,3)
2578 cd          write (iout,'(4f10.5)')
2579 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2580 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2581 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2582 cd           write (iout,'(2i3,9f10.5/)') i,j,
2583 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2584           if (calc_grad) then
2585 C Derivatives of the elements of A in virtual-bond vectors
2586           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2587 cd          do k=1,3
2588 cd            do l=1,3
2589 cd              erder(k,l)=0.0d0
2590 cd            enddo
2591 cd          enddo
2592           do k=1,3
2593             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2594             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2595             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2596             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2597             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2598             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2599             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2600             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2601             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2602             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2603             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2604             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2605           enddo
2606 cd          do k=1,3
2607 cd            do l=1,3
2608 cd              uryg(k,l)=0.0d0
2609 cd              urzg(k,l)=0.0d0
2610 cd              vryg(k,l)=0.0d0
2611 cd              vrzg(k,l)=0.0d0
2612 cd            enddo
2613 cd          enddo
2614 C Compute radial contributions to the gradient
2615           facr=-3.0d0*rrmij
2616           a22der=a22*facr
2617           a23der=a23*facr
2618           a32der=a32*facr
2619           a33der=a33*facr
2620 cd          a22der=0.0d0
2621 cd          a23der=0.0d0
2622 cd          a32der=0.0d0
2623 cd          a33der=0.0d0
2624           agg(1,1)=a22der*xj
2625           agg(2,1)=a22der*yj
2626           agg(3,1)=a22der*zj
2627           agg(1,2)=a23der*xj
2628           agg(2,2)=a23der*yj
2629           agg(3,2)=a23der*zj
2630           agg(1,3)=a32der*xj
2631           agg(2,3)=a32der*yj
2632           agg(3,3)=a32der*zj
2633           agg(1,4)=a33der*xj
2634           agg(2,4)=a33der*yj
2635           agg(3,4)=a33der*zj
2636 C Add the contributions coming from er
2637           fac3=-3.0d0*fac
2638           do k=1,3
2639             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2640             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2641             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2642             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2643           enddo
2644           do k=1,3
2645 C Derivatives in DC(i)
2646             ghalf1=0.5d0*agg(k,1)
2647             ghalf2=0.5d0*agg(k,2)
2648             ghalf3=0.5d0*agg(k,3)
2649             ghalf4=0.5d0*agg(k,4)
2650             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2651      &      -3.0d0*uryg(k,2)*vry)+ghalf1
2652             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2653      &      -3.0d0*uryg(k,2)*vrz)+ghalf2
2654             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2655      &      -3.0d0*urzg(k,2)*vry)+ghalf3
2656             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2657      &      -3.0d0*urzg(k,2)*vrz)+ghalf4
2658 C Derivatives in DC(i+1)
2659             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2660      &      -3.0d0*uryg(k,3)*vry)+agg(k,1)
2661             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2662      &      -3.0d0*uryg(k,3)*vrz)+agg(k,2)
2663             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2664      &      -3.0d0*urzg(k,3)*vry)+agg(k,3)
2665             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2666      &      -3.0d0*urzg(k,3)*vrz)+agg(k,4)
2667 C Derivatives in DC(j)
2668             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2669      &      -3.0d0*vryg(k,2)*ury)+ghalf1
2670             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2671      &      -3.0d0*vrzg(k,2)*ury)+ghalf2
2672             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2673      &      -3.0d0*vryg(k,2)*urz)+ghalf3
2674             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2675      &      -3.0d0*vrzg(k,2)*urz)+ghalf4
2676 C Derivatives in DC(j+1) or DC(nres-1)
2677             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2678      &      -3.0d0*vryg(k,3)*ury)
2679             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2680      &      -3.0d0*vrzg(k,3)*ury)
2681             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2682      &      -3.0d0*vryg(k,3)*urz)
2683             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2684      &      -3.0d0*vrzg(k,3)*urz)
2685 cd            aggi(k,1)=ghalf1
2686 cd            aggi(k,2)=ghalf2
2687 cd            aggi(k,3)=ghalf3
2688 cd            aggi(k,4)=ghalf4
2689 C Derivatives in DC(i+1)
2690 cd            aggi1(k,1)=agg(k,1)
2691 cd            aggi1(k,2)=agg(k,2)
2692 cd            aggi1(k,3)=agg(k,3)
2693 cd            aggi1(k,4)=agg(k,4)
2694 C Derivatives in DC(j)
2695 cd            aggj(k,1)=ghalf1
2696 cd            aggj(k,2)=ghalf2
2697 cd            aggj(k,3)=ghalf3
2698 cd            aggj(k,4)=ghalf4
2699 C Derivatives in DC(j+1)
2700 cd            aggj1(k,1)=0.0d0
2701 cd            aggj1(k,2)=0.0d0
2702 cd            aggj1(k,3)=0.0d0
2703 cd            aggj1(k,4)=0.0d0
2704             if (j.eq.nres-1 .and. i.lt.j-2) then
2705               do l=1,4
2706                 aggj1(k,l)=aggj1(k,l)+agg(k,l)
2707 cd                aggj1(k,l)=agg(k,l)
2708               enddo
2709             endif
2710           enddo
2711           endif
2712 c          goto 11111
2713 C Check the loc-el terms by numerical integration
2714           acipa(1,1)=a22
2715           acipa(1,2)=a23
2716           acipa(2,1)=a32
2717           acipa(2,2)=a33
2718           a22=-a22
2719           a23=-a23
2720           do l=1,2
2721             do k=1,3
2722               agg(k,l)=-agg(k,l)
2723               aggi(k,l)=-aggi(k,l)
2724               aggi1(k,l)=-aggi1(k,l)
2725               aggj(k,l)=-aggj(k,l)
2726               aggj1(k,l)=-aggj1(k,l)
2727             enddo
2728           enddo
2729           if (j.lt.nres-1) then
2730             a22=-a22
2731             a32=-a32
2732             do l=1,3,2
2733               do k=1,3
2734                 agg(k,l)=-agg(k,l)
2735                 aggi(k,l)=-aggi(k,l)
2736                 aggi1(k,l)=-aggi1(k,l)
2737                 aggj(k,l)=-aggj(k,l)
2738                 aggj1(k,l)=-aggj1(k,l)
2739               enddo
2740             enddo
2741           else
2742             a22=-a22
2743             a23=-a23
2744             a32=-a32
2745             a33=-a33
2746             do l=1,4
2747               do k=1,3
2748                 agg(k,l)=-agg(k,l)
2749                 aggi(k,l)=-aggi(k,l)
2750                 aggi1(k,l)=-aggi1(k,l)
2751                 aggj(k,l)=-aggj(k,l)
2752                 aggj1(k,l)=-aggj1(k,l)
2753               enddo
2754             enddo
2755           endif
2756           ENDIF ! WCORR
2757 11111     continue
2758           IF (wel_loc.gt.0.0d0) THEN
2759 C Contribution to the local-electrostatic energy coming from the i-j pair
2760           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2761      &     +a33*muij(4)
2762 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
2763 cd          write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
2764           if (shield_mode.eq.0) then
2765            fac_shield(i)=1.0
2766            fac_shield(j)=1.0
2767 C          else
2768 C           fac_shield(i)=0.4
2769 C           fac_shield(j)=0.6
2770           endif
2771           eel_loc_ij=eel_loc_ij
2772      &    *fac_shield(i)*fac_shield(j)
2773           eel_loc=eel_loc+eel_loc_ij
2774 C Partial derivatives in virtual-bond dihedral angles gamma
2775           if (calc_grad) then
2776           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2777      &  (shield_mode.gt.0)) then
2778 C          print *,i,j
2779
2780           do ilist=1,ishield_list(i)
2781            iresshield=shield_list(ilist,i)
2782            do k=1,3
2783            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2784      &                                          /fac_shield(i)
2785 C     &      *2.0
2786            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2787      &              rlocshield
2788      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2789             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2790      &      +rlocshield
2791            enddo
2792           enddo
2793           do ilist=1,ishield_list(j)
2794            iresshield=shield_list(ilist,j)
2795            do k=1,3
2796            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2797      &                                       /fac_shield(j)
2798 C     &     *2.0
2799            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2800      &              rlocshield
2801      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
2802            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2803      &             +rlocshield
2804
2805            enddo
2806           enddo
2807           do k=1,3
2808             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
2809      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2810             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
2811      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2812             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
2813      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
2814             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
2815      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
2816            enddo
2817            endif
2818           if (i.gt.1)
2819      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
2820      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
2821      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
2822      &    *fac_shield(i)*fac_shield(j)
2823           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
2824      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
2825      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
2826      &    *fac_shield(i)*fac_shield(j)
2827
2828 cd          call checkint3(i,j,mu1,mu2,a22,a23,a32,a33,acipa,eel_loc_ij)
2829 cd          write(iout,*) 'agg  ',agg
2830 cd          write(iout,*) 'aggi ',aggi
2831 cd          write(iout,*) 'aggi1',aggi1
2832 cd          write(iout,*) 'aggj ',aggj
2833 cd          write(iout,*) 'aggj1',aggj1
2834
2835 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
2836           do l=1,3
2837             ggg(l)=agg(l,1)*muij(1)+
2838      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
2839      &    *fac_shield(i)*fac_shield(j)
2840
2841           enddo
2842           do k=i+2,j2
2843             do l=1,3
2844               gel_loc(l,k)=gel_loc(l,k)+ggg(l)
2845             enddo
2846           enddo
2847 C Remaining derivatives of eello
2848           do l=1,3
2849             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
2850      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
2851      &    *fac_shield(i)*fac_shield(j)
2852
2853             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
2854      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
2855      &    *fac_shield(i)*fac_shield(j)
2856
2857             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
2858      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
2859      &    *fac_shield(i)*fac_shield(j)
2860
2861             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
2862      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
2863      &    *fac_shield(i)*fac_shield(j)
2864
2865           enddo
2866           endif
2867           ENDIF
2868           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
2869 C Contributions from turns
2870             a_temp(1,1)=a22
2871             a_temp(1,2)=a23
2872             a_temp(2,1)=a32
2873             a_temp(2,2)=a33
2874             call eturn34(i,j,eello_turn3,eello_turn4)
2875           endif
2876 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
2877           if (j.gt.i+1 .and. num_conti.le.maxconts) then
2878 C
2879 C Calculate the contact function. The ith column of the array JCONT will
2880 C contain the numbers of atoms that make contacts with the atom I (of numbers
2881 C greater than I). The arrays FACONT and GACONT will contain the values of
2882 C the contact function and its derivative.
2883 c           r0ij=1.02D0*rpp(iteli,itelj)
2884 c           r0ij=1.11D0*rpp(iteli,itelj)
2885             r0ij=2.20D0*rpp(iteli,itelj)
2886 c           r0ij=1.55D0*rpp(iteli,itelj)
2887             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
2888             if (fcont.gt.0.0D0) then
2889               num_conti=num_conti+1
2890               if (num_conti.gt.maxconts) then
2891                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
2892      &                         ' will skip next contacts for this conf.'
2893               else
2894                 jcont_hb(num_conti,i)=j
2895                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
2896      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2897 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
2898 C  terms.
2899                 d_cont(num_conti,i)=rij
2900 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
2901 C     --- Electrostatic-interaction matrix ---
2902                 a_chuj(1,1,num_conti,i)=a22
2903                 a_chuj(1,2,num_conti,i)=a23
2904                 a_chuj(2,1,num_conti,i)=a32
2905                 a_chuj(2,2,num_conti,i)=a33
2906 C     --- Gradient of rij
2907                 do kkk=1,3
2908                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
2909                 enddo
2910 c             if (i.eq.1) then
2911 c                a_chuj(1,1,num_conti,i)=-0.61d0
2912 c                a_chuj(1,2,num_conti,i)= 0.4d0
2913 c                a_chuj(2,1,num_conti,i)= 0.65d0
2914 c                a_chuj(2,2,num_conti,i)= 0.50d0
2915 c             else if (i.eq.2) then
2916 c                a_chuj(1,1,num_conti,i)= 0.0d0
2917 c                a_chuj(1,2,num_conti,i)= 0.0d0
2918 c                a_chuj(2,1,num_conti,i)= 0.0d0
2919 c                a_chuj(2,2,num_conti,i)= 0.0d0
2920 c             endif
2921 C     --- and its gradients
2922 cd                write (iout,*) 'i',i,' j',j
2923 cd                do kkk=1,3
2924 cd                write (iout,*) 'iii 1 kkk',kkk
2925 cd                write (iout,*) agg(kkk,:)
2926 cd                enddo
2927 cd                do kkk=1,3
2928 cd                write (iout,*) 'iii 2 kkk',kkk
2929 cd                write (iout,*) aggi(kkk,:)
2930 cd                enddo
2931 cd                do kkk=1,3
2932 cd                write (iout,*) 'iii 3 kkk',kkk
2933 cd                write (iout,*) aggi1(kkk,:)
2934 cd                enddo
2935 cd                do kkk=1,3
2936 cd                write (iout,*) 'iii 4 kkk',kkk
2937 cd                write (iout,*) aggj(kkk,:)
2938 cd                enddo
2939 cd                do kkk=1,3
2940 cd                write (iout,*) 'iii 5 kkk',kkk
2941 cd                write (iout,*) aggj1(kkk,:)
2942 cd                enddo
2943                 kkll=0
2944                 do k=1,2
2945                   do l=1,2
2946                     kkll=kkll+1
2947                     do m=1,3
2948                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
2949                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
2950                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
2951                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
2952                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
2953 c                      do mm=1,5
2954 c                      a_chuj_der(k,l,m,mm,num_conti,i)=0.0d0
2955 c                      enddo
2956                     enddo
2957                   enddo
2958                 enddo
2959                 ENDIF
2960                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
2961 C Calculate contact energies
2962                 cosa4=4.0D0*cosa
2963                 wij=cosa-3.0D0*cosb*cosg
2964                 cosbg1=cosb+cosg
2965                 cosbg2=cosb-cosg
2966 c               fac3=dsqrt(-ael6i)/r0ij**3
2967                 fac3=dsqrt(-ael6i)*r3ij
2968                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
2969                 ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
2970                 if (shield_mode.eq.0) then
2971                 fac_shield(i)=1.0d0
2972                 fac_shield(j)=1.0d0
2973                 else
2974                 ees0plist(num_conti,i)=j
2975 C                fac_shield(i)=0.4d0
2976 C                fac_shield(j)=0.6d0
2977                 endif
2978 c               ees0mij=0.0D0
2979                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
2980      &          *fac_shield(i)*fac_shield(j)
2981
2982                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
2983      &          *fac_shield(i)*fac_shield(j)
2984
2985 C Diagnostics. Comment out or remove after debugging!
2986 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
2987 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
2988 c               ees0m(num_conti,i)=0.0D0
2989 C End diagnostics.
2990 c                write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
2991 c     & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
2992                 facont_hb(num_conti,i)=fcont
2993                 if (calc_grad) then
2994 C Angular derivatives of the contact function
2995                 ees0pij1=fac3/ees0pij
2996                 ees0mij1=fac3/ees0mij
2997                 fac3p=-3.0D0*fac3*rrmij
2998                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
2999                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3000 c               ees0mij1=0.0D0
3001                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3002                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3003                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3004                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3005                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3006                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3007                 ecosap=ecosa1+ecosa2
3008                 ecosbp=ecosb1+ecosb2
3009                 ecosgp=ecosg1+ecosg2
3010                 ecosam=ecosa1-ecosa2
3011                 ecosbm=ecosb1-ecosb2
3012                 ecosgm=ecosg1-ecosg2
3013 C Diagnostics
3014 c               ecosap=ecosa1
3015 c               ecosbp=ecosb1
3016 c               ecosgp=ecosg1
3017 c               ecosam=0.0D0
3018 c               ecosbm=0.0D0
3019 c               ecosgm=0.0D0
3020 C End diagnostics
3021                 fprimcont=fprimcont/rij
3022 cd              facont_hb(num_conti,i)=1.0D0
3023 C Following line is for diagnostics.
3024 cd              fprimcont=0.0D0
3025                 do k=1,3
3026                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3027                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3028                 enddo
3029                 do k=1,3
3030                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3031                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3032                 enddo
3033                 gggp(1)=gggp(1)+ees0pijp*xj
3034                 gggp(2)=gggp(2)+ees0pijp*yj
3035                 gggp(3)=gggp(3)+ees0pijp*zj
3036                 gggm(1)=gggm(1)+ees0mijp*xj
3037                 gggm(2)=gggm(2)+ees0mijp*yj
3038                 gggm(3)=gggm(3)+ees0mijp*zj
3039 C Derivatives due to the contact function
3040                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3041                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3042                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3043                 do k=1,3
3044                   ghalfp=0.5D0*gggp(k)
3045                   ghalfm=0.5D0*gggm(k)
3046                   gacontp_hb1(k,num_conti,i)=ghalfp
3047      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3048      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3049      &          *fac_shield(i)*fac_shield(j)
3050
3051                   gacontp_hb2(k,num_conti,i)=ghalfp
3052      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3053      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3054      &          *fac_shield(i)*fac_shield(j)
3055
3056                   gacontp_hb3(k,num_conti,i)=gggp(k)
3057      &          *fac_shield(i)*fac_shield(j)
3058
3059                   gacontm_hb1(k,num_conti,i)=ghalfm
3060      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3061      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3062      &          *fac_shield(i)*fac_shield(j)
3063
3064                   gacontm_hb2(k,num_conti,i)=ghalfm
3065      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3066      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3067      &          *fac_shield(i)*fac_shield(j)
3068
3069                   gacontm_hb3(k,num_conti,i)=gggm(k)
3070      &          *fac_shield(i)*fac_shield(j)
3071
3072                 enddo
3073                 endif
3074 C Diagnostics. Comment out or remove after debugging!
3075 cdiag           do k=1,3
3076 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3077 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3078 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3079 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3080 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3081 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3082 cdiag           enddo
3083               ENDIF ! wcorr
3084               endif  ! num_conti.le.maxconts
3085             endif  ! fcont.gt.0
3086           endif    ! j.gt.i+1
3087  1216     continue
3088         enddo ! j
3089         num_cont_hb(i)=num_conti
3090  1215   continue
3091       enddo   ! i
3092 cd      do i=1,nres
3093 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3094 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3095 cd      enddo
3096 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3097 ccc      eel_loc=eel_loc+eello_turn3
3098       return
3099       end
3100 C-----------------------------------------------------------------------------
3101       subroutine eturn34(i,j,eello_turn3,eello_turn4)
3102 C Third- and fourth-order contributions from turns
3103       implicit real*8 (a-h,o-z)
3104       include 'DIMENSIONS'
3105       include 'sizesclu.dat'
3106       include 'COMMON.IOUNITS'
3107       include 'COMMON.GEO'
3108       include 'COMMON.VAR'
3109       include 'COMMON.LOCAL'
3110       include 'COMMON.CHAIN'
3111       include 'COMMON.DERIV'
3112       include 'COMMON.INTERACT'
3113       include 'COMMON.CONTACTS'
3114       include 'COMMON.TORSION'
3115       include 'COMMON.VECTORS'
3116       include 'COMMON.FFIELD'
3117       include 'COMMON.SHIELD'
3118       include 'COMMON.CONTROL'
3119
3120       dimension ggg(3)
3121       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3122      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3123      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3124       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3125      &    aggj(3,4),aggj1(3,4),a_temp(2,2)
3126       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,j1,j2
3127       if (j.eq.i+2) then
3128       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3129 C changes suggested by Ana to avoid out of bounds
3130 C     & .or.((i+5).gt.nres)
3131 C     & .or.((i-1).le.0)
3132 C end of changes suggested by Ana
3133      &    .or. itype(i+2).eq.ntyp1
3134      &    .or. itype(i+3).eq.ntyp1
3135 C     &    .or. itype(i+5).eq.ntyp1
3136 C     &    .or. itype(i).eq.ntyp1
3137 C     &    .or. itype(i-1).eq.ntyp1
3138      &    ) goto 179
3139
3140 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3141 C
3142 C               Third-order contributions
3143 C
3144 C                 (i+2)o----(i+3)
3145 C                      | |
3146 C                      | |
3147 C                 (i+1)o----i
3148 C
3149 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3150 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3151         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3152         call transpose2(auxmat(1,1),auxmat1(1,1))
3153         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3154         if (shield_mode.eq.0) then
3155         fac_shield(i)=1.0
3156         fac_shield(j)=1.0
3157 C        else
3158 C        fac_shield(i)=0.4
3159 C        fac_shield(j)=0.6
3160         endif
3161         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3162      &  *fac_shield(i)*fac_shield(j)
3163         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3164      &  *fac_shield(i)*fac_shield(j)
3165
3166 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3167 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3168 cd     &    ' eello_turn3_num',4*eello_turn3_num
3169         if (calc_grad) then
3170 C Derivatives in shield mode
3171           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3172      &  (shield_mode.gt.0)) then
3173 C          print *,i,j
3174
3175           do ilist=1,ishield_list(i)
3176            iresshield=shield_list(ilist,i)
3177            do k=1,3
3178            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3179 C     &      *2.0
3180            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3181      &              rlocshield
3182      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3183             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3184      &      +rlocshield
3185            enddo
3186           enddo
3187           do ilist=1,ishield_list(j)
3188            iresshield=shield_list(ilist,j)
3189            do k=1,3
3190            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3191 C     &     *2.0
3192            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3193      &              rlocshield
3194      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3195            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3196      &             +rlocshield
3197
3198            enddo
3199           enddo
3200
3201           do k=1,3
3202             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3203      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3204             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3205      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3206             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3207      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3208             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3209      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3210            enddo
3211            endif
3212
3213 C Derivatives in gamma(i)
3214         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3215         call transpose2(auxmat2(1,1),pizda(1,1))
3216         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3217         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3218      &   *fac_shield(i)*fac_shield(j)
3219
3220 C Derivatives in gamma(i+1)
3221         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3222         call transpose2(auxmat2(1,1),pizda(1,1))
3223         call matmat2(a_temp(1,1),pizda(1,1),pizda(1,1))
3224         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3225      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3226      &   *fac_shield(i)*fac_shield(j)
3227
3228 C Cartesian derivatives
3229         do l=1,3
3230           a_temp(1,1)=aggi(l,1)
3231           a_temp(1,2)=aggi(l,2)
3232           a_temp(2,1)=aggi(l,3)
3233           a_temp(2,2)=aggi(l,4)
3234           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3235           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3236      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3237      &   *fac_shield(i)*fac_shield(j)
3238
3239           a_temp(1,1)=aggi1(l,1)
3240           a_temp(1,2)=aggi1(l,2)
3241           a_temp(2,1)=aggi1(l,3)
3242           a_temp(2,2)=aggi1(l,4)
3243           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3244           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3245      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3246      &   *fac_shield(i)*fac_shield(j)
3247
3248           a_temp(1,1)=aggj(l,1)
3249           a_temp(1,2)=aggj(l,2)
3250           a_temp(2,1)=aggj(l,3)
3251           a_temp(2,2)=aggj(l,4)
3252           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3253           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3254      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3255      &   *fac_shield(i)*fac_shield(j)
3256
3257           a_temp(1,1)=aggj1(l,1)
3258           a_temp(1,2)=aggj1(l,2)
3259           a_temp(2,1)=aggj1(l,3)
3260           a_temp(2,2)=aggj1(l,4)
3261           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3262           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3263      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3264      &   *fac_shield(i)*fac_shield(j)
3265
3266         enddo
3267         endif
3268   179 continue
3269       else if (j.eq.i+3 .and. itype(i+2).ne.ntyp1) then
3270       if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3271 C changes suggested by Ana to avoid out of bounds
3272 C     & .or.((i+5).gt.nres)
3273 C     & .or.((i-1).le.0)
3274 C end of changes suggested by Ana
3275      &    .or. itype(i+3).eq.ntyp1
3276      &    .or. itype(i+4).eq.ntyp1
3277 C     &    .or. itype(i+5).eq.ntyp1
3278      &    .or. itype(i).eq.ntyp1
3279 C     &    .or. itype(i-1).eq.ntyp1
3280      &    ) goto 178
3281
3282 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3283 C
3284 C               Fourth-order contributions
3285 C
3286 C                 (i+3)o----(i+4)
3287 C                     /  |
3288 C               (i+2)o   |
3289 C                     \  |
3290 C                 (i+1)o----i
3291 C
3292 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3293 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3294         iti1=itortyp(itype(i+1))
3295         iti2=itortyp(itype(i+2))
3296         iti3=itortyp(itype(i+3))
3297         call transpose2(EUg(1,1,i+1),e1t(1,1))
3298         call transpose2(Eug(1,1,i+2),e2t(1,1))
3299         call transpose2(Eug(1,1,i+3),e3t(1,1))
3300         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3301         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3302         s1=scalar2(b1(1,iti2),auxvec(1))
3303         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3304         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3305         s2=scalar2(b1(1,iti1),auxvec(1))
3306         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3307         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3308         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3309         if (shield_mode.eq.0) then
3310         fac_shield(i)=1.0
3311         fac_shield(j)=1.0
3312 C        else
3313 C        fac_shield(i)=0.4
3314 C        fac_shield(j)=0.6
3315         endif
3316         eello_turn4=eello_turn4-(s1+s2+s3)
3317      &  *fac_shield(i)*fac_shield(j)
3318         eello_t4=-(s1+s2+s3)
3319      &  *fac_shield(i)*fac_shield(j)
3320
3321 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3322 cd     &    ' eello_turn4_num',8*eello_turn4_num
3323 C Derivatives in gamma(i)
3324         if (calc_grad) then
3325           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3326      &  (shield_mode.gt.0)) then
3327 C          print *,i,j
3328
3329           do ilist=1,ishield_list(i)
3330            iresshield=shield_list(ilist,i)
3331            do k=1,3
3332            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3333 C     &      *2.0
3334            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3335      &              rlocshield
3336      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3337             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3338      &      +rlocshield
3339            enddo
3340           enddo
3341           do ilist=1,ishield_list(j)
3342            iresshield=shield_list(ilist,j)
3343            do k=1,3
3344            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3345 C     &     *2.0
3346            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3347      &              rlocshield
3348      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3349            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3350      &             +rlocshield
3351
3352            enddo
3353           enddo
3354
3355           do k=1,3
3356             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3357      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3358             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3359      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3360             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3361      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3362             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3363      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3364            enddo
3365            endif
3366
3367         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3368         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3369         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3370         s1=scalar2(b1(1,iti2),auxvec(1))
3371         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3372         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3373         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3374      &  *fac_shield(i)*fac_shield(j)
3375
3376 C Derivatives in gamma(i+1)
3377         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3378         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3379         s2=scalar2(b1(1,iti1),auxvec(1))
3380         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3381         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3382         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3383         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3384      &  *fac_shield(i)*fac_shield(j)
3385
3386 C Derivatives in gamma(i+2)
3387         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3388         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3389         s1=scalar2(b1(1,iti2),auxvec(1))
3390         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3391         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3392         s2=scalar2(b1(1,iti1),auxvec(1))
3393         call matmat2(auxmat(1,1),e2t(1,1),auxmat(1,1))
3394         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3395         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3396         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3397      &  *fac_shield(i)*fac_shield(j)
3398
3399 C Cartesian derivatives
3400 C Derivatives of this turn contributions in DC(i+2)
3401         if (j.lt.nres-1) then
3402           do l=1,3
3403             a_temp(1,1)=agg(l,1)
3404             a_temp(1,2)=agg(l,2)
3405             a_temp(2,1)=agg(l,3)
3406             a_temp(2,2)=agg(l,4)
3407             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3408             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3409             s1=scalar2(b1(1,iti2),auxvec(1))
3410             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3411             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3412             s2=scalar2(b1(1,iti1),auxvec(1))
3413             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3414             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3415             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3416             ggg(l)=-(s1+s2+s3)
3417             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3418      &  *fac_shield(i)*fac_shield(j)
3419
3420           enddo
3421         endif
3422 C Remaining derivatives of this turn contribution
3423         do l=1,3
3424           a_temp(1,1)=aggi(l,1)
3425           a_temp(1,2)=aggi(l,2)
3426           a_temp(2,1)=aggi(l,3)
3427           a_temp(2,2)=aggi(l,4)
3428           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3429           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3430           s1=scalar2(b1(1,iti2),auxvec(1))
3431           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3432           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3433           s2=scalar2(b1(1,iti1),auxvec(1))
3434           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3435           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3436           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3437           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3438      &  *fac_shield(i)*fac_shield(j)
3439
3440           a_temp(1,1)=aggi1(l,1)
3441           a_temp(1,2)=aggi1(l,2)
3442           a_temp(2,1)=aggi1(l,3)
3443           a_temp(2,2)=aggi1(l,4)
3444           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3445           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3446           s1=scalar2(b1(1,iti2),auxvec(1))
3447           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3448           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3449           s2=scalar2(b1(1,iti1),auxvec(1))
3450           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3451           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3452           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3453           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3454      &  *fac_shield(i)*fac_shield(j)
3455
3456           a_temp(1,1)=aggj(l,1)
3457           a_temp(1,2)=aggj(l,2)
3458           a_temp(2,1)=aggj(l,3)
3459           a_temp(2,2)=aggj(l,4)
3460           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3461           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3462           s1=scalar2(b1(1,iti2),auxvec(1))
3463           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3464           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3465           s2=scalar2(b1(1,iti1),auxvec(1))
3466           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3467           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3468           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3469           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3470      &  *fac_shield(i)*fac_shield(j)
3471
3472           a_temp(1,1)=aggj1(l,1)
3473           a_temp(1,2)=aggj1(l,2)
3474           a_temp(2,1)=aggj1(l,3)
3475           a_temp(2,2)=aggj1(l,4)
3476           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3477           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3478           s1=scalar2(b1(1,iti2),auxvec(1))
3479           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3480           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3481           s2=scalar2(b1(1,iti1),auxvec(1))
3482           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3483           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3484           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3485           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3486      &  *fac_shield(i)*fac_shield(j)
3487
3488         enddo
3489         endif
3490   178 continue
3491       endif
3492       return
3493       end
3494 C-----------------------------------------------------------------------------
3495       subroutine vecpr(u,v,w)
3496       implicit real*8(a-h,o-z)
3497       dimension u(3),v(3),w(3)
3498       w(1)=u(2)*v(3)-u(3)*v(2)
3499       w(2)=-u(1)*v(3)+u(3)*v(1)
3500       w(3)=u(1)*v(2)-u(2)*v(1)
3501       return
3502       end
3503 C-----------------------------------------------------------------------------
3504       subroutine unormderiv(u,ugrad,unorm,ungrad)
3505 C This subroutine computes the derivatives of a normalized vector u, given
3506 C the derivatives computed without normalization conditions, ugrad. Returns
3507 C ungrad.
3508       implicit none
3509       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3510       double precision vec(3)
3511       double precision scalar
3512       integer i,j
3513 c      write (2,*) 'ugrad',ugrad
3514 c      write (2,*) 'u',u
3515       do i=1,3
3516         vec(i)=scalar(ugrad(1,i),u(1))
3517       enddo
3518 c      write (2,*) 'vec',vec
3519       do i=1,3
3520         do j=1,3
3521           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3522         enddo
3523       enddo
3524 c      write (2,*) 'ungrad',ungrad
3525       return
3526       end
3527 C-----------------------------------------------------------------------------
3528       subroutine escp(evdw2,evdw2_14)
3529 C
3530 C This subroutine calculates the excluded-volume interaction energy between
3531 C peptide-group centers and side chains and its gradient in virtual-bond and
3532 C side-chain vectors.
3533 C
3534       implicit real*8 (a-h,o-z)
3535       include 'DIMENSIONS'
3536       include 'sizesclu.dat'
3537       include 'COMMON.GEO'
3538       include 'COMMON.VAR'
3539       include 'COMMON.LOCAL'
3540       include 'COMMON.CHAIN'
3541       include 'COMMON.DERIV'
3542       include 'COMMON.INTERACT'
3543       include 'COMMON.FFIELD'
3544       include 'COMMON.IOUNITS'
3545       dimension ggg(3)
3546       evdw2=0.0D0
3547       evdw2_14=0.0d0
3548 cd    print '(a)','Enter ESCP'
3549 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3550 c     &  ' scal14',scal14
3551       do i=iatscp_s,iatscp_e
3552         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3553         iteli=itel(i)
3554 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3555 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3556         if (iteli.eq.0) goto 1225
3557         xi=0.5D0*(c(1,i)+c(1,i+1))
3558         yi=0.5D0*(c(2,i)+c(2,i+1))
3559         zi=0.5D0*(c(3,i)+c(3,i+1))
3560 C    Returning the ith atom to box
3561           xi=mod(xi,boxxsize)
3562           if (xi.lt.0) xi=xi+boxxsize
3563           yi=mod(yi,boxysize)
3564           if (yi.lt.0) yi=yi+boxysize
3565           zi=mod(zi,boxzsize)
3566           if (zi.lt.0) zi=zi+boxzsize
3567
3568         do iint=1,nscp_gr(i)
3569
3570         do j=iscpstart(i,iint),iscpend(i,iint)
3571           itypj=iabs(itype(j))
3572           if (itypj.eq.ntyp1) cycle
3573 C Uncomment following three lines for SC-p interactions
3574 c         xj=c(1,nres+j)-xi
3575 c         yj=c(2,nres+j)-yi
3576 c         zj=c(3,nres+j)-zi
3577 C Uncomment following three lines for Ca-p interactions
3578           xj=c(1,j)
3579           yj=c(2,j)
3580           zj=c(3,j)
3581 C returning the jth atom to box
3582           xj=mod(xj,boxxsize)
3583           if (xj.lt.0) xj=xj+boxxsize
3584           yj=mod(yj,boxysize)
3585           if (yj.lt.0) yj=yj+boxysize
3586           zj=mod(zj,boxzsize)
3587           if (zj.lt.0) zj=zj+boxzsize
3588       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3589       xj_safe=xj
3590       yj_safe=yj
3591       zj_safe=zj
3592       subchap=0
3593 C Finding the closest jth atom
3594       do xshift=-1,1
3595       do yshift=-1,1
3596       do zshift=-1,1
3597           xj=xj_safe+xshift*boxxsize
3598           yj=yj_safe+yshift*boxysize
3599           zj=zj_safe+zshift*boxzsize
3600           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3601           if(dist_temp.lt.dist_init) then
3602             dist_init=dist_temp
3603             xj_temp=xj
3604             yj_temp=yj
3605             zj_temp=zj
3606             subchap=1
3607           endif
3608        enddo
3609        enddo
3610        enddo
3611        if (subchap.eq.1) then
3612           xj=xj_temp-xi
3613           yj=yj_temp-yi
3614           zj=zj_temp-zi
3615        else
3616           xj=xj_safe-xi
3617           yj=yj_safe-yi
3618           zj=zj_safe-zi
3619        endif
3620
3621           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3622 C sss is scaling function for smoothing the cutoff gradient otherwise
3623 C the gradient would not be continuouse
3624           sss=sscale(1.0d0/(dsqrt(rrij)))
3625           if (sss.le.0.0d0) cycle
3626           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3627           fac=rrij**expon2
3628           e1=fac*fac*aad(itypj,iteli)
3629           e2=fac*bad(itypj,iteli)
3630           if (iabs(j-i) .le. 2) then
3631             e1=scal14*e1
3632             e2=scal14*e2
3633             evdw2_14=evdw2_14+(e1+e2)*sss
3634           endif
3635           evdwij=e1+e2
3636 c          write (iout,*) i,j,evdwij
3637           evdw2=evdw2+evdwij*sss
3638           if (calc_grad) then
3639 C
3640 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3641 C
3642            fac=-(evdwij+e1)*rrij*sss
3643            fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
3644           ggg(1)=xj*fac
3645           ggg(2)=yj*fac
3646           ggg(3)=zj*fac
3647           if (j.lt.i) then
3648 cd          write (iout,*) 'j<i'
3649 C Uncomment following three lines for SC-p interactions
3650 c           do k=1,3
3651 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3652 c           enddo
3653           else
3654 cd          write (iout,*) 'j>i'
3655             do k=1,3
3656               ggg(k)=-ggg(k)
3657 C Uncomment following line for SC-p interactions
3658 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3659             enddo
3660           endif
3661           do k=1,3
3662             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3663           enddo
3664           kstart=min0(i+1,j)
3665           kend=max0(i-1,j-1)
3666 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3667 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3668           do k=kstart,kend
3669             do l=1,3
3670               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3671             enddo
3672           enddo
3673           endif
3674         enddo
3675         enddo ! iint
3676  1225   continue
3677       enddo ! i
3678       do i=1,nct
3679         do j=1,3
3680           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
3681           gradx_scp(j,i)=expon*gradx_scp(j,i)
3682         enddo
3683       enddo
3684 C******************************************************************************
3685 C
3686 C                              N O T E !!!
3687 C
3688 C To save time the factor EXPON has been extracted from ALL components
3689 C of GVDWC and GRADX. Remember to multiply them by this factor before further
3690 C use!
3691 C
3692 C******************************************************************************
3693       return
3694       end
3695 C--------------------------------------------------------------------------
3696       subroutine edis(ehpb)
3697 C
3698 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
3699 C
3700       implicit real*8 (a-h,o-z)
3701       include 'DIMENSIONS'
3702       include 'sizesclu.dat'
3703       include 'COMMON.SBRIDGE'
3704       include 'COMMON.CHAIN'
3705       include 'COMMON.DERIV'
3706       include 'COMMON.VAR'
3707       include 'COMMON.INTERACT'
3708       include 'COMMON.CONTROL'
3709       dimension ggg(3)
3710       ehpb=0.0D0
3711 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
3712 cd    print *,'link_start=',link_start,' link_end=',link_end
3713       if (link_end.eq.0) return
3714       do i=link_start,link_end
3715 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
3716 C CA-CA distance used in regularization of structure.
3717         ii=ihpb(i)
3718         jj=jhpb(i)
3719 C iii and jjj point to the residues for which the distance is assigned.
3720         if (ii.gt.nres) then
3721           iii=ii-nres
3722           jjj=jj-nres
3723         else
3724           iii=ii
3725           jjj=jj
3726         endif
3727 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
3728 C    distance and angle dependent SS bond potential.
3729 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3730 C     &  iabs(itype(jjj)).eq.1) then
3731 C          call ssbond_ene(iii,jjj,eij)
3732 C          ehpb=ehpb+2*eij
3733 C        else
3734        if (.not.dyn_ss .and. i.le.nss) then
3735          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
3736      & iabs(itype(jjj)).eq.1) then
3737           call ssbond_ene(iii,jjj,eij)
3738           ehpb=ehpb+2*eij
3739            endif !ii.gt.neres
3740         else if (ii.gt.nres .and. jj.gt.nres) then
3741 c Restraints from contact prediction
3742           dd=dist(ii,jj)
3743           if (constr_dist.eq.11) then
3744 C            ehpb=ehpb+fordepth(i)**4.0d0
3745 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3746             ehpb=ehpb+fordepth(i)**4.0d0
3747      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3748             fac=fordepth(i)**4.0d0
3749      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3750 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3751 C     &    ehpb,fordepth(i),dd
3752 C             print *,"TUTU"
3753 C            write(iout,*) ehpb,"atu?"
3754 C            ehpb,"tu?"
3755 C            fac=fordepth(i)**4.0d0
3756 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3757            else !constr_dist.eq.11
3758           if (dhpb1(i).gt.0.0d0) then
3759             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3760             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3761 c            write (iout,*) "beta nmr",
3762 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3763           else !dhpb(i).gt.0.00
3764
3765 C Calculate the distance between the two points and its difference from the
3766 C target distance.
3767         dd=dist(ii,jj)
3768         rdis=dd-dhpb(i)
3769 C Get the force constant corresponding to this distance.
3770         waga=forcon(i)
3771 C Calculate the contribution to energy.
3772         ehpb=ehpb+waga*rdis*rdis
3773 C
3774 C Evaluate gradient.
3775 C
3776         fac=waga*rdis/dd
3777         endif !dhpb(i).gt.0
3778         endif
3779 cd      print *,'i=',i,' ii=',ii,' jj=',jj,' dhpb=',dhpb(i),' dd=',dd,
3780 cd   &   ' waga=',waga,' fac=',fac
3781         do j=1,3
3782           ggg(j)=fac*(c(j,jj)-c(j,ii))
3783         enddo
3784 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3785 C If this is a SC-SC distance, we need to calculate the contributions to the
3786 C Cartesian gradient in the SC vectors (ghpbx).
3787         if (iii.lt.ii) then
3788           do j=1,3
3789             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3790             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3791           enddo
3792         endif
3793         else !ii.gt.nres
3794 C          write(iout,*) "before"
3795           dd=dist(ii,jj)
3796 C          write(iout,*) "after",dd
3797           if (constr_dist.eq.11) then
3798             ehpb=ehpb+fordepth(i)**4.0d0
3799      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
3800             fac=fordepth(i)**4.0d0
3801      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
3802 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
3803 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
3804 C            print *,ehpb,"tu?"
3805 C            write(iout,*) ehpb,"btu?",
3806 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
3807 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
3808 C     &    ehpb,fordepth(i),dd
3809            else
3810           if (dhpb1(i).gt.0.0d0) then
3811             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3812             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
3813 c            write (iout,*) "alph nmr",
3814 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
3815           else
3816             rdis=dd-dhpb(i)
3817 C Get the force constant corresponding to this distance.
3818             waga=forcon(i)
3819 C Calculate the contribution to energy.
3820             ehpb=ehpb+waga*rdis*rdis
3821 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
3822 C
3823 C Evaluate gradient.
3824 C
3825             fac=waga*rdis/dd
3826           endif
3827           endif
3828         do j=1,3
3829           ggg(j)=fac*(c(j,jj)-c(j,ii))
3830         enddo
3831 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
3832 C If this is a SC-SC distance, we need to calculate the contributions to the
3833 C Cartesian gradient in the SC vectors (ghpbx).
3834         if (iii.lt.ii) then
3835           do j=1,3
3836             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
3837             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
3838           enddo
3839         endif
3840         do j=iii,jjj-1
3841           do k=1,3
3842             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
3843           enddo
3844         enddo
3845         endif
3846       enddo
3847       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
3848       return
3849       end
3850 C--------------------------------------------------------------------------
3851       subroutine ssbond_ene(i,j,eij)
3852 C
3853 C Calculate the distance and angle dependent SS-bond potential energy
3854 C using a free-energy function derived based on RHF/6-31G** ab initio
3855 C calculations of diethyl disulfide.
3856 C
3857 C A. Liwo and U. Kozlowska, 11/24/03
3858 C
3859       implicit real*8 (a-h,o-z)
3860       include 'DIMENSIONS'
3861       include 'sizesclu.dat'
3862       include 'COMMON.SBRIDGE'
3863       include 'COMMON.CHAIN'
3864       include 'COMMON.DERIV'
3865       include 'COMMON.LOCAL'
3866       include 'COMMON.INTERACT'
3867       include 'COMMON.VAR'
3868       include 'COMMON.IOUNITS'
3869       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
3870       itypi=iabs(itype(i))
3871       xi=c(1,nres+i)
3872       yi=c(2,nres+i)
3873       zi=c(3,nres+i)
3874       dxi=dc_norm(1,nres+i)
3875       dyi=dc_norm(2,nres+i)
3876       dzi=dc_norm(3,nres+i)
3877       dsci_inv=dsc_inv(itypi)
3878       itypj=iabs(itype(j))
3879       dscj_inv=dsc_inv(itypj)
3880       xj=c(1,nres+j)-xi
3881       yj=c(2,nres+j)-yi
3882       zj=c(3,nres+j)-zi
3883       dxj=dc_norm(1,nres+j)
3884       dyj=dc_norm(2,nres+j)
3885       dzj=dc_norm(3,nres+j)
3886       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3887       rij=dsqrt(rrij)
3888       erij(1)=xj*rij
3889       erij(2)=yj*rij
3890       erij(3)=zj*rij
3891       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
3892       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
3893       om12=dxi*dxj+dyi*dyj+dzi*dzj
3894       do k=1,3
3895         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
3896         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
3897       enddo
3898       rij=1.0d0/rij
3899       deltad=rij-d0cm
3900       deltat1=1.0d0-om1
3901       deltat2=1.0d0+om2
3902       deltat12=om2-om1+2.0d0
3903       cosphi=om12-om1*om2
3904       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
3905      &  +akct*deltad*deltat12
3906      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
3907 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
3908 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
3909 c     &  " deltat12",deltat12," eij",eij
3910       ed=2*akcm*deltad+akct*deltat12
3911       pom1=akct*deltad
3912       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
3913       eom1=-2*akth*deltat1-pom1-om2*pom2
3914       eom2= 2*akth*deltat2+pom1-om1*pom2
3915       eom12=pom2
3916       do k=1,3
3917         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
3918       enddo
3919       do k=1,3
3920         ghpbx(k,i)=ghpbx(k,i)-gg(k)
3921      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
3922         ghpbx(k,j)=ghpbx(k,j)+gg(k)
3923      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
3924       enddo
3925 C
3926 C Calculate the components of the gradient in DC and X
3927 C
3928       do k=i,j-1
3929         do l=1,3
3930           ghpbc(l,k)=ghpbc(l,k)+gg(l)
3931         enddo
3932       enddo
3933       return
3934       end
3935 C--------------------------------------------------------------------------
3936
3937
3938 c LICZENIE WIEZOW Z ROWNANIA ENERGII MODELLERA
3939       subroutine e_modeller(ehomology_constr)
3940       implicit real*8 (a-h,o-z)
3941
3942       include 'DIMENSIONS'
3943
3944       integer nnn, i, j, k, ki, irec, l
3945       integer katy, odleglosci, test7
3946       real*8 odleg, odleg2, odleg3, kat, kat2, kat3, gdih(max_template)
3947       real*8 distance(max_template),distancek(max_template),
3948      &    min_odl,godl(max_template),dih_diff(max_template)
3949
3950 c
3951 c     FP - 30/10/2014 Temporary specifications for homology restraints
3952 c
3953       double precision utheta_i,gutheta_i,sum_gtheta,sum_sgtheta,
3954      &                 sgtheta
3955       double precision, dimension (maxres) :: guscdiff,usc_diff
3956       double precision, dimension (max_template) ::
3957      &           gtheta,dscdiff,uscdiffk,guscdiff2,guscdiff3,
3958      &           theta_diff
3959
3960       include 'COMMON.SBRIDGE'
3961       include 'COMMON.CHAIN'
3962       include 'COMMON.GEO'
3963       include 'COMMON.DERIV'
3964       include 'COMMON.LOCAL'
3965       include 'COMMON.INTERACT'
3966       include 'COMMON.VAR'
3967       include 'COMMON.IOUNITS'
3968       include 'COMMON.CONTROL'
3969       include 'COMMON.HOMRESTR'
3970 c
3971       include 'COMMON.SETUP'
3972       include 'COMMON.NAMES'
3973
3974       do i=1,max_template
3975         distancek(i)=9999999.9
3976       enddo
3977
3978       odleg=0.0d0
3979
3980 c Pseudo-energy and gradient from homology restraints (MODELLER-like
3981 c function)
3982 C AL 5/2/14 - Introduce list of restraints
3983 c     write(iout,*) "waga_theta",waga_theta,"waga_d",waga_d
3984 #ifdef DEBUG
3985       write(iout,*) "------- dist restrs start -------"
3986       write (iout,*) "link_start_homo",link_start_homo,
3987      &    " link_end_homo",link_end_homo
3988 #endif
3989       do ii = link_start_homo,link_end_homo
3990          i = ires_homo(ii)
3991          j = jres_homo(ii)
3992          dij=dist(i,j)
3993 c        write (iout,*) "dij(",i,j,") =",dij
3994          do k=1,constr_homology
3995            if(.not.l_homo(k,ii)) cycle
3996            distance(k)=odl(k,ii)-dij
3997 c          write (iout,*) "distance(",k,") =",distance(k)
3998 c
3999 c          For Gaussian-type Urestr
4000 c
4001            distancek(k)=0.5d0*distance(k)**2*sigma_odl(k,ii) ! waga_dist rmvd from Gaussian argument
4002 c          write (iout,*) "sigma_odl(",k,ii,") =",sigma_odl(k,ii)
4003 c          write (iout,*) "distancek(",k,") =",distancek(k)
4004 c          distancek(k)=0.5d0*waga_dist*distance(k)**2*sigma_odl(k,ii)
4005 c
4006 c          For Lorentzian-type Urestr
4007 c
4008            if (waga_dist.lt.0.0d0) then
4009               sigma_odlir(k,ii)=dsqrt(1/sigma_odl(k,ii))
4010               distancek(k)=distance(k)**2/(sigma_odlir(k,ii)*
4011      &                     (distance(k)**2+sigma_odlir(k,ii)**2))
4012            endif
4013          enddo
4014
4015 c         min_odl=minval(distancek)
4016          do kk=1,constr_homology
4017           if(l_homo(kk,ii)) then
4018             min_odl=distancek(kk)
4019             exit
4020           endif
4021          enddo
4022          do kk=1,constr_homology
4023           if(l_homo(kk,ii) .and. distancek(kk).lt.min_odl)
4024      &              min_odl=distancek(kk)
4025          enddo
4026 c        write (iout,* )"min_odl",min_odl
4027 #ifdef DEBUG
4028          write (iout,*) "ij dij",i,j,dij
4029          write (iout,*) "distance",(distance(k),k=1,constr_homology)
4030          write (iout,*) "distancek",(distancek(k),k=1,constr_homology)
4031          write (iout,* )"min_odl",min_odl
4032 #endif
4033          odleg2=0.0d0
4034          do k=1,constr_homology
4035 c Nie wiem po co to liczycie jeszcze raz!
4036 c            odleg3=-waga_dist(iset)*((distance(i,j,k)**2)/
4037 c     &              (2*(sigma_odl(i,j,k))**2))
4038            if(.not.l_homo(k,ii)) cycle
4039            if (waga_dist.ge.0.0d0) then
4040 c
4041 c          For Gaussian-type Urestr
4042 c
4043             godl(k)=dexp(-distancek(k)+min_odl)
4044             odleg2=odleg2+godl(k)
4045 c
4046 c          For Lorentzian-type Urestr
4047 c
4048            else
4049             odleg2=odleg2+distancek(k)
4050            endif
4051
4052 ccc       write(iout,779) i,j,k, "odleg2=",odleg2, "odleg3=", odleg3,
4053 ccc     & "dEXP(odleg3)=", dEXP(odleg3),"distance(i,j,k)^2=",
4054 ccc     & distance(i,j,k)**2, "dist(i+1,j+1)=", dist(i+1,j+1),
4055 ccc     & "sigma_odl(i,j,k)=", sigma_odl(i,j,k)
4056
4057          enddo
4058 c        write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4059 c        write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4060 #ifdef DEBUG
4061          write (iout,*) "godl",(godl(k),k=1,constr_homology) ! exponents
4062          write (iout,*) "ii i j",ii,i,j," odleg2",odleg2 ! sum of exps
4063 #endif
4064            if (waga_dist.ge.0.0d0) then
4065 c
4066 c          For Gaussian-type Urestr
4067 c
4068               odleg=odleg-dLOG(odleg2/constr_homology)+min_odl
4069 c
4070 c          For Lorentzian-type Urestr
4071 c
4072            else
4073               odleg=odleg+odleg2/constr_homology
4074            endif
4075 c
4076 #ifdef GRAD
4077 c        write (iout,*) "odleg",odleg ! sum of -ln-s
4078 c Gradient
4079 c
4080 c          For Gaussian-type Urestr
4081 c
4082          if (waga_dist.ge.0.0d0) sum_godl=odleg2
4083          sum_sgodl=0.0d0
4084          do k=1,constr_homology
4085 c            godl=dexp(((-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4086 c     &           *waga_dist)+min_odl
4087 c          sgodl=-godl(k)*distance(k)*sigma_odl(k,ii)*waga_dist
4088 c
4089          if(.not.l_homo(k,ii)) cycle
4090          if (waga_dist.ge.0.0d0) then
4091 c          For Gaussian-type Urestr
4092 c
4093            sgodl=-godl(k)*distance(k)*sigma_odl(k,ii) ! waga_dist rmvd
4094 c
4095 c          For Lorentzian-type Urestr
4096 c
4097          else
4098            sgodl=-2*sigma_odlir(k,ii)*(distance(k)/(distance(k)**2+
4099      &           sigma_odlir(k,ii)**2)**2)
4100          endif
4101            sum_sgodl=sum_sgodl+sgodl
4102
4103 c            sgodl2=sgodl2+sgodl
4104 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE1"
4105 c      write(iout,*) "constr_homology=",constr_homology
4106 c      write(iout,*) i, j, k, "TEST K"
4107          enddo
4108          if (waga_dist.ge.0.0d0) then
4109 c
4110 c          For Gaussian-type Urestr
4111 c
4112             grad_odl3=waga_homology(iset)*waga_dist
4113      &                *sum_sgodl/(sum_godl*dij)
4114 c
4115 c          For Lorentzian-type Urestr
4116 c
4117          else
4118 c Original grad expr modified by analogy w Gaussian-type Urestr grad
4119 c           grad_odl3=-waga_homology(iset)*waga_dist*sum_sgodl
4120             grad_odl3=-waga_homology(iset)*waga_dist*
4121      &                sum_sgodl/(constr_homology*dij)
4122          endif
4123 c
4124 c        grad_odl3=sum_sgodl/(sum_godl*dij)
4125
4126
4127 c      write(iout,*) i, j, k, distance(i,j,k), "W GRADIENCIE2"
4128 c      write(iout,*) (distance(i,j,k)**2), (2*(sigma_odl(i,j,k))**2),
4129 c     &              (-(distance(i,j,k)**2)/(2*(sigma_odl(i,j,k))**2))
4130
4131 ccc      write(iout,*) godl, sgodl, grad_odl3
4132
4133 c          grad_odl=grad_odl+grad_odl3
4134
4135          do jik=1,3
4136             ggodl=grad_odl3*(c(jik,i)-c(jik,j))
4137 ccc      write(iout,*) c(jik,i+1), c(jik,j+1), (c(jik,i+1)-c(jik,j+1))
4138 ccc      write(iout,746) "GRAD_ODL_1", i, j, jik, ggodl,
4139 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4140             ghpbc(jik,i)=ghpbc(jik,i)+ggodl
4141             ghpbc(jik,j)=ghpbc(jik,j)-ggodl
4142 ccc      write(iout,746) "GRAD_ODL_2", i, j, jik, ggodl,
4143 ccc     &              ghpbc(jik,i+1), ghpbc(jik,j+1)
4144 c         if (i.eq.25.and.j.eq.27) then
4145 c         write(iout,*) "jik",jik,"i",i,"j",j
4146 c         write(iout,*) "sum_sgodl",sum_sgodl,"sgodl",sgodl
4147 c         write(iout,*) "grad_odl3",grad_odl3
4148 c         write(iout,*) "c(",jik,i,")",c(jik,i),"c(",jik,j,")",c(jik,j)
4149 c         write(iout,*) "ggodl",ggodl
4150 c         write(iout,*) "ghpbc(",jik,i,")",
4151 c     &                 ghpbc(jik,i),"ghpbc(",jik,j,")",
4152 c     &                 ghpbc(jik,j)
4153 c         endif
4154          enddo
4155 #endif
4156 ccc       write(iout,778)"TEST: odleg2=", odleg2, "DLOG(odleg2)=",
4157 ccc     & dLOG(odleg2),"-odleg=", -odleg
4158
4159       enddo ! ii-loop for dist
4160 #ifdef DEBUG
4161       write(iout,*) "------- dist restrs end -------"
4162 c     if (waga_angle.eq.1.0d0 .or. waga_theta.eq.1.0d0 .or.
4163 c    &     waga_d.eq.1.0d0) call sum_gradient
4164 #endif
4165 c Pseudo-energy and gradient from dihedral-angle restraints from
4166 c homology templates
4167 c      write (iout,*) "End of distance loop"
4168 c      call flush(iout)
4169       kat=0.0d0
4170 c      write (iout,*) idihconstr_start_homo,idihconstr_end_homo
4171 #ifdef DEBUG
4172       write(iout,*) "------- dih restrs start -------"
4173       do i=idihconstr_start_homo,idihconstr_end_homo
4174         write (iout,*) "gloc_init(",i,icg,")",gloc(i,icg)
4175       enddo
4176 #endif
4177       do i=idihconstr_start_homo,idihconstr_end_homo
4178         kat2=0.0d0
4179 c        betai=beta(i,i+1,i+2,i+3)
4180         betai = phi(i)
4181 c       write (iout,*) "betai =",betai
4182         do k=1,constr_homology
4183           dih_diff(k)=pinorm(dih(k,i)-betai)
4184 c         write (iout,*) "dih_diff(",k,") =",dih_diff(k)
4185 c          if (dih_diff(i,k).gt.3.14159) dih_diff(i,k)=
4186 c     &                                   -(6.28318-dih_diff(i,k))
4187 c          if (dih_diff(i,k).lt.-3.14159) dih_diff(i,k)=
4188 c     &                                   6.28318+dih_diff(i,k)
4189
4190           kat3=-0.5d0*dih_diff(k)**2*sigma_dih(k,i) ! waga_angle rmvd from Gaussian argument
4191 c         kat3=-0.5d0*waga_angle*dih_diff(k)**2*sigma_dih(k,i)
4192           gdih(k)=dexp(kat3)
4193           kat2=kat2+gdih(k)
4194 c          write(iout,*) "kat2=", kat2, "exp(kat3)=", exp(kat3)
4195 c          write(*,*)""
4196         enddo
4197 c       write (iout,*) "gdih",(gdih(k),k=1,constr_homology) ! exps
4198 c       write (iout,*) "i",i," betai",betai," kat2",kat2 ! sum of exps
4199 #ifdef DEBUG
4200         write (iout,*) "i",i," betai",betai," kat2",kat2
4201         write (iout,*) "gdih",(gdih(k),k=1,constr_homology)
4202 #endif
4203         if (kat2.le.1.0d-14) cycle
4204         kat=kat-dLOG(kat2/constr_homology)
4205 c       write (iout,*) "kat",kat ! sum of -ln-s
4206
4207 ccc       write(iout,778)"TEST: kat2=", kat2, "DLOG(kat2)=",
4208 ccc     & dLOG(kat2), "-kat=", -kat
4209
4210 #ifdef GRAD
4211 c ----------------------------------------------------------------------
4212 c Gradient
4213 c ----------------------------------------------------------------------
4214
4215         sum_gdih=kat2
4216         sum_sgdih=0.0d0
4217         do k=1,constr_homology
4218           sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)  ! waga_angle rmvd
4219 c         sgdih=-gdih(k)*dih_diff(k)*sigma_dih(k,i)*waga_angle
4220           sum_sgdih=sum_sgdih+sgdih
4221         enddo
4222 c       grad_dih3=sum_sgdih/sum_gdih
4223         grad_dih3=waga_homology(iset)*waga_angle*sum_sgdih/sum_gdih
4224
4225 c      write(iout,*)i,k,gdih,sgdih,beta(i+1,i+2,i+3,i+4),grad_dih3
4226 ccc      write(iout,747) "GRAD_KAT_1", i, nphi, icg, grad_dih3,
4227 ccc     & gloc(nphi+i-3,icg)
4228         gloc(i,icg)=gloc(i,icg)+grad_dih3
4229 c        if (i.eq.25) then
4230 c        write(iout,*) "i",i,"icg",icg,"gloc(",i,icg,")",gloc(i,icg)
4231 c        endif
4232 ccc      write(iout,747) "GRAD_KAT_2", i, nphi, icg, grad_dih3,
4233 ccc     & gloc(nphi+i-3,icg)
4234 #endif
4235       enddo ! i-loop for dih
4236 #ifdef DEBUG
4237       write(iout,*) "------- dih restrs end -------"
4238 #endif
4239
4240 c Pseudo-energy and gradient for theta angle restraints from
4241 c homology templates
4242 c FP 01/15 - inserted from econstr_local_test.F, loop structure
4243 c adapted
4244
4245 c
4246 c     For constr_homology reference structures (FP)
4247 c
4248 c     Uconst_back_tot=0.0d0
4249       Eval=0.0d0
4250       Erot=0.0d0
4251 c     Econstr_back legacy
4252 #ifdef GRAD
4253       do i=1,nres
4254 c     do i=ithet_start,ithet_end
4255        dutheta(i)=0.0d0
4256 c     enddo
4257 c     do i=loc_start,loc_end
4258         do j=1,3
4259           duscdiff(j,i)=0.0d0
4260           duscdiffx(j,i)=0.0d0
4261         enddo
4262       enddo
4263 #endif
4264 c
4265 c     do iref=1,nref
4266 c     write (iout,*) "ithet_start =",ithet_start,"ithet_end =",ithet_end
4267 c     write (iout,*) "waga_theta",waga_theta
4268       if (waga_theta.gt.0.0d0) then
4269 #ifdef DEBUG
4270       write (iout,*) "usampl",usampl
4271       write(iout,*) "------- theta restrs start -------"
4272 c     do i=ithet_start,ithet_end
4273 c       write (iout,*) "gloc_init(",nphi+i,icg,")",gloc(nphi+i,icg)
4274 c     enddo
4275 #endif
4276 c     write (iout,*) "maxres",maxres,"nres",nres
4277
4278       do i=ithet_start,ithet_end
4279 c
4280 c     do i=1,nfrag_back
4281 c       ii = ifrag_back(2,i,iset)-ifrag_back(1,i,iset)
4282 c
4283 c Deviation of theta angles wrt constr_homology ref structures
4284 c
4285         utheta_i=0.0d0 ! argument of Gaussian for single k
4286         gutheta_i=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4287 c       do j=ifrag_back(1,i,iset)+2,ifrag_back(2,i,iset) ! original loop
4288 c       over residues in a fragment
4289 c       write (iout,*) "theta(",i,")=",theta(i)
4290         do k=1,constr_homology
4291 c
4292 c         dtheta_i=theta(j)-thetaref(j,iref)
4293 c         dtheta_i=thetaref(k,i)-theta(i) ! original form without indexing
4294           theta_diff(k)=thetatpl(k,i)-theta(i)
4295 c
4296           utheta_i=-0.5d0*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta rmvd from Gaussian argument
4297 c         utheta_i=-0.5d0*waga_theta*theta_diff(k)**2*sigma_theta(k,i) ! waga_theta?
4298           gtheta(k)=dexp(utheta_i) ! + min_utheta_i?
4299           gutheta_i=gutheta_i+dexp(utheta_i)   ! Sum of Gaussians (pk)
4300 c         Gradient for single Gaussian restraint in subr Econstr_back
4301 c         dutheta(j-2)=dutheta(j-2)+wfrag_back(1,i,iset)*dtheta_i/(ii-1)
4302 c
4303         enddo
4304 c       write (iout,*) "gtheta",(gtheta(k),k=1,constr_homology) ! exps
4305 c       write (iout,*) "i",i," gutheta_i",gutheta_i ! sum of exps
4306
4307 c
4308 #ifdef GRAD
4309 c         Gradient for multiple Gaussian restraint
4310         sum_gtheta=gutheta_i
4311         sum_sgtheta=0.0d0
4312         do k=1,constr_homology
4313 c        New generalized expr for multiple Gaussian from Econstr_back
4314          sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i) ! waga_theta rmvd
4315 c
4316 c        sgtheta=-gtheta(k)*theta_diff(k)*sigma_theta(k,i)*waga_theta ! right functional form?
4317           sum_sgtheta=sum_sgtheta+sgtheta ! cum variable
4318         enddo
4319 c
4320 c       Final value of gradient using same var as in Econstr_back
4321         dutheta(i-2)=sum_sgtheta/sum_gtheta*waga_theta
4322      &               *waga_homology(iset)
4323 c       dutheta(i)=sum_sgtheta/sum_gtheta
4324 c
4325 c       Uconst_back=Uconst_back+waga_theta*utheta(i) ! waga_theta added as weight
4326 #endif
4327         Eval=Eval-dLOG(gutheta_i/constr_homology)
4328 c       write (iout,*) "utheta(",i,")=",utheta(i) ! -ln of sum of exps
4329 c       write (iout,*) "Uconst_back",Uconst_back ! sum of -ln-s
4330 c       Uconst_back=Uconst_back+utheta(i)
4331       enddo ! (i-loop for theta)
4332 #ifdef DEBUG
4333       write(iout,*) "------- theta restrs end -------"
4334 #endif
4335       endif
4336 c
4337 c Deviation of local SC geometry
4338 c
4339 c Separation of two i-loops (instructed by AL - 11/3/2014)
4340 c
4341 c     write (iout,*) "loc_start =",loc_start,"loc_end =",loc_end
4342 c     write (iout,*) "waga_d",waga_d
4343
4344 #ifdef DEBUG
4345       write(iout,*) "------- SC restrs start -------"
4346       write (iout,*) "Initial duscdiff,duscdiffx"
4347       do i=loc_start,loc_end
4348         write (iout,*) i,(duscdiff(jik,i),jik=1,3),
4349      &                 (duscdiffx(jik,i),jik=1,3)
4350       enddo
4351 #endif
4352       do i=loc_start,loc_end
4353         usc_diff_i=0.0d0 ! argument of Gaussian for single k
4354         guscdiff(i)=0.0d0 ! Sum of Gaussians over constr_homology ref structures
4355 c       do j=ifrag_back(1,i,iset)+1,ifrag_back(2,i,iset)-1 ! Econstr_back legacy
4356 c       write(iout,*) "xxtab, yytab, zztab"
4357 c       write(iout,'(i5,3f8.2)') i,xxtab(i),yytab(i),zztab(i)
4358         do k=1,constr_homology
4359 c
4360           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4361 c                                    Original sign inverted for calc of gradients (s. Econstr_back)
4362           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4363           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4364 c         write(iout,*) "dxx, dyy, dzz"
4365 c         write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4366 c
4367           usc_diff_i=-0.5d0*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i)  ! waga_d rmvd from Gaussian argument
4368 c         usc_diff(i)=-0.5d0*waga_d*(dxx**2+dyy**2+dzz**2)*sigma_d(k,i) ! waga_d?
4369 c         uscdiffk(k)=usc_diff(i)
4370           guscdiff2(k)=dexp(usc_diff_i) ! without min_scdiff
4371           guscdiff(i)=guscdiff(i)+dexp(usc_diff_i)   !Sum of Gaussians (pk)
4372 c          write (iout,'(i5,6f10.5)') j,xxtab(j),yytab(j),zztab(j),
4373 c     &      xxref(j),yyref(j),zzref(j)
4374         enddo
4375 c
4376 c       Gradient
4377 c
4378 c       Generalized expression for multiple Gaussian acc to that for a single
4379 c       Gaussian in Econstr_back as instructed by AL (FP - 03/11/2014)
4380 c
4381 c       Original implementation
4382 c       sum_guscdiff=guscdiff(i)
4383 c
4384 c       sum_sguscdiff=0.0d0
4385 c       do k=1,constr_homology
4386 c          sguscdiff=-guscdiff2(k)*dscdiff(k)*sigma_d(k,i)*waga_d !waga_d?
4387 c          sguscdiff=-guscdiff3(k)*dscdiff(k)*sigma_d(k,i)*waga_d ! w min_uscdiff
4388 c          sum_sguscdiff=sum_sguscdiff+sguscdiff
4389 c       enddo
4390 c
4391 c       Implementation of new expressions for gradient (Jan. 2015)
4392 c
4393 c       grad_uscdiff=sum_sguscdiff/(sum_guscdiff*dtab) !?
4394 #ifdef GRAD
4395         do k=1,constr_homology
4396 c
4397 c       New calculation of dxx, dyy, and dzz corrected by AL (07/11), was missing and wrong
4398 c       before. Now the drivatives should be correct
4399 c
4400           dxx=-xxtpl(k,i)+xxtab(i) ! Diff b/w x component of ith SC vector in model and kth ref str?
4401 c                                  Original sign inverted for calc of gradients (s. Econstr_back)
4402           dyy=-yytpl(k,i)+yytab(i) ! ibid y
4403           dzz=-zztpl(k,i)+zztab(i) ! ibid z
4404 c
4405 c         New implementation
4406 c
4407           sum_guscdiff=guscdiff2(k)*!(dsqrt(dxx*dxx+dyy*dyy+dzz*dzz))* -> wrong!
4408      &                 sigma_d(k,i) ! for the grad wrt r'
4409 c         sum_sguscdiff=sum_sguscdiff+sum_guscdiff
4410 c
4411 c
4412 c        New implementation
4413          sum_guscdiff = waga_homology(iset)*waga_d*sum_guscdiff
4414          do jik=1,3
4415             duscdiff(jik,i-1)=duscdiff(jik,i-1)+
4416      &      sum_guscdiff*(dXX_C1tab(jik,i)*dxx+
4417      &      dYY_C1tab(jik,i)*dyy+dZZ_C1tab(jik,i)*dzz)/guscdiff(i)
4418             duscdiff(jik,i)=duscdiff(jik,i)+
4419      &      sum_guscdiff*(dXX_Ctab(jik,i)*dxx+
4420      &      dYY_Ctab(jik,i)*dyy+dZZ_Ctab(jik,i)*dzz)/guscdiff(i)
4421             duscdiffx(jik,i)=duscdiffx(jik,i)+
4422      &      sum_guscdiff*(dXX_XYZtab(jik,i)*dxx+
4423      &      dYY_XYZtab(jik,i)*dyy+dZZ_XYZtab(jik,i)*dzz)/guscdiff(i)
4424 c
4425 #ifdef DEBUG
4426              write(iout,*) "jik",jik,"i",i
4427              write(iout,*) "dxx, dyy, dzz"
4428              write(iout,'(2i5,3f8.2)') k,i,dxx,dyy,dzz
4429              write(iout,*) "guscdiff2(",k,")",guscdiff2(k)
4430 c            write(iout,*) "sum_sguscdiff",sum_sguscdiff
4431 cc           write(iout,*) "dXX_Ctab(",jik,i,")",dXX_Ctab(jik,i)
4432 c            write(iout,*) "dYY_Ctab(",jik,i,")",dYY_Ctab(jik,i)
4433 c            write(iout,*) "dZZ_Ctab(",jik,i,")",dZZ_Ctab(jik,i)
4434 c            write(iout,*) "dXX_C1tab(",jik,i,")",dXX_C1tab(jik,i)
4435 c            write(iout,*) "dYY_C1tab(",jik,i,")",dYY_C1tab(jik,i)
4436 c            write(iout,*) "dZZ_C1tab(",jik,i,")",dZZ_C1tab(jik,i)
4437 c            write(iout,*) "dXX_XYZtab(",jik,i,")",dXX_XYZtab(jik,i)
4438 c            write(iout,*) "dYY_XYZtab(",jik,i,")",dYY_XYZtab(jik,i)
4439 c            write(iout,*) "dZZ_XYZtab(",jik,i,")",dZZ_XYZtab(jik,i)
4440 c            write(iout,*) "duscdiff(",jik,i-1,")",duscdiff(jik,i-1)
4441 c            write(iout,*) "duscdiff(",jik,i,")",duscdiff(jik,i)
4442 c            write(iout,*) "duscdiffx(",jik,i,")",duscdiffx(jik,i)
4443 c            endif
4444 #endif
4445          enddo
4446         enddo
4447 #endif
4448 c
4449 c       uscdiff(i)=-dLOG(guscdiff(i)/(ii-1))      ! Weighting by (ii-1) required?
4450 c        usc_diff(i)=-dLOG(guscdiff(i)/constr_homology) ! + min_uscdiff ?
4451 c
4452 c        write (iout,*) i," uscdiff",uscdiff(i)
4453 c
4454 c Put together deviations from local geometry
4455
4456 c       Uconst_back=Uconst_back+wfrag_back(1,i,iset)*utheta(i)+
4457 c      &            wfrag_back(3,i,iset)*uscdiff(i)
4458         Erot=Erot-dLOG(guscdiff(i)/constr_homology)
4459 c       write (iout,*) "usc_diff(",i,")=",usc_diff(i) ! -ln of sum of exps
4460 c       write (iout,*) "Uconst_back",Uconst_back ! cum sum of -ln-s
4461 c       Uconst_back=Uconst_back+usc_diff(i)
4462 c
4463 c     Gradient of multiple Gaussian restraint (FP - 04/11/2014 - right?)
4464 c
4465 c     New implment: multiplied by sum_sguscdiff
4466 c
4467
4468       enddo ! (i-loop for dscdiff)
4469
4470 c      endif
4471
4472 #ifdef DEBUG
4473       write(iout,*) "------- SC restrs end -------"
4474         write (iout,*) "------ After SC loop in e_modeller ------"
4475         do i=loc_start,loc_end
4476          write (iout,*) "i",i," gradc",(gradc(j,i,icg),j=1,3)
4477          write (iout,*) "i",i," gradx",(gradx(j,i,icg),j=1,3)
4478         enddo
4479       if (waga_theta.eq.1.0d0) then
4480       write (iout,*) "in e_modeller after SC restr end: dutheta"
4481       do i=ithet_start,ithet_end
4482         write (iout,*) i,dutheta(i)
4483       enddo
4484       endif
4485       if (waga_d.eq.1.0d0) then
4486       write (iout,*) "e_modeller after SC loop: duscdiff/x"
4487       do i=1,nres
4488         write (iout,*) i,(duscdiff(j,i),j=1,3)
4489         write (iout,*) i,(duscdiffx(j,i),j=1,3)
4490       enddo
4491       endif
4492 #endif
4493
4494 c Total energy from homology restraints
4495 #ifdef DEBUG
4496       write (iout,*) "odleg",odleg," kat",kat
4497       write (iout,*) "odleg",odleg," kat",kat
4498       write (iout,*) "Eval",Eval," Erot",Erot
4499       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4500       write (iout,*) "waga_dist ",waga_dist,"waga_angle ",waga_angle
4501       write (iout,*) "waga_theta ",waga_theta,"waga_d ",waga_d
4502       write (iout,*) "waga_homology(",iset,")",waga_homology(iset)
4503 #endif
4504 c
4505 c Addition of energy of theta angle and SC local geom over constr_homologs ref strs
4506 c
4507 c     ehomology_constr=odleg+kat
4508 c
4509 c     For Lorentzian-type Urestr
4510 c
4511
4512       if (waga_dist.ge.0.0d0) then
4513 c
4514 c          For Gaussian-type Urestr
4515 c
4516         ehomology_constr=(waga_dist*odleg+waga_angle*kat+
4517      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4518 c     write (iout,*) "ehomology_constr=",ehomology_constr
4519       else
4520 c
4521 c          For Lorentzian-type Urestr
4522 c
4523         ehomology_constr=(-waga_dist*odleg+waga_angle*kat+
4524      &              waga_theta*Eval+waga_d*Erot)*waga_homology(iset)
4525 c     write (iout,*) "ehomology_constr=",ehomology_constr
4526       endif
4527 #ifdef DEBUG
4528       write (iout,*) "iset",iset," waga_homology",waga_homology(iset)
4529       write (iout,*) "odleg",waga_dist,odleg," kat",waga_angle,kat,
4530      & " Eval",waga_theta,Eval," Erot",waga_d,Erot
4531       write (iout,*) "ehomology_constr",ehomology_constr
4532 #endif
4533       return
4534
4535   748 format(a8,f12.3,a6,f12.3,a7,f12.3)
4536   747 format(a12,i4,i4,i4,f8.3,f8.3)
4537   746 format(a12,i4,i4,i4,f8.3,f8.3,f8.3)
4538   778 format(a7,1X,f10.3,1X,a4,1X,f10.3,1X,a5,1X,f10.3)
4539   779 format(i3,1X,i3,1X,i2,1X,a7,1X,f7.3,1X,a7,1X,f7.3,1X,a13,1X,
4540      &       f7.3,1X,a17,1X,f9.3,1X,a10,1X,f8.3,1X,a10,1X,f8.3)
4541       end
4542 C--------------------------------------------------------------------------
4543
4544 C--------------------------------------------------------------------------
4545       subroutine ebond(estr)
4546 c
4547 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4548 c
4549       implicit real*8 (a-h,o-z)
4550       include 'DIMENSIONS'
4551       include 'sizesclu.dat'
4552       include 'COMMON.LOCAL'
4553       include 'COMMON.GEO'
4554       include 'COMMON.INTERACT'
4555       include 'COMMON.DERIV'
4556       include 'COMMON.VAR'
4557       include 'COMMON.CHAIN'
4558       include 'COMMON.IOUNITS'
4559       include 'COMMON.NAMES'
4560       include 'COMMON.FFIELD'
4561       include 'COMMON.CONTROL'
4562       logical energy_dec /.false./
4563       double precision u(3),ud(3)
4564       estr=0.0d0
4565       estr1=0.0d0
4566       do i=nnt+1,nct
4567         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4568 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4569 C          do j=1,3
4570 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4571 C     &      *dc(j,i-1)/vbld(i)
4572 C          enddo
4573 C          if (energy_dec) write(iout,*)
4574 C     &       "estr1",i,vbld(i),distchainmax,
4575 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4576 C        else
4577          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4578         diff = vbld(i)-vbldpDUM
4579          else
4580           diff = vbld(i)-vbldp0
4581 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4582          endif
4583           estr=estr+diff*diff
4584           do j=1,3
4585             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4586           enddo
4587 C        endif
4588 C        write (iout,'(a7,i5,4f7.3)')
4589 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4590       enddo
4591       estr=0.5d0*AKP*estr+estr1
4592 c
4593 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4594 c
4595       do i=nnt,nct
4596         iti=iabs(itype(i))
4597         if (iti.ne.10 .and. iti.ne.ntyp1) then
4598           nbi=nbondterm(iti)
4599           if (nbi.eq.1) then
4600             diff=vbld(i+nres)-vbldsc0(1,iti)
4601 c            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4602 c     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4603             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4604             do j=1,3
4605               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4606             enddo
4607           else
4608             do j=1,nbi
4609               diff=vbld(i+nres)-vbldsc0(j,iti)
4610               ud(j)=aksc(j,iti)*diff
4611               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4612             enddo
4613             uprod=u(1)
4614             do j=2,nbi
4615               uprod=uprod*u(j)
4616             enddo
4617             usum=0.0d0
4618             usumsqder=0.0d0
4619             do j=1,nbi
4620               uprod1=1.0d0
4621               uprod2=1.0d0
4622               do k=1,nbi
4623                 if (k.ne.j) then
4624                   uprod1=uprod1*u(k)
4625                   uprod2=uprod2*u(k)*u(k)
4626                 endif
4627               enddo
4628               usum=usum+uprod1
4629               usumsqder=usumsqder+ud(j)*uprod2
4630             enddo
4631 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4632 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4633             estr=estr+uprod/usum
4634             do j=1,3
4635              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4636             enddo
4637           endif
4638         endif
4639       enddo
4640       return
4641       end
4642 #ifdef CRYST_THETA
4643 C--------------------------------------------------------------------------
4644       subroutine ebend(etheta,ethetacnstr)
4645 C
4646 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4647 C angles gamma and its derivatives in consecutive thetas and gammas.
4648 C
4649       implicit real*8 (a-h,o-z)
4650       include 'DIMENSIONS'
4651       include 'sizesclu.dat'
4652       include 'COMMON.LOCAL'
4653       include 'COMMON.GEO'
4654       include 'COMMON.INTERACT'
4655       include 'COMMON.DERIV'
4656       include 'COMMON.VAR'
4657       include 'COMMON.CHAIN'
4658       include 'COMMON.IOUNITS'
4659       include 'COMMON.NAMES'
4660       include 'COMMON.FFIELD'
4661       include 'COMMON.TORCNSTR'
4662       common /calcthet/ term1,term2,termm,diffak,ratak,
4663      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4664      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4665       double precision y(2),z(2)
4666       delta=0.02d0*pi
4667 c      time11=dexp(-2*time)
4668 c      time12=1.0d0
4669       etheta=0.0D0
4670 c      write (iout,*) "nres",nres
4671 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4672 c      write (iout,*) ithet_start,ithet_end
4673       do i=ithet_start,ithet_end
4674         if (i.le.2) cycle
4675         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4676      &  .or.itype(i).eq.ntyp1) cycle
4677 C Zero the energy function and its derivative at 0 or pi.
4678         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4679         it=itype(i-1)
4680         ichir1=isign(1,itype(i-2))
4681         ichir2=isign(1,itype(i))
4682          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4683          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4684          if (itype(i-1).eq.10) then
4685           itype1=isign(10,itype(i-2))
4686           ichir11=isign(1,itype(i-2))
4687           ichir12=isign(1,itype(i-2))
4688           itype2=isign(10,itype(i))
4689           ichir21=isign(1,itype(i))
4690           ichir22=isign(1,itype(i))
4691          endif
4692          if (i.eq.3) then
4693           y(1)=0.0D0
4694           y(2)=0.0D0
4695           else
4696         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4697 #ifdef OSF
4698           phii=phi(i)
4699 c          icrc=0
4700 c          call proc_proc(phii,icrc)
4701           if (icrc.eq.1) phii=150.0
4702 #else
4703           phii=phi(i)
4704 #endif
4705           y(1)=dcos(phii)
4706           y(2)=dsin(phii)
4707         else
4708           y(1)=0.0D0
4709           y(2)=0.0D0
4710         endif
4711         endif
4712         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4713 #ifdef OSF
4714           phii1=phi(i+1)
4715 c          icrc=0
4716 c          call proc_proc(phii1,icrc)
4717           if (icrc.eq.1) phii1=150.0
4718           phii1=pinorm(phii1)
4719           z(1)=cos(phii1)
4720 #else
4721           phii1=phi(i+1)
4722           z(1)=dcos(phii1)
4723 #endif
4724           z(2)=dsin(phii1)
4725         else
4726           z(1)=0.0D0
4727           z(2)=0.0D0
4728         endif
4729 C Calculate the "mean" value of theta from the part of the distribution
4730 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4731 C In following comments this theta will be referred to as t_c.
4732         thet_pred_mean=0.0d0
4733         do k=1,2
4734             athetk=athet(k,it,ichir1,ichir2)
4735             bthetk=bthet(k,it,ichir1,ichir2)
4736           if (it.eq.10) then
4737              athetk=athet(k,itype1,ichir11,ichir12)
4738              bthetk=bthet(k,itype2,ichir21,ichir22)
4739           endif
4740           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4741         enddo
4742 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4743         dthett=thet_pred_mean*ssd
4744         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4745 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4746 C Derivatives of the "mean" values in gamma1 and gamma2.
4747         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4748      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4749          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4750      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4751          if (it.eq.10) then
4752       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4753      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4754         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4755      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4756          endif
4757         if (theta(i).gt.pi-delta) then
4758           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4759      &         E_tc0)
4760           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4761           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4762           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4763      &        E_theta)
4764           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4765      &        E_tc)
4766         else if (theta(i).lt.delta) then
4767           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4768           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4769           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4770      &        E_theta)
4771           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4772           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4773      &        E_tc)
4774         else
4775           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4776      &        E_theta,E_tc)
4777         endif
4778         etheta=etheta+ethetai
4779 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4780 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4781         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4782         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4783         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4784 c 1215   continue
4785       enddo
4786 C Ufff.... We've done all this!!!
4787 C now constrains
4788       ethetacnstr=0.0d0
4789 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4790       do i=1,ntheta_constr
4791         itheta=itheta_constr(i)
4792         thetiii=theta(itheta)
4793         difi=pinorm(thetiii-theta_constr0(i))
4794         if (difi.gt.theta_drange(i)) then
4795           difi=difi-theta_drange(i)
4796           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4797           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4798      &    +for_thet_constr(i)*difi**3
4799         else if (difi.lt.-drange(i)) then
4800           difi=difi+drange(i)
4801           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4802           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4803      &    +for_thet_constr(i)*difi**3
4804         else
4805           difi=0.0
4806         endif
4807 C       if (energy_dec) then
4808 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4809 C     &    i,itheta,rad2deg*thetiii,
4810 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4811 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4812 C     &    gloc(itheta+nphi-2,icg)
4813 C        endif
4814       enddo
4815       return
4816       end
4817 C---------------------------------------------------------------------------
4818       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4819      &     E_tc)
4820       implicit real*8 (a-h,o-z)
4821       include 'DIMENSIONS'
4822       include 'COMMON.LOCAL'
4823       include 'COMMON.IOUNITS'
4824       common /calcthet/ term1,term2,termm,diffak,ratak,
4825      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4826      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4827 C Calculate the contributions to both Gaussian lobes.
4828 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4829 C The "polynomial part" of the "standard deviation" of this part of
4830 C the distribution.
4831         sig=polthet(3,it)
4832         do j=2,0,-1
4833           sig=sig*thet_pred_mean+polthet(j,it)
4834         enddo
4835 C Derivative of the "interior part" of the "standard deviation of the"
4836 C gamma-dependent Gaussian lobe in t_c.
4837         sigtc=3*polthet(3,it)
4838         do j=2,1,-1
4839           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4840         enddo
4841         sigtc=sig*sigtc
4842 C Set the parameters of both Gaussian lobes of the distribution.
4843 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4844         fac=sig*sig+sigc0(it)
4845         sigcsq=fac+fac
4846         sigc=1.0D0/sigcsq
4847 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4848         sigsqtc=-4.0D0*sigcsq*sigtc
4849 c       print *,i,sig,sigtc,sigsqtc
4850 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4851         sigtc=-sigtc/(fac*fac)
4852 C Following variable is sigma(t_c)**(-2)
4853         sigcsq=sigcsq*sigcsq
4854         sig0i=sig0(it)
4855         sig0inv=1.0D0/sig0i**2
4856         delthec=thetai-thet_pred_mean
4857         delthe0=thetai-theta0i
4858         term1=-0.5D0*sigcsq*delthec*delthec
4859         term2=-0.5D0*sig0inv*delthe0*delthe0
4860 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4861 C NaNs in taking the logarithm. We extract the largest exponent which is added
4862 C to the energy (this being the log of the distribution) at the end of energy
4863 C term evaluation for this virtual-bond angle.
4864         if (term1.gt.term2) then
4865           termm=term1
4866           term2=dexp(term2-termm)
4867           term1=1.0d0
4868         else
4869           termm=term2
4870           term1=dexp(term1-termm)
4871           term2=1.0d0
4872         endif
4873 C The ratio between the gamma-independent and gamma-dependent lobes of
4874 C the distribution is a Gaussian function of thet_pred_mean too.
4875         diffak=gthet(2,it)-thet_pred_mean
4876         ratak=diffak/gthet(3,it)**2
4877         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4878 C Let's differentiate it in thet_pred_mean NOW.
4879         aktc=ak*ratak
4880 C Now put together the distribution terms to make complete distribution.
4881         termexp=term1+ak*term2
4882         termpre=sigc+ak*sig0i
4883 C Contribution of the bending energy from this theta is just the -log of
4884 C the sum of the contributions from the two lobes and the pre-exponential
4885 C factor. Simple enough, isn't it?
4886         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4887 C NOW the derivatives!!!
4888 C 6/6/97 Take into account the deformation.
4889         E_theta=(delthec*sigcsq*term1
4890      &       +ak*delthe0*sig0inv*term2)/termexp
4891         E_tc=((sigtc+aktc*sig0i)/termpre
4892      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4893      &       aktc*term2)/termexp)
4894       return
4895       end
4896 c-----------------------------------------------------------------------------
4897       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4898       implicit real*8 (a-h,o-z)
4899       include 'DIMENSIONS'
4900       include 'COMMON.LOCAL'
4901       include 'COMMON.IOUNITS'
4902       common /calcthet/ term1,term2,termm,diffak,ratak,
4903      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4904      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4905       delthec=thetai-thet_pred_mean
4906       delthe0=thetai-theta0i
4907 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4908       t3 = thetai-thet_pred_mean
4909       t6 = t3**2
4910       t9 = term1
4911       t12 = t3*sigcsq
4912       t14 = t12+t6*sigsqtc
4913       t16 = 1.0d0
4914       t21 = thetai-theta0i
4915       t23 = t21**2
4916       t26 = term2
4917       t27 = t21*t26
4918       t32 = termexp
4919       t40 = t32**2
4920       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4921      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4922      & *(-t12*t9-ak*sig0inv*t27)
4923       return
4924       end
4925 #else
4926 C--------------------------------------------------------------------------
4927       subroutine ebend(etheta,ethetacnstr)
4928 C
4929 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4930 C angles gamma and its derivatives in consecutive thetas and gammas.
4931 C ab initio-derived potentials from
4932 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4933 C
4934       implicit real*8 (a-h,o-z)
4935       include 'DIMENSIONS'
4936       include 'sizesclu.dat'
4937       include 'COMMON.LOCAL'
4938       include 'COMMON.GEO'
4939       include 'COMMON.INTERACT'
4940       include 'COMMON.DERIV'
4941       include 'COMMON.VAR'
4942       include 'COMMON.CHAIN'
4943       include 'COMMON.IOUNITS'
4944       include 'COMMON.NAMES'
4945       include 'COMMON.FFIELD'
4946       include 'COMMON.CONTROL'
4947       include 'COMMON.TORCNSTR'
4948       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4949      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4950      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4951      & sinph1ph2(maxdouble,maxdouble)
4952       logical lprn /.false./, lprn1 /.false./
4953       etheta=0.0D0
4954 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4955       do i=ithet_start,ithet_end
4956         if (i.eq.2) cycle
4957 c        print *,i,itype(i-1),itype(i),itype(i-2)
4958         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
4959      &  .or.(itype(i).eq.ntyp1)) cycle
4960 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4961
4962         if (iabs(itype(i+1)).eq.20) iblock=2
4963         if (iabs(itype(i+1)).ne.20) iblock=1
4964         dethetai=0.0d0
4965         dephii=0.0d0
4966         dephii1=0.0d0
4967         theti2=0.5d0*theta(i)
4968         ityp2=ithetyp((itype(i-1)))
4969         do k=1,nntheterm
4970           coskt(k)=dcos(k*theti2)
4971           sinkt(k)=dsin(k*theti2)
4972         enddo
4973         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4974 #ifdef OSF
4975           phii=phi(i)
4976           if (phii.ne.phii) phii=150.0
4977 #else
4978           phii=phi(i)
4979 #endif
4980           ityp1=ithetyp((itype(i-2)))
4981           do k=1,nsingle
4982             cosph1(k)=dcos(k*phii)
4983             sinph1(k)=dsin(k*phii)
4984           enddo
4985         else
4986           phii=0.0d0
4987           ityp1=nthetyp+1
4988           do k=1,nsingle
4989             cosph1(k)=0.0d0
4990             sinph1(k)=0.0d0
4991           enddo
4992         endif
4993         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4994 #ifdef OSF
4995           phii1=phi(i+1)
4996           if (phii1.ne.phii1) phii1=150.0
4997           phii1=pinorm(phii1)
4998 #else
4999           phii1=phi(i+1)
5000 #endif
5001           ityp3=ithetyp((itype(i)))
5002           do k=1,nsingle
5003             cosph2(k)=dcos(k*phii1)
5004             sinph2(k)=dsin(k*phii1)
5005           enddo
5006         else
5007           phii1=0.0d0
5008           ityp3=nthetyp+1
5009           do k=1,nsingle
5010             cosph2(k)=0.0d0
5011             sinph2(k)=0.0d0
5012           enddo
5013         endif
5014 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5015 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5016 c        call flush(iout)
5017         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5018         do k=1,ndouble
5019           do l=1,k-1
5020             ccl=cosph1(l)*cosph2(k-l)
5021             ssl=sinph1(l)*sinph2(k-l)
5022             scl=sinph1(l)*cosph2(k-l)
5023             csl=cosph1(l)*sinph2(k-l)
5024             cosph1ph2(l,k)=ccl-ssl
5025             cosph1ph2(k,l)=ccl+ssl
5026             sinph1ph2(l,k)=scl+csl
5027             sinph1ph2(k,l)=scl-csl
5028           enddo
5029         enddo
5030         if (lprn) then
5031         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5032      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5033         write (iout,*) "coskt and sinkt"
5034         do k=1,nntheterm
5035           write (iout,*) k,coskt(k),sinkt(k)
5036         enddo
5037         endif
5038         do k=1,ntheterm
5039           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5040           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5041      &      *coskt(k)
5042           if (lprn)
5043      &    write (iout,*) "k",k," aathet",
5044      &    aathet(k,ityp1,ityp2,ityp3,iblock),
5045      &     " ethetai",ethetai
5046         enddo
5047         if (lprn) then
5048         write (iout,*) "cosph and sinph"
5049         do k=1,nsingle
5050           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5051         enddo
5052         write (iout,*) "cosph1ph2 and sinph2ph2"
5053         do k=2,ndouble
5054           do l=1,k-1
5055             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5056      &         sinph1ph2(l,k),sinph1ph2(k,l)
5057           enddo
5058         enddo
5059         write(iout,*) "ethetai",ethetai
5060         endif
5061         do m=1,ntheterm2
5062           do k=1,nsingle
5063             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5064      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5065      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5066      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5067             ethetai=ethetai+sinkt(m)*aux
5068             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5069             dephii=dephii+k*sinkt(m)*(
5070      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5071      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5072             dephii1=dephii1+k*sinkt(m)*(
5073      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5074      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5075             if (lprn)
5076      &      write (iout,*) "m",m," k",k," bbthet",
5077      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5078      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5079      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5080      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5081           enddo
5082         enddo
5083         if (lprn)
5084      &  write(iout,*) "ethetai",ethetai
5085         do m=1,ntheterm3
5086           do k=2,ndouble
5087             do l=1,k-1
5088               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5089      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5090      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5091      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5092               ethetai=ethetai+sinkt(m)*aux
5093               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5094               dephii=dephii+l*sinkt(m)*(
5095      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5096      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5097      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5098      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5099               dephii1=dephii1+(k-l)*sinkt(m)*(
5100      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5101      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5102      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5103      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5104               if (lprn) then
5105               write (iout,*) "m",m," k",k," l",l," ffthet",
5106      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5107      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5108      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5109      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5110      &            " ethetai",ethetai
5111               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5112      &            cosph1ph2(k,l)*sinkt(m),
5113      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5114               endif
5115             enddo
5116           enddo
5117         enddo
5118 10      continue
5119         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5120      &   i,theta(i)*rad2deg,phii*rad2deg,
5121      &   phii1*rad2deg,ethetai
5122         etheta=etheta+ethetai
5123         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5124         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5125 c        gloc(nphi+i-2,icg)=wang*dethetai
5126         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5127       enddo
5128 C now constrains
5129       ethetacnstr=0.0d0
5130 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5131       do i=1,ntheta_constr
5132         itheta=itheta_constr(i)
5133         thetiii=theta(itheta)
5134         difi=pinorm(thetiii-theta_constr0(i))
5135         if (difi.gt.theta_drange(i)) then
5136           difi=difi-theta_drange(i)
5137           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5138           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5139      &    +for_thet_constr(i)*difi**3
5140         else if (difi.lt.-drange(i)) then
5141           difi=difi+drange(i)
5142           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5143           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5144      &    +for_thet_constr(i)*difi**3
5145         else
5146           difi=0.0
5147         endif
5148 C       if (energy_dec) then
5149 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5150 C     &    i,itheta,rad2deg*thetiii,
5151 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5152 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5153 C     &    gloc(itheta+nphi-2,icg)
5154 C        endif
5155       enddo
5156       return
5157       end
5158 #endif
5159 #ifdef CRYST_SC
5160 c-----------------------------------------------------------------------------
5161       subroutine esc(escloc)
5162 C Calculate the local energy of a side chain and its derivatives in the
5163 C corresponding virtual-bond valence angles THETA and the spherical angles
5164 C ALPHA and OMEGA.
5165       implicit real*8 (a-h,o-z)
5166       include 'DIMENSIONS'
5167       include 'sizesclu.dat'
5168       include 'COMMON.GEO'
5169       include 'COMMON.LOCAL'
5170       include 'COMMON.VAR'
5171       include 'COMMON.INTERACT'
5172       include 'COMMON.DERIV'
5173       include 'COMMON.CHAIN'
5174       include 'COMMON.IOUNITS'
5175       include 'COMMON.NAMES'
5176       include 'COMMON.FFIELD'
5177       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5178      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5179       common /sccalc/ time11,time12,time112,theti,it,nlobit
5180       delta=0.02d0*pi
5181       escloc=0.0D0
5182 c     write (iout,'(a)') 'ESC'
5183       do i=loc_start,loc_end
5184         it=itype(i)
5185         if (it.eq.ntyp1) cycle
5186         if (it.eq.10) goto 1
5187         nlobit=nlob(iabs(it))
5188 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5189 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5190         theti=theta(i+1)-pipol
5191         x(1)=dtan(theti)
5192         x(2)=alph(i)
5193         x(3)=omeg(i)
5194 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5195
5196         if (x(2).gt.pi-delta) then
5197           xtemp(1)=x(1)
5198           xtemp(2)=pi-delta
5199           xtemp(3)=x(3)
5200           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5201           xtemp(2)=pi
5202           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5203           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5204      &        escloci,dersc(2))
5205           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5206      &        ddersc0(1),dersc(1))
5207           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5208      &        ddersc0(3),dersc(3))
5209           xtemp(2)=pi-delta
5210           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5211           xtemp(2)=pi
5212           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5213           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5214      &            dersc0(2),esclocbi,dersc02)
5215           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5216      &            dersc12,dersc01)
5217           call splinthet(x(2),0.5d0*delta,ss,ssd)
5218           dersc0(1)=dersc01
5219           dersc0(2)=dersc02
5220           dersc0(3)=0.0d0
5221           do k=1,3
5222             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5223           enddo
5224           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5225 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5226 c    &             esclocbi,ss,ssd
5227           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5228 c         escloci=esclocbi
5229 c         write (iout,*) escloci
5230         else if (x(2).lt.delta) then
5231           xtemp(1)=x(1)
5232           xtemp(2)=delta
5233           xtemp(3)=x(3)
5234           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5235           xtemp(2)=0.0d0
5236           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5237           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5238      &        escloci,dersc(2))
5239           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5240      &        ddersc0(1),dersc(1))
5241           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5242      &        ddersc0(3),dersc(3))
5243           xtemp(2)=delta
5244           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5245           xtemp(2)=0.0d0
5246           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5247           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5248      &            dersc0(2),esclocbi,dersc02)
5249           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5250      &            dersc12,dersc01)
5251           dersc0(1)=dersc01
5252           dersc0(2)=dersc02
5253           dersc0(3)=0.0d0
5254           call splinthet(x(2),0.5d0*delta,ss,ssd)
5255           do k=1,3
5256             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5257           enddo
5258           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5259 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5260 c    &             esclocbi,ss,ssd
5261           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5262 c         write (iout,*) escloci
5263         else
5264           call enesc(x,escloci,dersc,ddummy,.false.)
5265         endif
5266
5267         escloc=escloc+escloci
5268 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5269
5270         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5271      &   wscloc*dersc(1)
5272         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5273         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5274     1   continue
5275       enddo
5276       return
5277       end
5278 C---------------------------------------------------------------------------
5279       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5280       implicit real*8 (a-h,o-z)
5281       include 'DIMENSIONS'
5282       include 'COMMON.GEO'
5283       include 'COMMON.LOCAL'
5284       include 'COMMON.IOUNITS'
5285       common /sccalc/ time11,time12,time112,theti,it,nlobit
5286       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5287       double precision contr(maxlob,-1:1)
5288       logical mixed
5289 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5290         escloc_i=0.0D0
5291         do j=1,3
5292           dersc(j)=0.0D0
5293           if (mixed) ddersc(j)=0.0d0
5294         enddo
5295         x3=x(3)
5296
5297 C Because of periodicity of the dependence of the SC energy in omega we have
5298 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5299 C To avoid underflows, first compute & store the exponents.
5300
5301         do iii=-1,1
5302
5303           x(3)=x3+iii*dwapi
5304
5305           do j=1,nlobit
5306             do k=1,3
5307               z(k)=x(k)-censc(k,j,it)
5308             enddo
5309             do k=1,3
5310               Axk=0.0D0
5311               do l=1,3
5312                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5313               enddo
5314               Ax(k,j,iii)=Axk
5315             enddo
5316             expfac=0.0D0
5317             do k=1,3
5318               expfac=expfac+Ax(k,j,iii)*z(k)
5319             enddo
5320             contr(j,iii)=expfac
5321           enddo ! j
5322
5323         enddo ! iii
5324
5325         x(3)=x3
5326 C As in the case of ebend, we want to avoid underflows in exponentiation and
5327 C subsequent NaNs and INFs in energy calculation.
5328 C Find the largest exponent
5329         emin=contr(1,-1)
5330         do iii=-1,1
5331           do j=1,nlobit
5332             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5333           enddo
5334         enddo
5335         emin=0.5D0*emin
5336 cd      print *,'it=',it,' emin=',emin
5337
5338 C Compute the contribution to SC energy and derivatives
5339         do iii=-1,1
5340
5341           do j=1,nlobit
5342             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5343 cd          print *,'j=',j,' expfac=',expfac
5344             escloc_i=escloc_i+expfac
5345             do k=1,3
5346               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5347             enddo
5348             if (mixed) then
5349               do k=1,3,2
5350                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5351      &            +gaussc(k,2,j,it))*expfac
5352               enddo
5353             endif
5354           enddo
5355
5356         enddo ! iii
5357
5358         dersc(1)=dersc(1)/cos(theti)**2
5359         ddersc(1)=ddersc(1)/cos(theti)**2
5360         ddersc(3)=ddersc(3)
5361
5362         escloci=-(dlog(escloc_i)-emin)
5363         do j=1,3
5364           dersc(j)=dersc(j)/escloc_i
5365         enddo
5366         if (mixed) then
5367           do j=1,3,2
5368             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5369           enddo
5370         endif
5371       return
5372       end
5373 C------------------------------------------------------------------------------
5374       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5375       implicit real*8 (a-h,o-z)
5376       include 'DIMENSIONS'
5377       include 'COMMON.GEO'
5378       include 'COMMON.LOCAL'
5379       include 'COMMON.IOUNITS'
5380       common /sccalc/ time11,time12,time112,theti,it,nlobit
5381       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5382       double precision contr(maxlob)
5383       logical mixed
5384
5385       escloc_i=0.0D0
5386
5387       do j=1,3
5388         dersc(j)=0.0D0
5389       enddo
5390
5391       do j=1,nlobit
5392         do k=1,2
5393           z(k)=x(k)-censc(k,j,it)
5394         enddo
5395         z(3)=dwapi
5396         do k=1,3
5397           Axk=0.0D0
5398           do l=1,3
5399             Axk=Axk+gaussc(l,k,j,it)*z(l)
5400           enddo
5401           Ax(k,j)=Axk
5402         enddo
5403         expfac=0.0D0
5404         do k=1,3
5405           expfac=expfac+Ax(k,j)*z(k)
5406         enddo
5407         contr(j)=expfac
5408       enddo ! j
5409
5410 C As in the case of ebend, we want to avoid underflows in exponentiation and
5411 C subsequent NaNs and INFs in energy calculation.
5412 C Find the largest exponent
5413       emin=contr(1)
5414       do j=1,nlobit
5415         if (emin.gt.contr(j)) emin=contr(j)
5416       enddo
5417       emin=0.5D0*emin
5418
5419 C Compute the contribution to SC energy and derivatives
5420
5421       dersc12=0.0d0
5422       do j=1,nlobit
5423         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5424         escloc_i=escloc_i+expfac
5425         do k=1,2
5426           dersc(k)=dersc(k)+Ax(k,j)*expfac
5427         enddo
5428         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5429      &            +gaussc(1,2,j,it))*expfac
5430         dersc(3)=0.0d0
5431       enddo
5432
5433       dersc(1)=dersc(1)/cos(theti)**2
5434       dersc12=dersc12/cos(theti)**2
5435       escloci=-(dlog(escloc_i)-emin)
5436       do j=1,2
5437         dersc(j)=dersc(j)/escloc_i
5438       enddo
5439       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5440       return
5441       end
5442 #else
5443 c----------------------------------------------------------------------------------
5444       subroutine esc(escloc)
5445 C Calculate the local energy of a side chain and its derivatives in the
5446 C corresponding virtual-bond valence angles THETA and the spherical angles
5447 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5448 C added by Urszula Kozlowska. 07/11/2007
5449 C
5450       implicit real*8 (a-h,o-z)
5451       include 'DIMENSIONS'
5452       include 'sizesclu.dat'
5453       include 'COMMON.GEO'
5454       include 'COMMON.LOCAL'
5455       include 'COMMON.VAR'
5456       include 'COMMON.SCROT'
5457       include 'COMMON.INTERACT'
5458       include 'COMMON.DERIV'
5459       include 'COMMON.CHAIN'
5460       include 'COMMON.IOUNITS'
5461       include 'COMMON.NAMES'
5462       include 'COMMON.FFIELD'
5463       include 'COMMON.CONTROL'
5464       include 'COMMON.VECTORS'
5465       double precision x_prime(3),y_prime(3),z_prime(3)
5466      &    , sumene,dsc_i,dp2_i,x(65),
5467      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5468      &    de_dxx,de_dyy,de_dzz,de_dt
5469       double precision s1_t,s1_6_t,s2_t,s2_6_t
5470       double precision
5471      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5472      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5473      & dt_dCi(3),dt_dCi1(3)
5474       common /sccalc/ time11,time12,time112,theti,it,nlobit
5475       delta=0.02d0*pi
5476       escloc=0.0D0
5477       do i=loc_start,loc_end
5478         if (itype(i).eq.ntyp1) cycle
5479         costtab(i+1) =dcos(theta(i+1))
5480         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5481         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5482         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5483         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5484         cosfac=dsqrt(cosfac2)
5485         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5486         sinfac=dsqrt(sinfac2)
5487         it=iabs(itype(i))
5488         if (it.eq.10) goto 1
5489 c
5490 C  Compute the axes of tghe local cartesian coordinates system; store in
5491 c   x_prime, y_prime and z_prime
5492 c
5493         do j=1,3
5494           x_prime(j) = 0.00
5495           y_prime(j) = 0.00
5496           z_prime(j) = 0.00
5497         enddo
5498 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5499 C     &   dc_norm(3,i+nres)
5500         do j = 1,3
5501           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5502           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5503         enddo
5504         do j = 1,3
5505           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5506         enddo
5507 c       write (2,*) "i",i
5508 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5509 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5510 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5511 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5512 c      & " xy",scalar(x_prime(1),y_prime(1)),
5513 c      & " xz",scalar(x_prime(1),z_prime(1)),
5514 c      & " yy",scalar(y_prime(1),y_prime(1)),
5515 c      & " yz",scalar(y_prime(1),z_prime(1)),
5516 c      & " zz",scalar(z_prime(1),z_prime(1))
5517 c
5518 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5519 C to local coordinate system. Store in xx, yy, zz.
5520 c
5521         xx=0.0d0
5522         yy=0.0d0
5523         zz=0.0d0
5524         do j = 1,3
5525           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5526           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5527           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5528         enddo
5529
5530         xxtab(i)=xx
5531         yytab(i)=yy
5532         zztab(i)=zz
5533 C
5534 C Compute the energy of the ith side cbain
5535 C
5536 c        write (2,*) "xx",xx," yy",yy," zz",zz
5537         it=iabs(itype(i))
5538         do j = 1,65
5539           x(j) = sc_parmin(j,it)
5540         enddo
5541 #ifdef CHECK_COORD
5542 Cc diagnostics - remove later
5543         xx1 = dcos(alph(2))
5544         yy1 = dsin(alph(2))*dcos(omeg(2))
5545 c        zz1 = -dsin(alph(2))*dsin(omeg(2))
5546         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5547         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5548      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5549      &    xx1,yy1,zz1
5550 C,"  --- ", xx_w,yy_w,zz_w
5551 c end diagnostics
5552 #endif
5553         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5554      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5555      &   + x(10)*yy*zz
5556         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5557      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5558      & + x(20)*yy*zz
5559         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5560      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5561      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5562      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5563      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5564      &  +x(40)*xx*yy*zz
5565         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5566      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5567      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5568      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5569      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5570      &  +x(60)*xx*yy*zz
5571         dsc_i   = 0.743d0+x(61)
5572         dp2_i   = 1.9d0+x(62)
5573         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5574      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5575         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5576      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5577         s1=(1+x(63))/(0.1d0 + dscp1)
5578         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5579         s2=(1+x(65))/(0.1d0 + dscp2)
5580         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5581         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5582      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5583 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5584 c     &   sumene4,
5585 c     &   dscp1,dscp2,sumene
5586 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5587         escloc = escloc + sumene
5588 c        write (2,*) "escloc",escloc
5589         if (.not. calc_grad) goto 1
5590 #ifdef DEBUG
5591 C
5592 C This section to check the numerical derivatives of the energy of ith side
5593 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5594 C #define DEBUG in the code to turn it on.
5595 C
5596         write (2,*) "sumene               =",sumene
5597         aincr=1.0d-7
5598         xxsave=xx
5599         xx=xx+aincr
5600         write (2,*) xx,yy,zz
5601         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5602         de_dxx_num=(sumenep-sumene)/aincr
5603         xx=xxsave
5604         write (2,*) "xx+ sumene from enesc=",sumenep
5605         yysave=yy
5606         yy=yy+aincr
5607         write (2,*) xx,yy,zz
5608         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5609         de_dyy_num=(sumenep-sumene)/aincr
5610         yy=yysave
5611         write (2,*) "yy+ sumene from enesc=",sumenep
5612         zzsave=zz
5613         zz=zz+aincr
5614         write (2,*) xx,yy,zz
5615         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5616         de_dzz_num=(sumenep-sumene)/aincr
5617         zz=zzsave
5618         write (2,*) "zz+ sumene from enesc=",sumenep
5619         costsave=cost2tab(i+1)
5620         sintsave=sint2tab(i+1)
5621         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5622         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5623         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5624         de_dt_num=(sumenep-sumene)/aincr
5625         write (2,*) " t+ sumene from enesc=",sumenep
5626         cost2tab(i+1)=costsave
5627         sint2tab(i+1)=sintsave
5628 C End of diagnostics section.
5629 #endif
5630 C
5631 C Compute the gradient of esc
5632 C
5633         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5634         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5635         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5636         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5637         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5638         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5639         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5640         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5641         pom1=(sumene3*sint2tab(i+1)+sumene1)
5642      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5643         pom2=(sumene4*cost2tab(i+1)+sumene2)
5644      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5645         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5646         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5647      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5648      &  +x(40)*yy*zz
5649         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5650         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5651      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5652      &  +x(60)*yy*zz
5653         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5654      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5655      &        +(pom1+pom2)*pom_dx
5656 #ifdef DEBUG
5657         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5658 #endif
5659 C
5660         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5661         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5662      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5663      &  +x(40)*xx*zz
5664         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5665         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5666      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5667      &  +x(59)*zz**2 +x(60)*xx*zz
5668         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5669      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5670      &        +(pom1-pom2)*pom_dy
5671 #ifdef DEBUG
5672         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5673 #endif
5674 C
5675         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5676      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5677      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5678      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5679      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5680      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5681      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5682      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5683 #ifdef DEBUG
5684         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5685 #endif
5686 C
5687         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5688      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5689      &  +pom1*pom_dt1+pom2*pom_dt2
5690 #ifdef DEBUG
5691         write(2,*), "de_dt = ", de_dt,de_dt_num
5692 #endif
5693 c
5694 C
5695        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5696        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5697        cosfac2xx=cosfac2*xx
5698        sinfac2yy=sinfac2*yy
5699        do k = 1,3
5700          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5701      &      vbld_inv(i+1)
5702          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5703      &      vbld_inv(i)
5704          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5705          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5706 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5707 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5708 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5709 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5710          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5711          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5712          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5713          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5714          dZZ_Ci1(k)=0.0d0
5715          dZZ_Ci(k)=0.0d0
5716          do j=1,3
5717            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5718      &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5719            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5720      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5721          enddo
5722
5723          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5724          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5725          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5726 c
5727          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5728          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5729        enddo
5730
5731        do k=1,3
5732          dXX_Ctab(k,i)=dXX_Ci(k)
5733          dXX_C1tab(k,i)=dXX_Ci1(k)
5734          dYY_Ctab(k,i)=dYY_Ci(k)
5735          dYY_C1tab(k,i)=dYY_Ci1(k)
5736          dZZ_Ctab(k,i)=dZZ_Ci(k)
5737          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5738          dXX_XYZtab(k,i)=dXX_XYZ(k)
5739          dYY_XYZtab(k,i)=dYY_XYZ(k)
5740          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5741        enddo
5742
5743        do k = 1,3
5744 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5745 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5746 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5747 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5748 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5749 c     &    dt_dci(k)
5750 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5751 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5752          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5753      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5754          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5755      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5756          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5757      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5758        enddo
5759 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5760 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5761
5762 C to check gradient call subroutine check_grad
5763
5764     1 continue
5765       enddo
5766       return
5767       end
5768 #endif
5769 c------------------------------------------------------------------------------
5770       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5771 C
5772 C This procedure calculates two-body contact function g(rij) and its derivative:
5773 C
5774 C           eps0ij                                     !       x < -1
5775 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5776 C            0                                         !       x > 1
5777 C
5778 C where x=(rij-r0ij)/delta
5779 C
5780 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5781 C
5782       implicit none
5783       double precision rij,r0ij,eps0ij,fcont,fprimcont
5784       double precision x,x2,x4,delta
5785 c     delta=0.02D0*r0ij
5786 c      delta=0.2D0*r0ij
5787       x=(rij-r0ij)/delta
5788       if (x.lt.-1.0D0) then
5789         fcont=eps0ij
5790         fprimcont=0.0D0
5791       else if (x.le.1.0D0) then
5792         x2=x*x
5793         x4=x2*x2
5794         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5795         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5796       else
5797         fcont=0.0D0
5798         fprimcont=0.0D0
5799       endif
5800       return
5801       end
5802 c------------------------------------------------------------------------------
5803       subroutine splinthet(theti,delta,ss,ssder)
5804       implicit real*8 (a-h,o-z)
5805       include 'DIMENSIONS'
5806       include 'sizesclu.dat'
5807       include 'COMMON.VAR'
5808       include 'COMMON.GEO'
5809       thetup=pi-delta
5810       thetlow=delta
5811       if (theti.gt.pipol) then
5812         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5813       else
5814         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5815         ssder=-ssder
5816       endif
5817       return
5818       end
5819 c------------------------------------------------------------------------------
5820       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5821       implicit none
5822       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5823       double precision ksi,ksi2,ksi3,a1,a2,a3
5824       a1=fprim0*delta/(f1-f0)
5825       a2=3.0d0-2.0d0*a1
5826       a3=a1-2.0d0
5827       ksi=(x-x0)/delta
5828       ksi2=ksi*ksi
5829       ksi3=ksi2*ksi
5830       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5831       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5832       return
5833       end
5834 c------------------------------------------------------------------------------
5835       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5836       implicit none
5837       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5838       double precision ksi,ksi2,ksi3,a1,a2,a3
5839       ksi=(x-x0)/delta
5840       ksi2=ksi*ksi
5841       ksi3=ksi2*ksi
5842       a1=fprim0x*delta
5843       a2=3*(f1x-f0x)-2*fprim0x*delta
5844       a3=fprim0x*delta-2*(f1x-f0x)
5845       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5846       return
5847       end
5848 C-----------------------------------------------------------------------------
5849 #ifdef CRYST_TOR
5850 C-----------------------------------------------------------------------------
5851       subroutine etor(etors,edihcnstr,fact)
5852       implicit real*8 (a-h,o-z)
5853       include 'DIMENSIONS'
5854       include 'sizesclu.dat'
5855       include 'COMMON.VAR'
5856       include 'COMMON.GEO'
5857       include 'COMMON.LOCAL'
5858       include 'COMMON.TORSION'
5859       include 'COMMON.INTERACT'
5860       include 'COMMON.DERIV'
5861       include 'COMMON.CHAIN'
5862       include 'COMMON.NAMES'
5863       include 'COMMON.IOUNITS'
5864       include 'COMMON.FFIELD'
5865       include 'COMMON.TORCNSTR'
5866       logical lprn
5867 C Set lprn=.true. for debugging
5868       lprn=.false.
5869 c      lprn=.true.
5870       etors=0.0D0
5871       do i=iphi_start,iphi_end
5872         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5873      &      .or. itype(i).eq.ntyp1) cycle
5874         itori=itortyp(itype(i-2))
5875         itori1=itortyp(itype(i-1))
5876         phii=phi(i)
5877         gloci=0.0D0
5878 C Proline-Proline pair is a special case...
5879         if (itori.eq.3 .and. itori1.eq.3) then
5880           if (phii.gt.-dwapi3) then
5881             cosphi=dcos(3*phii)
5882             fac=1.0D0/(1.0D0-cosphi)
5883             etorsi=v1(1,3,3)*fac
5884             etorsi=etorsi+etorsi
5885             etors=etors+etorsi-v1(1,3,3)
5886             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5887           endif
5888           do j=1,3
5889             v1ij=v1(j+1,itori,itori1)
5890             v2ij=v2(j+1,itori,itori1)
5891             cosphi=dcos(j*phii)
5892             sinphi=dsin(j*phii)
5893             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5894             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5895           enddo
5896         else
5897           do j=1,nterm_old
5898             v1ij=v1(j,itori,itori1)
5899             v2ij=v2(j,itori,itori1)
5900             cosphi=dcos(j*phii)
5901             sinphi=dsin(j*phii)
5902             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5903             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5904           enddo
5905         endif
5906         if (lprn)
5907      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5908      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5909      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5910         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5911 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5912       enddo
5913 ! 6/20/98 - dihedral angle constraints
5914       edihcnstr=0.0d0
5915       do i=1,ndih_constr
5916         itori=idih_constr(i)
5917         phii=phi(itori)
5918         difi=phii-phi0(i)
5919         if (difi.gt.drange(i)) then
5920           difi=difi-drange(i)
5921           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5922           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5923         else if (difi.lt.-drange(i)) then
5924           difi=difi+drange(i)
5925           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5926           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5927         endif
5928 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5929 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5930       enddo
5931 !      write (iout,*) 'edihcnstr',edihcnstr
5932       return
5933       end
5934 c------------------------------------------------------------------------------
5935 #else
5936       subroutine etor(etors,edihcnstr,fact)
5937       implicit real*8 (a-h,o-z)
5938       include 'DIMENSIONS'
5939       include 'sizesclu.dat'
5940       include 'COMMON.VAR'
5941       include 'COMMON.GEO'
5942       include 'COMMON.LOCAL'
5943       include 'COMMON.TORSION'
5944       include 'COMMON.INTERACT'
5945       include 'COMMON.DERIV'
5946       include 'COMMON.CHAIN'
5947       include 'COMMON.NAMES'
5948       include 'COMMON.IOUNITS'
5949       include 'COMMON.FFIELD'
5950       include 'COMMON.TORCNSTR'
5951       logical lprn
5952 C Set lprn=.true. for debugging
5953       lprn=.false.
5954 c      lprn=.true.
5955       etors=0.0D0
5956       do i=iphi_start,iphi_end
5957         if (i.le.2) cycle
5958         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5959      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5960         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5961          if (iabs(itype(i)).eq.20) then
5962          iblock=2
5963          else
5964          iblock=1
5965          endif
5966         itori=itortyp(itype(i-2))
5967         itori1=itortyp(itype(i-1))
5968         phii=phi(i)
5969         gloci=0.0D0
5970 C Regular cosine and sine terms
5971         do j=1,nterm(itori,itori1,iblock)
5972           v1ij=v1(j,itori,itori1,iblock)
5973           v2ij=v2(j,itori,itori1,iblock)
5974           cosphi=dcos(j*phii)
5975           sinphi=dsin(j*phii)
5976           etors=etors+v1ij*cosphi+v2ij*sinphi
5977           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5978         enddo
5979 C Lorentz terms
5980 C                         v1
5981 C  E = SUM ----------------------------------- - v1
5982 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5983 C
5984         cosphi=dcos(0.5d0*phii)
5985         sinphi=dsin(0.5d0*phii)
5986         do j=1,nlor(itori,itori1,iblock)
5987           vl1ij=vlor1(j,itori,itori1)
5988           vl2ij=vlor2(j,itori,itori1)
5989           vl3ij=vlor3(j,itori,itori1)
5990           pom=vl2ij*cosphi+vl3ij*sinphi
5991           pom1=1.0d0/(pom*pom+1.0d0)
5992           etors=etors+vl1ij*pom1
5993           pom=-pom*pom1*pom1
5994           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5995         enddo
5996 C Subtract the constant term
5997         etors=etors-v0(itori,itori1,iblock)
5998         if (lprn)
5999      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6000      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6001      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6002         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6003 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6004  1215   continue
6005       enddo
6006 ! 6/20/98 - dihedral angle constraints
6007       edihcnstr=0.0d0
6008       do i=1,ndih_constr
6009         itori=idih_constr(i)
6010         phii=phi(itori)
6011         difi=pinorm(phii-phi0(i))
6012         edihi=0.0d0
6013         if (difi.gt.drange(i)) then
6014           difi=difi-drange(i)
6015           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6016           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6017           edihi=0.25d0*ftors(i)*difi**4
6018         else if (difi.lt.-drange(i)) then
6019           difi=difi+drange(i)
6020           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6021           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6022           edihi=0.25d0*ftors(i)*difi**4
6023         else
6024           difi=0.0d0
6025         endif
6026 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
6027 c     &    drange(i),edihi
6028 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6029 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6030       enddo
6031 !      write (iout,*) 'edihcnstr',edihcnstr
6032       return
6033       end
6034 c----------------------------------------------------------------------------
6035       subroutine etor_d(etors_d,fact2)
6036 C 6/23/01 Compute double torsional energy
6037       implicit real*8 (a-h,o-z)
6038       include 'DIMENSIONS'
6039       include 'sizesclu.dat'
6040       include 'COMMON.VAR'
6041       include 'COMMON.GEO'
6042       include 'COMMON.LOCAL'
6043       include 'COMMON.TORSION'
6044       include 'COMMON.INTERACT'
6045       include 'COMMON.DERIV'
6046       include 'COMMON.CHAIN'
6047       include 'COMMON.NAMES'
6048       include 'COMMON.IOUNITS'
6049       include 'COMMON.FFIELD'
6050       include 'COMMON.TORCNSTR'
6051       logical lprn
6052 C Set lprn=.true. for debugging
6053       lprn=.false.
6054 c     lprn=.true.
6055       etors_d=0.0D0
6056       do i=iphi_start,iphi_end-1
6057         if (i.le.3) cycle
6058          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6059      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6060      &  (itype(i+1).eq.ntyp1)) cycle
6061         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6062      &     goto 1215
6063         itori=itortyp(itype(i-2))
6064         itori1=itortyp(itype(i-1))
6065         itori2=itortyp(itype(i))
6066         phii=phi(i)
6067         phii1=phi(i+1)
6068         gloci1=0.0D0
6069         gloci2=0.0D0
6070         iblock=1
6071         if (iabs(itype(i+1)).eq.20) iblock=2
6072 C Regular cosine and sine terms
6073        do j=1,ntermd_1(itori,itori1,itori2,iblock)
6074           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6075           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6076           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6077           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6078           cosphi1=dcos(j*phii)
6079           sinphi1=dsin(j*phii)
6080           cosphi2=dcos(j*phii1)
6081           sinphi2=dsin(j*phii1)
6082           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6083      &     v2cij*cosphi2+v2sij*sinphi2
6084           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6085           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6086         enddo
6087         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6088           do l=1,k-1
6089             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6090             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6091             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6092             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6093             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6094             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6095             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6096             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6097             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6098      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6099             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6100      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6101             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6102      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6103           enddo
6104         enddo
6105         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6106         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6107  1215   continue
6108       enddo
6109       return
6110       end
6111 #endif
6112 c------------------------------------------------------------------------------
6113       subroutine eback_sc_corr(esccor)
6114 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6115 c        conformational states; temporarily implemented as differences
6116 c        between UNRES torsional potentials (dependent on three types of
6117 c        residues) and the torsional potentials dependent on all 20 types
6118 c        of residues computed from AM1 energy surfaces of terminally-blocked
6119 c        amino-acid residues.
6120       implicit real*8 (a-h,o-z)
6121       include 'DIMENSIONS'
6122       include 'sizesclu.dat'
6123       include 'COMMON.VAR'
6124       include 'COMMON.GEO'
6125       include 'COMMON.LOCAL'
6126       include 'COMMON.TORSION'
6127       include 'COMMON.SCCOR'
6128       include 'COMMON.INTERACT'
6129       include 'COMMON.DERIV'
6130       include 'COMMON.CHAIN'
6131       include 'COMMON.NAMES'
6132       include 'COMMON.IOUNITS'
6133       include 'COMMON.FFIELD'
6134       include 'COMMON.CONTROL'
6135       logical lprn
6136 C Set lprn=.true. for debugging
6137       lprn=.false.
6138 c      lprn=.true.
6139 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6140       esccor=0.0D0
6141       do i=itau_start,itau_end
6142         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6143         esccor_ii=0.0D0
6144         isccori=isccortyp(itype(i-2))
6145         isccori1=isccortyp(itype(i-1))
6146         phii=phi(i)
6147         do intertyp=1,3 !intertyp
6148 cc Added 09 May 2012 (Adasko)
6149 cc  Intertyp means interaction type of backbone mainchain correlation:
6150 c   1 = SC...Ca...Ca...Ca
6151 c   2 = Ca...Ca...Ca...SC
6152 c   3 = SC...Ca...Ca...SCi
6153         gloci=0.0D0
6154         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6155      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6156      &      (itype(i-1).eq.ntyp1)))
6157      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6158      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6159      &     .or.(itype(i).eq.ntyp1)))
6160      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6161      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6162      &      (itype(i-3).eq.ntyp1)))) cycle
6163         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6164         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6165      & cycle
6166        do j=1,nterm_sccor(isccori,isccori1)
6167           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6168           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6169           cosphi=dcos(j*tauangle(intertyp,i))
6170           sinphi=dsin(j*tauangle(intertyp,i))
6171            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6172 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6173          enddo
6174 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
6175 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
6176         if (lprn)
6177      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6178      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6179      &  (v1sccor(j,1,itori,itori1),j=1,6),
6180      &  (v2sccor(j,1,itori,itori1),j=1,6)
6181         gsccor_loc(i-3)=gloci
6182        enddo !intertyp
6183       enddo
6184       return
6185       end
6186 c------------------------------------------------------------------------------
6187       subroutine multibody(ecorr)
6188 C This subroutine calculates multi-body contributions to energy following
6189 C the idea of Skolnick et al. If side chains I and J make a contact and
6190 C at the same time side chains I+1 and J+1 make a contact, an extra
6191 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6192       implicit real*8 (a-h,o-z)
6193       include 'DIMENSIONS'
6194       include 'COMMON.IOUNITS'
6195       include 'COMMON.DERIV'
6196       include 'COMMON.INTERACT'
6197       include 'COMMON.CONTACTS'
6198       double precision gx(3),gx1(3)
6199       logical lprn
6200
6201 C Set lprn=.true. for debugging
6202       lprn=.false.
6203
6204       if (lprn) then
6205         write (iout,'(a)') 'Contact function values:'
6206         do i=nnt,nct-2
6207           write (iout,'(i2,20(1x,i2,f10.5))')
6208      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6209         enddo
6210       endif
6211       ecorr=0.0D0
6212       do i=nnt,nct
6213         do j=1,3
6214           gradcorr(j,i)=0.0D0
6215           gradxorr(j,i)=0.0D0
6216         enddo
6217       enddo
6218       do i=nnt,nct-2
6219
6220         DO ISHIFT = 3,4
6221
6222         i1=i+ishift
6223         num_conti=num_cont(i)
6224         num_conti1=num_cont(i1)
6225         do jj=1,num_conti
6226           j=jcont(jj,i)
6227           do kk=1,num_conti1
6228             j1=jcont(kk,i1)
6229             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6230 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6231 cd   &                   ' ishift=',ishift
6232 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6233 C The system gains extra energy.
6234               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6235             endif   ! j1==j+-ishift
6236           enddo     ! kk
6237         enddo       ! jj
6238
6239         ENDDO ! ISHIFT
6240
6241       enddo         ! i
6242       return
6243       end
6244 c------------------------------------------------------------------------------
6245       double precision function esccorr(i,j,k,l,jj,kk)
6246       implicit real*8 (a-h,o-z)
6247       include 'DIMENSIONS'
6248       include 'COMMON.IOUNITS'
6249       include 'COMMON.DERIV'
6250       include 'COMMON.INTERACT'
6251       include 'COMMON.CONTACTS'
6252       double precision gx(3),gx1(3)
6253       logical lprn
6254       lprn=.false.
6255       eij=facont(jj,i)
6256       ekl=facont(kk,k)
6257 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6258 C Calculate the multi-body contribution to energy.
6259 C Calculate multi-body contributions to the gradient.
6260 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6261 cd   & k,l,(gacont(m,kk,k),m=1,3)
6262       do m=1,3
6263         gx(m) =ekl*gacont(m,jj,i)
6264         gx1(m)=eij*gacont(m,kk,k)
6265         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6266         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6267         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6268         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6269       enddo
6270       do m=i,j-1
6271         do ll=1,3
6272           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6273         enddo
6274       enddo
6275       do m=k,l-1
6276         do ll=1,3
6277           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6278         enddo
6279       enddo
6280       esccorr=-eij*ekl
6281       return
6282       end
6283 c------------------------------------------------------------------------------
6284 #ifdef MPL
6285       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6286       implicit real*8 (a-h,o-z)
6287       include 'DIMENSIONS'
6288       integer dimen1,dimen2,atom,indx
6289       double precision buffer(dimen1,dimen2)
6290       double precision zapas
6291       common /contacts_hb/ zapas(3,20,maxres,7),
6292      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6293      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6294       num_kont=num_cont_hb(atom)
6295       do i=1,num_kont
6296         do k=1,7
6297           do j=1,3
6298             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6299           enddo ! j
6300         enddo ! k
6301         buffer(i,indx+22)=facont_hb(i,atom)
6302         buffer(i,indx+23)=ees0p(i,atom)
6303         buffer(i,indx+24)=ees0m(i,atom)
6304         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6305       enddo ! i
6306       buffer(1,indx+26)=dfloat(num_kont)
6307       return
6308       end
6309 c------------------------------------------------------------------------------
6310       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6311       implicit real*8 (a-h,o-z)
6312       include 'DIMENSIONS'
6313       integer dimen1,dimen2,atom,indx
6314       double precision buffer(dimen1,dimen2)
6315       double precision zapas
6316       common /contacts_hb/ zapas(3,ntyp,maxres,7),
6317      &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
6318      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
6319       num_kont=buffer(1,indx+26)
6320       num_kont_old=num_cont_hb(atom)
6321       num_cont_hb(atom)=num_kont+num_kont_old
6322       do i=1,num_kont
6323         ii=i+num_kont_old
6324         do k=1,7
6325           do j=1,3
6326             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6327           enddo ! j
6328         enddo ! k
6329         facont_hb(ii,atom)=buffer(i,indx+22)
6330         ees0p(ii,atom)=buffer(i,indx+23)
6331         ees0m(ii,atom)=buffer(i,indx+24)
6332         jcont_hb(ii,atom)=buffer(i,indx+25)
6333       enddo ! i
6334       return
6335       end
6336 c------------------------------------------------------------------------------
6337 #endif
6338       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6339 C This subroutine calculates multi-body contributions to hydrogen-bonding
6340       implicit real*8 (a-h,o-z)
6341       include 'DIMENSIONS'
6342       include 'sizesclu.dat'
6343       include 'COMMON.IOUNITS'
6344 #ifdef MPL
6345       include 'COMMON.INFO'
6346 #endif
6347       include 'COMMON.FFIELD'
6348       include 'COMMON.DERIV'
6349       include 'COMMON.INTERACT'
6350       include 'COMMON.CONTACTS'
6351 #ifdef MPL
6352       parameter (max_cont=maxconts)
6353       parameter (max_dim=2*(8*3+2))
6354       parameter (msglen1=max_cont*max_dim*4)
6355       parameter (msglen2=2*msglen1)
6356       integer source,CorrelType,CorrelID,Error
6357       double precision buffer(max_cont,max_dim)
6358 #endif
6359       double precision gx(3),gx1(3)
6360       logical lprn,ldone
6361
6362 C Set lprn=.true. for debugging
6363       lprn=.false.
6364 #ifdef MPL
6365       n_corr=0
6366       n_corr1=0
6367       if (fgProcs.le.1) goto 30
6368       if (lprn) then
6369         write (iout,'(a)') 'Contact function values:'
6370         do i=nnt,nct-2
6371           write (iout,'(2i3,50(1x,i2,f5.2))')
6372      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6373      &    j=1,num_cont_hb(i))
6374         enddo
6375       endif
6376 C Caution! Following code assumes that electrostatic interactions concerning
6377 C a given atom are split among at most two processors!
6378       CorrelType=477
6379       CorrelID=MyID+1
6380       ldone=.false.
6381       do i=1,max_cont
6382         do j=1,max_dim
6383           buffer(i,j)=0.0D0
6384         enddo
6385       enddo
6386       mm=mod(MyRank,2)
6387 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6388       if (mm) 20,20,10
6389    10 continue
6390 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6391       if (MyRank.gt.0) then
6392 C Send correlation contributions to the preceding processor
6393         msglen=msglen1
6394         nn=num_cont_hb(iatel_s)
6395         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6396 cd      write (iout,*) 'The BUFFER array:'
6397 cd      do i=1,nn
6398 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6399 cd      enddo
6400         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6401           msglen=msglen2
6402             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6403 C Clear the contacts of the atom passed to the neighboring processor
6404         nn=num_cont_hb(iatel_s+1)
6405 cd      do i=1,nn
6406 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6407 cd      enddo
6408             num_cont_hb(iatel_s)=0
6409         endif
6410 cd      write (iout,*) 'Processor ',MyID,MyRank,
6411 cd   & ' is sending correlation contribution to processor',MyID-1,
6412 cd   & ' msglen=',msglen
6413 cd      write (*,*) 'Processor ',MyID,MyRank,
6414 cd   & ' is sending correlation contribution to processor',MyID-1,
6415 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6416         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6417 cd      write (iout,*) 'Processor ',MyID,
6418 cd   & ' has sent correlation contribution to processor',MyID-1,
6419 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6420 cd      write (*,*) 'Processor ',MyID,
6421 cd   & ' has sent correlation contribution to processor',MyID-1,
6422 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6423         msglen=msglen1
6424       endif ! (MyRank.gt.0)
6425       if (ldone) goto 30
6426       ldone=.true.
6427    20 continue
6428 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6429       if (MyRank.lt.fgProcs-1) then
6430 C Receive correlation contributions from the next processor
6431         msglen=msglen1
6432         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6433 cd      write (iout,*) 'Processor',MyID,
6434 cd   & ' is receiving correlation contribution from processor',MyID+1,
6435 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6436 cd      write (*,*) 'Processor',MyID,
6437 cd   & ' is receiving correlation contribution from processor',MyID+1,
6438 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6439         nbytes=-1
6440         do while (nbytes.le.0)
6441           call mp_probe(MyID+1,CorrelType,nbytes)
6442         enddo
6443 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6444         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6445 cd      write (iout,*) 'Processor',MyID,
6446 cd   & ' has received correlation contribution from processor',MyID+1,
6447 cd   & ' msglen=',msglen,' nbytes=',nbytes
6448 cd      write (iout,*) 'The received BUFFER array:'
6449 cd      do i=1,max_cont
6450 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6451 cd      enddo
6452         if (msglen.eq.msglen1) then
6453           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6454         else if (msglen.eq.msglen2)  then
6455           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6456           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6457         else
6458           write (iout,*)
6459      & 'ERROR!!!! message length changed while processing correlations.'
6460           write (*,*)
6461      & 'ERROR!!!! message length changed while processing correlations.'
6462           call mp_stopall(Error)
6463         endif ! msglen.eq.msglen1
6464       endif ! MyRank.lt.fgProcs-1
6465       if (ldone) goto 30
6466       ldone=.true.
6467       goto 10
6468    30 continue
6469 #endif
6470       if (lprn) then
6471         write (iout,'(a)') 'Contact function values:'
6472         do i=nnt,nct-2
6473           write (iout,'(2i3,50(1x,i2,f5.2))')
6474      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6475      &    j=1,num_cont_hb(i))
6476         enddo
6477       endif
6478       ecorr=0.0D0
6479 C Remove the loop below after debugging !!!
6480       do i=nnt,nct
6481         do j=1,3
6482           gradcorr(j,i)=0.0D0
6483           gradxorr(j,i)=0.0D0
6484         enddo
6485       enddo
6486 C Calculate the local-electrostatic correlation terms
6487       do i=iatel_s,iatel_e+1
6488         i1=i+1
6489         num_conti=num_cont_hb(i)
6490         num_conti1=num_cont_hb(i+1)
6491         do jj=1,num_conti
6492           j=jcont_hb(jj,i)
6493           do kk=1,num_conti1
6494             j1=jcont_hb(kk,i1)
6495 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6496 c     &         ' jj=',jj,' kk=',kk
6497             if (j1.eq.j+1 .or. j1.eq.j-1) then
6498 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6499 C The system gains extra energy.
6500               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6501               n_corr=n_corr+1
6502             else if (j1.eq.j) then
6503 C Contacts I-J and I-(J+1) occur simultaneously.
6504 C The system loses extra energy.
6505 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6506             endif
6507           enddo ! kk
6508           do kk=1,num_conti
6509             j1=jcont_hb(kk,i)
6510 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6511 c    &         ' jj=',jj,' kk=',kk
6512             if (j1.eq.j+1) then
6513 C Contacts I-J and (I+1)-J occur simultaneously.
6514 C The system loses extra energy.
6515 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6516             endif ! j1==j+1
6517           enddo ! kk
6518         enddo ! jj
6519       enddo ! i
6520       return
6521       end
6522 c------------------------------------------------------------------------------
6523       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6524      &  n_corr1)
6525 C This subroutine calculates multi-body contributions to hydrogen-bonding
6526       implicit real*8 (a-h,o-z)
6527       include 'DIMENSIONS'
6528       include 'sizesclu.dat'
6529       include 'COMMON.IOUNITS'
6530 #ifdef MPL
6531       include 'COMMON.INFO'
6532 #endif
6533       include 'COMMON.FFIELD'
6534       include 'COMMON.DERIV'
6535       include 'COMMON.INTERACT'
6536       include 'COMMON.CONTACTS'
6537 #ifdef MPL
6538       parameter (max_cont=maxconts)
6539       parameter (max_dim=2*(8*3+2))
6540       parameter (msglen1=max_cont*max_dim*4)
6541       parameter (msglen2=2*msglen1)
6542       integer source,CorrelType,CorrelID,Error
6543       double precision buffer(max_cont,max_dim)
6544 #endif
6545       double precision gx(3),gx1(3)
6546       logical lprn,ldone
6547
6548 C Set lprn=.true. for debugging
6549       lprn=.false.
6550       eturn6=0.0d0
6551 #ifdef MPL
6552       n_corr=0
6553       n_corr1=0
6554       if (fgProcs.le.1) goto 30
6555       if (lprn) then
6556         write (iout,'(a)') 'Contact function values:'
6557         do i=nnt,nct-2
6558           write (iout,'(2i3,50(1x,i2,f5.2))')
6559      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6560      &    j=1,num_cont_hb(i))
6561         enddo
6562       endif
6563 C Caution! Following code assumes that electrostatic interactions concerning
6564 C a given atom are split among at most two processors!
6565       CorrelType=477
6566       CorrelID=MyID+1
6567       ldone=.false.
6568       do i=1,max_cont
6569         do j=1,max_dim
6570           buffer(i,j)=0.0D0
6571         enddo
6572       enddo
6573       mm=mod(MyRank,2)
6574 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6575       if (mm) 20,20,10
6576    10 continue
6577 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6578       if (MyRank.gt.0) then
6579 C Send correlation contributions to the preceding processor
6580         msglen=msglen1
6581         nn=num_cont_hb(iatel_s)
6582         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6583 cd      write (iout,*) 'The BUFFER array:'
6584 cd      do i=1,nn
6585 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6586 cd      enddo
6587         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6588           msglen=msglen2
6589             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6590 C Clear the contacts of the atom passed to the neighboring processor
6591         nn=num_cont_hb(iatel_s+1)
6592 cd      do i=1,nn
6593 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6594 cd      enddo
6595             num_cont_hb(iatel_s)=0
6596         endif
6597 cd      write (iout,*) 'Processor ',MyID,MyRank,
6598 cd   & ' is sending correlation contribution to processor',MyID-1,
6599 cd   & ' msglen=',msglen
6600 cd      write (*,*) 'Processor ',MyID,MyRank,
6601 cd   & ' is sending correlation contribution to processor',MyID-1,
6602 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6603         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6604 cd      write (iout,*) 'Processor ',MyID,
6605 cd   & ' has sent correlation contribution to processor',MyID-1,
6606 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6607 cd      write (*,*) 'Processor ',MyID,
6608 cd   & ' has sent correlation contribution to processor',MyID-1,
6609 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6610         msglen=msglen1
6611       endif ! (MyRank.gt.0)
6612       if (ldone) goto 30
6613       ldone=.true.
6614    20 continue
6615 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6616       if (MyRank.lt.fgProcs-1) then
6617 C Receive correlation contributions from the next processor
6618         msglen=msglen1
6619         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6620 cd      write (iout,*) 'Processor',MyID,
6621 cd   & ' is receiving correlation contribution from processor',MyID+1,
6622 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6623 cd      write (*,*) 'Processor',MyID,
6624 cd   & ' is receiving correlation contribution from processor',MyID+1,
6625 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6626         nbytes=-1
6627         do while (nbytes.le.0)
6628           call mp_probe(MyID+1,CorrelType,nbytes)
6629         enddo
6630 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6631         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6632 cd      write (iout,*) 'Processor',MyID,
6633 cd   & ' has received correlation contribution from processor',MyID+1,
6634 cd   & ' msglen=',msglen,' nbytes=',nbytes
6635 cd      write (iout,*) 'The received BUFFER array:'
6636 cd      do i=1,max_cont
6637 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6638 cd      enddo
6639         if (msglen.eq.msglen1) then
6640           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6641         else if (msglen.eq.msglen2)  then
6642           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6643           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6644         else
6645           write (iout,*)
6646      & 'ERROR!!!! message length changed while processing correlations.'
6647           write (*,*)
6648      & 'ERROR!!!! message length changed while processing correlations.'
6649           call mp_stopall(Error)
6650         endif ! msglen.eq.msglen1
6651       endif ! MyRank.lt.fgProcs-1
6652       if (ldone) goto 30
6653       ldone=.true.
6654       goto 10
6655    30 continue
6656 #endif
6657       if (lprn) then
6658         write (iout,'(a)') 'Contact function values:'
6659         do i=nnt,nct-2
6660           write (iout,'(2i3,50(1x,i2,f5.2))')
6661      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6662      &    j=1,num_cont_hb(i))
6663         enddo
6664       endif
6665       ecorr=0.0D0
6666       ecorr5=0.0d0
6667       ecorr6=0.0d0
6668 C Remove the loop below after debugging !!!
6669       do i=nnt,nct
6670         do j=1,3
6671           gradcorr(j,i)=0.0D0
6672           gradxorr(j,i)=0.0D0
6673         enddo
6674       enddo
6675 C Calculate the dipole-dipole interaction energies
6676       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6677       do i=iatel_s,iatel_e+1
6678         num_conti=num_cont_hb(i)
6679         do jj=1,num_conti
6680           j=jcont_hb(jj,i)
6681           call dipole(i,j,jj)
6682         enddo
6683       enddo
6684       endif
6685 C Calculate the local-electrostatic correlation terms
6686       do i=iatel_s,iatel_e+1
6687         i1=i+1
6688         num_conti=num_cont_hb(i)
6689         num_conti1=num_cont_hb(i+1)
6690         do jj=1,num_conti
6691           j=jcont_hb(jj,i)
6692           do kk=1,num_conti1
6693             j1=jcont_hb(kk,i1)
6694 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6695 c     &         ' jj=',jj,' kk=',kk
6696             if (j1.eq.j+1 .or. j1.eq.j-1) then
6697 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6698 C The system gains extra energy.
6699               n_corr=n_corr+1
6700               sqd1=dsqrt(d_cont(jj,i))
6701               sqd2=dsqrt(d_cont(kk,i1))
6702               sred_geom = sqd1*sqd2
6703               IF (sred_geom.lt.cutoff_corr) THEN
6704                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6705      &            ekont,fprimcont)
6706 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6707 c     &         ' jj=',jj,' kk=',kk
6708                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6709                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6710                 do l=1,3
6711                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6712                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6713                 enddo
6714                 n_corr1=n_corr1+1
6715 cd               write (iout,*) 'sred_geom=',sred_geom,
6716 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6717                 call calc_eello(i,j,i+1,j1,jj,kk)
6718                 if (wcorr4.gt.0.0d0)
6719      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6720                 if (wcorr5.gt.0.0d0)
6721      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6722 c                print *,"wcorr5",ecorr5
6723 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6724 cd                write(2,*)'ijkl',i,j,i+1,j1
6725                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6726      &               .or. wturn6.eq.0.0d0))then
6727 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6728                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6729 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6730 cd     &            'ecorr6=',ecorr6
6731 cd                write (iout,'(4e15.5)') sred_geom,
6732 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6733 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6734 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6735                 else if (wturn6.gt.0.0d0
6736      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6737 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6738                   eturn6=eturn6+eello_turn6(i,jj,kk)
6739 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6740                 endif
6741               ENDIF
6742 1111          continue
6743             else if (j1.eq.j) then
6744 C Contacts I-J and I-(J+1) occur simultaneously.
6745 C The system loses extra energy.
6746 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6747             endif
6748           enddo ! kk
6749           do kk=1,num_conti
6750             j1=jcont_hb(kk,i)
6751 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6752 c    &         ' jj=',jj,' kk=',kk
6753             if (j1.eq.j+1) then
6754 C Contacts I-J and (I+1)-J occur simultaneously.
6755 C The system loses extra energy.
6756 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6757             endif ! j1==j+1
6758           enddo ! kk
6759         enddo ! jj
6760       enddo ! i
6761       return
6762       end
6763 c------------------------------------------------------------------------------
6764       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6765       implicit real*8 (a-h,o-z)
6766       include 'DIMENSIONS'
6767       include 'COMMON.IOUNITS'
6768       include 'COMMON.DERIV'
6769       include 'COMMON.INTERACT'
6770       include 'COMMON.CONTACTS'
6771       include 'COMMON.SHIELD'
6772
6773       double precision gx(3),gx1(3)
6774       logical lprn
6775       lprn=.false.
6776       eij=facont_hb(jj,i)
6777       ekl=facont_hb(kk,k)
6778       ees0pij=ees0p(jj,i)
6779       ees0pkl=ees0p(kk,k)
6780       ees0mij=ees0m(jj,i)
6781       ees0mkl=ees0m(kk,k)
6782       ekont=eij*ekl
6783       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6784 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6785 C Following 4 lines for diagnostics.
6786 cd    ees0pkl=0.0D0
6787 cd    ees0pij=1.0D0
6788 cd    ees0mkl=0.0D0
6789 cd    ees0mij=1.0D0
6790 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6791 c    &   ' and',k,l
6792 c     write (iout,*)'Contacts have occurred for peptide groups',
6793 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6794 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6795 C Calculate the multi-body contribution to energy.
6796       ecorr=ecorr+ekont*ees
6797       if (calc_grad) then
6798 C Calculate multi-body contributions to the gradient.
6799       do ll=1,3
6800         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6801         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6802      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6803      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6804         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6805      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6806      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6807         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6808         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6809      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6810      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6811         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6812      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6813      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6814       enddo
6815       do m=i+1,j-1
6816         do ll=1,3
6817           gradcorr(ll,m)=gradcorr(ll,m)+
6818      &     ees*ekl*gacont_hbr(ll,jj,i)-
6819      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6820      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6821         enddo
6822       enddo
6823       do m=k+1,l-1
6824         do ll=1,3
6825           gradcorr(ll,m)=gradcorr(ll,m)+
6826      &     ees*eij*gacont_hbr(ll,kk,k)-
6827      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6828      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6829         enddo
6830       enddo
6831       if (shield_mode.gt.0) then
6832        j=ees0plist(jj,i)
6833        l=ees0plist(kk,k)
6834 C        print *,i,j,fac_shield(i),fac_shield(j),
6835 C     &fac_shield(k),fac_shield(l)
6836         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6837      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6838           do ilist=1,ishield_list(i)
6839            iresshield=shield_list(ilist,i)
6840            do m=1,3
6841            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6842 C     &      *2.0
6843            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6844      &              rlocshield
6845      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6846             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6847      &+rlocshield
6848            enddo
6849           enddo
6850           do ilist=1,ishield_list(j)
6851            iresshield=shield_list(ilist,j)
6852            do m=1,3
6853            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6854 C     &     *2.0
6855            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6856      &              rlocshield
6857      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6858            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6859      &     +rlocshield
6860            enddo
6861           enddo
6862           do ilist=1,ishield_list(k)
6863            iresshield=shield_list(ilist,k)
6864            do m=1,3
6865            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6866 C     &     *2.0
6867            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6868      &              rlocshield
6869      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6870            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6871      &     +rlocshield
6872            enddo
6873           enddo
6874           do ilist=1,ishield_list(l)
6875            iresshield=shield_list(ilist,l)
6876            do m=1,3
6877            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6878 C     &     *2.0
6879            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6880      &              rlocshield
6881      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6882            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6883      &     +rlocshield
6884            enddo
6885           enddo
6886 C          print *,gshieldx(m,iresshield)
6887           do m=1,3
6888             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6889      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6890             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6891      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6892             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6893      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6894             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6895      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6896
6897             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6898      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6899             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6900      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6901             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6902      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6903             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6904      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6905
6906            enddo
6907       endif
6908       endif
6909       endif
6910       ehbcorr=ekont*ees
6911       return
6912       end
6913 C---------------------------------------------------------------------------
6914       subroutine dipole(i,j,jj)
6915       implicit real*8 (a-h,o-z)
6916       include 'DIMENSIONS'
6917       include 'sizesclu.dat'
6918       include 'COMMON.IOUNITS'
6919       include 'COMMON.CHAIN'
6920       include 'COMMON.FFIELD'
6921       include 'COMMON.DERIV'
6922       include 'COMMON.INTERACT'
6923       include 'COMMON.CONTACTS'
6924       include 'COMMON.TORSION'
6925       include 'COMMON.VAR'
6926       include 'COMMON.GEO'
6927       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6928      &  auxmat(2,2)
6929       iti1 = itortyp(itype(i+1))
6930       if (j.lt.nres-1) then
6931         if (itype(j).le.ntyp) then
6932           itj1 = itortyp(itype(j+1))
6933         else
6934           itj1=ntortyp+1
6935         endif
6936       else
6937         itj1=ntortyp+1
6938       endif
6939       do iii=1,2
6940         dipi(iii,1)=Ub2(iii,i)
6941         dipderi(iii)=Ub2der(iii,i)
6942         dipi(iii,2)=b1(iii,iti1)
6943         dipj(iii,1)=Ub2(iii,j)
6944         dipderj(iii)=Ub2der(iii,j)
6945         dipj(iii,2)=b1(iii,itj1)
6946       enddo
6947       kkk=0
6948       do iii=1,2
6949         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6950         do jjj=1,2
6951           kkk=kkk+1
6952           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6953         enddo
6954       enddo
6955       if (.not.calc_grad) return
6956       do kkk=1,5
6957         do lll=1,3
6958           mmm=0
6959           do iii=1,2
6960             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6961      &        auxvec(1))
6962             do jjj=1,2
6963               mmm=mmm+1
6964               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6965             enddo
6966           enddo
6967         enddo
6968       enddo
6969       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6970       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6971       do iii=1,2
6972         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6973       enddo
6974       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6975       do iii=1,2
6976         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6977       enddo
6978       return
6979       end
6980 C---------------------------------------------------------------------------
6981       subroutine calc_eello(i,j,k,l,jj,kk)
6982 C
6983 C This subroutine computes matrices and vectors needed to calculate
6984 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6985 C
6986       implicit real*8 (a-h,o-z)
6987       include 'DIMENSIONS'
6988       include 'sizesclu.dat'
6989       include 'COMMON.IOUNITS'
6990       include 'COMMON.CHAIN'
6991       include 'COMMON.DERIV'
6992       include 'COMMON.INTERACT'
6993       include 'COMMON.CONTACTS'
6994       include 'COMMON.TORSION'
6995       include 'COMMON.VAR'
6996       include 'COMMON.GEO'
6997       include 'COMMON.FFIELD'
6998       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6999      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7000       logical lprn
7001       common /kutas/ lprn
7002 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7003 cd     & ' jj=',jj,' kk=',kk
7004 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7005       do iii=1,2
7006         do jjj=1,2
7007           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7008           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7009         enddo
7010       enddo
7011       call transpose2(aa1(1,1),aa1t(1,1))
7012       call transpose2(aa2(1,1),aa2t(1,1))
7013       do kkk=1,5
7014         do lll=1,3
7015           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7016      &      aa1tder(1,1,lll,kkk))
7017           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7018      &      aa2tder(1,1,lll,kkk))
7019         enddo
7020       enddo
7021       if (l.eq.j+1) then
7022 C parallel orientation of the two CA-CA-CA frames.
7023 c        if (i.gt.1) then
7024         if (i.gt.1 .and. itype(i).le.ntyp) then
7025           iti=itortyp(itype(i))
7026         else
7027           iti=ntortyp+1
7028         endif
7029         itk1=itortyp(itype(k+1))
7030         itj=itortyp(itype(j))
7031 c        if (l.lt.nres-1) then
7032         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7033           itl1=itortyp(itype(l+1))
7034         else
7035           itl1=ntortyp+1
7036         endif
7037 C A1 kernel(j+1) A2T
7038 cd        do iii=1,2
7039 cd          write (iout,'(3f10.5,5x,3f10.5)')
7040 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7041 cd        enddo
7042         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7043      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7044      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7045 C Following matrices are needed only for 6-th order cumulants
7046         IF (wcorr6.gt.0.0d0) THEN
7047         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7048      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7049      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7050         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7051      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7052      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7053      &   ADtEAderx(1,1,1,1,1,1))
7054         lprn=.false.
7055         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7056      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7057      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7058      &   ADtEA1derx(1,1,1,1,1,1))
7059         ENDIF
7060 C End 6-th order cumulants
7061 cd        lprn=.false.
7062 cd        if (lprn) then
7063 cd        write (2,*) 'In calc_eello6'
7064 cd        do iii=1,2
7065 cd          write (2,*) 'iii=',iii
7066 cd          do kkk=1,5
7067 cd            write (2,*) 'kkk=',kkk
7068 cd            do jjj=1,2
7069 cd              write (2,'(3(2f10.5),5x)')
7070 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7071 cd            enddo
7072 cd          enddo
7073 cd        enddo
7074 cd        endif
7075         call transpose2(EUgder(1,1,k),auxmat(1,1))
7076         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7077         call transpose2(EUg(1,1,k),auxmat(1,1))
7078         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7079         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7080         do iii=1,2
7081           do kkk=1,5
7082             do lll=1,3
7083               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7084      &          EAEAderx(1,1,lll,kkk,iii,1))
7085             enddo
7086           enddo
7087         enddo
7088 C A1T kernel(i+1) A2
7089         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7090      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7091      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7092 C Following matrices are needed only for 6-th order cumulants
7093         IF (wcorr6.gt.0.0d0) THEN
7094         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7095      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7096      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7097         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7098      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7099      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7100      &   ADtEAderx(1,1,1,1,1,2))
7101         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7102      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7103      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7104      &   ADtEA1derx(1,1,1,1,1,2))
7105         ENDIF
7106 C End 6-th order cumulants
7107         call transpose2(EUgder(1,1,l),auxmat(1,1))
7108         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7109         call transpose2(EUg(1,1,l),auxmat(1,1))
7110         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7111         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7112         do iii=1,2
7113           do kkk=1,5
7114             do lll=1,3
7115               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7116      &          EAEAderx(1,1,lll,kkk,iii,2))
7117             enddo
7118           enddo
7119         enddo
7120 C AEAb1 and AEAb2
7121 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7122 C They are needed only when the fifth- or the sixth-order cumulants are
7123 C indluded.
7124         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7125         call transpose2(AEA(1,1,1),auxmat(1,1))
7126         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7127         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7128         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7129         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7130         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7131         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7132         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7133         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7134         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7135         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7136         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7137         call transpose2(AEA(1,1,2),auxmat(1,1))
7138         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7139         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7140         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7141         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7142         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7143         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7144         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7145         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7146         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7147         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7148         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7149 C Calculate the Cartesian derivatives of the vectors.
7150         do iii=1,2
7151           do kkk=1,5
7152             do lll=1,3
7153               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7154               call matvec2(auxmat(1,1),b1(1,iti),
7155      &          AEAb1derx(1,lll,kkk,iii,1,1))
7156               call matvec2(auxmat(1,1),Ub2(1,i),
7157      &          AEAb2derx(1,lll,kkk,iii,1,1))
7158               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7159      &          AEAb1derx(1,lll,kkk,iii,2,1))
7160               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7161      &          AEAb2derx(1,lll,kkk,iii,2,1))
7162               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7163               call matvec2(auxmat(1,1),b1(1,itj),
7164      &          AEAb1derx(1,lll,kkk,iii,1,2))
7165               call matvec2(auxmat(1,1),Ub2(1,j),
7166      &          AEAb2derx(1,lll,kkk,iii,1,2))
7167               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7168      &          AEAb1derx(1,lll,kkk,iii,2,2))
7169               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7170      &          AEAb2derx(1,lll,kkk,iii,2,2))
7171             enddo
7172           enddo
7173         enddo
7174         ENDIF
7175 C End vectors
7176       else
7177 C Antiparallel orientation of the two CA-CA-CA frames.
7178 c        if (i.gt.1) then
7179         if (i.gt.1 .and. itype(i).le.ntyp) then
7180           iti=itortyp(itype(i))
7181         else
7182           iti=ntortyp+1
7183         endif
7184         itk1=itortyp(itype(k+1))
7185         itl=itortyp(itype(l))
7186         itj=itortyp(itype(j))
7187 c        if (j.lt.nres-1) then
7188         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7189           itj1=itortyp(itype(j+1))
7190         else
7191           itj1=ntortyp+1
7192         endif
7193 C A2 kernel(j-1)T A1T
7194         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7195      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7196      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7197 C Following matrices are needed only for 6-th order cumulants
7198         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7199      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7200         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7201      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7202      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7203         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7204      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7205      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7206      &   ADtEAderx(1,1,1,1,1,1))
7207         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7208      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7209      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7210      &   ADtEA1derx(1,1,1,1,1,1))
7211         ENDIF
7212 C End 6-th order cumulants
7213         call transpose2(EUgder(1,1,k),auxmat(1,1))
7214         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7215         call transpose2(EUg(1,1,k),auxmat(1,1))
7216         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7217         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7218         do iii=1,2
7219           do kkk=1,5
7220             do lll=1,3
7221               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7222      &          EAEAderx(1,1,lll,kkk,iii,1))
7223             enddo
7224           enddo
7225         enddo
7226 C A2T kernel(i+1)T A1
7227         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7228      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7229      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7230 C Following matrices are needed only for 6-th order cumulants
7231         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7232      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7233         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7234      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7235      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7236         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7237      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7238      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7239      &   ADtEAderx(1,1,1,1,1,2))
7240         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7241      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7242      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7243      &   ADtEA1derx(1,1,1,1,1,2))
7244         ENDIF
7245 C End 6-th order cumulants
7246         call transpose2(EUgder(1,1,j),auxmat(1,1))
7247         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7248         call transpose2(EUg(1,1,j),auxmat(1,1))
7249         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7250         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7251         do iii=1,2
7252           do kkk=1,5
7253             do lll=1,3
7254               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7255      &          EAEAderx(1,1,lll,kkk,iii,2))
7256             enddo
7257           enddo
7258         enddo
7259 C AEAb1 and AEAb2
7260 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7261 C They are needed only when the fifth- or the sixth-order cumulants are
7262 C indluded.
7263         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7264      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7265         call transpose2(AEA(1,1,1),auxmat(1,1))
7266         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7267         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7268         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7269         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7270         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7271         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7272         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7273         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7274         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7275         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7276         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7277         call transpose2(AEA(1,1,2),auxmat(1,1))
7278         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7279         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7280         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7281         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7282         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7283         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7284         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7285         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7286         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7287         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7288         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7289 C Calculate the Cartesian derivatives of the vectors.
7290         do iii=1,2
7291           do kkk=1,5
7292             do lll=1,3
7293               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7294               call matvec2(auxmat(1,1),b1(1,iti),
7295      &          AEAb1derx(1,lll,kkk,iii,1,1))
7296               call matvec2(auxmat(1,1),Ub2(1,i),
7297      &          AEAb2derx(1,lll,kkk,iii,1,1))
7298               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7299      &          AEAb1derx(1,lll,kkk,iii,2,1))
7300               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7301      &          AEAb2derx(1,lll,kkk,iii,2,1))
7302               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7303               call matvec2(auxmat(1,1),b1(1,itl),
7304      &          AEAb1derx(1,lll,kkk,iii,1,2))
7305               call matvec2(auxmat(1,1),Ub2(1,l),
7306      &          AEAb2derx(1,lll,kkk,iii,1,2))
7307               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7308      &          AEAb1derx(1,lll,kkk,iii,2,2))
7309               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7310      &          AEAb2derx(1,lll,kkk,iii,2,2))
7311             enddo
7312           enddo
7313         enddo
7314         ENDIF
7315 C End vectors
7316       endif
7317       return
7318       end
7319 C---------------------------------------------------------------------------
7320       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7321      &  KK,KKderg,AKA,AKAderg,AKAderx)
7322       implicit none
7323       integer nderg
7324       logical transp
7325       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7326      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7327      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7328       integer iii,kkk,lll
7329       integer jjj,mmm
7330       logical lprn
7331       common /kutas/ lprn
7332       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7333       do iii=1,nderg
7334         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7335      &    AKAderg(1,1,iii))
7336       enddo
7337 cd      if (lprn) write (2,*) 'In kernel'
7338       do kkk=1,5
7339 cd        if (lprn) write (2,*) 'kkk=',kkk
7340         do lll=1,3
7341           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7342      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7343 cd          if (lprn) then
7344 cd            write (2,*) 'lll=',lll
7345 cd            write (2,*) 'iii=1'
7346 cd            do jjj=1,2
7347 cd              write (2,'(3(2f10.5),5x)')
7348 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7349 cd            enddo
7350 cd          endif
7351           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7352      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7353 cd          if (lprn) then
7354 cd            write (2,*) 'lll=',lll
7355 cd            write (2,*) 'iii=2'
7356 cd            do jjj=1,2
7357 cd              write (2,'(3(2f10.5),5x)')
7358 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7359 cd            enddo
7360 cd          endif
7361         enddo
7362       enddo
7363       return
7364       end
7365 C---------------------------------------------------------------------------
7366       double precision function eello4(i,j,k,l,jj,kk)
7367       implicit real*8 (a-h,o-z)
7368       include 'DIMENSIONS'
7369       include 'sizesclu.dat'
7370       include 'COMMON.IOUNITS'
7371       include 'COMMON.CHAIN'
7372       include 'COMMON.DERIV'
7373       include 'COMMON.INTERACT'
7374       include 'COMMON.CONTACTS'
7375       include 'COMMON.TORSION'
7376       include 'COMMON.VAR'
7377       include 'COMMON.GEO'
7378       double precision pizda(2,2),ggg1(3),ggg2(3)
7379 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7380 cd        eello4=0.0d0
7381 cd        return
7382 cd      endif
7383 cd      print *,'eello4:',i,j,k,l,jj,kk
7384 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7385 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7386 cold      eij=facont_hb(jj,i)
7387 cold      ekl=facont_hb(kk,k)
7388 cold      ekont=eij*ekl
7389       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7390       if (calc_grad) then
7391 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7392       gcorr_loc(k-1)=gcorr_loc(k-1)
7393      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7394       if (l.eq.j+1) then
7395         gcorr_loc(l-1)=gcorr_loc(l-1)
7396      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7397       else
7398         gcorr_loc(j-1)=gcorr_loc(j-1)
7399      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7400       endif
7401       do iii=1,2
7402         do kkk=1,5
7403           do lll=1,3
7404             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7405      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7406 cd            derx(lll,kkk,iii)=0.0d0
7407           enddo
7408         enddo
7409       enddo
7410 cd      gcorr_loc(l-1)=0.0d0
7411 cd      gcorr_loc(j-1)=0.0d0
7412 cd      gcorr_loc(k-1)=0.0d0
7413 cd      eel4=1.0d0
7414 cd      write (iout,*)'Contacts have occurred for peptide groups',
7415 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7416 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7417       if (j.lt.nres-1) then
7418         j1=j+1
7419         j2=j-1
7420       else
7421         j1=j-1
7422         j2=j-2
7423       endif
7424       if (l.lt.nres-1) then
7425         l1=l+1
7426         l2=l-1
7427       else
7428         l1=l-1
7429         l2=l-2
7430       endif
7431       do ll=1,3
7432 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7433         ggg1(ll)=eel4*g_contij(ll,1)
7434         ggg2(ll)=eel4*g_contij(ll,2)
7435         ghalf=0.5d0*ggg1(ll)
7436 cd        ghalf=0.0d0
7437         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7438         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7439         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7440         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7441 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7442         ghalf=0.5d0*ggg2(ll)
7443 cd        ghalf=0.0d0
7444         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7445         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7446         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7447         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7448       enddo
7449 cd      goto 1112
7450       do m=i+1,j-1
7451         do ll=1,3
7452 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7453           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7454         enddo
7455       enddo
7456       do m=k+1,l-1
7457         do ll=1,3
7458 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7459           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7460         enddo
7461       enddo
7462 1112  continue
7463       do m=i+2,j2
7464         do ll=1,3
7465           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7466         enddo
7467       enddo
7468       do m=k+2,l2
7469         do ll=1,3
7470           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7471         enddo
7472       enddo
7473 cd      do iii=1,nres-3
7474 cd        write (2,*) iii,gcorr_loc(iii)
7475 cd      enddo
7476       endif
7477       eello4=ekont*eel4
7478 cd      write (2,*) 'ekont',ekont
7479 cd      write (iout,*) 'eello4',ekont*eel4
7480       return
7481       end
7482 C---------------------------------------------------------------------------
7483       double precision function eello5(i,j,k,l,jj,kk)
7484       implicit real*8 (a-h,o-z)
7485       include 'DIMENSIONS'
7486       include 'sizesclu.dat'
7487       include 'COMMON.IOUNITS'
7488       include 'COMMON.CHAIN'
7489       include 'COMMON.DERIV'
7490       include 'COMMON.INTERACT'
7491       include 'COMMON.CONTACTS'
7492       include 'COMMON.TORSION'
7493       include 'COMMON.VAR'
7494       include 'COMMON.GEO'
7495       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7496       double precision ggg1(3),ggg2(3)
7497 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7498 C                                                                              C
7499 C                            Parallel chains                                   C
7500 C                                                                              C
7501 C          o             o                   o             o                   C
7502 C         /l\           / \             \   / \           / \   /              C
7503 C        /   \         /   \             \ /   \         /   \ /               C
7504 C       j| o |l1       | o |              o| o |         | o |o                C
7505 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7506 C      \i/   \         /   \ /             /   \         /   \                 C
7507 C       o    k1             o                                                  C
7508 C         (I)          (II)                (III)          (IV)                 C
7509 C                                                                              C
7510 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7511 C                                                                              C
7512 C                            Antiparallel chains                               C
7513 C                                                                              C
7514 C          o             o                   o             o                   C
7515 C         /j\           / \             \   / \           / \   /              C
7516 C        /   \         /   \             \ /   \         /   \ /               C
7517 C      j1| o |l        | o |              o| o |         | o |o                C
7518 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7519 C      \i/   \         /   \ /             /   \         /   \                 C
7520 C       o     k1            o                                                  C
7521 C         (I)          (II)                (III)          (IV)                 C
7522 C                                                                              C
7523 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7524 C                                                                              C
7525 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7526 C                                                                              C
7527 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7528 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7529 cd        eello5=0.0d0
7530 cd        return
7531 cd      endif
7532 cd      write (iout,*)
7533 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7534 cd     &   ' and',k,l
7535       itk=itortyp(itype(k))
7536       itl=itortyp(itype(l))
7537       itj=itortyp(itype(j))
7538       eello5_1=0.0d0
7539       eello5_2=0.0d0
7540       eello5_3=0.0d0
7541       eello5_4=0.0d0
7542 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7543 cd     &   eel5_3_num,eel5_4_num)
7544       do iii=1,2
7545         do kkk=1,5
7546           do lll=1,3
7547             derx(lll,kkk,iii)=0.0d0
7548           enddo
7549         enddo
7550       enddo
7551 cd      eij=facont_hb(jj,i)
7552 cd      ekl=facont_hb(kk,k)
7553 cd      ekont=eij*ekl
7554 cd      write (iout,*)'Contacts have occurred for peptide groups',
7555 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7556 cd      goto 1111
7557 C Contribution from the graph I.
7558 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7559 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7560       call transpose2(EUg(1,1,k),auxmat(1,1))
7561       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7562       vv(1)=pizda(1,1)-pizda(2,2)
7563       vv(2)=pizda(1,2)+pizda(2,1)
7564       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7565      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7566       if (calc_grad) then
7567 C Explicit gradient in virtual-dihedral angles.
7568       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7569      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7570      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7571       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7572       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7573       vv(1)=pizda(1,1)-pizda(2,2)
7574       vv(2)=pizda(1,2)+pizda(2,1)
7575       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7576      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7577      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7578       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7579       vv(1)=pizda(1,1)-pizda(2,2)
7580       vv(2)=pizda(1,2)+pizda(2,1)
7581       if (l.eq.j+1) then
7582         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7583      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7584      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7585       else
7586         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7587      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7588      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7589       endif
7590 C Cartesian gradient
7591       do iii=1,2
7592         do kkk=1,5
7593           do lll=1,3
7594             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7595      &        pizda(1,1))
7596             vv(1)=pizda(1,1)-pizda(2,2)
7597             vv(2)=pizda(1,2)+pizda(2,1)
7598             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7599      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7600      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7601           enddo
7602         enddo
7603       enddo
7604 c      goto 1112
7605       endif
7606 c1111  continue
7607 C Contribution from graph II
7608       call transpose2(EE(1,1,itk),auxmat(1,1))
7609       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7610       vv(1)=pizda(1,1)+pizda(2,2)
7611       vv(2)=pizda(2,1)-pizda(1,2)
7612       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7613      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7614       if (calc_grad) then
7615 C Explicit gradient in virtual-dihedral angles.
7616       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7617      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7618       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7619       vv(1)=pizda(1,1)+pizda(2,2)
7620       vv(2)=pizda(2,1)-pizda(1,2)
7621       if (l.eq.j+1) then
7622         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7623      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7624      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7625       else
7626         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7627      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7628      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7629       endif
7630 C Cartesian gradient
7631       do iii=1,2
7632         do kkk=1,5
7633           do lll=1,3
7634             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7635      &        pizda(1,1))
7636             vv(1)=pizda(1,1)+pizda(2,2)
7637             vv(2)=pizda(2,1)-pizda(1,2)
7638             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7639      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7640      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7641           enddo
7642         enddo
7643       enddo
7644 cd      goto 1112
7645       endif
7646 cd1111  continue
7647       if (l.eq.j+1) then
7648 cd        goto 1110
7649 C Parallel orientation
7650 C Contribution from graph III
7651         call transpose2(EUg(1,1,l),auxmat(1,1))
7652         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7653         vv(1)=pizda(1,1)-pizda(2,2)
7654         vv(2)=pizda(1,2)+pizda(2,1)
7655         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7656      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7657         if (calc_grad) then
7658 C Explicit gradient in virtual-dihedral angles.
7659         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7660      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7661      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7662         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7663         vv(1)=pizda(1,1)-pizda(2,2)
7664         vv(2)=pizda(1,2)+pizda(2,1)
7665         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7666      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7667      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7668         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7669         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7670         vv(1)=pizda(1,1)-pizda(2,2)
7671         vv(2)=pizda(1,2)+pizda(2,1)
7672         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7673      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7674      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7675 C Cartesian gradient
7676         do iii=1,2
7677           do kkk=1,5
7678             do lll=1,3
7679               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7680      &          pizda(1,1))
7681               vv(1)=pizda(1,1)-pizda(2,2)
7682               vv(2)=pizda(1,2)+pizda(2,1)
7683               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7684      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7685      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7686             enddo
7687           enddo
7688         enddo
7689 cd        goto 1112
7690         endif
7691 C Contribution from graph IV
7692 cd1110    continue
7693         call transpose2(EE(1,1,itl),auxmat(1,1))
7694         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7695         vv(1)=pizda(1,1)+pizda(2,2)
7696         vv(2)=pizda(2,1)-pizda(1,2)
7697         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7698      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7699         if (calc_grad) then
7700 C Explicit gradient in virtual-dihedral angles.
7701         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7702      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7703         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7704         vv(1)=pizda(1,1)+pizda(2,2)
7705         vv(2)=pizda(2,1)-pizda(1,2)
7706         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7707      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7708      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7709 C Cartesian gradient
7710         do iii=1,2
7711           do kkk=1,5
7712             do lll=1,3
7713               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7714      &          pizda(1,1))
7715               vv(1)=pizda(1,1)+pizda(2,2)
7716               vv(2)=pizda(2,1)-pizda(1,2)
7717               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7718      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7719      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7720             enddo
7721           enddo
7722         enddo
7723         endif
7724       else
7725 C Antiparallel orientation
7726 C Contribution from graph III
7727 c        goto 1110
7728         call transpose2(EUg(1,1,j),auxmat(1,1))
7729         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7730         vv(1)=pizda(1,1)-pizda(2,2)
7731         vv(2)=pizda(1,2)+pizda(2,1)
7732         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7733      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7734         if (calc_grad) then
7735 C Explicit gradient in virtual-dihedral angles.
7736         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7737      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7738      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7739         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7740         vv(1)=pizda(1,1)-pizda(2,2)
7741         vv(2)=pizda(1,2)+pizda(2,1)
7742         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7743      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7744      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7745         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7746         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7747         vv(1)=pizda(1,1)-pizda(2,2)
7748         vv(2)=pizda(1,2)+pizda(2,1)
7749         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7750      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7751      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7752 C Cartesian gradient
7753         do iii=1,2
7754           do kkk=1,5
7755             do lll=1,3
7756               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7757      &          pizda(1,1))
7758               vv(1)=pizda(1,1)-pizda(2,2)
7759               vv(2)=pizda(1,2)+pizda(2,1)
7760               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7761      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7762      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7763             enddo
7764           enddo
7765         enddo
7766 cd        goto 1112
7767         endif
7768 C Contribution from graph IV
7769 1110    continue
7770         call transpose2(EE(1,1,itj),auxmat(1,1))
7771         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7772         vv(1)=pizda(1,1)+pizda(2,2)
7773         vv(2)=pizda(2,1)-pizda(1,2)
7774         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7775      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7776         if (calc_grad) then
7777 C Explicit gradient in virtual-dihedral angles.
7778         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7779      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7780         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7781         vv(1)=pizda(1,1)+pizda(2,2)
7782         vv(2)=pizda(2,1)-pizda(1,2)
7783         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7784      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7785      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7786 C Cartesian gradient
7787         do iii=1,2
7788           do kkk=1,5
7789             do lll=1,3
7790               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7791      &          pizda(1,1))
7792               vv(1)=pizda(1,1)+pizda(2,2)
7793               vv(2)=pizda(2,1)-pizda(1,2)
7794               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7795      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7796      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7797             enddo
7798           enddo
7799         enddo
7800       endif
7801       endif
7802 1112  continue
7803       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7804 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7805 cd        write (2,*) 'ijkl',i,j,k,l
7806 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7807 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7808 cd      endif
7809 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7810 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7811 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7812 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7813       if (calc_grad) then
7814       if (j.lt.nres-1) then
7815         j1=j+1
7816         j2=j-1
7817       else
7818         j1=j-1
7819         j2=j-2
7820       endif
7821       if (l.lt.nres-1) then
7822         l1=l+1
7823         l2=l-1
7824       else
7825         l1=l-1
7826         l2=l-2
7827       endif
7828 cd      eij=1.0d0
7829 cd      ekl=1.0d0
7830 cd      ekont=1.0d0
7831 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7832       do ll=1,3
7833         ggg1(ll)=eel5*g_contij(ll,1)
7834         ggg2(ll)=eel5*g_contij(ll,2)
7835 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7836         ghalf=0.5d0*ggg1(ll)
7837 cd        ghalf=0.0d0
7838         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7839         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7840         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7841         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7842 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7843         ghalf=0.5d0*ggg2(ll)
7844 cd        ghalf=0.0d0
7845         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7846         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7847         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7848         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7849       enddo
7850 cd      goto 1112
7851       do m=i+1,j-1
7852         do ll=1,3
7853 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7854           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7855         enddo
7856       enddo
7857       do m=k+1,l-1
7858         do ll=1,3
7859 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7860           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7861         enddo
7862       enddo
7863 c1112  continue
7864       do m=i+2,j2
7865         do ll=1,3
7866           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7867         enddo
7868       enddo
7869       do m=k+2,l2
7870         do ll=1,3
7871           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7872         enddo
7873       enddo
7874 cd      do iii=1,nres-3
7875 cd        write (2,*) iii,g_corr5_loc(iii)
7876 cd      enddo
7877       endif
7878       eello5=ekont*eel5
7879 cd      write (2,*) 'ekont',ekont
7880 cd      write (iout,*) 'eello5',ekont*eel5
7881       return
7882       end
7883 c--------------------------------------------------------------------------
7884       double precision function eello6(i,j,k,l,jj,kk)
7885       implicit real*8 (a-h,o-z)
7886       include 'DIMENSIONS'
7887       include 'sizesclu.dat'
7888       include 'COMMON.IOUNITS'
7889       include 'COMMON.CHAIN'
7890       include 'COMMON.DERIV'
7891       include 'COMMON.INTERACT'
7892       include 'COMMON.CONTACTS'
7893       include 'COMMON.TORSION'
7894       include 'COMMON.VAR'
7895       include 'COMMON.GEO'
7896       include 'COMMON.FFIELD'
7897       double precision ggg1(3),ggg2(3)
7898 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7899 cd        eello6=0.0d0
7900 cd        return
7901 cd      endif
7902 cd      write (iout,*)
7903 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7904 cd     &   ' and',k,l
7905       eello6_1=0.0d0
7906       eello6_2=0.0d0
7907       eello6_3=0.0d0
7908       eello6_4=0.0d0
7909       eello6_5=0.0d0
7910       eello6_6=0.0d0
7911 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7912 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7913       do iii=1,2
7914         do kkk=1,5
7915           do lll=1,3
7916             derx(lll,kkk,iii)=0.0d0
7917           enddo
7918         enddo
7919       enddo
7920 cd      eij=facont_hb(jj,i)
7921 cd      ekl=facont_hb(kk,k)
7922 cd      ekont=eij*ekl
7923 cd      eij=1.0d0
7924 cd      ekl=1.0d0
7925 cd      ekont=1.0d0
7926       if (l.eq.j+1) then
7927         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7928         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7929         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7930         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7931         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7932         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7933       else
7934         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7935         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7936         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7937         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7938         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7939           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7940         else
7941           eello6_5=0.0d0
7942         endif
7943         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7944       endif
7945 C If turn contributions are considered, they will be handled separately.
7946       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7947 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7948 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7949 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7950 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7951 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7952 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7953 cd      goto 1112
7954       if (calc_grad) then
7955       if (j.lt.nres-1) then
7956         j1=j+1
7957         j2=j-1
7958       else
7959         j1=j-1
7960         j2=j-2
7961       endif
7962       if (l.lt.nres-1) then
7963         l1=l+1
7964         l2=l-1
7965       else
7966         l1=l-1
7967         l2=l-2
7968       endif
7969       do ll=1,3
7970         ggg1(ll)=eel6*g_contij(ll,1)
7971         ggg2(ll)=eel6*g_contij(ll,2)
7972 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7973         ghalf=0.5d0*ggg1(ll)
7974 cd        ghalf=0.0d0
7975         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7976         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7977         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7978         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7979         ghalf=0.5d0*ggg2(ll)
7980 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7981 cd        ghalf=0.0d0
7982         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7983         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7984         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7985         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7986       enddo
7987 cd      goto 1112
7988       do m=i+1,j-1
7989         do ll=1,3
7990 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7991           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7992         enddo
7993       enddo
7994       do m=k+1,l-1
7995         do ll=1,3
7996 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7997           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7998         enddo
7999       enddo
8000 1112  continue
8001       do m=i+2,j2
8002         do ll=1,3
8003           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8004         enddo
8005       enddo
8006       do m=k+2,l2
8007         do ll=1,3
8008           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8009         enddo
8010       enddo
8011 cd      do iii=1,nres-3
8012 cd        write (2,*) iii,g_corr6_loc(iii)
8013 cd      enddo
8014       endif
8015       eello6=ekont*eel6
8016 cd      write (2,*) 'ekont',ekont
8017 cd      write (iout,*) 'eello6',ekont*eel6
8018       return
8019       end
8020 c--------------------------------------------------------------------------
8021       double precision function eello6_graph1(i,j,k,l,imat,swap)
8022       implicit real*8 (a-h,o-z)
8023       include 'DIMENSIONS'
8024       include 'sizesclu.dat'
8025       include 'COMMON.IOUNITS'
8026       include 'COMMON.CHAIN'
8027       include 'COMMON.DERIV'
8028       include 'COMMON.INTERACT'
8029       include 'COMMON.CONTACTS'
8030       include 'COMMON.TORSION'
8031       include 'COMMON.VAR'
8032       include 'COMMON.GEO'
8033       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8034       logical swap
8035       logical lprn
8036       common /kutas/ lprn
8037 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8038 C                                                                              C
8039 C      Parallel       Antiparallel                                             C
8040 C                                                                              C
8041 C          o             o                                                     C
8042 C         /l\           /j\                                                    C
8043 C        /   \         /   \                                                   C
8044 C       /| o |         | o |\                                                  C
8045 C     \ j|/k\|  /   \  |/k\|l /                                                C
8046 C      \ /   \ /     \ /   \ /                                                 C
8047 C       o     o       o     o                                                  C
8048 C       i             i                                                        C
8049 C                                                                              C
8050 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8051       itk=itortyp(itype(k))
8052       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8053       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8054       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8055       call transpose2(EUgC(1,1,k),auxmat(1,1))
8056       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8057       vv1(1)=pizda1(1,1)-pizda1(2,2)
8058       vv1(2)=pizda1(1,2)+pizda1(2,1)
8059       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8060       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8061       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8062       s5=scalar2(vv(1),Dtobr2(1,i))
8063 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8064       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8065       if (.not. calc_grad) return
8066       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8067      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8068      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8069      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8070      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8071      & +scalar2(vv(1),Dtobr2der(1,i)))
8072       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8073       vv1(1)=pizda1(1,1)-pizda1(2,2)
8074       vv1(2)=pizda1(1,2)+pizda1(2,1)
8075       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8076       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8077       if (l.eq.j+1) then
8078         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8079      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8080      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8081      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8082      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8083       else
8084         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8085      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8086      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8087      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8088      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8089       endif
8090       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8091       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8092       vv1(1)=pizda1(1,1)-pizda1(2,2)
8093       vv1(2)=pizda1(1,2)+pizda1(2,1)
8094       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8095      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8096      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8097      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8098       do iii=1,2
8099         if (swap) then
8100           ind=3-iii
8101         else
8102           ind=iii
8103         endif
8104         do kkk=1,5
8105           do lll=1,3
8106             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8107             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8108             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8109             call transpose2(EUgC(1,1,k),auxmat(1,1))
8110             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8111      &        pizda1(1,1))
8112             vv1(1)=pizda1(1,1)-pizda1(2,2)
8113             vv1(2)=pizda1(1,2)+pizda1(2,1)
8114             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8115             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8116      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8117             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8118      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8119             s5=scalar2(vv(1),Dtobr2(1,i))
8120             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8121           enddo
8122         enddo
8123       enddo
8124       return
8125       end
8126 c----------------------------------------------------------------------------
8127       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8128       implicit real*8 (a-h,o-z)
8129       include 'DIMENSIONS'
8130       include 'sizesclu.dat'
8131       include 'COMMON.IOUNITS'
8132       include 'COMMON.CHAIN'
8133       include 'COMMON.DERIV'
8134       include 'COMMON.INTERACT'
8135       include 'COMMON.CONTACTS'
8136       include 'COMMON.TORSION'
8137       include 'COMMON.VAR'
8138       include 'COMMON.GEO'
8139       logical swap
8140       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8141      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8142       logical lprn
8143       common /kutas/ lprn
8144 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8145 C                                                                              C
8146 C      Parallel       Antiparallel                                             C
8147 C                                                                              C
8148 C          o             o                                                     C
8149 C     \   /l\           /j\   /                                                C
8150 C      \ /   \         /   \ /                                                 C
8151 C       o| o |         | o |o                                                  C
8152 C     \ j|/k\|      \  |/k\|l                                                  C
8153 C      \ /   \       \ /   \                                                   C
8154 C       o             o                                                        C
8155 C       i             i                                                        C
8156 C                                                                              C
8157 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8158 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8159 C AL 7/4/01 s1 would occur in the sixth-order moment,
8160 C           but not in a cluster cumulant
8161 #ifdef MOMENT
8162       s1=dip(1,jj,i)*dip(1,kk,k)
8163 #endif
8164       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8165       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8166       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8167       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8168       call transpose2(EUg(1,1,k),auxmat(1,1))
8169       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8170       vv(1)=pizda(1,1)-pizda(2,2)
8171       vv(2)=pizda(1,2)+pizda(2,1)
8172       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8173 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8174 #ifdef MOMENT
8175       eello6_graph2=-(s1+s2+s3+s4)
8176 #else
8177       eello6_graph2=-(s2+s3+s4)
8178 #endif
8179 c      eello6_graph2=-s3
8180       if (.not. calc_grad) return
8181 C Derivatives in gamma(i-1)
8182       if (i.gt.1) then
8183 #ifdef MOMENT
8184         s1=dipderg(1,jj,i)*dip(1,kk,k)
8185 #endif
8186         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8187         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8188         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8189         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8190 #ifdef MOMENT
8191         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8192 #else
8193         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8194 #endif
8195 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8196       endif
8197 C Derivatives in gamma(k-1)
8198 #ifdef MOMENT
8199       s1=dip(1,jj,i)*dipderg(1,kk,k)
8200 #endif
8201       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8202       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8203       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8204       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8205       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8206       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8207       vv(1)=pizda(1,1)-pizda(2,2)
8208       vv(2)=pizda(1,2)+pizda(2,1)
8209       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8210 #ifdef MOMENT
8211       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8212 #else
8213       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8214 #endif
8215 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8216 C Derivatives in gamma(j-1) or gamma(l-1)
8217       if (j.gt.1) then
8218 #ifdef MOMENT
8219         s1=dipderg(3,jj,i)*dip(1,kk,k)
8220 #endif
8221         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8222         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8223         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8224         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8225         vv(1)=pizda(1,1)-pizda(2,2)
8226         vv(2)=pizda(1,2)+pizda(2,1)
8227         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8228 #ifdef MOMENT
8229         if (swap) then
8230           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8231         else
8232           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8233         endif
8234 #endif
8235         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8236 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8237       endif
8238 C Derivatives in gamma(l-1) or gamma(j-1)
8239       if (l.gt.1) then
8240 #ifdef MOMENT
8241         s1=dip(1,jj,i)*dipderg(3,kk,k)
8242 #endif
8243         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8244         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8245         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8246         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8247         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8248         vv(1)=pizda(1,1)-pizda(2,2)
8249         vv(2)=pizda(1,2)+pizda(2,1)
8250         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8251 #ifdef MOMENT
8252         if (swap) then
8253           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8254         else
8255           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8256         endif
8257 #endif
8258         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8259 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8260       endif
8261 C Cartesian derivatives.
8262       if (lprn) then
8263         write (2,*) 'In eello6_graph2'
8264         do iii=1,2
8265           write (2,*) 'iii=',iii
8266           do kkk=1,5
8267             write (2,*) 'kkk=',kkk
8268             do jjj=1,2
8269               write (2,'(3(2f10.5),5x)')
8270      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8271             enddo
8272           enddo
8273         enddo
8274       endif
8275       do iii=1,2
8276         do kkk=1,5
8277           do lll=1,3
8278 #ifdef MOMENT
8279             if (iii.eq.1) then
8280               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8281             else
8282               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8283             endif
8284 #endif
8285             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8286      &        auxvec(1))
8287             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8288             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8289      &        auxvec(1))
8290             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8291             call transpose2(EUg(1,1,k),auxmat(1,1))
8292             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8293      &        pizda(1,1))
8294             vv(1)=pizda(1,1)-pizda(2,2)
8295             vv(2)=pizda(1,2)+pizda(2,1)
8296             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8297 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8298 #ifdef MOMENT
8299             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8300 #else
8301             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8302 #endif
8303             if (swap) then
8304               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8305             else
8306               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8307             endif
8308           enddo
8309         enddo
8310       enddo
8311       return
8312       end
8313 c----------------------------------------------------------------------------
8314       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8315       implicit real*8 (a-h,o-z)
8316       include 'DIMENSIONS'
8317       include 'sizesclu.dat'
8318       include 'COMMON.IOUNITS'
8319       include 'COMMON.CHAIN'
8320       include 'COMMON.DERIV'
8321       include 'COMMON.INTERACT'
8322       include 'COMMON.CONTACTS'
8323       include 'COMMON.TORSION'
8324       include 'COMMON.VAR'
8325       include 'COMMON.GEO'
8326       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8327       logical swap
8328 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8329 C                                                                              C
8330 C      Parallel       Antiparallel                                             C
8331 C                                                                              C
8332 C          o             o                                                     C
8333 C         /l\   /   \   /j\                                                    C
8334 C        /   \ /     \ /   \                                                   C
8335 C       /| o |o       o| o |\                                                  C
8336 C       j|/k\|  /      |/k\|l /                                                C
8337 C        /   \ /       /   \ /                                                 C
8338 C       /     o       /     o                                                  C
8339 C       i             i                                                        C
8340 C                                                                              C
8341 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8342 C
8343 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8344 C           energy moment and not to the cluster cumulant.
8345       iti=itortyp(itype(i))
8346 c      if (j.lt.nres-1) then
8347       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
8348         itj1=itortyp(itype(j+1))
8349       else
8350         itj1=ntortyp+1
8351       endif
8352       itk=itortyp(itype(k))
8353       itk1=itortyp(itype(k+1))
8354 c      if (l.lt.nres-1) then
8355       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
8356         itl1=itortyp(itype(l+1))
8357       else
8358         itl1=ntortyp+1
8359       endif
8360 #ifdef MOMENT
8361       s1=dip(4,jj,i)*dip(4,kk,k)
8362 #endif
8363       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8364       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8365       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8366       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8367       call transpose2(EE(1,1,itk),auxmat(1,1))
8368       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8369       vv(1)=pizda(1,1)+pizda(2,2)
8370       vv(2)=pizda(2,1)-pizda(1,2)
8371       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8372 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8373 #ifdef MOMENT
8374       eello6_graph3=-(s1+s2+s3+s4)
8375 #else
8376       eello6_graph3=-(s2+s3+s4)
8377 #endif
8378 c      eello6_graph3=-s4
8379       if (.not. calc_grad) return
8380 C Derivatives in gamma(k-1)
8381       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8382       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8383       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8384       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8385 C Derivatives in gamma(l-1)
8386       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8387       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8388       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8389       vv(1)=pizda(1,1)+pizda(2,2)
8390       vv(2)=pizda(2,1)-pizda(1,2)
8391       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8392       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8393 C Cartesian derivatives.
8394       do iii=1,2
8395         do kkk=1,5
8396           do lll=1,3
8397 #ifdef MOMENT
8398             if (iii.eq.1) then
8399               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8400             else
8401               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8402             endif
8403 #endif
8404             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8405      &        auxvec(1))
8406             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8407             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8408      &        auxvec(1))
8409             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8410             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8411      &        pizda(1,1))
8412             vv(1)=pizda(1,1)+pizda(2,2)
8413             vv(2)=pizda(2,1)-pizda(1,2)
8414             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8415 #ifdef MOMENT
8416             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8417 #else
8418             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8419 #endif
8420             if (swap) then
8421               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8422             else
8423               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8424             endif
8425 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8426           enddo
8427         enddo
8428       enddo
8429       return
8430       end
8431 c----------------------------------------------------------------------------
8432       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8433       implicit real*8 (a-h,o-z)
8434       include 'DIMENSIONS'
8435       include 'sizesclu.dat'
8436       include 'COMMON.IOUNITS'
8437       include 'COMMON.CHAIN'
8438       include 'COMMON.DERIV'
8439       include 'COMMON.INTERACT'
8440       include 'COMMON.CONTACTS'
8441       include 'COMMON.TORSION'
8442       include 'COMMON.VAR'
8443       include 'COMMON.GEO'
8444       include 'COMMON.FFIELD'
8445       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8446      & auxvec1(2),auxmat1(2,2)
8447       logical swap
8448 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8449 C                                                                              C
8450 C      Parallel       Antiparallel                                             C
8451 C                                                                              C
8452 C          o             o                                                     C
8453 C         /l\   /   \   /j\                                                    C
8454 C        /   \ /     \ /   \                                                   C
8455 C       /| o |o       o| o |\                                                  C
8456 C     \ j|/k\|      \  |/k\|l                                                  C
8457 C      \ /   \       \ /   \                                                   C
8458 C       o     \       o     \                                                  C
8459 C       i             i                                                        C
8460 C                                                                              C
8461 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8462 C
8463 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8464 C           energy moment and not to the cluster cumulant.
8465 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8466       iti=itortyp(itype(i))
8467       itj=itortyp(itype(j))
8468 c      if (j.lt.nres-1) then
8469       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
8470         itj1=itortyp(itype(j+1))
8471       else
8472         itj1=ntortyp+1
8473       endif
8474       itk=itortyp(itype(k))
8475 c      if (k.lt.nres-1) then
8476       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
8477         itk1=itortyp(itype(k+1))
8478       else
8479         itk1=ntortyp+1
8480       endif
8481       itl=itortyp(itype(l))
8482       if (l.lt.nres-1) then
8483         itl1=itortyp(itype(l+1))
8484       else
8485         itl1=ntortyp+1
8486       endif
8487 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8488 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8489 cd     & ' itl',itl,' itl1',itl1
8490 #ifdef MOMENT
8491       if (imat.eq.1) then
8492         s1=dip(3,jj,i)*dip(3,kk,k)
8493       else
8494         s1=dip(2,jj,j)*dip(2,kk,l)
8495       endif
8496 #endif
8497       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8498       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8499       if (j.eq.l+1) then
8500         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8501         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8502       else
8503         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8504         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8505       endif
8506       call transpose2(EUg(1,1,k),auxmat(1,1))
8507       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8508       vv(1)=pizda(1,1)-pizda(2,2)
8509       vv(2)=pizda(2,1)+pizda(1,2)
8510       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8511 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8512 #ifdef MOMENT
8513       eello6_graph4=-(s1+s2+s3+s4)
8514 #else
8515       eello6_graph4=-(s2+s3+s4)
8516 #endif
8517       if (.not. calc_grad) return
8518 C Derivatives in gamma(i-1)
8519       if (i.gt.1) then
8520 #ifdef MOMENT
8521         if (imat.eq.1) then
8522           s1=dipderg(2,jj,i)*dip(3,kk,k)
8523         else
8524           s1=dipderg(4,jj,j)*dip(2,kk,l)
8525         endif
8526 #endif
8527         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8528         if (j.eq.l+1) then
8529           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8530           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8531         else
8532           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8533           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8534         endif
8535         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8536         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8537 cd          write (2,*) 'turn6 derivatives'
8538 #ifdef MOMENT
8539           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8540 #else
8541           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8542 #endif
8543         else
8544 #ifdef MOMENT
8545           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8546 #else
8547           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8548 #endif
8549         endif
8550       endif
8551 C Derivatives in gamma(k-1)
8552 #ifdef MOMENT
8553       if (imat.eq.1) then
8554         s1=dip(3,jj,i)*dipderg(2,kk,k)
8555       else
8556         s1=dip(2,jj,j)*dipderg(4,kk,l)
8557       endif
8558 #endif
8559       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8560       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8561       if (j.eq.l+1) then
8562         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8563         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8564       else
8565         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8566         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8567       endif
8568       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8569       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8570       vv(1)=pizda(1,1)-pizda(2,2)
8571       vv(2)=pizda(2,1)+pizda(1,2)
8572       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8573       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8574 #ifdef MOMENT
8575         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8576 #else
8577         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8578 #endif
8579       else
8580 #ifdef MOMENT
8581         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8582 #else
8583         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8584 #endif
8585       endif
8586 C Derivatives in gamma(j-1) or gamma(l-1)
8587       if (l.eq.j+1 .and. l.gt.1) then
8588         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8589         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8590         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8591         vv(1)=pizda(1,1)-pizda(2,2)
8592         vv(2)=pizda(2,1)+pizda(1,2)
8593         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8594         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8595       else if (j.gt.1) then
8596         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8597         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8598         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8599         vv(1)=pizda(1,1)-pizda(2,2)
8600         vv(2)=pizda(2,1)+pizda(1,2)
8601         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8602         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8603           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8604         else
8605           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8606         endif
8607       endif
8608 C Cartesian derivatives.
8609       do iii=1,2
8610         do kkk=1,5
8611           do lll=1,3
8612 #ifdef MOMENT
8613             if (iii.eq.1) then
8614               if (imat.eq.1) then
8615                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8616               else
8617                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8618               endif
8619             else
8620               if (imat.eq.1) then
8621                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8622               else
8623                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8624               endif
8625             endif
8626 #endif
8627             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8628      &        auxvec(1))
8629             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8630             if (j.eq.l+1) then
8631               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8632      &          b1(1,itj1),auxvec(1))
8633               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8634             else
8635               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8636      &          b1(1,itl1),auxvec(1))
8637               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8638             endif
8639             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8640      &        pizda(1,1))
8641             vv(1)=pizda(1,1)-pizda(2,2)
8642             vv(2)=pizda(2,1)+pizda(1,2)
8643             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8644             if (swap) then
8645               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8646 #ifdef MOMENT
8647                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8648      &             -(s1+s2+s4)
8649 #else
8650                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8651      &             -(s2+s4)
8652 #endif
8653                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8654               else
8655 #ifdef MOMENT
8656                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8657 #else
8658                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8659 #endif
8660                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8661               endif
8662             else
8663 #ifdef MOMENT
8664               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8665 #else
8666               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8667 #endif
8668               if (l.eq.j+1) then
8669                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8670               else
8671                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8672               endif
8673             endif
8674           enddo
8675         enddo
8676       enddo
8677       return
8678       end
8679 c----------------------------------------------------------------------------
8680       double precision function eello_turn6(i,jj,kk)
8681       implicit real*8 (a-h,o-z)
8682       include 'DIMENSIONS'
8683       include 'sizesclu.dat'
8684       include 'COMMON.IOUNITS'
8685       include 'COMMON.CHAIN'
8686       include 'COMMON.DERIV'
8687       include 'COMMON.INTERACT'
8688       include 'COMMON.CONTACTS'
8689       include 'COMMON.TORSION'
8690       include 'COMMON.VAR'
8691       include 'COMMON.GEO'
8692       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8693      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8694      &  ggg1(3),ggg2(3)
8695       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8696      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8697 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8698 C           the respective energy moment and not to the cluster cumulant.
8699       eello_turn6=0.0d0
8700       j=i+4
8701       k=i+1
8702       l=i+3
8703       iti=itortyp(itype(i))
8704       itk=itortyp(itype(k))
8705       itk1=itortyp(itype(k+1))
8706       itl=itortyp(itype(l))
8707       itj=itortyp(itype(j))
8708 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8709 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8710 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8711 cd        eello6=0.0d0
8712 cd        return
8713 cd      endif
8714 cd      write (iout,*)
8715 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8716 cd     &   ' and',k,l
8717 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8718       do iii=1,2
8719         do kkk=1,5
8720           do lll=1,3
8721             derx_turn(lll,kkk,iii)=0.0d0
8722           enddo
8723         enddo
8724       enddo
8725 cd      eij=1.0d0
8726 cd      ekl=1.0d0
8727 cd      ekont=1.0d0
8728       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8729 cd      eello6_5=0.0d0
8730 cd      write (2,*) 'eello6_5',eello6_5
8731 #ifdef MOMENT
8732       call transpose2(AEA(1,1,1),auxmat(1,1))
8733       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8734       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8735       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8736 #else
8737       s1 = 0.0d0
8738 #endif
8739       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8740       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8741       s2 = scalar2(b1(1,itk),vtemp1(1))
8742 #ifdef MOMENT
8743       call transpose2(AEA(1,1,2),atemp(1,1))
8744       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8745       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8746       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8747 #else
8748       s8=0.0d0
8749 #endif
8750       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8751       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8752       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8753 #ifdef MOMENT
8754       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8755       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8756       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8757       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8758       ss13 = scalar2(b1(1,itk),vtemp4(1))
8759       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8760 #else
8761       s13=0.0d0
8762 #endif
8763 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8764 c      s1=0.0d0
8765 c      s2=0.0d0
8766 c      s8=0.0d0
8767 c      s12=0.0d0
8768 c      s13=0.0d0
8769       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8770       if (calc_grad) then
8771 C Derivatives in gamma(i+2)
8772 #ifdef MOMENT
8773       call transpose2(AEA(1,1,1),auxmatd(1,1))
8774       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8775       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8776       call transpose2(AEAderg(1,1,2),atempd(1,1))
8777       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8778       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8779 #else
8780       s8d=0.0d0
8781 #endif
8782       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8783       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8784       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8785 c      s1d=0.0d0
8786 c      s2d=0.0d0
8787 c      s8d=0.0d0
8788 c      s12d=0.0d0
8789 c      s13d=0.0d0
8790       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8791 C Derivatives in gamma(i+3)
8792 #ifdef MOMENT
8793       call transpose2(AEA(1,1,1),auxmatd(1,1))
8794       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8795       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8796       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8797 #else
8798       s1d=0.0d0
8799 #endif
8800       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8801       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8802       s2d = scalar2(b1(1,itk),vtemp1d(1))
8803 #ifdef MOMENT
8804       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8805       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8806 #endif
8807       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8808 #ifdef MOMENT
8809       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8810       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8811       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8812 #else
8813       s13d=0.0d0
8814 #endif
8815 c      s1d=0.0d0
8816 c      s2d=0.0d0
8817 c      s8d=0.0d0
8818 c      s12d=0.0d0
8819 c      s13d=0.0d0
8820 #ifdef MOMENT
8821       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8822      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8823 #else
8824       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8825      &               -0.5d0*ekont*(s2d+s12d)
8826 #endif
8827 C Derivatives in gamma(i+4)
8828       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8829       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8830       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8831 #ifdef MOMENT
8832       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8833       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8834       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8835 #else
8836       s13d = 0.0d0
8837 #endif
8838 c      s1d=0.0d0
8839 c      s2d=0.0d0
8840 c      s8d=0.0d0
8841 C      s12d=0.0d0
8842 c      s13d=0.0d0
8843 #ifdef MOMENT
8844       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8845 #else
8846       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8847 #endif
8848 C Derivatives in gamma(i+5)
8849 #ifdef MOMENT
8850       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8851       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8852       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8853 #else
8854       s1d = 0.0d0
8855 #endif
8856       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8857       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8858       s2d = scalar2(b1(1,itk),vtemp1d(1))
8859 #ifdef MOMENT
8860       call transpose2(AEA(1,1,2),atempd(1,1))
8861       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8862       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8863 #else
8864       s8d = 0.0d0
8865 #endif
8866       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8867       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8868 #ifdef MOMENT
8869       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8870       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8871       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8872 #else
8873       s13d = 0.0d0
8874 #endif
8875 c      s1d=0.0d0
8876 c      s2d=0.0d0
8877 c      s8d=0.0d0
8878 c      s12d=0.0d0
8879 c      s13d=0.0d0
8880 #ifdef MOMENT
8881       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8882      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8883 #else
8884       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8885      &               -0.5d0*ekont*(s2d+s12d)
8886 #endif
8887 C Cartesian derivatives
8888       do iii=1,2
8889         do kkk=1,5
8890           do lll=1,3
8891 #ifdef MOMENT
8892             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8893             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8894             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8895 #else
8896             s1d = 0.0d0
8897 #endif
8898             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8899             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8900      &          vtemp1d(1))
8901             s2d = scalar2(b1(1,itk),vtemp1d(1))
8902 #ifdef MOMENT
8903             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8904             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8905             s8d = -(atempd(1,1)+atempd(2,2))*
8906      &           scalar2(cc(1,1,itl),vtemp2(1))
8907 #else
8908             s8d = 0.0d0
8909 #endif
8910             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8911      &           auxmatd(1,1))
8912             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8913             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8914 c      s1d=0.0d0
8915 c      s2d=0.0d0
8916 c      s8d=0.0d0
8917 c      s12d=0.0d0
8918 c      s13d=0.0d0
8919 #ifdef MOMENT
8920             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8921      &        - 0.5d0*(s1d+s2d)
8922 #else
8923             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8924      &        - 0.5d0*s2d
8925 #endif
8926 #ifdef MOMENT
8927             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8928      &        - 0.5d0*(s8d+s12d)
8929 #else
8930             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8931      &        - 0.5d0*s12d
8932 #endif
8933           enddo
8934         enddo
8935       enddo
8936 #ifdef MOMENT
8937       do kkk=1,5
8938         do lll=1,3
8939           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8940      &      achuj_tempd(1,1))
8941           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8942           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8943           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8944           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8945           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8946      &      vtemp4d(1))
8947           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8948           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8949           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8950         enddo
8951       enddo
8952 #endif
8953 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8954 cd     &  16*eel_turn6_num
8955 cd      goto 1112
8956       if (j.lt.nres-1) then
8957         j1=j+1
8958         j2=j-1
8959       else
8960         j1=j-1
8961         j2=j-2
8962       endif
8963       if (l.lt.nres-1) then
8964         l1=l+1
8965         l2=l-1
8966       else
8967         l1=l-1
8968         l2=l-2
8969       endif
8970       do ll=1,3
8971         ggg1(ll)=eel_turn6*g_contij(ll,1)
8972         ggg2(ll)=eel_turn6*g_contij(ll,2)
8973         ghalf=0.5d0*ggg1(ll)
8974 cd        ghalf=0.0d0
8975         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8976      &    +ekont*derx_turn(ll,2,1)
8977         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8978         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8979      &    +ekont*derx_turn(ll,4,1)
8980         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8981         ghalf=0.5d0*ggg2(ll)
8982 cd        ghalf=0.0d0
8983         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8984      &    +ekont*derx_turn(ll,2,2)
8985         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8986         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8987      &    +ekont*derx_turn(ll,4,2)
8988         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8989       enddo
8990 cd      goto 1112
8991       do m=i+1,j-1
8992         do ll=1,3
8993           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8994         enddo
8995       enddo
8996       do m=k+1,l-1
8997         do ll=1,3
8998           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8999         enddo
9000       enddo
9001 1112  continue
9002       do m=i+2,j2
9003         do ll=1,3
9004           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9005         enddo
9006       enddo
9007       do m=k+2,l2
9008         do ll=1,3
9009           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9010         enddo
9011       enddo
9012 cd      do iii=1,nres-3
9013 cd        write (2,*) iii,g_corr6_loc(iii)
9014 cd      enddo
9015       endif
9016       eello_turn6=ekont*eel_turn6
9017 cd      write (2,*) 'ekont',ekont
9018 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9019       return
9020       end
9021 crc-------------------------------------------------
9022       SUBROUTINE MATVEC2(A1,V1,V2)
9023       implicit real*8 (a-h,o-z)
9024       include 'DIMENSIONS'
9025       DIMENSION A1(2,2),V1(2),V2(2)
9026 c      DO 1 I=1,2
9027 c        VI=0.0
9028 c        DO 3 K=1,2
9029 c    3     VI=VI+A1(I,K)*V1(K)
9030 c        Vaux(I)=VI
9031 c    1 CONTINUE
9032
9033       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9034       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9035
9036       v2(1)=vaux1
9037       v2(2)=vaux2
9038       END
9039 C---------------------------------------
9040       SUBROUTINE MATMAT2(A1,A2,A3)
9041       implicit real*8 (a-h,o-z)
9042       include 'DIMENSIONS'
9043       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9044 c      DIMENSION AI3(2,2)
9045 c        DO  J=1,2
9046 c          A3IJ=0.0
9047 c          DO K=1,2
9048 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9049 c          enddo
9050 c          A3(I,J)=A3IJ
9051 c       enddo
9052 c      enddo
9053
9054       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9055       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9056       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9057       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9058
9059       A3(1,1)=AI3_11
9060       A3(2,1)=AI3_21
9061       A3(1,2)=AI3_12
9062       A3(2,2)=AI3_22
9063       END
9064
9065 c-------------------------------------------------------------------------
9066       double precision function scalar2(u,v)
9067       implicit none
9068       double precision u(2),v(2)
9069       double precision sc
9070       integer i
9071       scalar2=u(1)*v(1)+u(2)*v(2)
9072       return
9073       end
9074
9075 C-----------------------------------------------------------------------------
9076
9077       subroutine transpose2(a,at)
9078       implicit none
9079       double precision a(2,2),at(2,2)
9080       at(1,1)=a(1,1)
9081       at(1,2)=a(2,1)
9082       at(2,1)=a(1,2)
9083       at(2,2)=a(2,2)
9084       return
9085       end
9086 c--------------------------------------------------------------------------
9087       subroutine transpose(n,a,at)
9088       implicit none
9089       integer n,i,j
9090       double precision a(n,n),at(n,n)
9091       do i=1,n
9092         do j=1,n
9093           at(j,i)=a(i,j)
9094         enddo
9095       enddo
9096       return
9097       end
9098 C---------------------------------------------------------------------------
9099       subroutine prodmat3(a1,a2,kk,transp,prod)
9100       implicit none
9101       integer i,j
9102       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9103       logical transp
9104 crc      double precision auxmat(2,2),prod_(2,2)
9105
9106       if (transp) then
9107 crc        call transpose2(kk(1,1),auxmat(1,1))
9108 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9109 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9110
9111            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9112      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9113            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9114      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9115            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9116      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9117            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9118      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9119
9120       else
9121 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9122 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9123
9124            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9125      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9126            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9127      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9128            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9129      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9130            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9131      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9132
9133       endif
9134 c      call transpose2(a2(1,1),a2t(1,1))
9135
9136 crc      print *,transp
9137 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9138 crc      print *,((prod(i,j),i=1,2),j=1,2)
9139
9140       return
9141       end
9142 C-----------------------------------------------------------------------------
9143       double precision function scalar(u,v)
9144       implicit none
9145       double precision u(3),v(3)
9146       double precision sc
9147       integer i
9148       sc=0.0d0
9149       do i=1,3
9150         sc=sc+u(i)*v(i)
9151       enddo
9152       scalar=sc
9153       return
9154       end
9155 C-----------------------------------------------------------------------
9156       double precision function sscale(r)
9157       double precision r,gamm
9158       include "COMMON.SPLITELE"
9159       if(r.lt.r_cut-rlamb) then
9160         sscale=1.0d0
9161       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9162         gamm=(r-(r_cut-rlamb))/rlamb
9163         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9164       else
9165         sscale=0d0
9166       endif
9167       return
9168       end
9169 C-----------------------------------------------------------------------
9170 C-----------------------------------------------------------------------
9171       double precision function sscagrad(r)
9172       double precision r,gamm
9173       include "COMMON.SPLITELE"
9174       if(r.lt.r_cut-rlamb) then
9175         sscagrad=0.0d0
9176       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9177         gamm=(r-(r_cut-rlamb))/rlamb
9178         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9179       else
9180         sscagrad=0.0d0
9181       endif
9182       return
9183       end
9184 C-----------------------------------------------------------------------
9185 C first for shielding is setting of function of side-chains
9186        subroutine set_shield_fac2
9187       implicit real*8 (a-h,o-z)
9188       include 'DIMENSIONS'
9189       include 'COMMON.CHAIN'
9190       include 'COMMON.DERIV'
9191       include 'COMMON.IOUNITS'
9192       include 'COMMON.SHIELD'
9193       include 'COMMON.INTERACT'
9194 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9195       double precision div77_81/0.974996043d0/,
9196      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9197
9198 C the vector between center of side_chain and peptide group
9199        double precision pep_side(3),long,side_calf(3),
9200      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9201      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9202 C the line belowe needs to be changed for FGPROC>1
9203       do i=1,nres-1
9204       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9205       ishield_list(i)=0
9206 Cif there two consequtive dummy atoms there is no peptide group between them
9207 C the line below has to be changed for FGPROC>1
9208       VolumeTotal=0.0
9209       do k=1,nres
9210        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9211        dist_pep_side=0.0
9212        dist_side_calf=0.0
9213        do j=1,3
9214 C first lets set vector conecting the ithe side-chain with kth side-chain
9215       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9216 C      pep_side(j)=2.0d0
9217 C and vector conecting the side-chain with its proper calfa
9218       side_calf(j)=c(j,k+nres)-c(j,k)
9219 C      side_calf(j)=2.0d0
9220       pept_group(j)=c(j,i)-c(j,i+1)
9221 C lets have their lenght
9222       dist_pep_side=pep_side(j)**2+dist_pep_side
9223       dist_side_calf=dist_side_calf+side_calf(j)**2
9224       dist_pept_group=dist_pept_group+pept_group(j)**2
9225       enddo
9226        dist_pep_side=dsqrt(dist_pep_side)
9227        dist_pept_group=dsqrt(dist_pept_group)
9228        dist_side_calf=dsqrt(dist_side_calf)
9229       do j=1,3
9230         pep_side_norm(j)=pep_side(j)/dist_pep_side
9231         side_calf_norm(j)=dist_side_calf
9232       enddo
9233 C now sscale fraction
9234        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9235 C       print *,buff_shield,"buff"
9236 C now sscale
9237         if (sh_frac_dist.le.0.0) cycle
9238 C If we reach here it means that this side chain reaches the shielding sphere
9239 C Lets add him to the list for gradient
9240         ishield_list(i)=ishield_list(i)+1
9241 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9242 C this list is essential otherwise problem would be O3
9243         shield_list(ishield_list(i),i)=k
9244 C Lets have the sscale value
9245         if (sh_frac_dist.gt.1.0) then
9246          scale_fac_dist=1.0d0
9247          do j=1,3
9248          sh_frac_dist_grad(j)=0.0d0
9249          enddo
9250         else
9251          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9252      &                   *(2.0d0*sh_frac_dist-3.0d0)
9253          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9254      &                  /dist_pep_side/buff_shield*0.5d0
9255 C remember for the final gradient multiply sh_frac_dist_grad(j)
9256 C for side_chain by factor -2 !
9257          do j=1,3
9258          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9259 C         sh_frac_dist_grad(j)=0.0d0
9260 C         scale_fac_dist=1.0d0
9261 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9262 C     &                    sh_frac_dist_grad(j)
9263          enddo
9264         endif
9265 C this is what is now we have the distance scaling now volume...
9266       short=short_r_sidechain(itype(k))
9267       long=long_r_sidechain(itype(k))
9268       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9269       sinthet=short/dist_pep_side*costhet
9270 C now costhet_grad
9271 C       costhet=0.6d0
9272 C       sinthet=0.8
9273        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9274 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9275 C     &             -short/dist_pep_side**2/costhet)
9276 C       costhet_fac=0.0d0
9277        do j=1,3
9278          costhet_grad(j)=costhet_fac*pep_side(j)
9279        enddo
9280 C remember for the final gradient multiply costhet_grad(j)
9281 C for side_chain by factor -2 !
9282 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9283 C pep_side0pept_group is vector multiplication
9284       pep_side0pept_group=0.0d0
9285       do j=1,3
9286       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9287       enddo
9288       cosalfa=(pep_side0pept_group/
9289      & (dist_pep_side*dist_side_calf))
9290       fac_alfa_sin=1.0d0-cosalfa**2
9291       fac_alfa_sin=dsqrt(fac_alfa_sin)
9292       rkprim=fac_alfa_sin*(long-short)+short
9293 C      rkprim=short
9294
9295 C now costhet_grad
9296        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9297 C       cosphi=0.6
9298        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9299        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9300      &      dist_pep_side**2)
9301 C       sinphi=0.8
9302        do j=1,3
9303          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9304      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9305      &*(long-short)/fac_alfa_sin*cosalfa/
9306      &((dist_pep_side*dist_side_calf))*
9307      &((side_calf(j))-cosalfa*
9308      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9309 C       cosphi_grad_long(j)=0.0d0
9310         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9311      &*(long-short)/fac_alfa_sin*cosalfa
9312      &/((dist_pep_side*dist_side_calf))*
9313      &(pep_side(j)-
9314      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9315 C       cosphi_grad_loc(j)=0.0d0
9316        enddo
9317 C      print *,sinphi,sinthet
9318       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9319      &                    /VSolvSphere_div
9320 C     &                    *wshield
9321 C now the gradient...
9322       do j=1,3
9323       grad_shield(j,i)=grad_shield(j,i)
9324 C gradient po skalowaniu
9325      &                +(sh_frac_dist_grad(j)*VofOverlap
9326 C  gradient po costhet
9327      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9328      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9329      &       sinphi/sinthet*costhet*costhet_grad(j)
9330      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9331      & )*wshield
9332 C grad_shield_side is Cbeta sidechain gradient
9333       grad_shield_side(j,ishield_list(i),i)=
9334      &        (sh_frac_dist_grad(j)*-2.0d0
9335      &        *VofOverlap
9336      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9337      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9338      &       sinphi/sinthet*costhet*costhet_grad(j)
9339      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9340      &       )*wshield
9341
9342        grad_shield_loc(j,ishield_list(i),i)=
9343      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9344      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9345      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9346      &        ))
9347      &        *wshield
9348       enddo
9349       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9350       enddo
9351       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9352 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9353       enddo
9354       return
9355       end
9356 C first for shielding is setting of function of side-chains
9357        subroutine set_shield_fac
9358       implicit real*8 (a-h,o-z)
9359       include 'DIMENSIONS'
9360       include 'COMMON.CHAIN'
9361       include 'COMMON.DERIV'
9362       include 'COMMON.IOUNITS'
9363       include 'COMMON.SHIELD'
9364       include 'COMMON.INTERACT'
9365 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9366       double precision div77_81/0.974996043d0/,
9367      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9368
9369 C the vector between center of side_chain and peptide group
9370        double precision pep_side(3),long,side_calf(3),
9371      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9372      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9373 C the line belowe needs to be changed for FGPROC>1
9374       do i=1,nres-1
9375       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9376       ishield_list(i)=0
9377 Cif there two consequtive dummy atoms there is no peptide group between them
9378 C the line below has to be changed for FGPROC>1
9379       VolumeTotal=0.0
9380       do k=1,nres
9381        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9382        dist_pep_side=0.0
9383        dist_side_calf=0.0
9384        do j=1,3
9385 C first lets set vector conecting the ithe side-chain with kth side-chain
9386       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9387 C      pep_side(j)=2.0d0
9388 C and vector conecting the side-chain with its proper calfa
9389       side_calf(j)=c(j,k+nres)-c(j,k)
9390 C      side_calf(j)=2.0d0
9391       pept_group(j)=c(j,i)-c(j,i+1)
9392 C lets have their lenght
9393       dist_pep_side=pep_side(j)**2+dist_pep_side
9394       dist_side_calf=dist_side_calf+side_calf(j)**2
9395       dist_pept_group=dist_pept_group+pept_group(j)**2
9396       enddo
9397        dist_pep_side=dsqrt(dist_pep_side)
9398        dist_pept_group=dsqrt(dist_pept_group)
9399        dist_side_calf=dsqrt(dist_side_calf)
9400       do j=1,3
9401         pep_side_norm(j)=pep_side(j)/dist_pep_side
9402         side_calf_norm(j)=dist_side_calf
9403       enddo
9404 C now sscale fraction
9405        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9406 C       print *,buff_shield,"buff"
9407 C now sscale
9408         if (sh_frac_dist.le.0.0) cycle
9409 C If we reach here it means that this side chain reaches the shielding sphere
9410 C Lets add him to the list for gradient
9411         ishield_list(i)=ishield_list(i)+1
9412 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9413 C this list is essential otherwise problem would be O3
9414         shield_list(ishield_list(i),i)=k
9415 C Lets have the sscale value
9416         if (sh_frac_dist.gt.1.0) then
9417          scale_fac_dist=1.0d0
9418          do j=1,3
9419          sh_frac_dist_grad(j)=0.0d0
9420          enddo
9421         else
9422          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9423      &                   *(2.0*sh_frac_dist-3.0d0)
9424          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9425      &                  /dist_pep_side/buff_shield*0.5
9426 C remember for the final gradient multiply sh_frac_dist_grad(j)
9427 C for side_chain by factor -2 !
9428          do j=1,3
9429          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9430 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9431 C     &                    sh_frac_dist_grad(j)
9432          enddo
9433         endif
9434 C        if ((i.eq.3).and.(k.eq.2)) then
9435 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9436 C     & ,"TU"
9437 C        endif
9438
9439 C this is what is now we have the distance scaling now volume...
9440       short=short_r_sidechain(itype(k))
9441       long=long_r_sidechain(itype(k))
9442       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9443 C now costhet_grad
9444 C       costhet=0.0d0
9445        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9446 C       costhet_fac=0.0d0
9447        do j=1,3
9448          costhet_grad(j)=costhet_fac*pep_side(j)
9449        enddo
9450 C remember for the final gradient multiply costhet_grad(j)
9451 C for side_chain by factor -2 !
9452 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9453 C pep_side0pept_group is vector multiplication
9454       pep_side0pept_group=0.0
9455       do j=1,3
9456       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9457       enddo
9458       cosalfa=(pep_side0pept_group/
9459      & (dist_pep_side*dist_side_calf))
9460       fac_alfa_sin=1.0-cosalfa**2
9461       fac_alfa_sin=dsqrt(fac_alfa_sin)
9462       rkprim=fac_alfa_sin*(long-short)+short
9463 C now costhet_grad
9464        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9465        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9466
9467        do j=1,3
9468          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9469      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9470      &*(long-short)/fac_alfa_sin*cosalfa/
9471      &((dist_pep_side*dist_side_calf))*
9472      &((side_calf(j))-cosalfa*
9473      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9474
9475         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9476      &*(long-short)/fac_alfa_sin*cosalfa
9477      &/((dist_pep_side*dist_side_calf))*
9478      &(pep_side(j)-
9479      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9480        enddo
9481
9482       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9483      &                    /VSolvSphere_div
9484      &                    *wshield
9485 C now the gradient...
9486 C grad_shield is gradient of Calfa for peptide groups
9487 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9488 C     &               costhet,cosphi
9489 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9490 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9491       do j=1,3
9492       grad_shield(j,i)=grad_shield(j,i)
9493 C gradient po skalowaniu
9494      &                +(sh_frac_dist_grad(j)
9495 C  gradient po costhet
9496      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9497      &-scale_fac_dist*(cosphi_grad_long(j))
9498      &/(1.0-cosphi) )*div77_81
9499      &*VofOverlap
9500 C grad_shield_side is Cbeta sidechain gradient
9501       grad_shield_side(j,ishield_list(i),i)=
9502      &        (sh_frac_dist_grad(j)*-2.0d0
9503      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9504      &       +scale_fac_dist*(cosphi_grad_long(j))
9505      &        *2.0d0/(1.0-cosphi))
9506      &        *div77_81*VofOverlap
9507
9508        grad_shield_loc(j,ishield_list(i),i)=
9509      &   scale_fac_dist*cosphi_grad_loc(j)
9510      &        *2.0d0/(1.0-cosphi)
9511      &        *div77_81*VofOverlap
9512       enddo
9513       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9514       enddo
9515       fac_shield(i)=VolumeTotal*div77_81+div4_81
9516 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9517       enddo
9518       return
9519       end
9520 C--------------------------------------------------------------------------
9521 C-----------------------------------------------------------------------
9522       double precision function sscalelip(r)
9523       double precision r,gamm
9524       include "COMMON.SPLITELE"
9525 C      if(r.lt.r_cut-rlamb) then
9526 C        sscale=1.0d0
9527 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9528 C        gamm=(r-(r_cut-rlamb))/rlamb
9529         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9530 C      else
9531 C        sscale=0d0
9532 C      endif
9533       return
9534       end
9535 C-----------------------------------------------------------------------
9536       double precision function sscagradlip(r)
9537       double precision r,gamm
9538       include "COMMON.SPLITELE"
9539 C     if(r.lt.r_cut-rlamb) then
9540 C        sscagrad=0.0d0
9541 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9542 C        gamm=(r-(r_cut-rlamb))/rlamb
9543         sscagradlip=r*(6*r-6.0d0)
9544 C      else
9545 C        sscagrad=0.0d0
9546 C      endif
9547       return
9548       end
9549
9550 C-----------------------------------------------------------------------
9551 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9552       subroutine Eliptransfer(eliptran)
9553       implicit real*8 (a-h,o-z)
9554       include 'DIMENSIONS'
9555       include 'COMMON.GEO'
9556       include 'COMMON.VAR'
9557       include 'COMMON.LOCAL'
9558       include 'COMMON.CHAIN'
9559       include 'COMMON.DERIV'
9560       include 'COMMON.INTERACT'
9561       include 'COMMON.IOUNITS'
9562       include 'COMMON.CALC'
9563       include 'COMMON.CONTROL'
9564       include 'COMMON.SPLITELE'
9565       include 'COMMON.SBRIDGE'
9566 C this is done by Adasko
9567 C      print *,"wchodze"
9568 C structure of box:
9569 C      water
9570 C--bordliptop-- buffore starts
9571 C--bufliptop--- here true lipid starts
9572 C      lipid
9573 C--buflipbot--- lipid ends buffore starts
9574 C--bordlipbot--buffore ends
9575       eliptran=0.0
9576       write(iout,*) "I am in?"
9577       do i=1,nres
9578 C       do i=1,1
9579         if (itype(i).eq.ntyp1) cycle
9580
9581         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9582         if (positi.le.0) positi=positi+boxzsize
9583 C        print *,i
9584 C first for peptide groups
9585 c for each residue check if it is in lipid or lipid water border area
9586        if ((positi.gt.bordlipbot)
9587      &.and.(positi.lt.bordliptop)) then
9588 C the energy transfer exist
9589         if (positi.lt.buflipbot) then
9590 C what fraction I am in
9591          fracinbuf=1.0d0-
9592      &        ((positi-bordlipbot)/lipbufthick)
9593 C lipbufthick is thickenes of lipid buffore
9594          sslip=sscalelip(fracinbuf)
9595          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9596          eliptran=eliptran+sslip*pepliptran
9597          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9598          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9599 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9600         elseif (positi.gt.bufliptop) then
9601          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9602          sslip=sscalelip(fracinbuf)
9603          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9604          eliptran=eliptran+sslip*pepliptran
9605          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9606          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9607 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9608 C          print *, "doing sscalefor top part"
9609 C         print *,i,sslip,fracinbuf,ssgradlip
9610         else
9611          eliptran=eliptran+pepliptran
9612 C         print *,"I am in true lipid"
9613         endif
9614 C       else
9615 C       eliptran=elpitran+0.0 ! I am in water
9616        endif
9617        enddo
9618 C       print *, "nic nie bylo w lipidzie?"
9619 C now multiply all by the peptide group transfer factor
9620 C       eliptran=eliptran*pepliptran
9621 C now the same for side chains
9622 CV       do i=1,1
9623        do i=1,nres
9624         if (itype(i).eq.ntyp1) cycle
9625         positi=(mod(c(3,i+nres),boxzsize))
9626         if (positi.le.0) positi=positi+boxzsize
9627 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9628 c for each residue check if it is in lipid or lipid water border area
9629 C       respos=mod(c(3,i+nres),boxzsize)
9630 C       print *,positi,bordlipbot,buflipbot
9631        if ((positi.gt.bordlipbot)
9632      & .and.(positi.lt.bordliptop)) then
9633 C the energy transfer exist
9634         if (positi.lt.buflipbot) then
9635          fracinbuf=1.0d0-
9636      &     ((positi-bordlipbot)/lipbufthick)
9637 C lipbufthick is thickenes of lipid buffore
9638          sslip=sscalelip(fracinbuf)
9639          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9640          eliptran=eliptran+sslip*liptranene(itype(i))
9641          gliptranx(3,i)=gliptranx(3,i)
9642      &+ssgradlip*liptranene(itype(i))
9643          gliptranc(3,i-1)= gliptranc(3,i-1)
9644      &+ssgradlip*liptranene(itype(i))
9645 C         print *,"doing sccale for lower part"
9646         elseif (positi.gt.bufliptop) then
9647          fracinbuf=1.0d0-
9648      &((bordliptop-positi)/lipbufthick)
9649          sslip=sscalelip(fracinbuf)
9650          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9651          eliptran=eliptran+sslip*liptranene(itype(i))
9652          gliptranx(3,i)=gliptranx(3,i)
9653      &+ssgradlip*liptranene(itype(i))
9654          gliptranc(3,i-1)= gliptranc(3,i-1)
9655      &+ssgradlip*liptranene(itype(i))
9656 C          print *, "doing sscalefor top part",sslip,fracinbuf
9657         else
9658          eliptran=eliptran+liptranene(itype(i))
9659 C         print *,"I am in true lipid"
9660         endif
9661         endif ! if in lipid or buffor
9662 C       else
9663 C       eliptran=elpitran+0.0 ! I am in water
9664        enddo
9665        return
9666        end
9667 C-------------------------------------------------------------------------------------