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 cAna           if (i.le.1) cycle
2201            if (itype(i).eq.ntyp1.or. itype(i+1).eq.ntyp1
2202 cAna     &  .or. ((i+2).gt.nres)
2203 cAna     &  .or. ((i-1).le.0)
2204 cAna     &  .or. itype(i+2).eq.ntyp1
2205 cAna     &  .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 cAna          if (j.le.1) cycle
2228           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1
2229 cAna     & .or.((j+2).gt.nres)
2230 cAna     & .or.((j-1).le.0)
2231 cAna     & .or.itype(j+2).eq.ntyp1
2232 cAna     & .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 C        if (itype(i-1).eq.ntyp1) cycle
4675 c        if (i.le.2) cycle
4676         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4677      &  .or.itype(i).eq.ntyp1) cycle
4678 C Zero the energy function and its derivative at 0 or pi.
4679         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4680         it=itype(i-1)
4681         ichir1=isign(1,itype(i-2))
4682         ichir2=isign(1,itype(i))
4683          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4684          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4685          if (itype(i-1).eq.10) then
4686           itype1=isign(10,itype(i-2))
4687           ichir11=isign(1,itype(i-2))
4688           ichir12=isign(1,itype(i-2))
4689           itype2=isign(10,itype(i))
4690           ichir21=isign(1,itype(i))
4691           ichir22=isign(1,itype(i))
4692          endif
4693          if (i.eq.3) then
4694           y(1)=0.0D0
4695           y(2)=0.0D0
4696           else
4697
4698         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4699 #ifdef OSF
4700           phii=phi(i)
4701 c          icrc=0
4702 c          call proc_proc(phii,icrc)
4703           if (icrc.eq.1) phii=150.0
4704 #else
4705           phii=phi(i)
4706 #endif
4707           y(1)=dcos(phii)
4708           y(2)=dsin(phii)
4709         else
4710           y(1)=0.0D0
4711           y(2)=0.0D0
4712         endif
4713         endif
4714         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4715 #ifdef OSF
4716           phii1=phi(i+1)
4717 c          icrc=0
4718 c          call proc_proc(phii1,icrc)
4719           if (icrc.eq.1) phii1=150.0
4720           phii1=pinorm(phii1)
4721           z(1)=cos(phii1)
4722 #else
4723           phii1=phi(i+1)
4724           z(1)=dcos(phii1)
4725 #endif
4726           z(2)=dsin(phii1)
4727         else
4728           z(1)=0.0D0
4729           z(2)=0.0D0
4730         endif
4731 C Calculate the "mean" value of theta from the part of the distribution
4732 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4733 C In following comments this theta will be referred to as t_c.
4734         thet_pred_mean=0.0d0
4735         do k=1,2
4736             athetk=athet(k,it,ichir1,ichir2)
4737             bthetk=bthet(k,it,ichir1,ichir2)
4738           if (it.eq.10) then
4739              athetk=athet(k,itype1,ichir11,ichir12)
4740              bthetk=bthet(k,itype2,ichir21,ichir22)
4741           endif
4742           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4743         enddo
4744 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4745         dthett=thet_pred_mean*ssd
4746         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4747 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4748 C Derivatives of the "mean" values in gamma1 and gamma2.
4749         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4750      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4751          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4752      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4753          if (it.eq.10) then
4754       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4755      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4756         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4757      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4758          endif
4759         if (theta(i).gt.pi-delta) then
4760           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4761      &         E_tc0)
4762           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4763           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4764           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4765      &        E_theta)
4766           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4767      &        E_tc)
4768         else if (theta(i).lt.delta) then
4769           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4770           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4771           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4772      &        E_theta)
4773           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4774           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4775      &        E_tc)
4776         else
4777           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4778      &        E_theta,E_tc)
4779         endif
4780         etheta=etheta+ethetai
4781 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4782 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4783         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4784         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4785         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4786 c 1215   continue
4787       enddo
4788 C Ufff.... We've done all this!!!
4789 C now constrains
4790       ethetacnstr=0.0d0
4791 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4792       do i=1,ntheta_constr
4793         itheta=itheta_constr(i)
4794         thetiii=theta(itheta)
4795         difi=pinorm(thetiii-theta_constr0(i))
4796         if (difi.gt.theta_drange(i)) then
4797           difi=difi-theta_drange(i)
4798           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4799           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4800      &    +for_thet_constr(i)*difi**3
4801         else if (difi.lt.-drange(i)) then
4802           difi=difi+drange(i)
4803           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4804           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4805      &    +for_thet_constr(i)*difi**3
4806         else
4807           difi=0.0
4808         endif
4809 C       if (energy_dec) then
4810 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4811 C     &    i,itheta,rad2deg*thetiii,
4812 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4813 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4814 C     &    gloc(itheta+nphi-2,icg)
4815 C        endif
4816       enddo
4817       return
4818       end
4819 C---------------------------------------------------------------------------
4820       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4821      &     E_tc)
4822       implicit real*8 (a-h,o-z)
4823       include 'DIMENSIONS'
4824       include 'COMMON.LOCAL'
4825       include 'COMMON.IOUNITS'
4826       common /calcthet/ term1,term2,termm,diffak,ratak,
4827      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4828      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4829 C Calculate the contributions to both Gaussian lobes.
4830 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4831 C The "polynomial part" of the "standard deviation" of this part of
4832 C the distribution.
4833         sig=polthet(3,it)
4834         do j=2,0,-1
4835           sig=sig*thet_pred_mean+polthet(j,it)
4836         enddo
4837 C Derivative of the "interior part" of the "standard deviation of the"
4838 C gamma-dependent Gaussian lobe in t_c.
4839         sigtc=3*polthet(3,it)
4840         do j=2,1,-1
4841           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4842         enddo
4843         sigtc=sig*sigtc
4844 C Set the parameters of both Gaussian lobes of the distribution.
4845 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4846         fac=sig*sig+sigc0(it)
4847         sigcsq=fac+fac
4848         sigc=1.0D0/sigcsq
4849 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4850         sigsqtc=-4.0D0*sigcsq*sigtc
4851 c       print *,i,sig,sigtc,sigsqtc
4852 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4853         sigtc=-sigtc/(fac*fac)
4854 C Following variable is sigma(t_c)**(-2)
4855         sigcsq=sigcsq*sigcsq
4856         sig0i=sig0(it)
4857         sig0inv=1.0D0/sig0i**2
4858         delthec=thetai-thet_pred_mean
4859         delthe0=thetai-theta0i
4860         term1=-0.5D0*sigcsq*delthec*delthec
4861         term2=-0.5D0*sig0inv*delthe0*delthe0
4862 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4863 C NaNs in taking the logarithm. We extract the largest exponent which is added
4864 C to the energy (this being the log of the distribution) at the end of energy
4865 C term evaluation for this virtual-bond angle.
4866         if (term1.gt.term2) then
4867           termm=term1
4868           term2=dexp(term2-termm)
4869           term1=1.0d0
4870         else
4871           termm=term2
4872           term1=dexp(term1-termm)
4873           term2=1.0d0
4874         endif
4875 C The ratio between the gamma-independent and gamma-dependent lobes of
4876 C the distribution is a Gaussian function of thet_pred_mean too.
4877         diffak=gthet(2,it)-thet_pred_mean
4878         ratak=diffak/gthet(3,it)**2
4879         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4880 C Let's differentiate it in thet_pred_mean NOW.
4881         aktc=ak*ratak
4882 C Now put together the distribution terms to make complete distribution.
4883         termexp=term1+ak*term2
4884         termpre=sigc+ak*sig0i
4885 C Contribution of the bending energy from this theta is just the -log of
4886 C the sum of the contributions from the two lobes and the pre-exponential
4887 C factor. Simple enough, isn't it?
4888         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4889 C NOW the derivatives!!!
4890 C 6/6/97 Take into account the deformation.
4891         E_theta=(delthec*sigcsq*term1
4892      &       +ak*delthe0*sig0inv*term2)/termexp
4893         E_tc=((sigtc+aktc*sig0i)/termpre
4894      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4895      &       aktc*term2)/termexp)
4896       return
4897       end
4898 c-----------------------------------------------------------------------------
4899       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4900       implicit real*8 (a-h,o-z)
4901       include 'DIMENSIONS'
4902       include 'COMMON.LOCAL'
4903       include 'COMMON.IOUNITS'
4904       common /calcthet/ term1,term2,termm,diffak,ratak,
4905      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4906      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4907       delthec=thetai-thet_pred_mean
4908       delthe0=thetai-theta0i
4909 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4910       t3 = thetai-thet_pred_mean
4911       t6 = t3**2
4912       t9 = term1
4913       t12 = t3*sigcsq
4914       t14 = t12+t6*sigsqtc
4915       t16 = 1.0d0
4916       t21 = thetai-theta0i
4917       t23 = t21**2
4918       t26 = term2
4919       t27 = t21*t26
4920       t32 = termexp
4921       t40 = t32**2
4922       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4923      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4924      & *(-t12*t9-ak*sig0inv*t27)
4925       return
4926       end
4927 #else
4928 C--------------------------------------------------------------------------
4929       subroutine ebend(etheta,ethetacnstr)
4930 C
4931 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4932 C angles gamma and its derivatives in consecutive thetas and gammas.
4933 C ab initio-derived potentials from
4934 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4935 C
4936       implicit real*8 (a-h,o-z)
4937       include 'DIMENSIONS'
4938       include 'sizesclu.dat'
4939       include 'COMMON.LOCAL'
4940       include 'COMMON.GEO'
4941       include 'COMMON.INTERACT'
4942       include 'COMMON.DERIV'
4943       include 'COMMON.VAR'
4944       include 'COMMON.CHAIN'
4945       include 'COMMON.IOUNITS'
4946       include 'COMMON.NAMES'
4947       include 'COMMON.FFIELD'
4948       include 'COMMON.CONTROL'
4949       include 'COMMON.TORCNSTR'
4950       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4951      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4952      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4953      & sinph1ph2(maxdouble,maxdouble)
4954       logical lprn /.false./, lprn1 /.false./
4955       etheta=0.0D0
4956 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4957       do i=ithet_start,ithet_end
4958 c        if (i.eq.2) cycle
4959 c        print *,i,itype(i-1),itype(i),itype(i-2)
4960         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1)
4961      &  .or.(itype(i).eq.ntyp1)) cycle
4962 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
4963
4964         if (iabs(itype(i+1)).eq.20) iblock=2
4965         if (iabs(itype(i+1)).ne.20) iblock=1
4966         dethetai=0.0d0
4967         dephii=0.0d0
4968         dephii1=0.0d0
4969         theti2=0.5d0*theta(i)
4970         ityp2=ithetyp((itype(i-1)))
4971         do k=1,nntheterm
4972           coskt(k)=dcos(k*theti2)
4973           sinkt(k)=dsin(k*theti2)
4974         enddo
4975         if (i.gt.3 .and. itype(max0(i-3,1)).ne.ntyp1) then
4976 #ifdef OSF
4977           phii=phi(i)
4978           if (phii.ne.phii) phii=150.0
4979 #else
4980           phii=phi(i)
4981 #endif
4982           ityp1=ithetyp((itype(i-2)))
4983           do k=1,nsingle
4984             cosph1(k)=dcos(k*phii)
4985             sinph1(k)=dsin(k*phii)
4986           enddo
4987         else
4988           phii=0.0d0
4989           ityp1=ithetyp(itype(i-2))
4990           do k=1,nsingle
4991             cosph1(k)=0.0d0
4992             sinph1(k)=0.0d0
4993           enddo
4994         endif
4995         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4996 #ifdef OSF
4997           phii1=phi(i+1)
4998           if (phii1.ne.phii1) phii1=150.0
4999           phii1=pinorm(phii1)
5000 #else
5001           phii1=phi(i+1)
5002 #endif
5003           ityp3=ithetyp((itype(i)))
5004           do k=1,nsingle
5005             cosph2(k)=dcos(k*phii1)
5006             sinph2(k)=dsin(k*phii1)
5007           enddo
5008         else
5009           phii1=0.0d0
5010           ityp3=ithetyp(itype(i))
5011           do k=1,nsingle
5012             cosph2(k)=0.0d0
5013             sinph2(k)=0.0d0
5014           enddo
5015         endif
5016 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
5017 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
5018 c        call flush(iout)
5019         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
5020         do k=1,ndouble
5021           do l=1,k-1
5022             ccl=cosph1(l)*cosph2(k-l)
5023             ssl=sinph1(l)*sinph2(k-l)
5024             scl=sinph1(l)*cosph2(k-l)
5025             csl=cosph1(l)*sinph2(k-l)
5026             cosph1ph2(l,k)=ccl-ssl
5027             cosph1ph2(k,l)=ccl+ssl
5028             sinph1ph2(l,k)=scl+csl
5029             sinph1ph2(k,l)=scl-csl
5030           enddo
5031         enddo
5032         if (lprn) then
5033         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
5034      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
5035         write (iout,*) "coskt and sinkt"
5036         do k=1,nntheterm
5037           write (iout,*) k,coskt(k),sinkt(k)
5038         enddo
5039         endif
5040         do k=1,ntheterm
5041           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
5042           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
5043      &      *coskt(k)
5044           if (lprn)
5045      &    write (iout,*) "k",k," aathet",
5046      &    aathet(k,ityp1,ityp2,ityp3,iblock),
5047      &     " ethetai",ethetai
5048         enddo
5049         if (lprn) then
5050         write (iout,*) "cosph and sinph"
5051         do k=1,nsingle
5052           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
5053         enddo
5054         write (iout,*) "cosph1ph2 and sinph2ph2"
5055         do k=2,ndouble
5056           do l=1,k-1
5057             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
5058      &         sinph1ph2(l,k),sinph1ph2(k,l)
5059           enddo
5060         enddo
5061         write(iout,*) "ethetai",ethetai
5062         endif
5063         do m=1,ntheterm2
5064           do k=1,nsingle
5065             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
5066      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
5067      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
5068      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
5069             ethetai=ethetai+sinkt(m)*aux
5070             dethetai=dethetai+0.5d0*m*aux*coskt(m)
5071             dephii=dephii+k*sinkt(m)*(
5072      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
5073      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
5074             dephii1=dephii1+k*sinkt(m)*(
5075      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
5076      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
5077             if (lprn)
5078      &      write (iout,*) "m",m," k",k," bbthet",
5079      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
5080      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
5081      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
5082      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
5083           enddo
5084         enddo
5085         if (lprn)
5086      &  write(iout,*) "ethetai",ethetai
5087         do m=1,ntheterm3
5088           do k=2,ndouble
5089             do l=1,k-1
5090               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5091      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
5092      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5093      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
5094               ethetai=ethetai+sinkt(m)*aux
5095               dethetai=dethetai+0.5d0*m*coskt(m)*aux
5096               dephii=dephii+l*sinkt(m)*(
5097      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
5098      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5099      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
5100      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5101               dephii1=dephii1+(k-l)*sinkt(m)*(
5102      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
5103      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
5104      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
5105      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
5106               if (lprn) then
5107               write (iout,*) "m",m," k",k," l",l," ffthet",
5108      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5109      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
5110      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
5111      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
5112      &            " ethetai",ethetai
5113               write (iout,*) cosph1ph2(l,k)*sinkt(m),
5114      &            cosph1ph2(k,l)*sinkt(m),
5115      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
5116               endif
5117             enddo
5118           enddo
5119         enddo
5120 10      continue
5121         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
5122      &   i,theta(i)*rad2deg,phii*rad2deg,
5123      &   phii1*rad2deg,ethetai
5124         etheta=etheta+ethetai
5125         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
5126         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
5127 c        gloc(nphi+i-2,icg)=wang*dethetai
5128         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
5129       enddo
5130 C now constrains
5131       ethetacnstr=0.0d0
5132 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
5133       do i=1,ntheta_constr
5134         itheta=itheta_constr(i)
5135         thetiii=theta(itheta)
5136         difi=pinorm(thetiii-theta_constr0(i))
5137         if (difi.gt.theta_drange(i)) then
5138           difi=difi-theta_drange(i)
5139           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5140           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5141      &    +for_thet_constr(i)*difi**3
5142         else if (difi.lt.-drange(i)) then
5143           difi=difi+drange(i)
5144           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
5145           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
5146      &    +for_thet_constr(i)*difi**3
5147         else
5148           difi=0.0
5149         endif
5150 C       if (energy_dec) then
5151 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
5152 C     &    i,itheta,rad2deg*thetiii,
5153 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
5154 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
5155 C     &    gloc(itheta+nphi-2,icg)
5156 C        endif
5157       enddo
5158       return
5159       end
5160 #endif
5161 #ifdef CRYST_SC
5162 c-----------------------------------------------------------------------------
5163       subroutine esc(escloc)
5164 C Calculate the local energy of a side chain and its derivatives in the
5165 C corresponding virtual-bond valence angles THETA and the spherical angles
5166 C ALPHA and OMEGA.
5167       implicit real*8 (a-h,o-z)
5168       include 'DIMENSIONS'
5169       include 'sizesclu.dat'
5170       include 'COMMON.GEO'
5171       include 'COMMON.LOCAL'
5172       include 'COMMON.VAR'
5173       include 'COMMON.INTERACT'
5174       include 'COMMON.DERIV'
5175       include 'COMMON.CHAIN'
5176       include 'COMMON.IOUNITS'
5177       include 'COMMON.NAMES'
5178       include 'COMMON.FFIELD'
5179       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
5180      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
5181       common /sccalc/ time11,time12,time112,theti,it,nlobit
5182       delta=0.02d0*pi
5183       escloc=0.0D0
5184 c     write (iout,'(a)') 'ESC'
5185       do i=loc_start,loc_end
5186         it=itype(i)
5187         if (it.eq.ntyp1) cycle
5188         if (it.eq.10) goto 1
5189         nlobit=nlob(iabs(it))
5190 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5191 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5192         theti=theta(i+1)-pipol
5193         x(1)=dtan(theti)
5194         x(2)=alph(i)
5195         x(3)=omeg(i)
5196 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5197
5198         if (x(2).gt.pi-delta) then
5199           xtemp(1)=x(1)
5200           xtemp(2)=pi-delta
5201           xtemp(3)=x(3)
5202           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5203           xtemp(2)=pi
5204           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5205           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5206      &        escloci,dersc(2))
5207           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5208      &        ddersc0(1),dersc(1))
5209           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5210      &        ddersc0(3),dersc(3))
5211           xtemp(2)=pi-delta
5212           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5213           xtemp(2)=pi
5214           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5215           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5216      &            dersc0(2),esclocbi,dersc02)
5217           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5218      &            dersc12,dersc01)
5219           call splinthet(x(2),0.5d0*delta,ss,ssd)
5220           dersc0(1)=dersc01
5221           dersc0(2)=dersc02
5222           dersc0(3)=0.0d0
5223           do k=1,3
5224             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5225           enddo
5226           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5227 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5228 c    &             esclocbi,ss,ssd
5229           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5230 c         escloci=esclocbi
5231 c         write (iout,*) escloci
5232         else if (x(2).lt.delta) then
5233           xtemp(1)=x(1)
5234           xtemp(2)=delta
5235           xtemp(3)=x(3)
5236           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5237           xtemp(2)=0.0d0
5238           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5239           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5240      &        escloci,dersc(2))
5241           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5242      &        ddersc0(1),dersc(1))
5243           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5244      &        ddersc0(3),dersc(3))
5245           xtemp(2)=delta
5246           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5247           xtemp(2)=0.0d0
5248           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5249           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5250      &            dersc0(2),esclocbi,dersc02)
5251           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5252      &            dersc12,dersc01)
5253           dersc0(1)=dersc01
5254           dersc0(2)=dersc02
5255           dersc0(3)=0.0d0
5256           call splinthet(x(2),0.5d0*delta,ss,ssd)
5257           do k=1,3
5258             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5259           enddo
5260           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5261 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5262 c    &             esclocbi,ss,ssd
5263           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5264 c         write (iout,*) escloci
5265         else
5266           call enesc(x,escloci,dersc,ddummy,.false.)
5267         endif
5268
5269         escloc=escloc+escloci
5270 c        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5271
5272         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5273      &   wscloc*dersc(1)
5274         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5275         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5276     1   continue
5277       enddo
5278       return
5279       end
5280 C---------------------------------------------------------------------------
5281       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5282       implicit real*8 (a-h,o-z)
5283       include 'DIMENSIONS'
5284       include 'COMMON.GEO'
5285       include 'COMMON.LOCAL'
5286       include 'COMMON.IOUNITS'
5287       common /sccalc/ time11,time12,time112,theti,it,nlobit
5288       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5289       double precision contr(maxlob,-1:1)
5290       logical mixed
5291 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5292         escloc_i=0.0D0
5293         do j=1,3
5294           dersc(j)=0.0D0
5295           if (mixed) ddersc(j)=0.0d0
5296         enddo
5297         x3=x(3)
5298
5299 C Because of periodicity of the dependence of the SC energy in omega we have
5300 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5301 C To avoid underflows, first compute & store the exponents.
5302
5303         do iii=-1,1
5304
5305           x(3)=x3+iii*dwapi
5306
5307           do j=1,nlobit
5308             do k=1,3
5309               z(k)=x(k)-censc(k,j,it)
5310             enddo
5311             do k=1,3
5312               Axk=0.0D0
5313               do l=1,3
5314                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5315               enddo
5316               Ax(k,j,iii)=Axk
5317             enddo
5318             expfac=0.0D0
5319             do k=1,3
5320               expfac=expfac+Ax(k,j,iii)*z(k)
5321             enddo
5322             contr(j,iii)=expfac
5323           enddo ! j
5324
5325         enddo ! iii
5326
5327         x(3)=x3
5328 C As in the case of ebend, we want to avoid underflows in exponentiation and
5329 C subsequent NaNs and INFs in energy calculation.
5330 C Find the largest exponent
5331         emin=contr(1,-1)
5332         do iii=-1,1
5333           do j=1,nlobit
5334             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5335           enddo
5336         enddo
5337         emin=0.5D0*emin
5338 cd      print *,'it=',it,' emin=',emin
5339
5340 C Compute the contribution to SC energy and derivatives
5341         do iii=-1,1
5342
5343           do j=1,nlobit
5344             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5345 cd          print *,'j=',j,' expfac=',expfac
5346             escloc_i=escloc_i+expfac
5347             do k=1,3
5348               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5349             enddo
5350             if (mixed) then
5351               do k=1,3,2
5352                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5353      &            +gaussc(k,2,j,it))*expfac
5354               enddo
5355             endif
5356           enddo
5357
5358         enddo ! iii
5359
5360         dersc(1)=dersc(1)/cos(theti)**2
5361         ddersc(1)=ddersc(1)/cos(theti)**2
5362         ddersc(3)=ddersc(3)
5363
5364         escloci=-(dlog(escloc_i)-emin)
5365         do j=1,3
5366           dersc(j)=dersc(j)/escloc_i
5367         enddo
5368         if (mixed) then
5369           do j=1,3,2
5370             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5371           enddo
5372         endif
5373       return
5374       end
5375 C------------------------------------------------------------------------------
5376       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5377       implicit real*8 (a-h,o-z)
5378       include 'DIMENSIONS'
5379       include 'COMMON.GEO'
5380       include 'COMMON.LOCAL'
5381       include 'COMMON.IOUNITS'
5382       common /sccalc/ time11,time12,time112,theti,it,nlobit
5383       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5384       double precision contr(maxlob)
5385       logical mixed
5386
5387       escloc_i=0.0D0
5388
5389       do j=1,3
5390         dersc(j)=0.0D0
5391       enddo
5392
5393       do j=1,nlobit
5394         do k=1,2
5395           z(k)=x(k)-censc(k,j,it)
5396         enddo
5397         z(3)=dwapi
5398         do k=1,3
5399           Axk=0.0D0
5400           do l=1,3
5401             Axk=Axk+gaussc(l,k,j,it)*z(l)
5402           enddo
5403           Ax(k,j)=Axk
5404         enddo
5405         expfac=0.0D0
5406         do k=1,3
5407           expfac=expfac+Ax(k,j)*z(k)
5408         enddo
5409         contr(j)=expfac
5410       enddo ! j
5411
5412 C As in the case of ebend, we want to avoid underflows in exponentiation and
5413 C subsequent NaNs and INFs in energy calculation.
5414 C Find the largest exponent
5415       emin=contr(1)
5416       do j=1,nlobit
5417         if (emin.gt.contr(j)) emin=contr(j)
5418       enddo
5419       emin=0.5D0*emin
5420
5421 C Compute the contribution to SC energy and derivatives
5422
5423       dersc12=0.0d0
5424       do j=1,nlobit
5425         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5426         escloc_i=escloc_i+expfac
5427         do k=1,2
5428           dersc(k)=dersc(k)+Ax(k,j)*expfac
5429         enddo
5430         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5431      &            +gaussc(1,2,j,it))*expfac
5432         dersc(3)=0.0d0
5433       enddo
5434
5435       dersc(1)=dersc(1)/cos(theti)**2
5436       dersc12=dersc12/cos(theti)**2
5437       escloci=-(dlog(escloc_i)-emin)
5438       do j=1,2
5439         dersc(j)=dersc(j)/escloc_i
5440       enddo
5441       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5442       return
5443       end
5444 #else
5445 c----------------------------------------------------------------------------------
5446       subroutine esc(escloc)
5447 C Calculate the local energy of a side chain and its derivatives in the
5448 C corresponding virtual-bond valence angles THETA and the spherical angles
5449 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5450 C added by Urszula Kozlowska. 07/11/2007
5451 C
5452       implicit real*8 (a-h,o-z)
5453       include 'DIMENSIONS'
5454       include 'sizesclu.dat'
5455       include 'COMMON.GEO'
5456       include 'COMMON.LOCAL'
5457       include 'COMMON.VAR'
5458       include 'COMMON.SCROT'
5459       include 'COMMON.INTERACT'
5460       include 'COMMON.DERIV'
5461       include 'COMMON.CHAIN'
5462       include 'COMMON.IOUNITS'
5463       include 'COMMON.NAMES'
5464       include 'COMMON.FFIELD'
5465       include 'COMMON.CONTROL'
5466       include 'COMMON.VECTORS'
5467       double precision x_prime(3),y_prime(3),z_prime(3)
5468      &    , sumene,dsc_i,dp2_i,x(65),
5469      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5470      &    de_dxx,de_dyy,de_dzz,de_dt
5471       double precision s1_t,s1_6_t,s2_t,s2_6_t
5472       double precision
5473      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5474      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5475      & dt_dCi(3),dt_dCi1(3)
5476       common /sccalc/ time11,time12,time112,theti,it,nlobit
5477       delta=0.02d0*pi
5478       escloc=0.0D0
5479       do i=loc_start,loc_end
5480         if (itype(i).eq.ntyp1) cycle
5481         costtab(i+1) =dcos(theta(i+1))
5482         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5483         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5484         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5485         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5486         cosfac=dsqrt(cosfac2)
5487         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5488         sinfac=dsqrt(sinfac2)
5489         it=iabs(itype(i))
5490         if (it.eq.10) goto 1
5491 c
5492 C  Compute the axes of tghe local cartesian coordinates system; store in
5493 c   x_prime, y_prime and z_prime
5494 c
5495         do j=1,3
5496           x_prime(j) = 0.00
5497           y_prime(j) = 0.00
5498           z_prime(j) = 0.00
5499         enddo
5500 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5501 C     &   dc_norm(3,i+nres)
5502         do j = 1,3
5503           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5504           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5505         enddo
5506         do j = 1,3
5507           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5508         enddo
5509 c       write (2,*) "i",i
5510 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5511 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5512 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5513 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5514 c      & " xy",scalar(x_prime(1),y_prime(1)),
5515 c      & " xz",scalar(x_prime(1),z_prime(1)),
5516 c      & " yy",scalar(y_prime(1),y_prime(1)),
5517 c      & " yz",scalar(y_prime(1),z_prime(1)),
5518 c      & " zz",scalar(z_prime(1),z_prime(1))
5519 c
5520 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5521 C to local coordinate system. Store in xx, yy, zz.
5522 c
5523         xx=0.0d0
5524         yy=0.0d0
5525         zz=0.0d0
5526         do j = 1,3
5527           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5528           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5529           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5530         enddo
5531
5532         xxtab(i)=xx
5533         yytab(i)=yy
5534         zztab(i)=zz
5535 C
5536 C Compute the energy of the ith side cbain
5537 C
5538 c        write (2,*) "xx",xx," yy",yy," zz",zz
5539         it=iabs(itype(i))
5540         do j = 1,65
5541           x(j) = sc_parmin(j,it)
5542         enddo
5543 #ifdef CHECK_COORD
5544 Cc diagnostics - remove later
5545         xx1 = dcos(alph(2))
5546         yy1 = dsin(alph(2))*dcos(omeg(2))
5547 c        zz1 = -dsin(alph(2))*dsin(omeg(2))
5548         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5549         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5550      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5551      &    xx1,yy1,zz1
5552 C,"  --- ", xx_w,yy_w,zz_w
5553 c end diagnostics
5554 #endif
5555         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5556      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5557      &   + x(10)*yy*zz
5558         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5559      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5560      & + x(20)*yy*zz
5561         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5562      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5563      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5564      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5565      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5566      &  +x(40)*xx*yy*zz
5567         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5568      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5569      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5570      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5571      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5572      &  +x(60)*xx*yy*zz
5573         dsc_i   = 0.743d0+x(61)
5574         dp2_i   = 1.9d0+x(62)
5575         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5576      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5577         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5578      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5579         s1=(1+x(63))/(0.1d0 + dscp1)
5580         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5581         s2=(1+x(65))/(0.1d0 + dscp2)
5582         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5583         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5584      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5585 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5586 c     &   sumene4,
5587 c     &   dscp1,dscp2,sumene
5588 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5589         escloc = escloc + sumene
5590 c        write (2,*) "escloc",escloc
5591         if (.not. calc_grad) goto 1
5592 #ifdef DEBUG
5593 C
5594 C This section to check the numerical derivatives of the energy of ith side
5595 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5596 C #define DEBUG in the code to turn it on.
5597 C
5598         write (2,*) "sumene               =",sumene
5599         aincr=1.0d-7
5600         xxsave=xx
5601         xx=xx+aincr
5602         write (2,*) xx,yy,zz
5603         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5604         de_dxx_num=(sumenep-sumene)/aincr
5605         xx=xxsave
5606         write (2,*) "xx+ sumene from enesc=",sumenep
5607         yysave=yy
5608         yy=yy+aincr
5609         write (2,*) xx,yy,zz
5610         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5611         de_dyy_num=(sumenep-sumene)/aincr
5612         yy=yysave
5613         write (2,*) "yy+ sumene from enesc=",sumenep
5614         zzsave=zz
5615         zz=zz+aincr
5616         write (2,*) xx,yy,zz
5617         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5618         de_dzz_num=(sumenep-sumene)/aincr
5619         zz=zzsave
5620         write (2,*) "zz+ sumene from enesc=",sumenep
5621         costsave=cost2tab(i+1)
5622         sintsave=sint2tab(i+1)
5623         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5624         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5625         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5626         de_dt_num=(sumenep-sumene)/aincr
5627         write (2,*) " t+ sumene from enesc=",sumenep
5628         cost2tab(i+1)=costsave
5629         sint2tab(i+1)=sintsave
5630 C End of diagnostics section.
5631 #endif
5632 C
5633 C Compute the gradient of esc
5634 C
5635         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5636         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5637         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5638         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5639         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5640         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5641         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5642         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5643         pom1=(sumene3*sint2tab(i+1)+sumene1)
5644      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5645         pom2=(sumene4*cost2tab(i+1)+sumene2)
5646      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5647         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5648         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5649      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5650      &  +x(40)*yy*zz
5651         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5652         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5653      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5654      &  +x(60)*yy*zz
5655         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5656      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5657      &        +(pom1+pom2)*pom_dx
5658 #ifdef DEBUG
5659         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5660 #endif
5661 C
5662         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5663         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5664      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5665      &  +x(40)*xx*zz
5666         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5667         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5668      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5669      &  +x(59)*zz**2 +x(60)*xx*zz
5670         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5671      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5672      &        +(pom1-pom2)*pom_dy
5673 #ifdef DEBUG
5674         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5675 #endif
5676 C
5677         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5678      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5679      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5680      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5681      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5682      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5683      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5684      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5685 #ifdef DEBUG
5686         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5687 #endif
5688 C
5689         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5690      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5691      &  +pom1*pom_dt1+pom2*pom_dt2
5692 #ifdef DEBUG
5693         write(2,*), "de_dt = ", de_dt,de_dt_num
5694 #endif
5695 c
5696 C
5697        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5698        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5699        cosfac2xx=cosfac2*xx
5700        sinfac2yy=sinfac2*yy
5701        do k = 1,3
5702          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5703      &      vbld_inv(i+1)
5704          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5705      &      vbld_inv(i)
5706          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5707          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5708 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5709 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5710 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5711 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5712          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5713          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5714          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5715          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5716          dZZ_Ci1(k)=0.0d0
5717          dZZ_Ci(k)=0.0d0
5718          do j=1,3
5719            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5720      &      *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5721            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5722      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5723          enddo
5724
5725          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5726          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5727          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5728 c
5729          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5730          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5731        enddo
5732
5733        do k=1,3
5734          dXX_Ctab(k,i)=dXX_Ci(k)
5735          dXX_C1tab(k,i)=dXX_Ci1(k)
5736          dYY_Ctab(k,i)=dYY_Ci(k)
5737          dYY_C1tab(k,i)=dYY_Ci1(k)
5738          dZZ_Ctab(k,i)=dZZ_Ci(k)
5739          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5740          dXX_XYZtab(k,i)=dXX_XYZ(k)
5741          dYY_XYZtab(k,i)=dYY_XYZ(k)
5742          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5743        enddo
5744
5745        do k = 1,3
5746 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5747 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5748 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5749 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5750 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5751 c     &    dt_dci(k)
5752 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5753 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5754          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5755      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5756          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5757      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5758          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5759      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5760        enddo
5761 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5762 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5763
5764 C to check gradient call subroutine check_grad
5765
5766     1 continue
5767       enddo
5768       return
5769       end
5770 #endif
5771 c------------------------------------------------------------------------------
5772       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5773 C
5774 C This procedure calculates two-body contact function g(rij) and its derivative:
5775 C
5776 C           eps0ij                                     !       x < -1
5777 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5778 C            0                                         !       x > 1
5779 C
5780 C where x=(rij-r0ij)/delta
5781 C
5782 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5783 C
5784       implicit none
5785       double precision rij,r0ij,eps0ij,fcont,fprimcont
5786       double precision x,x2,x4,delta
5787 c     delta=0.02D0*r0ij
5788 c      delta=0.2D0*r0ij
5789       x=(rij-r0ij)/delta
5790       if (x.lt.-1.0D0) then
5791         fcont=eps0ij
5792         fprimcont=0.0D0
5793       else if (x.le.1.0D0) then
5794         x2=x*x
5795         x4=x2*x2
5796         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5797         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5798       else
5799         fcont=0.0D0
5800         fprimcont=0.0D0
5801       endif
5802       return
5803       end
5804 c------------------------------------------------------------------------------
5805       subroutine splinthet(theti,delta,ss,ssder)
5806       implicit real*8 (a-h,o-z)
5807       include 'DIMENSIONS'
5808       include 'sizesclu.dat'
5809       include 'COMMON.VAR'
5810       include 'COMMON.GEO'
5811       thetup=pi-delta
5812       thetlow=delta
5813       if (theti.gt.pipol) then
5814         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5815       else
5816         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5817         ssder=-ssder
5818       endif
5819       return
5820       end
5821 c------------------------------------------------------------------------------
5822       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5823       implicit none
5824       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5825       double precision ksi,ksi2,ksi3,a1,a2,a3
5826       a1=fprim0*delta/(f1-f0)
5827       a2=3.0d0-2.0d0*a1
5828       a3=a1-2.0d0
5829       ksi=(x-x0)/delta
5830       ksi2=ksi*ksi
5831       ksi3=ksi2*ksi
5832       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5833       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5834       return
5835       end
5836 c------------------------------------------------------------------------------
5837       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5838       implicit none
5839       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5840       double precision ksi,ksi2,ksi3,a1,a2,a3
5841       ksi=(x-x0)/delta
5842       ksi2=ksi*ksi
5843       ksi3=ksi2*ksi
5844       a1=fprim0x*delta
5845       a2=3*(f1x-f0x)-2*fprim0x*delta
5846       a3=fprim0x*delta-2*(f1x-f0x)
5847       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5848       return
5849       end
5850 C-----------------------------------------------------------------------------
5851 #ifdef CRYST_TOR
5852 C-----------------------------------------------------------------------------
5853       subroutine etor(etors,edihcnstr,fact)
5854       implicit real*8 (a-h,o-z)
5855       include 'DIMENSIONS'
5856       include 'sizesclu.dat'
5857       include 'COMMON.VAR'
5858       include 'COMMON.GEO'
5859       include 'COMMON.LOCAL'
5860       include 'COMMON.TORSION'
5861       include 'COMMON.INTERACT'
5862       include 'COMMON.DERIV'
5863       include 'COMMON.CHAIN'
5864       include 'COMMON.NAMES'
5865       include 'COMMON.IOUNITS'
5866       include 'COMMON.FFIELD'
5867       include 'COMMON.TORCNSTR'
5868       logical lprn
5869 C Set lprn=.true. for debugging
5870       lprn=.false.
5871 c      lprn=.true.
5872       etors=0.0D0
5873       do i=iphi_start,iphi_end
5874         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5875      &      .or. itype(i).eq.ntyp1) cycle
5876         itori=itortyp(itype(i-2))
5877         itori1=itortyp(itype(i-1))
5878         phii=phi(i)
5879         gloci=0.0D0
5880 C Proline-Proline pair is a special case...
5881         if (itori.eq.3 .and. itori1.eq.3) then
5882           if (phii.gt.-dwapi3) then
5883             cosphi=dcos(3*phii)
5884             fac=1.0D0/(1.0D0-cosphi)
5885             etorsi=v1(1,3,3)*fac
5886             etorsi=etorsi+etorsi
5887             etors=etors+etorsi-v1(1,3,3)
5888             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5889           endif
5890           do j=1,3
5891             v1ij=v1(j+1,itori,itori1)
5892             v2ij=v2(j+1,itori,itori1)
5893             cosphi=dcos(j*phii)
5894             sinphi=dsin(j*phii)
5895             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5896             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5897           enddo
5898         else
5899           do j=1,nterm_old
5900             v1ij=v1(j,itori,itori1)
5901             v2ij=v2(j,itori,itori1)
5902             cosphi=dcos(j*phii)
5903             sinphi=dsin(j*phii)
5904             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5905             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5906           enddo
5907         endif
5908         if (lprn)
5909      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5910      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5911      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5912         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5913 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5914       enddo
5915 ! 6/20/98 - dihedral angle constraints
5916       edihcnstr=0.0d0
5917       do i=1,ndih_constr
5918         itori=idih_constr(i)
5919         phii=phi(itori)
5920         difi=phii-phi0(i)
5921         if (difi.gt.drange(i)) then
5922           difi=difi-drange(i)
5923           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5924           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5925         else if (difi.lt.-drange(i)) then
5926           difi=difi+drange(i)
5927           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5928           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5929         endif
5930 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5931 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5932       enddo
5933 !      write (iout,*) 'edihcnstr',edihcnstr
5934       return
5935       end
5936 c------------------------------------------------------------------------------
5937 #else
5938       subroutine etor(etors,edihcnstr,fact)
5939       implicit real*8 (a-h,o-z)
5940       include 'DIMENSIONS'
5941       include 'sizesclu.dat'
5942       include 'COMMON.VAR'
5943       include 'COMMON.GEO'
5944       include 'COMMON.LOCAL'
5945       include 'COMMON.TORSION'
5946       include 'COMMON.INTERACT'
5947       include 'COMMON.DERIV'
5948       include 'COMMON.CHAIN'
5949       include 'COMMON.NAMES'
5950       include 'COMMON.IOUNITS'
5951       include 'COMMON.FFIELD'
5952       include 'COMMON.TORCNSTR'
5953       logical lprn
5954 C Set lprn=.true. for debugging
5955       lprn=.false.
5956 c      lprn=.true.
5957       etors=0.0D0
5958       do i=iphi_start,iphi_end
5959         if (i.le.2) cycle
5960         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5961      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5962         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5963          if (iabs(itype(i)).eq.20) then
5964          iblock=2
5965          else
5966          iblock=1
5967          endif
5968         itori=itortyp(itype(i-2))
5969         itori1=itortyp(itype(i-1))
5970         phii=phi(i)
5971         gloci=0.0D0
5972 C Regular cosine and sine terms
5973         do j=1,nterm(itori,itori1,iblock)
5974           v1ij=v1(j,itori,itori1,iblock)
5975           v2ij=v2(j,itori,itori1,iblock)
5976           cosphi=dcos(j*phii)
5977           sinphi=dsin(j*phii)
5978           etors=etors+v1ij*cosphi+v2ij*sinphi
5979           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5980         enddo
5981 C Lorentz terms
5982 C                         v1
5983 C  E = SUM ----------------------------------- - v1
5984 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5985 C
5986         cosphi=dcos(0.5d0*phii)
5987         sinphi=dsin(0.5d0*phii)
5988         do j=1,nlor(itori,itori1,iblock)
5989           vl1ij=vlor1(j,itori,itori1)
5990           vl2ij=vlor2(j,itori,itori1)
5991           vl3ij=vlor3(j,itori,itori1)
5992           pom=vl2ij*cosphi+vl3ij*sinphi
5993           pom1=1.0d0/(pom*pom+1.0d0)
5994           etors=etors+vl1ij*pom1
5995           pom=-pom*pom1*pom1
5996           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5997         enddo
5998 C Subtract the constant term
5999         etors=etors-v0(itori,itori1,iblock)
6000         if (lprn)
6001      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6002      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6003      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
6004         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
6005 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
6006  1215   continue
6007       enddo
6008 ! 6/20/98 - dihedral angle constraints
6009       edihcnstr=0.0d0
6010       do i=1,ndih_constr
6011         itori=idih_constr(i)
6012         phii=phi(itori)
6013         difi=pinorm(phii-phi0(i))
6014         edihi=0.0d0
6015         if (difi.gt.drange(i)) then
6016           difi=difi-drange(i)
6017           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6018           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6019           edihi=0.25d0*ftors(i)*difi**4
6020         else if (difi.lt.-drange(i)) then
6021           difi=difi+drange(i)
6022           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6023           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6024           edihi=0.25d0*ftors(i)*difi**4
6025         else
6026           difi=0.0d0
6027         endif
6028 c        write (iout,'(2i5,4f10.5,e15.5)') i,itori,phii,phi0(i),difi,
6029 c     &    drange(i),edihi
6030 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
6031 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
6032       enddo
6033 !      write (iout,*) 'edihcnstr',edihcnstr
6034       return
6035       end
6036 c----------------------------------------------------------------------------
6037       subroutine etor_d(etors_d,fact2)
6038 C 6/23/01 Compute double torsional energy
6039       implicit real*8 (a-h,o-z)
6040       include 'DIMENSIONS'
6041       include 'sizesclu.dat'
6042       include 'COMMON.VAR'
6043       include 'COMMON.GEO'
6044       include 'COMMON.LOCAL'
6045       include 'COMMON.TORSION'
6046       include 'COMMON.INTERACT'
6047       include 'COMMON.DERIV'
6048       include 'COMMON.CHAIN'
6049       include 'COMMON.NAMES'
6050       include 'COMMON.IOUNITS'
6051       include 'COMMON.FFIELD'
6052       include 'COMMON.TORCNSTR'
6053       logical lprn
6054 C Set lprn=.true. for debugging
6055       lprn=.false.
6056 c     lprn=.true.
6057       etors_d=0.0D0
6058       do i=iphi_start,iphi_end-1
6059         if (i.le.3) cycle
6060          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
6061      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
6062      &  (itype(i+1).eq.ntyp1)) cycle
6063         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
6064      &     goto 1215
6065         itori=itortyp(itype(i-2))
6066         itori1=itortyp(itype(i-1))
6067         itori2=itortyp(itype(i))
6068         phii=phi(i)
6069         phii1=phi(i+1)
6070         gloci1=0.0D0
6071         gloci2=0.0D0
6072         iblock=1
6073         if (iabs(itype(i+1)).eq.20) iblock=2
6074 C Regular cosine and sine terms
6075        do j=1,ntermd_1(itori,itori1,itori2,iblock)
6076           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
6077           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
6078           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
6079           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
6080           cosphi1=dcos(j*phii)
6081           sinphi1=dsin(j*phii)
6082           cosphi2=dcos(j*phii1)
6083           sinphi2=dsin(j*phii1)
6084           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
6085      &     v2cij*cosphi2+v2sij*sinphi2
6086           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
6087           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
6088         enddo
6089         do k=2,ntermd_2(itori,itori1,itori2,iblock)
6090           do l=1,k-1
6091             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
6092             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
6093             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
6094             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
6095             cosphi1p2=dcos(l*phii+(k-l)*phii1)
6096             cosphi1m2=dcos(l*phii-(k-l)*phii1)
6097             sinphi1p2=dsin(l*phii+(k-l)*phii1)
6098             sinphi1m2=dsin(l*phii-(k-l)*phii1)
6099             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
6100      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
6101             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
6102      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
6103             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
6104      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
6105           enddo
6106         enddo
6107         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
6108         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
6109  1215   continue
6110       enddo
6111       return
6112       end
6113 #endif
6114 c------------------------------------------------------------------------------
6115       subroutine eback_sc_corr(esccor)
6116 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6117 c        conformational states; temporarily implemented as differences
6118 c        between UNRES torsional potentials (dependent on three types of
6119 c        residues) and the torsional potentials dependent on all 20 types
6120 c        of residues computed from AM1 energy surfaces of terminally-blocked
6121 c        amino-acid residues.
6122       implicit real*8 (a-h,o-z)
6123       include 'DIMENSIONS'
6124       include 'sizesclu.dat'
6125       include 'COMMON.VAR'
6126       include 'COMMON.GEO'
6127       include 'COMMON.LOCAL'
6128       include 'COMMON.TORSION'
6129       include 'COMMON.SCCOR'
6130       include 'COMMON.INTERACT'
6131       include 'COMMON.DERIV'
6132       include 'COMMON.CHAIN'
6133       include 'COMMON.NAMES'
6134       include 'COMMON.IOUNITS'
6135       include 'COMMON.FFIELD'
6136       include 'COMMON.CONTROL'
6137       logical lprn
6138 C Set lprn=.true. for debugging
6139       lprn=.false.
6140 c      lprn=.true.
6141 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6142       esccor=0.0D0
6143       do i=itau_start,itau_end
6144         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6145         esccor_ii=0.0D0
6146         isccori=isccortyp(itype(i-2))
6147         isccori1=isccortyp(itype(i-1))
6148         phii=phi(i)
6149         do intertyp=1,3 !intertyp
6150 cc Added 09 May 2012 (Adasko)
6151 cc  Intertyp means interaction type of backbone mainchain correlation:
6152 c   1 = SC...Ca...Ca...Ca
6153 c   2 = Ca...Ca...Ca...SC
6154 c   3 = SC...Ca...Ca...SCi
6155         gloci=0.0D0
6156         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6157      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6158      &      (itype(i-1).eq.ntyp1)))
6159      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6160      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6161      &     .or.(itype(i).eq.ntyp1)))
6162      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6163      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6164      &      (itype(i-3).eq.ntyp1)))) cycle
6165         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6166         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6167      & cycle
6168        do j=1,nterm_sccor(isccori,isccori1)
6169           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6170           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6171           cosphi=dcos(j*tauangle(intertyp,i))
6172           sinphi=dsin(j*tauangle(intertyp,i))
6173            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6174 c           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6175          enddo
6176 c      write (iout,*) "EBACK_SC_COR",i,esccor,intertyp
6177 c      gloc_sc(intertyp,i-3)=gloc_sc(intertyp,i-3)+wsccor*gloci
6178         if (lprn)
6179      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6180      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6181      &  (v1sccor(j,1,itori,itori1),j=1,6),
6182      &  (v2sccor(j,1,itori,itori1),j=1,6)
6183         gsccor_loc(i-3)=gloci
6184        enddo !intertyp
6185       enddo
6186       return
6187       end
6188 c------------------------------------------------------------------------------
6189       subroutine multibody(ecorr)
6190 C This subroutine calculates multi-body contributions to energy following
6191 C the idea of Skolnick et al. If side chains I and J make a contact and
6192 C at the same time side chains I+1 and J+1 make a contact, an extra
6193 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6194       implicit real*8 (a-h,o-z)
6195       include 'DIMENSIONS'
6196       include 'COMMON.IOUNITS'
6197       include 'COMMON.DERIV'
6198       include 'COMMON.INTERACT'
6199       include 'COMMON.CONTACTS'
6200       double precision gx(3),gx1(3)
6201       logical lprn
6202
6203 C Set lprn=.true. for debugging
6204       lprn=.false.
6205
6206       if (lprn) then
6207         write (iout,'(a)') 'Contact function values:'
6208         do i=nnt,nct-2
6209           write (iout,'(i2,20(1x,i2,f10.5))')
6210      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6211         enddo
6212       endif
6213       ecorr=0.0D0
6214       do i=nnt,nct
6215         do j=1,3
6216           gradcorr(j,i)=0.0D0
6217           gradxorr(j,i)=0.0D0
6218         enddo
6219       enddo
6220       do i=nnt,nct-2
6221
6222         DO ISHIFT = 3,4
6223
6224         i1=i+ishift
6225         num_conti=num_cont(i)
6226         num_conti1=num_cont(i1)
6227         do jj=1,num_conti
6228           j=jcont(jj,i)
6229           do kk=1,num_conti1
6230             j1=jcont(kk,i1)
6231             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6232 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6233 cd   &                   ' ishift=',ishift
6234 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6235 C The system gains extra energy.
6236               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6237             endif   ! j1==j+-ishift
6238           enddo     ! kk
6239         enddo       ! jj
6240
6241         ENDDO ! ISHIFT
6242
6243       enddo         ! i
6244       return
6245       end
6246 c------------------------------------------------------------------------------
6247       double precision function esccorr(i,j,k,l,jj,kk)
6248       implicit real*8 (a-h,o-z)
6249       include 'DIMENSIONS'
6250       include 'COMMON.IOUNITS'
6251       include 'COMMON.DERIV'
6252       include 'COMMON.INTERACT'
6253       include 'COMMON.CONTACTS'
6254       double precision gx(3),gx1(3)
6255       logical lprn
6256       lprn=.false.
6257       eij=facont(jj,i)
6258       ekl=facont(kk,k)
6259 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6260 C Calculate the multi-body contribution to energy.
6261 C Calculate multi-body contributions to the gradient.
6262 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6263 cd   & k,l,(gacont(m,kk,k),m=1,3)
6264       do m=1,3
6265         gx(m) =ekl*gacont(m,jj,i)
6266         gx1(m)=eij*gacont(m,kk,k)
6267         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6268         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6269         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6270         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6271       enddo
6272       do m=i,j-1
6273         do ll=1,3
6274           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6275         enddo
6276       enddo
6277       do m=k,l-1
6278         do ll=1,3
6279           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6280         enddo
6281       enddo
6282       esccorr=-eij*ekl
6283       return
6284       end
6285 c------------------------------------------------------------------------------
6286 #ifdef MPL
6287       subroutine pack_buffer(dimen1,dimen2,atom,indx,buffer)
6288       implicit real*8 (a-h,o-z)
6289       include 'DIMENSIONS'
6290       integer dimen1,dimen2,atom,indx
6291       double precision buffer(dimen1,dimen2)
6292       double precision zapas
6293       common /contacts_hb/ zapas(3,20,maxres,7),
6294      &   facont_hb(20,maxres),ees0p(20,maxres),ees0m(20,maxres),
6295      &         num_cont_hb(maxres),jcont_hb(20,maxres)
6296       num_kont=num_cont_hb(atom)
6297       do i=1,num_kont
6298         do k=1,7
6299           do j=1,3
6300             buffer(i,indx+(k-1)*3+j)=zapas(j,i,atom,k)
6301           enddo ! j
6302         enddo ! k
6303         buffer(i,indx+22)=facont_hb(i,atom)
6304         buffer(i,indx+23)=ees0p(i,atom)
6305         buffer(i,indx+24)=ees0m(i,atom)
6306         buffer(i,indx+25)=dfloat(jcont_hb(i,atom))
6307       enddo ! i
6308       buffer(1,indx+26)=dfloat(num_kont)
6309       return
6310       end
6311 c------------------------------------------------------------------------------
6312       subroutine unpack_buffer(dimen1,dimen2,atom,indx,buffer)
6313       implicit real*8 (a-h,o-z)
6314       include 'DIMENSIONS'
6315       integer dimen1,dimen2,atom,indx
6316       double precision buffer(dimen1,dimen2)
6317       double precision zapas
6318       common /contacts_hb/ zapas(3,ntyp,maxres,7),
6319      &     facont_hb(ntyp,maxres),ees0p(ntyp,maxres),ees0m(ntyp,maxres),
6320      &         num_cont_hb(maxres),jcont_hb(ntyp,maxres)
6321       num_kont=buffer(1,indx+26)
6322       num_kont_old=num_cont_hb(atom)
6323       num_cont_hb(atom)=num_kont+num_kont_old
6324       do i=1,num_kont
6325         ii=i+num_kont_old
6326         do k=1,7
6327           do j=1,3
6328             zapas(j,ii,atom,k)=buffer(i,indx+(k-1)*3+j)
6329           enddo ! j
6330         enddo ! k
6331         facont_hb(ii,atom)=buffer(i,indx+22)
6332         ees0p(ii,atom)=buffer(i,indx+23)
6333         ees0m(ii,atom)=buffer(i,indx+24)
6334         jcont_hb(ii,atom)=buffer(i,indx+25)
6335       enddo ! i
6336       return
6337       end
6338 c------------------------------------------------------------------------------
6339 #endif
6340       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6341 C This subroutine calculates multi-body contributions to hydrogen-bonding
6342       implicit real*8 (a-h,o-z)
6343       include 'DIMENSIONS'
6344       include 'sizesclu.dat'
6345       include 'COMMON.IOUNITS'
6346 #ifdef MPL
6347       include 'COMMON.INFO'
6348 #endif
6349       include 'COMMON.FFIELD'
6350       include 'COMMON.DERIV'
6351       include 'COMMON.INTERACT'
6352       include 'COMMON.CONTACTS'
6353 #ifdef MPL
6354       parameter (max_cont=maxconts)
6355       parameter (max_dim=2*(8*3+2))
6356       parameter (msglen1=max_cont*max_dim*4)
6357       parameter (msglen2=2*msglen1)
6358       integer source,CorrelType,CorrelID,Error
6359       double precision buffer(max_cont,max_dim)
6360 #endif
6361       double precision gx(3),gx1(3)
6362       logical lprn,ldone
6363
6364 C Set lprn=.true. for debugging
6365       lprn=.false.
6366 #ifdef MPL
6367       n_corr=0
6368       n_corr1=0
6369       if (fgProcs.le.1) goto 30
6370       if (lprn) then
6371         write (iout,'(a)') 'Contact function values:'
6372         do i=nnt,nct-2
6373           write (iout,'(2i3,50(1x,i2,f5.2))')
6374      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6375      &    j=1,num_cont_hb(i))
6376         enddo
6377       endif
6378 C Caution! Following code assumes that electrostatic interactions concerning
6379 C a given atom are split among at most two processors!
6380       CorrelType=477
6381       CorrelID=MyID+1
6382       ldone=.false.
6383       do i=1,max_cont
6384         do j=1,max_dim
6385           buffer(i,j)=0.0D0
6386         enddo
6387       enddo
6388       mm=mod(MyRank,2)
6389 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6390       if (mm) 20,20,10
6391    10 continue
6392 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6393       if (MyRank.gt.0) then
6394 C Send correlation contributions to the preceding processor
6395         msglen=msglen1
6396         nn=num_cont_hb(iatel_s)
6397         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6398 cd      write (iout,*) 'The BUFFER array:'
6399 cd      do i=1,nn
6400 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6401 cd      enddo
6402         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6403           msglen=msglen2
6404             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6405 C Clear the contacts of the atom passed to the neighboring processor
6406         nn=num_cont_hb(iatel_s+1)
6407 cd      do i=1,nn
6408 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6409 cd      enddo
6410             num_cont_hb(iatel_s)=0
6411         endif
6412 cd      write (iout,*) 'Processor ',MyID,MyRank,
6413 cd   & ' is sending correlation contribution to processor',MyID-1,
6414 cd   & ' msglen=',msglen
6415 cd      write (*,*) 'Processor ',MyID,MyRank,
6416 cd   & ' is sending correlation contribution to processor',MyID-1,
6417 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6418         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6419 cd      write (iout,*) 'Processor ',MyID,
6420 cd   & ' has sent correlation contribution to processor',MyID-1,
6421 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6422 cd      write (*,*) 'Processor ',MyID,
6423 cd   & ' has sent correlation contribution to processor',MyID-1,
6424 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6425         msglen=msglen1
6426       endif ! (MyRank.gt.0)
6427       if (ldone) goto 30
6428       ldone=.true.
6429    20 continue
6430 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6431       if (MyRank.lt.fgProcs-1) then
6432 C Receive correlation contributions from the next processor
6433         msglen=msglen1
6434         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6435 cd      write (iout,*) 'Processor',MyID,
6436 cd   & ' is receiving correlation contribution from processor',MyID+1,
6437 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6438 cd      write (*,*) 'Processor',MyID,
6439 cd   & ' is receiving correlation contribution from processor',MyID+1,
6440 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6441         nbytes=-1
6442         do while (nbytes.le.0)
6443           call mp_probe(MyID+1,CorrelType,nbytes)
6444         enddo
6445 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6446         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6447 cd      write (iout,*) 'Processor',MyID,
6448 cd   & ' has received correlation contribution from processor',MyID+1,
6449 cd   & ' msglen=',msglen,' nbytes=',nbytes
6450 cd      write (iout,*) 'The received BUFFER array:'
6451 cd      do i=1,max_cont
6452 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6453 cd      enddo
6454         if (msglen.eq.msglen1) then
6455           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6456         else if (msglen.eq.msglen2)  then
6457           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6458           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6459         else
6460           write (iout,*)
6461      & 'ERROR!!!! message length changed while processing correlations.'
6462           write (*,*)
6463      & 'ERROR!!!! message length changed while processing correlations.'
6464           call mp_stopall(Error)
6465         endif ! msglen.eq.msglen1
6466       endif ! MyRank.lt.fgProcs-1
6467       if (ldone) goto 30
6468       ldone=.true.
6469       goto 10
6470    30 continue
6471 #endif
6472       if (lprn) then
6473         write (iout,'(a)') 'Contact function values:'
6474         do i=nnt,nct-2
6475           write (iout,'(2i3,50(1x,i2,f5.2))')
6476      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6477      &    j=1,num_cont_hb(i))
6478         enddo
6479       endif
6480       ecorr=0.0D0
6481 C Remove the loop below after debugging !!!
6482       do i=nnt,nct
6483         do j=1,3
6484           gradcorr(j,i)=0.0D0
6485           gradxorr(j,i)=0.0D0
6486         enddo
6487       enddo
6488 C Calculate the local-electrostatic correlation terms
6489       do i=iatel_s,iatel_e+1
6490         i1=i+1
6491         num_conti=num_cont_hb(i)
6492         num_conti1=num_cont_hb(i+1)
6493         do jj=1,num_conti
6494           j=jcont_hb(jj,i)
6495           do kk=1,num_conti1
6496             j1=jcont_hb(kk,i1)
6497 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6498 c     &         ' jj=',jj,' kk=',kk
6499             if (j1.eq.j+1 .or. j1.eq.j-1) then
6500 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6501 C The system gains extra energy.
6502               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6503               n_corr=n_corr+1
6504             else if (j1.eq.j) then
6505 C Contacts I-J and I-(J+1) occur simultaneously.
6506 C The system loses extra energy.
6507 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6508             endif
6509           enddo ! kk
6510           do kk=1,num_conti
6511             j1=jcont_hb(kk,i)
6512 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6513 c    &         ' jj=',jj,' kk=',kk
6514             if (j1.eq.j+1) then
6515 C Contacts I-J and (I+1)-J occur simultaneously.
6516 C The system loses extra energy.
6517 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6518             endif ! j1==j+1
6519           enddo ! kk
6520         enddo ! jj
6521       enddo ! i
6522       return
6523       end
6524 c------------------------------------------------------------------------------
6525       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6526      &  n_corr1)
6527 C This subroutine calculates multi-body contributions to hydrogen-bonding
6528       implicit real*8 (a-h,o-z)
6529       include 'DIMENSIONS'
6530       include 'sizesclu.dat'
6531       include 'COMMON.IOUNITS'
6532 #ifdef MPL
6533       include 'COMMON.INFO'
6534 #endif
6535       include 'COMMON.FFIELD'
6536       include 'COMMON.DERIV'
6537       include 'COMMON.INTERACT'
6538       include 'COMMON.CONTACTS'
6539 #ifdef MPL
6540       parameter (max_cont=maxconts)
6541       parameter (max_dim=2*(8*3+2))
6542       parameter (msglen1=max_cont*max_dim*4)
6543       parameter (msglen2=2*msglen1)
6544       integer source,CorrelType,CorrelID,Error
6545       double precision buffer(max_cont,max_dim)
6546 #endif
6547       double precision gx(3),gx1(3)
6548       logical lprn,ldone
6549
6550 C Set lprn=.true. for debugging
6551       lprn=.false.
6552       eturn6=0.0d0
6553 #ifdef MPL
6554       n_corr=0
6555       n_corr1=0
6556       if (fgProcs.le.1) goto 30
6557       if (lprn) then
6558         write (iout,'(a)') 'Contact function values:'
6559         do i=nnt,nct-2
6560           write (iout,'(2i3,50(1x,i2,f5.2))')
6561      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6562      &    j=1,num_cont_hb(i))
6563         enddo
6564       endif
6565 C Caution! Following code assumes that electrostatic interactions concerning
6566 C a given atom are split among at most two processors!
6567       CorrelType=477
6568       CorrelID=MyID+1
6569       ldone=.false.
6570       do i=1,max_cont
6571         do j=1,max_dim
6572           buffer(i,j)=0.0D0
6573         enddo
6574       enddo
6575       mm=mod(MyRank,2)
6576 cd    write (iout,*) 'MyRank',MyRank,' mm',mm
6577       if (mm) 20,20,10
6578    10 continue
6579 cd    write (iout,*) 'Sending: MyRank',MyRank,' mm',mm,' ldone',ldone
6580       if (MyRank.gt.0) then
6581 C Send correlation contributions to the preceding processor
6582         msglen=msglen1
6583         nn=num_cont_hb(iatel_s)
6584         call pack_buffer(max_cont,max_dim,iatel_s,0,buffer)
6585 cd      write (iout,*) 'The BUFFER array:'
6586 cd      do i=1,nn
6587 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,26)
6588 cd      enddo
6589         if (ielstart(iatel_s).gt.iatel_s+ispp) then
6590           msglen=msglen2
6591             call pack_buffer(max_cont,max_dim,iatel_s+1,26,buffer)
6592 C Clear the contacts of the atom passed to the neighboring processor
6593         nn=num_cont_hb(iatel_s+1)
6594 cd      do i=1,nn
6595 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j+26),j=1,26)
6596 cd      enddo
6597             num_cont_hb(iatel_s)=0
6598         endif
6599 cd      write (iout,*) 'Processor ',MyID,MyRank,
6600 cd   & ' is sending correlation contribution to processor',MyID-1,
6601 cd   & ' msglen=',msglen
6602 cd      write (*,*) 'Processor ',MyID,MyRank,
6603 cd   & ' is sending correlation contribution to processor',MyID-1,
6604 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6605         call mp_bsend(buffer,msglen,MyID-1,CorrelType,CorrelID)
6606 cd      write (iout,*) 'Processor ',MyID,
6607 cd   & ' has sent correlation contribution to processor',MyID-1,
6608 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6609 cd      write (*,*) 'Processor ',MyID,
6610 cd   & ' has sent correlation contribution to processor',MyID-1,
6611 cd   & ' msglen=',msglen,' CorrelID=',CorrelID
6612         msglen=msglen1
6613       endif ! (MyRank.gt.0)
6614       if (ldone) goto 30
6615       ldone=.true.
6616    20 continue
6617 cd    write (iout,*) 'Receiving: MyRank',MyRank,' mm',mm,' ldone',ldone
6618       if (MyRank.lt.fgProcs-1) then
6619 C Receive correlation contributions from the next processor
6620         msglen=msglen1
6621         if (ielend(iatel_e).lt.nct-1) msglen=msglen2
6622 cd      write (iout,*) 'Processor',MyID,
6623 cd   & ' is receiving correlation contribution from processor',MyID+1,
6624 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6625 cd      write (*,*) 'Processor',MyID,
6626 cd   & ' is receiving correlation contribution from processor',MyID+1,
6627 cd   & ' msglen=',msglen,' CorrelType=',CorrelType
6628         nbytes=-1
6629         do while (nbytes.le.0)
6630           call mp_probe(MyID+1,CorrelType,nbytes)
6631         enddo
6632 cd      print *,'Processor',MyID,' msglen',msglen,' nbytes',nbytes
6633         call mp_brecv(buffer,msglen,MyID+1,CorrelType,nbytes)
6634 cd      write (iout,*) 'Processor',MyID,
6635 cd   & ' has received correlation contribution from processor',MyID+1,
6636 cd   & ' msglen=',msglen,' nbytes=',nbytes
6637 cd      write (iout,*) 'The received BUFFER array:'
6638 cd      do i=1,max_cont
6639 cd        write (iout,'(i2,9(3f8.3,2x))') i,(buffer(i,j),j=1,52)
6640 cd      enddo
6641         if (msglen.eq.msglen1) then
6642           call unpack_buffer(max_cont,max_dim,iatel_e+1,0,buffer)
6643         else if (msglen.eq.msglen2)  then
6644           call unpack_buffer(max_cont,max_dim,iatel_e,0,buffer)
6645           call unpack_buffer(max_cont,max_dim,iatel_e+1,26,buffer)
6646         else
6647           write (iout,*)
6648      & 'ERROR!!!! message length changed while processing correlations.'
6649           write (*,*)
6650      & 'ERROR!!!! message length changed while processing correlations.'
6651           call mp_stopall(Error)
6652         endif ! msglen.eq.msglen1
6653       endif ! MyRank.lt.fgProcs-1
6654       if (ldone) goto 30
6655       ldone=.true.
6656       goto 10
6657    30 continue
6658 #endif
6659       if (lprn) then
6660         write (iout,'(a)') 'Contact function values:'
6661         do i=nnt,nct-2
6662           write (iout,'(2i3,50(1x,i2,f5.2))')
6663      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6664      &    j=1,num_cont_hb(i))
6665         enddo
6666       endif
6667       ecorr=0.0D0
6668       ecorr5=0.0d0
6669       ecorr6=0.0d0
6670 C Remove the loop below after debugging !!!
6671       do i=nnt,nct
6672         do j=1,3
6673           gradcorr(j,i)=0.0D0
6674           gradxorr(j,i)=0.0D0
6675         enddo
6676       enddo
6677 C Calculate the dipole-dipole interaction energies
6678       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6679       do i=iatel_s,iatel_e+1
6680         num_conti=num_cont_hb(i)
6681         do jj=1,num_conti
6682           j=jcont_hb(jj,i)
6683           call dipole(i,j,jj)
6684         enddo
6685       enddo
6686       endif
6687 C Calculate the local-electrostatic correlation terms
6688       do i=iatel_s,iatel_e+1
6689         i1=i+1
6690         num_conti=num_cont_hb(i)
6691         num_conti1=num_cont_hb(i+1)
6692         do jj=1,num_conti
6693           j=jcont_hb(jj,i)
6694           do kk=1,num_conti1
6695             j1=jcont_hb(kk,i1)
6696 c            write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6697 c     &         ' jj=',jj,' kk=',kk
6698             if (j1.eq.j+1 .or. j1.eq.j-1) then
6699 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6700 C The system gains extra energy.
6701               n_corr=n_corr+1
6702               sqd1=dsqrt(d_cont(jj,i))
6703               sqd2=dsqrt(d_cont(kk,i1))
6704               sred_geom = sqd1*sqd2
6705               IF (sred_geom.lt.cutoff_corr) THEN
6706                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6707      &            ekont,fprimcont)
6708 c               write (*,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6709 c     &         ' jj=',jj,' kk=',kk
6710                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6711                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6712                 do l=1,3
6713                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6714                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6715                 enddo
6716                 n_corr1=n_corr1+1
6717 cd               write (iout,*) 'sred_geom=',sred_geom,
6718 cd     &          ' ekont=',ekont,' fprim=',fprimcont
6719                 call calc_eello(i,j,i+1,j1,jj,kk)
6720                 if (wcorr4.gt.0.0d0)
6721      &            ecorr=ecorr+eello4(i,j,i+1,j1,jj,kk)
6722                 if (wcorr5.gt.0.0d0)
6723      &            ecorr5=ecorr5+eello5(i,j,i+1,j1,jj,kk)
6724 c                print *,"wcorr5",ecorr5
6725 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6726 cd                write(2,*)'ijkl',i,j,i+1,j1
6727                 if (wcorr6.gt.0.0d0 .and. (j.ne.i+4 .or. j1.ne.i+3
6728      &               .or. wturn6.eq.0.0d0))then
6729 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6730                   ecorr6=ecorr6+eello6(i,j,i+1,j1,jj,kk)
6731 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6732 cd     &            'ecorr6=',ecorr6
6733 cd                write (iout,'(4e15.5)') sred_geom,
6734 cd     &          dabs(eello4(i,j,i+1,j1,jj,kk)),
6735 cd     &          dabs(eello5(i,j,i+1,j1,jj,kk)),
6736 cd     &          dabs(eello6(i,j,i+1,j1,jj,kk))
6737                 else if (wturn6.gt.0.0d0
6738      &            .and. (j.eq.i+4 .and. j1.eq.i+3)) then
6739 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,j,i+1,j1
6740                   eturn6=eturn6+eello_turn6(i,jj,kk)
6741 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6742                 endif
6743               ENDIF
6744 1111          continue
6745             else if (j1.eq.j) then
6746 C Contacts I-J and I-(J+1) occur simultaneously.
6747 C The system loses extra energy.
6748 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6749             endif
6750           enddo ! kk
6751           do kk=1,num_conti
6752             j1=jcont_hb(kk,i)
6753 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6754 c    &         ' jj=',jj,' kk=',kk
6755             if (j1.eq.j+1) then
6756 C Contacts I-J and (I+1)-J occur simultaneously.
6757 C The system loses extra energy.
6758 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6759             endif ! j1==j+1
6760           enddo ! kk
6761         enddo ! jj
6762       enddo ! i
6763       return
6764       end
6765 c------------------------------------------------------------------------------
6766       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6767       implicit real*8 (a-h,o-z)
6768       include 'DIMENSIONS'
6769       include 'COMMON.IOUNITS'
6770       include 'COMMON.DERIV'
6771       include 'COMMON.INTERACT'
6772       include 'COMMON.CONTACTS'
6773       include 'COMMON.SHIELD'
6774
6775       double precision gx(3),gx1(3)
6776       logical lprn
6777       lprn=.false.
6778       eij=facont_hb(jj,i)
6779       ekl=facont_hb(kk,k)
6780       ees0pij=ees0p(jj,i)
6781       ees0pkl=ees0p(kk,k)
6782       ees0mij=ees0m(jj,i)
6783       ees0mkl=ees0m(kk,k)
6784       ekont=eij*ekl
6785       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6786 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6787 C Following 4 lines for diagnostics.
6788 cd    ees0pkl=0.0D0
6789 cd    ees0pij=1.0D0
6790 cd    ees0mkl=0.0D0
6791 cd    ees0mij=1.0D0
6792 c     write (iout,*)'Contacts have occurred for peptide groups',i,j,
6793 c    &   ' and',k,l
6794 c     write (iout,*)'Contacts have occurred for peptide groups',
6795 c    &  i,j,' fcont:',eij,' eij',' eesij',ees0pij,ees0mij,' and ',k,l
6796 c    & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' ees=',ees
6797 C Calculate the multi-body contribution to energy.
6798       ecorr=ecorr+ekont*ees
6799       if (calc_grad) then
6800 C Calculate multi-body contributions to the gradient.
6801       do ll=1,3
6802         ghalf=0.5D0*ees*ekl*gacont_hbr(ll,jj,i)
6803         gradcorr(ll,i)=gradcorr(ll,i)+ghalf
6804      &  -ekont*(coeffp*ees0pkl*gacontp_hb1(ll,jj,i)+
6805      &  coeffm*ees0mkl*gacontm_hb1(ll,jj,i))
6806         gradcorr(ll,j)=gradcorr(ll,j)+ghalf
6807      &  -ekont*(coeffp*ees0pkl*gacontp_hb2(ll,jj,i)+
6808      &  coeffm*ees0mkl*gacontm_hb2(ll,jj,i))
6809         ghalf=0.5D0*ees*eij*gacont_hbr(ll,kk,k)
6810         gradcorr(ll,k)=gradcorr(ll,k)+ghalf
6811      &  -ekont*(coeffp*ees0pij*gacontp_hb1(ll,kk,k)+
6812      &  coeffm*ees0mij*gacontm_hb1(ll,kk,k))
6813         gradcorr(ll,l)=gradcorr(ll,l)+ghalf
6814      &  -ekont*(coeffp*ees0pij*gacontp_hb2(ll,kk,k)+
6815      &  coeffm*ees0mij*gacontm_hb2(ll,kk,k))
6816       enddo
6817       do m=i+1,j-1
6818         do ll=1,3
6819           gradcorr(ll,m)=gradcorr(ll,m)+
6820      &     ees*ekl*gacont_hbr(ll,jj,i)-
6821      &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6822      &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6823         enddo
6824       enddo
6825       do m=k+1,l-1
6826         do ll=1,3
6827           gradcorr(ll,m)=gradcorr(ll,m)+
6828      &     ees*eij*gacont_hbr(ll,kk,k)-
6829      &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6830      &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6831         enddo
6832       enddo
6833       if (shield_mode.gt.0) then
6834        j=ees0plist(jj,i)
6835        l=ees0plist(kk,k)
6836 C        print *,i,j,fac_shield(i),fac_shield(j),
6837 C     &fac_shield(k),fac_shield(l)
6838         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6839      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6840           do ilist=1,ishield_list(i)
6841            iresshield=shield_list(ilist,i)
6842            do m=1,3
6843            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6844 C     &      *2.0
6845            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6846      &              rlocshield
6847      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6848             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6849      &+rlocshield
6850            enddo
6851           enddo
6852           do ilist=1,ishield_list(j)
6853            iresshield=shield_list(ilist,j)
6854            do m=1,3
6855            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6856 C     &     *2.0
6857            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6858      &              rlocshield
6859      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6860            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6861      &     +rlocshield
6862            enddo
6863           enddo
6864           do ilist=1,ishield_list(k)
6865            iresshield=shield_list(ilist,k)
6866            do m=1,3
6867            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6868 C     &     *2.0
6869            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6870      &              rlocshield
6871      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6872            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6873      &     +rlocshield
6874            enddo
6875           enddo
6876           do ilist=1,ishield_list(l)
6877            iresshield=shield_list(ilist,l)
6878            do m=1,3
6879            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6880 C     &     *2.0
6881            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6882      &              rlocshield
6883      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6884            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6885      &     +rlocshield
6886            enddo
6887           enddo
6888 C          print *,gshieldx(m,iresshield)
6889           do m=1,3
6890             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6891      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6892             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6893      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6894             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6895      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6896             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6897      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6898
6899             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6900      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6901             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6902      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6903             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6904      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6905             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6906      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6907
6908            enddo
6909       endif
6910       endif
6911       endif
6912       ehbcorr=ekont*ees
6913       return
6914       end
6915 C---------------------------------------------------------------------------
6916       subroutine dipole(i,j,jj)
6917       implicit real*8 (a-h,o-z)
6918       include 'DIMENSIONS'
6919       include 'sizesclu.dat'
6920       include 'COMMON.IOUNITS'
6921       include 'COMMON.CHAIN'
6922       include 'COMMON.FFIELD'
6923       include 'COMMON.DERIV'
6924       include 'COMMON.INTERACT'
6925       include 'COMMON.CONTACTS'
6926       include 'COMMON.TORSION'
6927       include 'COMMON.VAR'
6928       include 'COMMON.GEO'
6929       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6930      &  auxmat(2,2)
6931       iti1 = itortyp(itype(i+1))
6932       if (j.lt.nres-1) then
6933         if (itype(j).le.ntyp) then
6934           itj1 = itortyp(itype(j+1))
6935         else
6936           itj1=ntortyp+1
6937         endif
6938       else
6939         itj1=ntortyp+1
6940       endif
6941       do iii=1,2
6942         dipi(iii,1)=Ub2(iii,i)
6943         dipderi(iii)=Ub2der(iii,i)
6944         dipi(iii,2)=b1(iii,iti1)
6945         dipj(iii,1)=Ub2(iii,j)
6946         dipderj(iii)=Ub2der(iii,j)
6947         dipj(iii,2)=b1(iii,itj1)
6948       enddo
6949       kkk=0
6950       do iii=1,2
6951         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6952         do jjj=1,2
6953           kkk=kkk+1
6954           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6955         enddo
6956       enddo
6957       if (.not.calc_grad) return
6958       do kkk=1,5
6959         do lll=1,3
6960           mmm=0
6961           do iii=1,2
6962             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6963      &        auxvec(1))
6964             do jjj=1,2
6965               mmm=mmm+1
6966               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6967             enddo
6968           enddo
6969         enddo
6970       enddo
6971       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6972       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6973       do iii=1,2
6974         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6975       enddo
6976       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6977       do iii=1,2
6978         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6979       enddo
6980       return
6981       end
6982 C---------------------------------------------------------------------------
6983       subroutine calc_eello(i,j,k,l,jj,kk)
6984 C
6985 C This subroutine computes matrices and vectors needed to calculate
6986 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6987 C
6988       implicit real*8 (a-h,o-z)
6989       include 'DIMENSIONS'
6990       include 'sizesclu.dat'
6991       include 'COMMON.IOUNITS'
6992       include 'COMMON.CHAIN'
6993       include 'COMMON.DERIV'
6994       include 'COMMON.INTERACT'
6995       include 'COMMON.CONTACTS'
6996       include 'COMMON.TORSION'
6997       include 'COMMON.VAR'
6998       include 'COMMON.GEO'
6999       include 'COMMON.FFIELD'
7000       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7001      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7002       logical lprn
7003       common /kutas/ lprn
7004 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7005 cd     & ' jj=',jj,' kk=',kk
7006 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7007       do iii=1,2
7008         do jjj=1,2
7009           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7010           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7011         enddo
7012       enddo
7013       call transpose2(aa1(1,1),aa1t(1,1))
7014       call transpose2(aa2(1,1),aa2t(1,1))
7015       do kkk=1,5
7016         do lll=1,3
7017           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7018      &      aa1tder(1,1,lll,kkk))
7019           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7020      &      aa2tder(1,1,lll,kkk))
7021         enddo
7022       enddo
7023       if (l.eq.j+1) then
7024 C parallel orientation of the two CA-CA-CA frames.
7025 c        if (i.gt.1) then
7026         if (i.gt.1 .and. itype(i).le.ntyp) then
7027           iti=itortyp(itype(i))
7028         else
7029           iti=ntortyp+1
7030         endif
7031         itk1=itortyp(itype(k+1))
7032         itj=itortyp(itype(j))
7033 c        if (l.lt.nres-1) then
7034         if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
7035           itl1=itortyp(itype(l+1))
7036         else
7037           itl1=ntortyp+1
7038         endif
7039 C A1 kernel(j+1) A2T
7040 cd        do iii=1,2
7041 cd          write (iout,'(3f10.5,5x,3f10.5)')
7042 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7043 cd        enddo
7044         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7045      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7046      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7047 C Following matrices are needed only for 6-th order cumulants
7048         IF (wcorr6.gt.0.0d0) THEN
7049         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7050      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7051      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7052         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7053      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7054      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7055      &   ADtEAderx(1,1,1,1,1,1))
7056         lprn=.false.
7057         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7058      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7059      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7060      &   ADtEA1derx(1,1,1,1,1,1))
7061         ENDIF
7062 C End 6-th order cumulants
7063 cd        lprn=.false.
7064 cd        if (lprn) then
7065 cd        write (2,*) 'In calc_eello6'
7066 cd        do iii=1,2
7067 cd          write (2,*) 'iii=',iii
7068 cd          do kkk=1,5
7069 cd            write (2,*) 'kkk=',kkk
7070 cd            do jjj=1,2
7071 cd              write (2,'(3(2f10.5),5x)')
7072 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7073 cd            enddo
7074 cd          enddo
7075 cd        enddo
7076 cd        endif
7077         call transpose2(EUgder(1,1,k),auxmat(1,1))
7078         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7079         call transpose2(EUg(1,1,k),auxmat(1,1))
7080         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7081         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7082         do iii=1,2
7083           do kkk=1,5
7084             do lll=1,3
7085               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7086      &          EAEAderx(1,1,lll,kkk,iii,1))
7087             enddo
7088           enddo
7089         enddo
7090 C A1T kernel(i+1) A2
7091         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7092      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7093      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7094 C Following matrices are needed only for 6-th order cumulants
7095         IF (wcorr6.gt.0.0d0) THEN
7096         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7097      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7098      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7099         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7100      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7101      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7102      &   ADtEAderx(1,1,1,1,1,2))
7103         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7104      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7105      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7106      &   ADtEA1derx(1,1,1,1,1,2))
7107         ENDIF
7108 C End 6-th order cumulants
7109         call transpose2(EUgder(1,1,l),auxmat(1,1))
7110         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7111         call transpose2(EUg(1,1,l),auxmat(1,1))
7112         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7113         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7114         do iii=1,2
7115           do kkk=1,5
7116             do lll=1,3
7117               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7118      &          EAEAderx(1,1,lll,kkk,iii,2))
7119             enddo
7120           enddo
7121         enddo
7122 C AEAb1 and AEAb2
7123 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7124 C They are needed only when the fifth- or the sixth-order cumulants are
7125 C indluded.
7126         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7127         call transpose2(AEA(1,1,1),auxmat(1,1))
7128         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7129         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7130         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7131         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7132         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7133         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7134         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7135         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7136         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7137         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7138         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7139         call transpose2(AEA(1,1,2),auxmat(1,1))
7140         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7141         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7142         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7143         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7144         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7145         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7146         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7147         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7148         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7149         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7150         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7151 C Calculate the Cartesian derivatives of the vectors.
7152         do iii=1,2
7153           do kkk=1,5
7154             do lll=1,3
7155               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7156               call matvec2(auxmat(1,1),b1(1,iti),
7157      &          AEAb1derx(1,lll,kkk,iii,1,1))
7158               call matvec2(auxmat(1,1),Ub2(1,i),
7159      &          AEAb2derx(1,lll,kkk,iii,1,1))
7160               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7161      &          AEAb1derx(1,lll,kkk,iii,2,1))
7162               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7163      &          AEAb2derx(1,lll,kkk,iii,2,1))
7164               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7165               call matvec2(auxmat(1,1),b1(1,itj),
7166      &          AEAb1derx(1,lll,kkk,iii,1,2))
7167               call matvec2(auxmat(1,1),Ub2(1,j),
7168      &          AEAb2derx(1,lll,kkk,iii,1,2))
7169               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7170      &          AEAb1derx(1,lll,kkk,iii,2,2))
7171               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7172      &          AEAb2derx(1,lll,kkk,iii,2,2))
7173             enddo
7174           enddo
7175         enddo
7176         ENDIF
7177 C End vectors
7178       else
7179 C Antiparallel orientation of the two CA-CA-CA frames.
7180 c        if (i.gt.1) then
7181         if (i.gt.1 .and. itype(i).le.ntyp) then
7182           iti=itortyp(itype(i))
7183         else
7184           iti=ntortyp+1
7185         endif
7186         itk1=itortyp(itype(k+1))
7187         itl=itortyp(itype(l))
7188         itj=itortyp(itype(j))
7189 c        if (j.lt.nres-1) then
7190         if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
7191           itj1=itortyp(itype(j+1))
7192         else
7193           itj1=ntortyp+1
7194         endif
7195 C A2 kernel(j-1)T A1T
7196         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7197      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7198      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7199 C Following matrices are needed only for 6-th order cumulants
7200         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7201      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7202         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7203      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7204      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7205         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7206      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7207      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7208      &   ADtEAderx(1,1,1,1,1,1))
7209         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7210      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7211      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7212      &   ADtEA1derx(1,1,1,1,1,1))
7213         ENDIF
7214 C End 6-th order cumulants
7215         call transpose2(EUgder(1,1,k),auxmat(1,1))
7216         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7217         call transpose2(EUg(1,1,k),auxmat(1,1))
7218         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7219         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7220         do iii=1,2
7221           do kkk=1,5
7222             do lll=1,3
7223               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7224      &          EAEAderx(1,1,lll,kkk,iii,1))
7225             enddo
7226           enddo
7227         enddo
7228 C A2T kernel(i+1)T A1
7229         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7230      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7231      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7232 C Following matrices are needed only for 6-th order cumulants
7233         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7234      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7235         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7236      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7237      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7238         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7239      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7240      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7241      &   ADtEAderx(1,1,1,1,1,2))
7242         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7243      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7244      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7245      &   ADtEA1derx(1,1,1,1,1,2))
7246         ENDIF
7247 C End 6-th order cumulants
7248         call transpose2(EUgder(1,1,j),auxmat(1,1))
7249         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7250         call transpose2(EUg(1,1,j),auxmat(1,1))
7251         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7252         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7253         do iii=1,2
7254           do kkk=1,5
7255             do lll=1,3
7256               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7257      &          EAEAderx(1,1,lll,kkk,iii,2))
7258             enddo
7259           enddo
7260         enddo
7261 C AEAb1 and AEAb2
7262 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7263 C They are needed only when the fifth- or the sixth-order cumulants are
7264 C indluded.
7265         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7266      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7267         call transpose2(AEA(1,1,1),auxmat(1,1))
7268         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7269         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7270         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7271         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7272         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7273         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7274         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7275         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7276         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7277         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7278         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7279         call transpose2(AEA(1,1,2),auxmat(1,1))
7280         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7281         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7282         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7283         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7284         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7285         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7286         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7287         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7288         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7289         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7290         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7291 C Calculate the Cartesian derivatives of the vectors.
7292         do iii=1,2
7293           do kkk=1,5
7294             do lll=1,3
7295               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7296               call matvec2(auxmat(1,1),b1(1,iti),
7297      &          AEAb1derx(1,lll,kkk,iii,1,1))
7298               call matvec2(auxmat(1,1),Ub2(1,i),
7299      &          AEAb2derx(1,lll,kkk,iii,1,1))
7300               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7301      &          AEAb1derx(1,lll,kkk,iii,2,1))
7302               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7303      &          AEAb2derx(1,lll,kkk,iii,2,1))
7304               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7305               call matvec2(auxmat(1,1),b1(1,itl),
7306      &          AEAb1derx(1,lll,kkk,iii,1,2))
7307               call matvec2(auxmat(1,1),Ub2(1,l),
7308      &          AEAb2derx(1,lll,kkk,iii,1,2))
7309               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7310      &          AEAb1derx(1,lll,kkk,iii,2,2))
7311               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7312      &          AEAb2derx(1,lll,kkk,iii,2,2))
7313             enddo
7314           enddo
7315         enddo
7316         ENDIF
7317 C End vectors
7318       endif
7319       return
7320       end
7321 C---------------------------------------------------------------------------
7322       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7323      &  KK,KKderg,AKA,AKAderg,AKAderx)
7324       implicit none
7325       integer nderg
7326       logical transp
7327       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7328      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7329      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7330       integer iii,kkk,lll
7331       integer jjj,mmm
7332       logical lprn
7333       common /kutas/ lprn
7334       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7335       do iii=1,nderg
7336         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7337      &    AKAderg(1,1,iii))
7338       enddo
7339 cd      if (lprn) write (2,*) 'In kernel'
7340       do kkk=1,5
7341 cd        if (lprn) write (2,*) 'kkk=',kkk
7342         do lll=1,3
7343           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7344      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7345 cd          if (lprn) then
7346 cd            write (2,*) 'lll=',lll
7347 cd            write (2,*) 'iii=1'
7348 cd            do jjj=1,2
7349 cd              write (2,'(3(2f10.5),5x)')
7350 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7351 cd            enddo
7352 cd          endif
7353           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7354      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7355 cd          if (lprn) then
7356 cd            write (2,*) 'lll=',lll
7357 cd            write (2,*) 'iii=2'
7358 cd            do jjj=1,2
7359 cd              write (2,'(3(2f10.5),5x)')
7360 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7361 cd            enddo
7362 cd          endif
7363         enddo
7364       enddo
7365       return
7366       end
7367 C---------------------------------------------------------------------------
7368       double precision function eello4(i,j,k,l,jj,kk)
7369       implicit real*8 (a-h,o-z)
7370       include 'DIMENSIONS'
7371       include 'sizesclu.dat'
7372       include 'COMMON.IOUNITS'
7373       include 'COMMON.CHAIN'
7374       include 'COMMON.DERIV'
7375       include 'COMMON.INTERACT'
7376       include 'COMMON.CONTACTS'
7377       include 'COMMON.TORSION'
7378       include 'COMMON.VAR'
7379       include 'COMMON.GEO'
7380       double precision pizda(2,2),ggg1(3),ggg2(3)
7381 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7382 cd        eello4=0.0d0
7383 cd        return
7384 cd      endif
7385 cd      print *,'eello4:',i,j,k,l,jj,kk
7386 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7387 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7388 cold      eij=facont_hb(jj,i)
7389 cold      ekl=facont_hb(kk,k)
7390 cold      ekont=eij*ekl
7391       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7392       if (calc_grad) then
7393 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7394       gcorr_loc(k-1)=gcorr_loc(k-1)
7395      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7396       if (l.eq.j+1) then
7397         gcorr_loc(l-1)=gcorr_loc(l-1)
7398      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7399       else
7400         gcorr_loc(j-1)=gcorr_loc(j-1)
7401      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7402       endif
7403       do iii=1,2
7404         do kkk=1,5
7405           do lll=1,3
7406             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7407      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7408 cd            derx(lll,kkk,iii)=0.0d0
7409           enddo
7410         enddo
7411       enddo
7412 cd      gcorr_loc(l-1)=0.0d0
7413 cd      gcorr_loc(j-1)=0.0d0
7414 cd      gcorr_loc(k-1)=0.0d0
7415 cd      eel4=1.0d0
7416 cd      write (iout,*)'Contacts have occurred for peptide groups',
7417 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7418 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7419       if (j.lt.nres-1) then
7420         j1=j+1
7421         j2=j-1
7422       else
7423         j1=j-1
7424         j2=j-2
7425       endif
7426       if (l.lt.nres-1) then
7427         l1=l+1
7428         l2=l-1
7429       else
7430         l1=l-1
7431         l2=l-2
7432       endif
7433       do ll=1,3
7434 cold        ghalf=0.5d0*eel4*ekl*gacont_hbr(ll,jj,i)
7435         ggg1(ll)=eel4*g_contij(ll,1)
7436         ggg2(ll)=eel4*g_contij(ll,2)
7437         ghalf=0.5d0*ggg1(ll)
7438 cd        ghalf=0.0d0
7439         gradcorr(ll,i)=gradcorr(ll,i)+ghalf+ekont*derx(ll,2,1)
7440         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7441         gradcorr(ll,j)=gradcorr(ll,j)+ghalf+ekont*derx(ll,4,1)
7442         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7443 cold        ghalf=0.5d0*eel4*eij*gacont_hbr(ll,kk,k)
7444         ghalf=0.5d0*ggg2(ll)
7445 cd        ghalf=0.0d0
7446         gradcorr(ll,k)=gradcorr(ll,k)+ghalf+ekont*derx(ll,2,2)
7447         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7448         gradcorr(ll,l)=gradcorr(ll,l)+ghalf+ekont*derx(ll,4,2)
7449         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7450       enddo
7451 cd      goto 1112
7452       do m=i+1,j-1
7453         do ll=1,3
7454 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*ekl*gacont_hbr(ll,jj,i)
7455           gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7456         enddo
7457       enddo
7458       do m=k+1,l-1
7459         do ll=1,3
7460 cold          gradcorr(ll,m)=gradcorr(ll,m)+eel4*eij*gacont_hbr(ll,kk,k)
7461           gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7462         enddo
7463       enddo
7464 1112  continue
7465       do m=i+2,j2
7466         do ll=1,3
7467           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7468         enddo
7469       enddo
7470       do m=k+2,l2
7471         do ll=1,3
7472           gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7473         enddo
7474       enddo
7475 cd      do iii=1,nres-3
7476 cd        write (2,*) iii,gcorr_loc(iii)
7477 cd      enddo
7478       endif
7479       eello4=ekont*eel4
7480 cd      write (2,*) 'ekont',ekont
7481 cd      write (iout,*) 'eello4',ekont*eel4
7482       return
7483       end
7484 C---------------------------------------------------------------------------
7485       double precision function eello5(i,j,k,l,jj,kk)
7486       implicit real*8 (a-h,o-z)
7487       include 'DIMENSIONS'
7488       include 'sizesclu.dat'
7489       include 'COMMON.IOUNITS'
7490       include 'COMMON.CHAIN'
7491       include 'COMMON.DERIV'
7492       include 'COMMON.INTERACT'
7493       include 'COMMON.CONTACTS'
7494       include 'COMMON.TORSION'
7495       include 'COMMON.VAR'
7496       include 'COMMON.GEO'
7497       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7498       double precision ggg1(3),ggg2(3)
7499 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7500 C                                                                              C
7501 C                            Parallel chains                                   C
7502 C                                                                              C
7503 C          o             o                   o             o                   C
7504 C         /l\           / \             \   / \           / \   /              C
7505 C        /   \         /   \             \ /   \         /   \ /               C
7506 C       j| o |l1       | o |              o| o |         | o |o                C
7507 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7508 C      \i/   \         /   \ /             /   \         /   \                 C
7509 C       o    k1             o                                                  C
7510 C         (I)          (II)                (III)          (IV)                 C
7511 C                                                                              C
7512 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7513 C                                                                              C
7514 C                            Antiparallel chains                               C
7515 C                                                                              C
7516 C          o             o                   o             o                   C
7517 C         /j\           / \             \   / \           / \   /              C
7518 C        /   \         /   \             \ /   \         /   \ /               C
7519 C      j1| o |l        | o |              o| o |         | o |o                C
7520 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7521 C      \i/   \         /   \ /             /   \         /   \                 C
7522 C       o     k1            o                                                  C
7523 C         (I)          (II)                (III)          (IV)                 C
7524 C                                                                              C
7525 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7526 C                                                                              C
7527 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7528 C                                                                              C
7529 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7530 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7531 cd        eello5=0.0d0
7532 cd        return
7533 cd      endif
7534 cd      write (iout,*)
7535 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7536 cd     &   ' and',k,l
7537       itk=itortyp(itype(k))
7538       itl=itortyp(itype(l))
7539       itj=itortyp(itype(j))
7540       eello5_1=0.0d0
7541       eello5_2=0.0d0
7542       eello5_3=0.0d0
7543       eello5_4=0.0d0
7544 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7545 cd     &   eel5_3_num,eel5_4_num)
7546       do iii=1,2
7547         do kkk=1,5
7548           do lll=1,3
7549             derx(lll,kkk,iii)=0.0d0
7550           enddo
7551         enddo
7552       enddo
7553 cd      eij=facont_hb(jj,i)
7554 cd      ekl=facont_hb(kk,k)
7555 cd      ekont=eij*ekl
7556 cd      write (iout,*)'Contacts have occurred for peptide groups',
7557 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7558 cd      goto 1111
7559 C Contribution from the graph I.
7560 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7561 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7562       call transpose2(EUg(1,1,k),auxmat(1,1))
7563       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7564       vv(1)=pizda(1,1)-pizda(2,2)
7565       vv(2)=pizda(1,2)+pizda(2,1)
7566       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7567      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7568       if (calc_grad) then
7569 C Explicit gradient in virtual-dihedral angles.
7570       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7571      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7572      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7573       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7574       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7575       vv(1)=pizda(1,1)-pizda(2,2)
7576       vv(2)=pizda(1,2)+pizda(2,1)
7577       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7578      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7579      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7580       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7581       vv(1)=pizda(1,1)-pizda(2,2)
7582       vv(2)=pizda(1,2)+pizda(2,1)
7583       if (l.eq.j+1) then
7584         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7585      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7586      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7587       else
7588         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7589      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7590      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7591       endif
7592 C Cartesian gradient
7593       do iii=1,2
7594         do kkk=1,5
7595           do lll=1,3
7596             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7597      &        pizda(1,1))
7598             vv(1)=pizda(1,1)-pizda(2,2)
7599             vv(2)=pizda(1,2)+pizda(2,1)
7600             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7601      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7602      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7603           enddo
7604         enddo
7605       enddo
7606 c      goto 1112
7607       endif
7608 c1111  continue
7609 C Contribution from graph II
7610       call transpose2(EE(1,1,itk),auxmat(1,1))
7611       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7612       vv(1)=pizda(1,1)+pizda(2,2)
7613       vv(2)=pizda(2,1)-pizda(1,2)
7614       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7615      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7616       if (calc_grad) then
7617 C Explicit gradient in virtual-dihedral angles.
7618       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7619      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7620       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7621       vv(1)=pizda(1,1)+pizda(2,2)
7622       vv(2)=pizda(2,1)-pizda(1,2)
7623       if (l.eq.j+1) then
7624         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7625      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7626      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7627       else
7628         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7629      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7630      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7631       endif
7632 C Cartesian gradient
7633       do iii=1,2
7634         do kkk=1,5
7635           do lll=1,3
7636             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7637      &        pizda(1,1))
7638             vv(1)=pizda(1,1)+pizda(2,2)
7639             vv(2)=pizda(2,1)-pizda(1,2)
7640             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7641      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7642      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7643           enddo
7644         enddo
7645       enddo
7646 cd      goto 1112
7647       endif
7648 cd1111  continue
7649       if (l.eq.j+1) then
7650 cd        goto 1110
7651 C Parallel orientation
7652 C Contribution from graph III
7653         call transpose2(EUg(1,1,l),auxmat(1,1))
7654         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7655         vv(1)=pizda(1,1)-pizda(2,2)
7656         vv(2)=pizda(1,2)+pizda(2,1)
7657         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7658      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7659         if (calc_grad) then
7660 C Explicit gradient in virtual-dihedral angles.
7661         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7662      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7663      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7664         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7665         vv(1)=pizda(1,1)-pizda(2,2)
7666         vv(2)=pizda(1,2)+pizda(2,1)
7667         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7668      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7669      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7670         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7671         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7672         vv(1)=pizda(1,1)-pizda(2,2)
7673         vv(2)=pizda(1,2)+pizda(2,1)
7674         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7675      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7676      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7677 C Cartesian gradient
7678         do iii=1,2
7679           do kkk=1,5
7680             do lll=1,3
7681               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7682      &          pizda(1,1))
7683               vv(1)=pizda(1,1)-pizda(2,2)
7684               vv(2)=pizda(1,2)+pizda(2,1)
7685               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7686      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7687      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7688             enddo
7689           enddo
7690         enddo
7691 cd        goto 1112
7692         endif
7693 C Contribution from graph IV
7694 cd1110    continue
7695         call transpose2(EE(1,1,itl),auxmat(1,1))
7696         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7697         vv(1)=pizda(1,1)+pizda(2,2)
7698         vv(2)=pizda(2,1)-pizda(1,2)
7699         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7700      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7701         if (calc_grad) then
7702 C Explicit gradient in virtual-dihedral angles.
7703         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7704      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7705         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7706         vv(1)=pizda(1,1)+pizda(2,2)
7707         vv(2)=pizda(2,1)-pizda(1,2)
7708         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7709      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7710      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7711 C Cartesian gradient
7712         do iii=1,2
7713           do kkk=1,5
7714             do lll=1,3
7715               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7716      &          pizda(1,1))
7717               vv(1)=pizda(1,1)+pizda(2,2)
7718               vv(2)=pizda(2,1)-pizda(1,2)
7719               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7720      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7721      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7722             enddo
7723           enddo
7724         enddo
7725         endif
7726       else
7727 C Antiparallel orientation
7728 C Contribution from graph III
7729 c        goto 1110
7730         call transpose2(EUg(1,1,j),auxmat(1,1))
7731         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7732         vv(1)=pizda(1,1)-pizda(2,2)
7733         vv(2)=pizda(1,2)+pizda(2,1)
7734         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7735      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7736         if (calc_grad) then
7737 C Explicit gradient in virtual-dihedral angles.
7738         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7739      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7740      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7741         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7742         vv(1)=pizda(1,1)-pizda(2,2)
7743         vv(2)=pizda(1,2)+pizda(2,1)
7744         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7745      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7746      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7747         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7748         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7749         vv(1)=pizda(1,1)-pizda(2,2)
7750         vv(2)=pizda(1,2)+pizda(2,1)
7751         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7752      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7753      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7754 C Cartesian gradient
7755         do iii=1,2
7756           do kkk=1,5
7757             do lll=1,3
7758               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7759      &          pizda(1,1))
7760               vv(1)=pizda(1,1)-pizda(2,2)
7761               vv(2)=pizda(1,2)+pizda(2,1)
7762               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7763      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7764      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7765             enddo
7766           enddo
7767         enddo
7768 cd        goto 1112
7769         endif
7770 C Contribution from graph IV
7771 1110    continue
7772         call transpose2(EE(1,1,itj),auxmat(1,1))
7773         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7774         vv(1)=pizda(1,1)+pizda(2,2)
7775         vv(2)=pizda(2,1)-pizda(1,2)
7776         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7777      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7778         if (calc_grad) then
7779 C Explicit gradient in virtual-dihedral angles.
7780         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7781      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7782         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7783         vv(1)=pizda(1,1)+pizda(2,2)
7784         vv(2)=pizda(2,1)-pizda(1,2)
7785         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7786      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7787      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7788 C Cartesian gradient
7789         do iii=1,2
7790           do kkk=1,5
7791             do lll=1,3
7792               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7793      &          pizda(1,1))
7794               vv(1)=pizda(1,1)+pizda(2,2)
7795               vv(2)=pizda(2,1)-pizda(1,2)
7796               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7797      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7798      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7799             enddo
7800           enddo
7801         enddo
7802       endif
7803       endif
7804 1112  continue
7805       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7806 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7807 cd        write (2,*) 'ijkl',i,j,k,l
7808 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7809 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7810 cd      endif
7811 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7812 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7813 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7814 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7815       if (calc_grad) then
7816       if (j.lt.nres-1) then
7817         j1=j+1
7818         j2=j-1
7819       else
7820         j1=j-1
7821         j2=j-2
7822       endif
7823       if (l.lt.nres-1) then
7824         l1=l+1
7825         l2=l-1
7826       else
7827         l1=l-1
7828         l2=l-2
7829       endif
7830 cd      eij=1.0d0
7831 cd      ekl=1.0d0
7832 cd      ekont=1.0d0
7833 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7834       do ll=1,3
7835         ggg1(ll)=eel5*g_contij(ll,1)
7836         ggg2(ll)=eel5*g_contij(ll,2)
7837 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7838         ghalf=0.5d0*ggg1(ll)
7839 cd        ghalf=0.0d0
7840         gradcorr5(ll,i)=gradcorr5(ll,i)+ghalf+ekont*derx(ll,2,1)
7841         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7842         gradcorr5(ll,j)=gradcorr5(ll,j)+ghalf+ekont*derx(ll,4,1)
7843         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7844 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7845         ghalf=0.5d0*ggg2(ll)
7846 cd        ghalf=0.0d0
7847         gradcorr5(ll,k)=gradcorr5(ll,k)+ghalf+ekont*derx(ll,2,2)
7848         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7849         gradcorr5(ll,l)=gradcorr5(ll,l)+ghalf+ekont*derx(ll,4,2)
7850         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7851       enddo
7852 cd      goto 1112
7853       do m=i+1,j-1
7854         do ll=1,3
7855 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7856           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7857         enddo
7858       enddo
7859       do m=k+1,l-1
7860         do ll=1,3
7861 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7862           gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7863         enddo
7864       enddo
7865 c1112  continue
7866       do m=i+2,j2
7867         do ll=1,3
7868           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7869         enddo
7870       enddo
7871       do m=k+2,l2
7872         do ll=1,3
7873           gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7874         enddo
7875       enddo
7876 cd      do iii=1,nres-3
7877 cd        write (2,*) iii,g_corr5_loc(iii)
7878 cd      enddo
7879       endif
7880       eello5=ekont*eel5
7881 cd      write (2,*) 'ekont',ekont
7882 cd      write (iout,*) 'eello5',ekont*eel5
7883       return
7884       end
7885 c--------------------------------------------------------------------------
7886       double precision function eello6(i,j,k,l,jj,kk)
7887       implicit real*8 (a-h,o-z)
7888       include 'DIMENSIONS'
7889       include 'sizesclu.dat'
7890       include 'COMMON.IOUNITS'
7891       include 'COMMON.CHAIN'
7892       include 'COMMON.DERIV'
7893       include 'COMMON.INTERACT'
7894       include 'COMMON.CONTACTS'
7895       include 'COMMON.TORSION'
7896       include 'COMMON.VAR'
7897       include 'COMMON.GEO'
7898       include 'COMMON.FFIELD'
7899       double precision ggg1(3),ggg2(3)
7900 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7901 cd        eello6=0.0d0
7902 cd        return
7903 cd      endif
7904 cd      write (iout,*)
7905 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7906 cd     &   ' and',k,l
7907       eello6_1=0.0d0
7908       eello6_2=0.0d0
7909       eello6_3=0.0d0
7910       eello6_4=0.0d0
7911       eello6_5=0.0d0
7912       eello6_6=0.0d0
7913 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7914 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7915       do iii=1,2
7916         do kkk=1,5
7917           do lll=1,3
7918             derx(lll,kkk,iii)=0.0d0
7919           enddo
7920         enddo
7921       enddo
7922 cd      eij=facont_hb(jj,i)
7923 cd      ekl=facont_hb(kk,k)
7924 cd      ekont=eij*ekl
7925 cd      eij=1.0d0
7926 cd      ekl=1.0d0
7927 cd      ekont=1.0d0
7928       if (l.eq.j+1) then
7929         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7930         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7931         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7932         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7933         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7934         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7935       else
7936         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7937         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7938         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7939         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7940         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7941           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7942         else
7943           eello6_5=0.0d0
7944         endif
7945         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7946       endif
7947 C If turn contributions are considered, they will be handled separately.
7948       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7949 cd      write(iout,*) 'eello6_1',eello6_1,' eel6_1_num',16*eel6_1_num
7950 cd      write(iout,*) 'eello6_2',eello6_2,' eel6_2_num',16*eel6_2_num
7951 cd      write(iout,*) 'eello6_3',eello6_3,' eel6_3_num',16*eel6_3_num
7952 cd      write(iout,*) 'eello6_4',eello6_4,' eel6_4_num',16*eel6_4_num
7953 cd      write(iout,*) 'eello6_5',eello6_5,' eel6_5_num',16*eel6_5_num
7954 cd      write(iout,*) 'eello6_6',eello6_6,' eel6_6_num',16*eel6_6_num
7955 cd      goto 1112
7956       if (calc_grad) then
7957       if (j.lt.nres-1) then
7958         j1=j+1
7959         j2=j-1
7960       else
7961         j1=j-1
7962         j2=j-2
7963       endif
7964       if (l.lt.nres-1) then
7965         l1=l+1
7966         l2=l-1
7967       else
7968         l1=l-1
7969         l2=l-2
7970       endif
7971       do ll=1,3
7972         ggg1(ll)=eel6*g_contij(ll,1)
7973         ggg2(ll)=eel6*g_contij(ll,2)
7974 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7975         ghalf=0.5d0*ggg1(ll)
7976 cd        ghalf=0.0d0
7977         gradcorr6(ll,i)=gradcorr6(ll,i)+ghalf+ekont*derx(ll,2,1)
7978         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7979         gradcorr6(ll,j)=gradcorr6(ll,j)+ghalf+ekont*derx(ll,4,1)
7980         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7981         ghalf=0.5d0*ggg2(ll)
7982 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7983 cd        ghalf=0.0d0
7984         gradcorr6(ll,k)=gradcorr6(ll,k)+ghalf+ekont*derx(ll,2,2)
7985         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7986         gradcorr6(ll,l)=gradcorr6(ll,l)+ghalf+ekont*derx(ll,4,2)
7987         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7988       enddo
7989 cd      goto 1112
7990       do m=i+1,j-1
7991         do ll=1,3
7992 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7993           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7994         enddo
7995       enddo
7996       do m=k+1,l-1
7997         do ll=1,3
7998 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7999           gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8000         enddo
8001       enddo
8002 1112  continue
8003       do m=i+2,j2
8004         do ll=1,3
8005           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8006         enddo
8007       enddo
8008       do m=k+2,l2
8009         do ll=1,3
8010           gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8011         enddo
8012       enddo
8013 cd      do iii=1,nres-3
8014 cd        write (2,*) iii,g_corr6_loc(iii)
8015 cd      enddo
8016       endif
8017       eello6=ekont*eel6
8018 cd      write (2,*) 'ekont',ekont
8019 cd      write (iout,*) 'eello6',ekont*eel6
8020       return
8021       end
8022 c--------------------------------------------------------------------------
8023       double precision function eello6_graph1(i,j,k,l,imat,swap)
8024       implicit real*8 (a-h,o-z)
8025       include 'DIMENSIONS'
8026       include 'sizesclu.dat'
8027       include 'COMMON.IOUNITS'
8028       include 'COMMON.CHAIN'
8029       include 'COMMON.DERIV'
8030       include 'COMMON.INTERACT'
8031       include 'COMMON.CONTACTS'
8032       include 'COMMON.TORSION'
8033       include 'COMMON.VAR'
8034       include 'COMMON.GEO'
8035       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8036       logical swap
8037       logical lprn
8038       common /kutas/ lprn
8039 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8040 C                                                                              C
8041 C      Parallel       Antiparallel                                             C
8042 C                                                                              C
8043 C          o             o                                                     C
8044 C         /l\           /j\                                                    C
8045 C        /   \         /   \                                                   C
8046 C       /| o |         | o |\                                                  C
8047 C     \ j|/k\|  /   \  |/k\|l /                                                C
8048 C      \ /   \ /     \ /   \ /                                                 C
8049 C       o     o       o     o                                                  C
8050 C       i             i                                                        C
8051 C                                                                              C
8052 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8053       itk=itortyp(itype(k))
8054       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8055       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8056       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8057       call transpose2(EUgC(1,1,k),auxmat(1,1))
8058       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8059       vv1(1)=pizda1(1,1)-pizda1(2,2)
8060       vv1(2)=pizda1(1,2)+pizda1(2,1)
8061       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8062       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8063       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8064       s5=scalar2(vv(1),Dtobr2(1,i))
8065 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8066       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8067       if (.not. calc_grad) return
8068       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8069      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8070      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8071      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8072      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8073      & +scalar2(vv(1),Dtobr2der(1,i)))
8074       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8075       vv1(1)=pizda1(1,1)-pizda1(2,2)
8076       vv1(2)=pizda1(1,2)+pizda1(2,1)
8077       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8078       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8079       if (l.eq.j+1) then
8080         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8081      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8082      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8083      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8084      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8085       else
8086         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8087      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8088      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8089      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8090      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8091       endif
8092       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8093       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8094       vv1(1)=pizda1(1,1)-pizda1(2,2)
8095       vv1(2)=pizda1(1,2)+pizda1(2,1)
8096       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8097      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8098      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8099      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8100       do iii=1,2
8101         if (swap) then
8102           ind=3-iii
8103         else
8104           ind=iii
8105         endif
8106         do kkk=1,5
8107           do lll=1,3
8108             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8109             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8110             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8111             call transpose2(EUgC(1,1,k),auxmat(1,1))
8112             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8113      &        pizda1(1,1))
8114             vv1(1)=pizda1(1,1)-pizda1(2,2)
8115             vv1(2)=pizda1(1,2)+pizda1(2,1)
8116             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8117             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8118      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8119             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8120      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8121             s5=scalar2(vv(1),Dtobr2(1,i))
8122             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8123           enddo
8124         enddo
8125       enddo
8126       return
8127       end
8128 c----------------------------------------------------------------------------
8129       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8130       implicit real*8 (a-h,o-z)
8131       include 'DIMENSIONS'
8132       include 'sizesclu.dat'
8133       include 'COMMON.IOUNITS'
8134       include 'COMMON.CHAIN'
8135       include 'COMMON.DERIV'
8136       include 'COMMON.INTERACT'
8137       include 'COMMON.CONTACTS'
8138       include 'COMMON.TORSION'
8139       include 'COMMON.VAR'
8140       include 'COMMON.GEO'
8141       logical swap
8142       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8143      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8144       logical lprn
8145       common /kutas/ lprn
8146 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8147 C                                                                              C
8148 C      Parallel       Antiparallel                                             C
8149 C                                                                              C
8150 C          o             o                                                     C
8151 C     \   /l\           /j\   /                                                C
8152 C      \ /   \         /   \ /                                                 C
8153 C       o| o |         | o |o                                                  C
8154 C     \ j|/k\|      \  |/k\|l                                                  C
8155 C      \ /   \       \ /   \                                                   C
8156 C       o             o                                                        C
8157 C       i             i                                                        C
8158 C                                                                              C
8159 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8160 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8161 C AL 7/4/01 s1 would occur in the sixth-order moment,
8162 C           but not in a cluster cumulant
8163 #ifdef MOMENT
8164       s1=dip(1,jj,i)*dip(1,kk,k)
8165 #endif
8166       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8167       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8168       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8169       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8170       call transpose2(EUg(1,1,k),auxmat(1,1))
8171       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8172       vv(1)=pizda(1,1)-pizda(2,2)
8173       vv(2)=pizda(1,2)+pizda(2,1)
8174       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8175 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8176 #ifdef MOMENT
8177       eello6_graph2=-(s1+s2+s3+s4)
8178 #else
8179       eello6_graph2=-(s2+s3+s4)
8180 #endif
8181 c      eello6_graph2=-s3
8182       if (.not. calc_grad) return
8183 C Derivatives in gamma(i-1)
8184       if (i.gt.1) then
8185 #ifdef MOMENT
8186         s1=dipderg(1,jj,i)*dip(1,kk,k)
8187 #endif
8188         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8189         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8190         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8191         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8192 #ifdef MOMENT
8193         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8194 #else
8195         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8196 #endif
8197 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8198       endif
8199 C Derivatives in gamma(k-1)
8200 #ifdef MOMENT
8201       s1=dip(1,jj,i)*dipderg(1,kk,k)
8202 #endif
8203       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8204       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8205       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8206       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8207       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8208       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8209       vv(1)=pizda(1,1)-pizda(2,2)
8210       vv(2)=pizda(1,2)+pizda(2,1)
8211       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8212 #ifdef MOMENT
8213       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8214 #else
8215       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8216 #endif
8217 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8218 C Derivatives in gamma(j-1) or gamma(l-1)
8219       if (j.gt.1) then
8220 #ifdef MOMENT
8221         s1=dipderg(3,jj,i)*dip(1,kk,k)
8222 #endif
8223         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8224         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8225         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8226         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8227         vv(1)=pizda(1,1)-pizda(2,2)
8228         vv(2)=pizda(1,2)+pizda(2,1)
8229         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8230 #ifdef MOMENT
8231         if (swap) then
8232           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8233         else
8234           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8235         endif
8236 #endif
8237         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8238 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8239       endif
8240 C Derivatives in gamma(l-1) or gamma(j-1)
8241       if (l.gt.1) then
8242 #ifdef MOMENT
8243         s1=dip(1,jj,i)*dipderg(3,kk,k)
8244 #endif
8245         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8246         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8247         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8248         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8249         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8250         vv(1)=pizda(1,1)-pizda(2,2)
8251         vv(2)=pizda(1,2)+pizda(2,1)
8252         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8253 #ifdef MOMENT
8254         if (swap) then
8255           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8256         else
8257           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8258         endif
8259 #endif
8260         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8261 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8262       endif
8263 C Cartesian derivatives.
8264       if (lprn) then
8265         write (2,*) 'In eello6_graph2'
8266         do iii=1,2
8267           write (2,*) 'iii=',iii
8268           do kkk=1,5
8269             write (2,*) 'kkk=',kkk
8270             do jjj=1,2
8271               write (2,'(3(2f10.5),5x)')
8272      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8273             enddo
8274           enddo
8275         enddo
8276       endif
8277       do iii=1,2
8278         do kkk=1,5
8279           do lll=1,3
8280 #ifdef MOMENT
8281             if (iii.eq.1) then
8282               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8283             else
8284               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8285             endif
8286 #endif
8287             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8288      &        auxvec(1))
8289             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8290             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8291      &        auxvec(1))
8292             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8293             call transpose2(EUg(1,1,k),auxmat(1,1))
8294             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8295      &        pizda(1,1))
8296             vv(1)=pizda(1,1)-pizda(2,2)
8297             vv(2)=pizda(1,2)+pizda(2,1)
8298             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8299 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8300 #ifdef MOMENT
8301             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8302 #else
8303             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8304 #endif
8305             if (swap) then
8306               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8307             else
8308               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8309             endif
8310           enddo
8311         enddo
8312       enddo
8313       return
8314       end
8315 c----------------------------------------------------------------------------
8316       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8317       implicit real*8 (a-h,o-z)
8318       include 'DIMENSIONS'
8319       include 'sizesclu.dat'
8320       include 'COMMON.IOUNITS'
8321       include 'COMMON.CHAIN'
8322       include 'COMMON.DERIV'
8323       include 'COMMON.INTERACT'
8324       include 'COMMON.CONTACTS'
8325       include 'COMMON.TORSION'
8326       include 'COMMON.VAR'
8327       include 'COMMON.GEO'
8328       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8329       logical swap
8330 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8331 C                                                                              C
8332 C      Parallel       Antiparallel                                             C
8333 C                                                                              C
8334 C          o             o                                                     C
8335 C         /l\   /   \   /j\                                                    C
8336 C        /   \ /     \ /   \                                                   C
8337 C       /| o |o       o| o |\                                                  C
8338 C       j|/k\|  /      |/k\|l /                                                C
8339 C        /   \ /       /   \ /                                                 C
8340 C       /     o       /     o                                                  C
8341 C       i             i                                                        C
8342 C                                                                              C
8343 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8344 C
8345 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8346 C           energy moment and not to the cluster cumulant.
8347       iti=itortyp(itype(i))
8348 c      if (j.lt.nres-1) then
8349       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
8350         itj1=itortyp(itype(j+1))
8351       else
8352         itj1=ntortyp+1
8353       endif
8354       itk=itortyp(itype(k))
8355       itk1=itortyp(itype(k+1))
8356 c      if (l.lt.nres-1) then
8357       if (l.lt.nres-1 .and. itype(l+1).le.ntyp) then
8358         itl1=itortyp(itype(l+1))
8359       else
8360         itl1=ntortyp+1
8361       endif
8362 #ifdef MOMENT
8363       s1=dip(4,jj,i)*dip(4,kk,k)
8364 #endif
8365       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8366       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8367       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8368       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8369       call transpose2(EE(1,1,itk),auxmat(1,1))
8370       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8371       vv(1)=pizda(1,1)+pizda(2,2)
8372       vv(2)=pizda(2,1)-pizda(1,2)
8373       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8374 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8375 #ifdef MOMENT
8376       eello6_graph3=-(s1+s2+s3+s4)
8377 #else
8378       eello6_graph3=-(s2+s3+s4)
8379 #endif
8380 c      eello6_graph3=-s4
8381       if (.not. calc_grad) return
8382 C Derivatives in gamma(k-1)
8383       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8384       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8385       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8386       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8387 C Derivatives in gamma(l-1)
8388       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8389       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8390       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8391       vv(1)=pizda(1,1)+pizda(2,2)
8392       vv(2)=pizda(2,1)-pizda(1,2)
8393       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8394       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8395 C Cartesian derivatives.
8396       do iii=1,2
8397         do kkk=1,5
8398           do lll=1,3
8399 #ifdef MOMENT
8400             if (iii.eq.1) then
8401               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8402             else
8403               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8404             endif
8405 #endif
8406             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8407      &        auxvec(1))
8408             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8409             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8410      &        auxvec(1))
8411             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8412             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8413      &        pizda(1,1))
8414             vv(1)=pizda(1,1)+pizda(2,2)
8415             vv(2)=pizda(2,1)-pizda(1,2)
8416             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8417 #ifdef MOMENT
8418             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8419 #else
8420             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8421 #endif
8422             if (swap) then
8423               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8424             else
8425               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8426             endif
8427 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8428           enddo
8429         enddo
8430       enddo
8431       return
8432       end
8433 c----------------------------------------------------------------------------
8434       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8435       implicit real*8 (a-h,o-z)
8436       include 'DIMENSIONS'
8437       include 'sizesclu.dat'
8438       include 'COMMON.IOUNITS'
8439       include 'COMMON.CHAIN'
8440       include 'COMMON.DERIV'
8441       include 'COMMON.INTERACT'
8442       include 'COMMON.CONTACTS'
8443       include 'COMMON.TORSION'
8444       include 'COMMON.VAR'
8445       include 'COMMON.GEO'
8446       include 'COMMON.FFIELD'
8447       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8448      & auxvec1(2),auxmat1(2,2)
8449       logical swap
8450 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8451 C                                                                              C
8452 C      Parallel       Antiparallel                                             C
8453 C                                                                              C
8454 C          o             o                                                     C
8455 C         /l\   /   \   /j\                                                    C
8456 C        /   \ /     \ /   \                                                   C
8457 C       /| o |o       o| o |\                                                  C
8458 C     \ j|/k\|      \  |/k\|l                                                  C
8459 C      \ /   \       \ /   \                                                   C
8460 C       o     \       o     \                                                  C
8461 C       i             i                                                        C
8462 C                                                                              C
8463 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8464 C
8465 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8466 C           energy moment and not to the cluster cumulant.
8467 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8468       iti=itortyp(itype(i))
8469       itj=itortyp(itype(j))
8470 c      if (j.lt.nres-1) then
8471       if (j.lt.nres-1 .and. itype(j+1).le.ntyp) then
8472         itj1=itortyp(itype(j+1))
8473       else
8474         itj1=ntortyp+1
8475       endif
8476       itk=itortyp(itype(k))
8477 c      if (k.lt.nres-1) then
8478       if (k.lt.nres-1 .and. itype(k+1).le.ntyp) then
8479         itk1=itortyp(itype(k+1))
8480       else
8481         itk1=ntortyp+1
8482       endif
8483       itl=itortyp(itype(l))
8484       if (l.lt.nres-1) then
8485         itl1=itortyp(itype(l+1))
8486       else
8487         itl1=ntortyp+1
8488       endif
8489 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8490 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8491 cd     & ' itl',itl,' itl1',itl1
8492 #ifdef MOMENT
8493       if (imat.eq.1) then
8494         s1=dip(3,jj,i)*dip(3,kk,k)
8495       else
8496         s1=dip(2,jj,j)*dip(2,kk,l)
8497       endif
8498 #endif
8499       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8500       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8501       if (j.eq.l+1) then
8502         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8503         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8504       else
8505         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8506         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8507       endif
8508       call transpose2(EUg(1,1,k),auxmat(1,1))
8509       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8510       vv(1)=pizda(1,1)-pizda(2,2)
8511       vv(2)=pizda(2,1)+pizda(1,2)
8512       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8513 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8514 #ifdef MOMENT
8515       eello6_graph4=-(s1+s2+s3+s4)
8516 #else
8517       eello6_graph4=-(s2+s3+s4)
8518 #endif
8519       if (.not. calc_grad) return
8520 C Derivatives in gamma(i-1)
8521       if (i.gt.1) then
8522 #ifdef MOMENT
8523         if (imat.eq.1) then
8524           s1=dipderg(2,jj,i)*dip(3,kk,k)
8525         else
8526           s1=dipderg(4,jj,j)*dip(2,kk,l)
8527         endif
8528 #endif
8529         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8530         if (j.eq.l+1) then
8531           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8532           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8533         else
8534           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8535           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8536         endif
8537         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8538         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8539 cd          write (2,*) 'turn6 derivatives'
8540 #ifdef MOMENT
8541           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8542 #else
8543           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8544 #endif
8545         else
8546 #ifdef MOMENT
8547           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8548 #else
8549           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8550 #endif
8551         endif
8552       endif
8553 C Derivatives in gamma(k-1)
8554 #ifdef MOMENT
8555       if (imat.eq.1) then
8556         s1=dip(3,jj,i)*dipderg(2,kk,k)
8557       else
8558         s1=dip(2,jj,j)*dipderg(4,kk,l)
8559       endif
8560 #endif
8561       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8562       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8563       if (j.eq.l+1) then
8564         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8565         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8566       else
8567         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8568         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8569       endif
8570       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8571       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8572       vv(1)=pizda(1,1)-pizda(2,2)
8573       vv(2)=pizda(2,1)+pizda(1,2)
8574       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8575       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8576 #ifdef MOMENT
8577         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8578 #else
8579         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8580 #endif
8581       else
8582 #ifdef MOMENT
8583         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8584 #else
8585         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8586 #endif
8587       endif
8588 C Derivatives in gamma(j-1) or gamma(l-1)
8589       if (l.eq.j+1 .and. l.gt.1) then
8590         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8591         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8592         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8593         vv(1)=pizda(1,1)-pizda(2,2)
8594         vv(2)=pizda(2,1)+pizda(1,2)
8595         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8596         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8597       else if (j.gt.1) then
8598         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8599         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8600         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8601         vv(1)=pizda(1,1)-pizda(2,2)
8602         vv(2)=pizda(2,1)+pizda(1,2)
8603         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8604         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8605           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8606         else
8607           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8608         endif
8609       endif
8610 C Cartesian derivatives.
8611       do iii=1,2
8612         do kkk=1,5
8613           do lll=1,3
8614 #ifdef MOMENT
8615             if (iii.eq.1) then
8616               if (imat.eq.1) then
8617                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8618               else
8619                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8620               endif
8621             else
8622               if (imat.eq.1) then
8623                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8624               else
8625                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8626               endif
8627             endif
8628 #endif
8629             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8630      &        auxvec(1))
8631             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8632             if (j.eq.l+1) then
8633               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8634      &          b1(1,itj1),auxvec(1))
8635               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8636             else
8637               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8638      &          b1(1,itl1),auxvec(1))
8639               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8640             endif
8641             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8642      &        pizda(1,1))
8643             vv(1)=pizda(1,1)-pizda(2,2)
8644             vv(2)=pizda(2,1)+pizda(1,2)
8645             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8646             if (swap) then
8647               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8648 #ifdef MOMENT
8649                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8650      &             -(s1+s2+s4)
8651 #else
8652                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8653      &             -(s2+s4)
8654 #endif
8655                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8656               else
8657 #ifdef MOMENT
8658                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8659 #else
8660                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8661 #endif
8662                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8663               endif
8664             else
8665 #ifdef MOMENT
8666               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8667 #else
8668               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8669 #endif
8670               if (l.eq.j+1) then
8671                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8672               else
8673                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8674               endif
8675             endif
8676           enddo
8677         enddo
8678       enddo
8679       return
8680       end
8681 c----------------------------------------------------------------------------
8682       double precision function eello_turn6(i,jj,kk)
8683       implicit real*8 (a-h,o-z)
8684       include 'DIMENSIONS'
8685       include 'sizesclu.dat'
8686       include 'COMMON.IOUNITS'
8687       include 'COMMON.CHAIN'
8688       include 'COMMON.DERIV'
8689       include 'COMMON.INTERACT'
8690       include 'COMMON.CONTACTS'
8691       include 'COMMON.TORSION'
8692       include 'COMMON.VAR'
8693       include 'COMMON.GEO'
8694       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8695      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8696      &  ggg1(3),ggg2(3)
8697       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8698      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8699 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8700 C           the respective energy moment and not to the cluster cumulant.
8701       eello_turn6=0.0d0
8702       j=i+4
8703       k=i+1
8704       l=i+3
8705       iti=itortyp(itype(i))
8706       itk=itortyp(itype(k))
8707       itk1=itortyp(itype(k+1))
8708       itl=itortyp(itype(l))
8709       itj=itortyp(itype(j))
8710 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8711 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8712 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8713 cd        eello6=0.0d0
8714 cd        return
8715 cd      endif
8716 cd      write (iout,*)
8717 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8718 cd     &   ' and',k,l
8719 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8720       do iii=1,2
8721         do kkk=1,5
8722           do lll=1,3
8723             derx_turn(lll,kkk,iii)=0.0d0
8724           enddo
8725         enddo
8726       enddo
8727 cd      eij=1.0d0
8728 cd      ekl=1.0d0
8729 cd      ekont=1.0d0
8730       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8731 cd      eello6_5=0.0d0
8732 cd      write (2,*) 'eello6_5',eello6_5
8733 #ifdef MOMENT
8734       call transpose2(AEA(1,1,1),auxmat(1,1))
8735       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8736       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8737       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8738 #else
8739       s1 = 0.0d0
8740 #endif
8741       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8742       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8743       s2 = scalar2(b1(1,itk),vtemp1(1))
8744 #ifdef MOMENT
8745       call transpose2(AEA(1,1,2),atemp(1,1))
8746       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8747       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8748       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8749 #else
8750       s8=0.0d0
8751 #endif
8752       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8753       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8754       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8755 #ifdef MOMENT
8756       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8757       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8758       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8759       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8760       ss13 = scalar2(b1(1,itk),vtemp4(1))
8761       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8762 #else
8763       s13=0.0d0
8764 #endif
8765 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8766 c      s1=0.0d0
8767 c      s2=0.0d0
8768 c      s8=0.0d0
8769 c      s12=0.0d0
8770 c      s13=0.0d0
8771       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8772       if (calc_grad) then
8773 C Derivatives in gamma(i+2)
8774 #ifdef MOMENT
8775       call transpose2(AEA(1,1,1),auxmatd(1,1))
8776       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8777       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8778       call transpose2(AEAderg(1,1,2),atempd(1,1))
8779       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8780       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8781 #else
8782       s8d=0.0d0
8783 #endif
8784       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8785       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8786       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8787 c      s1d=0.0d0
8788 c      s2d=0.0d0
8789 c      s8d=0.0d0
8790 c      s12d=0.0d0
8791 c      s13d=0.0d0
8792       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8793 C Derivatives in gamma(i+3)
8794 #ifdef MOMENT
8795       call transpose2(AEA(1,1,1),auxmatd(1,1))
8796       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8797       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8798       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8799 #else
8800       s1d=0.0d0
8801 #endif
8802       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8803       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8804       s2d = scalar2(b1(1,itk),vtemp1d(1))
8805 #ifdef MOMENT
8806       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8807       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8808 #endif
8809       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8810 #ifdef MOMENT
8811       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8812       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8813       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8814 #else
8815       s13d=0.0d0
8816 #endif
8817 c      s1d=0.0d0
8818 c      s2d=0.0d0
8819 c      s8d=0.0d0
8820 c      s12d=0.0d0
8821 c      s13d=0.0d0
8822 #ifdef MOMENT
8823       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8824      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8825 #else
8826       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8827      &               -0.5d0*ekont*(s2d+s12d)
8828 #endif
8829 C Derivatives in gamma(i+4)
8830       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8831       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8832       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8833 #ifdef MOMENT
8834       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8835       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8836       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8837 #else
8838       s13d = 0.0d0
8839 #endif
8840 c      s1d=0.0d0
8841 c      s2d=0.0d0
8842 c      s8d=0.0d0
8843 C      s12d=0.0d0
8844 c      s13d=0.0d0
8845 #ifdef MOMENT
8846       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8847 #else
8848       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8849 #endif
8850 C Derivatives in gamma(i+5)
8851 #ifdef MOMENT
8852       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8853       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8854       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8855 #else
8856       s1d = 0.0d0
8857 #endif
8858       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8859       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8860       s2d = scalar2(b1(1,itk),vtemp1d(1))
8861 #ifdef MOMENT
8862       call transpose2(AEA(1,1,2),atempd(1,1))
8863       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8864       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8865 #else
8866       s8d = 0.0d0
8867 #endif
8868       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8869       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8870 #ifdef MOMENT
8871       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8872       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8873       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8874 #else
8875       s13d = 0.0d0
8876 #endif
8877 c      s1d=0.0d0
8878 c      s2d=0.0d0
8879 c      s8d=0.0d0
8880 c      s12d=0.0d0
8881 c      s13d=0.0d0
8882 #ifdef MOMENT
8883       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8884      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8885 #else
8886       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8887      &               -0.5d0*ekont*(s2d+s12d)
8888 #endif
8889 C Cartesian derivatives
8890       do iii=1,2
8891         do kkk=1,5
8892           do lll=1,3
8893 #ifdef MOMENT
8894             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8895             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8896             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8897 #else
8898             s1d = 0.0d0
8899 #endif
8900             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8901             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8902      &          vtemp1d(1))
8903             s2d = scalar2(b1(1,itk),vtemp1d(1))
8904 #ifdef MOMENT
8905             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8906             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8907             s8d = -(atempd(1,1)+atempd(2,2))*
8908      &           scalar2(cc(1,1,itl),vtemp2(1))
8909 #else
8910             s8d = 0.0d0
8911 #endif
8912             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8913      &           auxmatd(1,1))
8914             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8915             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8916 c      s1d=0.0d0
8917 c      s2d=0.0d0
8918 c      s8d=0.0d0
8919 c      s12d=0.0d0
8920 c      s13d=0.0d0
8921 #ifdef MOMENT
8922             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8923      &        - 0.5d0*(s1d+s2d)
8924 #else
8925             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8926      &        - 0.5d0*s2d
8927 #endif
8928 #ifdef MOMENT
8929             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8930      &        - 0.5d0*(s8d+s12d)
8931 #else
8932             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8933      &        - 0.5d0*s12d
8934 #endif
8935           enddo
8936         enddo
8937       enddo
8938 #ifdef MOMENT
8939       do kkk=1,5
8940         do lll=1,3
8941           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8942      &      achuj_tempd(1,1))
8943           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8944           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8945           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8946           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8947           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8948      &      vtemp4d(1))
8949           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8950           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8951           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8952         enddo
8953       enddo
8954 #endif
8955 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8956 cd     &  16*eel_turn6_num
8957 cd      goto 1112
8958       if (j.lt.nres-1) then
8959         j1=j+1
8960         j2=j-1
8961       else
8962         j1=j-1
8963         j2=j-2
8964       endif
8965       if (l.lt.nres-1) then
8966         l1=l+1
8967         l2=l-1
8968       else
8969         l1=l-1
8970         l2=l-2
8971       endif
8972       do ll=1,3
8973         ggg1(ll)=eel_turn6*g_contij(ll,1)
8974         ggg2(ll)=eel_turn6*g_contij(ll,2)
8975         ghalf=0.5d0*ggg1(ll)
8976 cd        ghalf=0.0d0
8977         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)+ghalf
8978      &    +ekont*derx_turn(ll,2,1)
8979         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8980         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)+ghalf
8981      &    +ekont*derx_turn(ll,4,1)
8982         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8983         ghalf=0.5d0*ggg2(ll)
8984 cd        ghalf=0.0d0
8985         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)+ghalf
8986      &    +ekont*derx_turn(ll,2,2)
8987         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8988         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)+ghalf
8989      &    +ekont*derx_turn(ll,4,2)
8990         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8991       enddo
8992 cd      goto 1112
8993       do m=i+1,j-1
8994         do ll=1,3
8995           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8996         enddo
8997       enddo
8998       do m=k+1,l-1
8999         do ll=1,3
9000           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9001         enddo
9002       enddo
9003 1112  continue
9004       do m=i+2,j2
9005         do ll=1,3
9006           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9007         enddo
9008       enddo
9009       do m=k+2,l2
9010         do ll=1,3
9011           gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9012         enddo
9013       enddo
9014 cd      do iii=1,nres-3
9015 cd        write (2,*) iii,g_corr6_loc(iii)
9016 cd      enddo
9017       endif
9018       eello_turn6=ekont*eel_turn6
9019 cd      write (2,*) 'ekont',ekont
9020 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9021       return
9022       end
9023 crc-------------------------------------------------
9024       SUBROUTINE MATVEC2(A1,V1,V2)
9025       implicit real*8 (a-h,o-z)
9026       include 'DIMENSIONS'
9027       DIMENSION A1(2,2),V1(2),V2(2)
9028 c      DO 1 I=1,2
9029 c        VI=0.0
9030 c        DO 3 K=1,2
9031 c    3     VI=VI+A1(I,K)*V1(K)
9032 c        Vaux(I)=VI
9033 c    1 CONTINUE
9034
9035       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9036       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9037
9038       v2(1)=vaux1
9039       v2(2)=vaux2
9040       END
9041 C---------------------------------------
9042       SUBROUTINE MATMAT2(A1,A2,A3)
9043       implicit real*8 (a-h,o-z)
9044       include 'DIMENSIONS'
9045       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9046 c      DIMENSION AI3(2,2)
9047 c        DO  J=1,2
9048 c          A3IJ=0.0
9049 c          DO K=1,2
9050 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9051 c          enddo
9052 c          A3(I,J)=A3IJ
9053 c       enddo
9054 c      enddo
9055
9056       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9057       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9058       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9059       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9060
9061       A3(1,1)=AI3_11
9062       A3(2,1)=AI3_21
9063       A3(1,2)=AI3_12
9064       A3(2,2)=AI3_22
9065       END
9066
9067 c-------------------------------------------------------------------------
9068       double precision function scalar2(u,v)
9069       implicit none
9070       double precision u(2),v(2)
9071       double precision sc
9072       integer i
9073       scalar2=u(1)*v(1)+u(2)*v(2)
9074       return
9075       end
9076
9077 C-----------------------------------------------------------------------------
9078
9079       subroutine transpose2(a,at)
9080       implicit none
9081       double precision a(2,2),at(2,2)
9082       at(1,1)=a(1,1)
9083       at(1,2)=a(2,1)
9084       at(2,1)=a(1,2)
9085       at(2,2)=a(2,2)
9086       return
9087       end
9088 c--------------------------------------------------------------------------
9089       subroutine transpose(n,a,at)
9090       implicit none
9091       integer n,i,j
9092       double precision a(n,n),at(n,n)
9093       do i=1,n
9094         do j=1,n
9095           at(j,i)=a(i,j)
9096         enddo
9097       enddo
9098       return
9099       end
9100 C---------------------------------------------------------------------------
9101       subroutine prodmat3(a1,a2,kk,transp,prod)
9102       implicit none
9103       integer i,j
9104       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9105       logical transp
9106 crc      double precision auxmat(2,2),prod_(2,2)
9107
9108       if (transp) then
9109 crc        call transpose2(kk(1,1),auxmat(1,1))
9110 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9111 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9112
9113            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9114      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9115            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9116      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9117            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9118      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9119            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9120      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9121
9122       else
9123 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9124 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9125
9126            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9127      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9128            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9129      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9130            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9131      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9132            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9133      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9134
9135       endif
9136 c      call transpose2(a2(1,1),a2t(1,1))
9137
9138 crc      print *,transp
9139 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9140 crc      print *,((prod(i,j),i=1,2),j=1,2)
9141
9142       return
9143       end
9144 C-----------------------------------------------------------------------------
9145       double precision function scalar(u,v)
9146       implicit none
9147       double precision u(3),v(3)
9148       double precision sc
9149       integer i
9150       sc=0.0d0
9151       do i=1,3
9152         sc=sc+u(i)*v(i)
9153       enddo
9154       scalar=sc
9155       return
9156       end
9157 C-----------------------------------------------------------------------
9158       double precision function sscale(r)
9159       double precision r,gamm
9160       include "COMMON.SPLITELE"
9161       if(r.lt.r_cut-rlamb) then
9162         sscale=1.0d0
9163       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9164         gamm=(r-(r_cut-rlamb))/rlamb
9165         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9166       else
9167         sscale=0d0
9168       endif
9169       return
9170       end
9171 C-----------------------------------------------------------------------
9172 C-----------------------------------------------------------------------
9173       double precision function sscagrad(r)
9174       double precision r,gamm
9175       include "COMMON.SPLITELE"
9176       if(r.lt.r_cut-rlamb) then
9177         sscagrad=0.0d0
9178       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9179         gamm=(r-(r_cut-rlamb))/rlamb
9180         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9181       else
9182         sscagrad=0.0d0
9183       endif
9184       return
9185       end
9186 C-----------------------------------------------------------------------
9187 C first for shielding is setting of function of side-chains
9188        subroutine set_shield_fac2
9189       implicit real*8 (a-h,o-z)
9190       include 'DIMENSIONS'
9191       include 'COMMON.CHAIN'
9192       include 'COMMON.DERIV'
9193       include 'COMMON.IOUNITS'
9194       include 'COMMON.SHIELD'
9195       include 'COMMON.INTERACT'
9196 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9197       double precision div77_81/0.974996043d0/,
9198      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9199
9200 C the vector between center of side_chain and peptide group
9201        double precision pep_side(3),long,side_calf(3),
9202      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9203      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9204 C the line belowe needs to be changed for FGPROC>1
9205       do i=1,nres-1
9206       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9207       ishield_list(i)=0
9208 Cif there two consequtive dummy atoms there is no peptide group between them
9209 C the line below has to be changed for FGPROC>1
9210       VolumeTotal=0.0
9211       do k=1,nres
9212        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9213        dist_pep_side=0.0
9214        dist_side_calf=0.0
9215        do j=1,3
9216 C first lets set vector conecting the ithe side-chain with kth side-chain
9217       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9218 C      pep_side(j)=2.0d0
9219 C and vector conecting the side-chain with its proper calfa
9220       side_calf(j)=c(j,k+nres)-c(j,k)
9221 C      side_calf(j)=2.0d0
9222       pept_group(j)=c(j,i)-c(j,i+1)
9223 C lets have their lenght
9224       dist_pep_side=pep_side(j)**2+dist_pep_side
9225       dist_side_calf=dist_side_calf+side_calf(j)**2
9226       dist_pept_group=dist_pept_group+pept_group(j)**2
9227       enddo
9228        dist_pep_side=dsqrt(dist_pep_side)
9229        dist_pept_group=dsqrt(dist_pept_group)
9230        dist_side_calf=dsqrt(dist_side_calf)
9231       do j=1,3
9232         pep_side_norm(j)=pep_side(j)/dist_pep_side
9233         side_calf_norm(j)=dist_side_calf
9234       enddo
9235 C now sscale fraction
9236        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9237 C       print *,buff_shield,"buff"
9238 C now sscale
9239         if (sh_frac_dist.le.0.0) cycle
9240 C If we reach here it means that this side chain reaches the shielding sphere
9241 C Lets add him to the list for gradient
9242         ishield_list(i)=ishield_list(i)+1
9243 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9244 C this list is essential otherwise problem would be O3
9245         shield_list(ishield_list(i),i)=k
9246 C Lets have the sscale value
9247         if (sh_frac_dist.gt.1.0) then
9248          scale_fac_dist=1.0d0
9249          do j=1,3
9250          sh_frac_dist_grad(j)=0.0d0
9251          enddo
9252         else
9253          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9254      &                   *(2.0d0*sh_frac_dist-3.0d0)
9255          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9256      &                  /dist_pep_side/buff_shield*0.5d0
9257 C remember for the final gradient multiply sh_frac_dist_grad(j)
9258 C for side_chain by factor -2 !
9259          do j=1,3
9260          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9261 C         sh_frac_dist_grad(j)=0.0d0
9262 C         scale_fac_dist=1.0d0
9263 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9264 C     &                    sh_frac_dist_grad(j)
9265          enddo
9266         endif
9267 C this is what is now we have the distance scaling now volume...
9268       short=short_r_sidechain(itype(k))
9269       long=long_r_sidechain(itype(k))
9270       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9271       sinthet=short/dist_pep_side*costhet
9272 C now costhet_grad
9273 C       costhet=0.6d0
9274 C       sinthet=0.8
9275        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9276 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9277 C     &             -short/dist_pep_side**2/costhet)
9278 C       costhet_fac=0.0d0
9279        do j=1,3
9280          costhet_grad(j)=costhet_fac*pep_side(j)
9281        enddo
9282 C remember for the final gradient multiply costhet_grad(j)
9283 C for side_chain by factor -2 !
9284 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9285 C pep_side0pept_group is vector multiplication
9286       pep_side0pept_group=0.0d0
9287       do j=1,3
9288       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9289       enddo
9290       cosalfa=(pep_side0pept_group/
9291      & (dist_pep_side*dist_side_calf))
9292       fac_alfa_sin=1.0d0-cosalfa**2
9293       fac_alfa_sin=dsqrt(fac_alfa_sin)
9294       rkprim=fac_alfa_sin*(long-short)+short
9295 C      rkprim=short
9296
9297 C now costhet_grad
9298        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9299 C       cosphi=0.6
9300        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9301        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9302      &      dist_pep_side**2)
9303 C       sinphi=0.8
9304        do j=1,3
9305          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9306      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9307      &*(long-short)/fac_alfa_sin*cosalfa/
9308      &((dist_pep_side*dist_side_calf))*
9309      &((side_calf(j))-cosalfa*
9310      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9311 C       cosphi_grad_long(j)=0.0d0
9312         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9313      &*(long-short)/fac_alfa_sin*cosalfa
9314      &/((dist_pep_side*dist_side_calf))*
9315      &(pep_side(j)-
9316      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9317 C       cosphi_grad_loc(j)=0.0d0
9318        enddo
9319 C      print *,sinphi,sinthet
9320       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9321      &                    /VSolvSphere_div
9322 C     &                    *wshield
9323 C now the gradient...
9324       do j=1,3
9325       grad_shield(j,i)=grad_shield(j,i)
9326 C gradient po skalowaniu
9327      &                +(sh_frac_dist_grad(j)*VofOverlap
9328 C  gradient po costhet
9329      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9330      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9331      &       sinphi/sinthet*costhet*costhet_grad(j)
9332      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9333      & )*wshield
9334 C grad_shield_side is Cbeta sidechain gradient
9335       grad_shield_side(j,ishield_list(i),i)=
9336      &        (sh_frac_dist_grad(j)*-2.0d0
9337      &        *VofOverlap
9338      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9339      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9340      &       sinphi/sinthet*costhet*costhet_grad(j)
9341      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9342      &       )*wshield
9343
9344        grad_shield_loc(j,ishield_list(i),i)=
9345      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9346      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9347      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9348      &        ))
9349      &        *wshield
9350       enddo
9351       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9352       enddo
9353       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9354 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9355       enddo
9356       return
9357       end
9358 C first for shielding is setting of function of side-chains
9359        subroutine set_shield_fac
9360       implicit real*8 (a-h,o-z)
9361       include 'DIMENSIONS'
9362       include 'COMMON.CHAIN'
9363       include 'COMMON.DERIV'
9364       include 'COMMON.IOUNITS'
9365       include 'COMMON.SHIELD'
9366       include 'COMMON.INTERACT'
9367 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9368       double precision div77_81/0.974996043d0/,
9369      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9370
9371 C the vector between center of side_chain and peptide group
9372        double precision pep_side(3),long,side_calf(3),
9373      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9374      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9375 C the line belowe needs to be changed for FGPROC>1
9376       do i=1,nres-1
9377       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9378       ishield_list(i)=0
9379 Cif there two consequtive dummy atoms there is no peptide group between them
9380 C the line below has to be changed for FGPROC>1
9381       VolumeTotal=0.0
9382       do k=1,nres
9383        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9384        dist_pep_side=0.0
9385        dist_side_calf=0.0
9386        do j=1,3
9387 C first lets set vector conecting the ithe side-chain with kth side-chain
9388       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9389 C      pep_side(j)=2.0d0
9390 C and vector conecting the side-chain with its proper calfa
9391       side_calf(j)=c(j,k+nres)-c(j,k)
9392 C      side_calf(j)=2.0d0
9393       pept_group(j)=c(j,i)-c(j,i+1)
9394 C lets have their lenght
9395       dist_pep_side=pep_side(j)**2+dist_pep_side
9396       dist_side_calf=dist_side_calf+side_calf(j)**2
9397       dist_pept_group=dist_pept_group+pept_group(j)**2
9398       enddo
9399        dist_pep_side=dsqrt(dist_pep_side)
9400        dist_pept_group=dsqrt(dist_pept_group)
9401        dist_side_calf=dsqrt(dist_side_calf)
9402       do j=1,3
9403         pep_side_norm(j)=pep_side(j)/dist_pep_side
9404         side_calf_norm(j)=dist_side_calf
9405       enddo
9406 C now sscale fraction
9407        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9408 C       print *,buff_shield,"buff"
9409 C now sscale
9410         if (sh_frac_dist.le.0.0) cycle
9411 C If we reach here it means that this side chain reaches the shielding sphere
9412 C Lets add him to the list for gradient
9413         ishield_list(i)=ishield_list(i)+1
9414 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9415 C this list is essential otherwise problem would be O3
9416         shield_list(ishield_list(i),i)=k
9417 C Lets have the sscale value
9418         if (sh_frac_dist.gt.1.0) then
9419          scale_fac_dist=1.0d0
9420          do j=1,3
9421          sh_frac_dist_grad(j)=0.0d0
9422          enddo
9423         else
9424          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9425      &                   *(2.0*sh_frac_dist-3.0d0)
9426          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9427      &                  /dist_pep_side/buff_shield*0.5
9428 C remember for the final gradient multiply sh_frac_dist_grad(j)
9429 C for side_chain by factor -2 !
9430          do j=1,3
9431          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9432 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9433 C     &                    sh_frac_dist_grad(j)
9434          enddo
9435         endif
9436 C        if ((i.eq.3).and.(k.eq.2)) then
9437 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9438 C     & ,"TU"
9439 C        endif
9440
9441 C this is what is now we have the distance scaling now volume...
9442       short=short_r_sidechain(itype(k))
9443       long=long_r_sidechain(itype(k))
9444       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9445 C now costhet_grad
9446 C       costhet=0.0d0
9447        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
9448 C       costhet_fac=0.0d0
9449        do j=1,3
9450          costhet_grad(j)=costhet_fac*pep_side(j)
9451        enddo
9452 C remember for the final gradient multiply costhet_grad(j)
9453 C for side_chain by factor -2 !
9454 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9455 C pep_side0pept_group is vector multiplication
9456       pep_side0pept_group=0.0
9457       do j=1,3
9458       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9459       enddo
9460       cosalfa=(pep_side0pept_group/
9461      & (dist_pep_side*dist_side_calf))
9462       fac_alfa_sin=1.0-cosalfa**2
9463       fac_alfa_sin=dsqrt(fac_alfa_sin)
9464       rkprim=fac_alfa_sin*(long-short)+short
9465 C now costhet_grad
9466        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9467        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9468
9469        do j=1,3
9470          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9471      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9472      &*(long-short)/fac_alfa_sin*cosalfa/
9473      &((dist_pep_side*dist_side_calf))*
9474      &((side_calf(j))-cosalfa*
9475      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9476
9477         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9478      &*(long-short)/fac_alfa_sin*cosalfa
9479      &/((dist_pep_side*dist_side_calf))*
9480      &(pep_side(j)-
9481      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9482        enddo
9483
9484       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9485      &                    /VSolvSphere_div
9486      &                    *wshield
9487 C now the gradient...
9488 C grad_shield is gradient of Calfa for peptide groups
9489 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9490 C     &               costhet,cosphi
9491 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9492 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9493       do j=1,3
9494       grad_shield(j,i)=grad_shield(j,i)
9495 C gradient po skalowaniu
9496      &                +(sh_frac_dist_grad(j)
9497 C  gradient po costhet
9498      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9499      &-scale_fac_dist*(cosphi_grad_long(j))
9500      &/(1.0-cosphi) )*div77_81
9501      &*VofOverlap
9502 C grad_shield_side is Cbeta sidechain gradient
9503       grad_shield_side(j,ishield_list(i),i)=
9504      &        (sh_frac_dist_grad(j)*-2.0d0
9505      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9506      &       +scale_fac_dist*(cosphi_grad_long(j))
9507      &        *2.0d0/(1.0-cosphi))
9508      &        *div77_81*VofOverlap
9509
9510        grad_shield_loc(j,ishield_list(i),i)=
9511      &   scale_fac_dist*cosphi_grad_loc(j)
9512      &        *2.0d0/(1.0-cosphi)
9513      &        *div77_81*VofOverlap
9514       enddo
9515       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9516       enddo
9517       fac_shield(i)=VolumeTotal*div77_81+div4_81
9518 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9519       enddo
9520       return
9521       end
9522 C--------------------------------------------------------------------------
9523 C-----------------------------------------------------------------------
9524       double precision function sscalelip(r)
9525       double precision r,gamm
9526       include "COMMON.SPLITELE"
9527 C      if(r.lt.r_cut-rlamb) then
9528 C        sscale=1.0d0
9529 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9530 C        gamm=(r-(r_cut-rlamb))/rlamb
9531         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9532 C      else
9533 C        sscale=0d0
9534 C      endif
9535       return
9536       end
9537 C-----------------------------------------------------------------------
9538       double precision function sscagradlip(r)
9539       double precision r,gamm
9540       include "COMMON.SPLITELE"
9541 C     if(r.lt.r_cut-rlamb) then
9542 C        sscagrad=0.0d0
9543 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9544 C        gamm=(r-(r_cut-rlamb))/rlamb
9545         sscagradlip=r*(6*r-6.0d0)
9546 C      else
9547 C        sscagrad=0.0d0
9548 C      endif
9549       return
9550       end
9551
9552 C-----------------------------------------------------------------------
9553 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9554       subroutine Eliptransfer(eliptran)
9555       implicit real*8 (a-h,o-z)
9556       include 'DIMENSIONS'
9557       include 'COMMON.GEO'
9558       include 'COMMON.VAR'
9559       include 'COMMON.LOCAL'
9560       include 'COMMON.CHAIN'
9561       include 'COMMON.DERIV'
9562       include 'COMMON.INTERACT'
9563       include 'COMMON.IOUNITS'
9564       include 'COMMON.CALC'
9565       include 'COMMON.CONTROL'
9566       include 'COMMON.SPLITELE'
9567       include 'COMMON.SBRIDGE'
9568 C this is done by Adasko
9569 C      print *,"wchodze"
9570 C structure of box:
9571 C      water
9572 C--bordliptop-- buffore starts
9573 C--bufliptop--- here true lipid starts
9574 C      lipid
9575 C--buflipbot--- lipid ends buffore starts
9576 C--bordlipbot--buffore ends
9577       eliptran=0.0
9578       write(iout,*) "I am in?"
9579       do i=1,nres
9580 C       do i=1,1
9581         if (itype(i).eq.ntyp1) cycle
9582
9583         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
9584         if (positi.le.0) positi=positi+boxzsize
9585 C        print *,i
9586 C first for peptide groups
9587 c for each residue check if it is in lipid or lipid water border area
9588        if ((positi.gt.bordlipbot)
9589      &.and.(positi.lt.bordliptop)) then
9590 C the energy transfer exist
9591         if (positi.lt.buflipbot) then
9592 C what fraction I am in
9593          fracinbuf=1.0d0-
9594      &        ((positi-bordlipbot)/lipbufthick)
9595 C lipbufthick is thickenes of lipid buffore
9596          sslip=sscalelip(fracinbuf)
9597          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9598          eliptran=eliptran+sslip*pepliptran
9599          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9600          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9601 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9602         elseif (positi.gt.bufliptop) then
9603          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
9604          sslip=sscalelip(fracinbuf)
9605          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9606          eliptran=eliptran+sslip*pepliptran
9607          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
9608          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
9609 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
9610 C          print *, "doing sscalefor top part"
9611 C         print *,i,sslip,fracinbuf,ssgradlip
9612         else
9613          eliptran=eliptran+pepliptran
9614 C         print *,"I am in true lipid"
9615         endif
9616 C       else
9617 C       eliptran=elpitran+0.0 ! I am in water
9618        endif
9619        enddo
9620 C       print *, "nic nie bylo w lipidzie?"
9621 C now multiply all by the peptide group transfer factor
9622 C       eliptran=eliptran*pepliptran
9623 C now the same for side chains
9624 CV       do i=1,1
9625        do i=1,nres
9626         if (itype(i).eq.ntyp1) cycle
9627         positi=(mod(c(3,i+nres),boxzsize))
9628         if (positi.le.0) positi=positi+boxzsize
9629 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
9630 c for each residue check if it is in lipid or lipid water border area
9631 C       respos=mod(c(3,i+nres),boxzsize)
9632 C       print *,positi,bordlipbot,buflipbot
9633        if ((positi.gt.bordlipbot)
9634      & .and.(positi.lt.bordliptop)) then
9635 C the energy transfer exist
9636         if (positi.lt.buflipbot) then
9637          fracinbuf=1.0d0-
9638      &     ((positi-bordlipbot)/lipbufthick)
9639 C lipbufthick is thickenes of lipid buffore
9640          sslip=sscalelip(fracinbuf)
9641          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
9642          eliptran=eliptran+sslip*liptranene(itype(i))
9643          gliptranx(3,i)=gliptranx(3,i)
9644      &+ssgradlip*liptranene(itype(i))
9645          gliptranc(3,i-1)= gliptranc(3,i-1)
9646      &+ssgradlip*liptranene(itype(i))
9647 C         print *,"doing sccale for lower part"
9648         elseif (positi.gt.bufliptop) then
9649          fracinbuf=1.0d0-
9650      &((bordliptop-positi)/lipbufthick)
9651          sslip=sscalelip(fracinbuf)
9652          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
9653          eliptran=eliptran+sslip*liptranene(itype(i))
9654          gliptranx(3,i)=gliptranx(3,i)
9655      &+ssgradlip*liptranene(itype(i))
9656          gliptranc(3,i-1)= gliptranc(3,i-1)
9657      &+ssgradlip*liptranene(itype(i))
9658 C          print *, "doing sscalefor top part",sslip,fracinbuf
9659         else
9660          eliptran=eliptran+liptranene(itype(i))
9661 C         print *,"I am in true lipid"
9662         endif
9663         endif ! if in lipid or buffor
9664 C       else
9665 C       eliptran=elpitran+0.0 ! I am in water
9666        enddo
9667        return
9668        end
9669 C-------------------------------------------------------------------------------------