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

   1       subroutine etotal(energia,fact)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'DIMENSIONS.ZSCOPT'
   5
   6 #ifndef ISNAN
   7       external proc_proc
   8 #endif
   9 #ifdef WINPGI
  10 cMS$ATTRIBUTES C ::  proc_proc
  11 #endif
  12
  13       include 'COMMON.IOUNITS'
  14       double precision energia(0:max_ene),energia1(0:max_ene+1)
  15       include 'COMMON.FFIELD'
  16       include 'COMMON.DERIV'
  17       include 'COMMON.INTERACT'
  18       include 'COMMON.SBRIDGE'
  19       include 'COMMON.CHAIN'
  20       include 'COMMON.SHIELD'
  21       include 'COMMON.CONTROL'
  22       include 'COMMON.TORCNSTR'
  23       double precision fact(6)
  24 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  25 c      call flush(iout)
  26 cd    print *,'nnt=',nnt,' nct=',nct
  27 C
  28 C Compute the side-chain and electrostatic interaction energy
  29 C
  30       goto (101,102,103,104,105) ipot
  31 C Lennard-Jones potential.
  32   101 call elj(evdw,evdw_t)
  33 cd    print '(a)','Exit ELJ'
  34       goto 106
  35 C Lennard-Jones-Kihara potential (shifted).
  36   102 call eljk(evdw,evdw_t)
  37       goto 106
  38 C Berne-Pechukas potential (dilated LJ, angular dependence).
  39   103 call ebp(evdw,evdw_t)
  40       goto 106
  41 C Gay-Berne potential (shifted LJ, angular dependence).
  42   104 call egb(evdw,evdw_t)
  43       goto 106
  44 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  45   105 call egbv(evdw,evdw_t)
  46 C      write(iout,*) 'po elektostatyce'
  47 C
  48 C Calculate electrostatic (H-bonding) energy of the main chain.
  49 C
  50   106 continue
  51       call vec_and_deriv
  52       if (shield_mode.eq.1) then
  53        call set_shield_fac
  54       else if  (shield_mode.eq.2) then
  55        call set_shield_fac2
  56       endif
  57       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  58 C            write(iout,*) 'po eelec'
  59
  60 C Calculate excluded-volume interaction energy between peptide groups
  61 C and side chains.
  62 C
  63       call escp(evdw2,evdw2_14)
  64 c
  65 c Calculate the bond-stretching energy
  66 c
  67
  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 C      print *,'Bend energy finished.'
  80       if (wang.gt.0d0) then
  81        if (tor_mode.eq.0) then
  82          call ebend(ebe)
  83        else
  84 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  85 C energy function
  86          call ebend_kcc(ebe)
  87        endif
  88       else
  89         ebe=0.0d0
  90       endif
  91       ethetacnstr=0.0d0
  92       if (with_theta_constr) call etheta_constr(ethetacnstr)
  93 c      call ebend(ebe,ethetacnstr)
  94 cd    print *,'Bend energy finished.'
  95 C
  96 C Calculate the SC local energy.
  97 C
  98       call esc(escloc)
  99 C       print *,'SCLOC energy finished.'
 100 C
 101 C Calculate the virtual-bond torsional energy.
 102 C
 103       if (wtor.gt.0.0d0) then
 104          if (tor_mode.eq.0) then
 105            call etor(etors,fact(1))
 106          else
 107 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 108 C energy function
 109            call etor_kcc(etors,fact(1))
 110          endif
 111       else
 112         etors=0.0d0
 113       endif
 114       edihcnstr=0.0d0
 115       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 116 c      print *,"Processor",myrank," computed Utor"
 117 C
 118 C 6/23/01 Calculate double-torsional energy
 119 C
 120       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 121         call etor_d(etors_d,fact(2))
 122       else
 123         etors_d=0
 124       endif
 125 c      print *,"Processor",myrank," computed Utord"
 126 C
 127       call eback_sc_corr(esccor)
 128
 129       if (wliptran.gt.0) then
 130         call Eliptransfer(eliptran)
 131       endif
 132
 133 C
 134 C 12/1/95 Multi-body terms
 135 C
 136       n_corr=0
 137       n_corr1=0
 138       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 139      &    .or. wturn6.gt.0.0d0) then
 140 c         write(iout,*)"calling multibody_eello"
 141          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 142 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 143 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 144       else
 145          ecorr=0.0d0
 146          ecorr5=0.0d0
 147          ecorr6=0.0d0
 148          eturn6=0.0d0
 149       endif
 150       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 151 c         write (iout,*) "Calling multibody_hbond"
 152          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 153       endif
 154 c      write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 155       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 156         call e_saxs(Esaxs_constr)
 157 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 158       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 159         call e_saxsC(Esaxs_constr)
 160 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 161       else
 162         Esaxs_constr = 0.0d0
 163       endif
 164
 165 c      write (iout,*) "ft(6)",fact(6)," evdw",evdw," evdw_t",evdw_t
 166 #ifdef SPLITELE
 167       if (shield_mode.gt.0) then
 168       etot=fact(1)*wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 169      & +welec*fact(1)*ees
 170      & +fact(1)*wvdwpp*evdw1
 171      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 172      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 173      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 174      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 175      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 176      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr+wsaxs*esaxs_constr
 177      & +wliptran*eliptran*esaxs_constr
 178       else
 179       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2+welec*fact(1)*ees
 180      & +wvdwpp*evdw1
 181      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 182      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 183      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 184      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 185      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 186      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 187      & +wliptran*eliptran+wsaxs*esaxs_constr
 188       endif
 189 #else
 190       if (shield_mode.gt.0) then
 191       etot=fact(1)wsc*(evdw+fact(6)*evdw_t)+fact(1)*wscp*evdw2
 192      & +welec*fact(1)*(ees+evdw1)
 193      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 194      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 195      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 196      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 197      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 198      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 199      & +wliptran*eliptran+wsaxs*esaxs_constr
 200       else
 201       etot=wsc*(evdw+fact(6)*evdw_t)+wscp*evdw2
 202      & +welec*fact(1)*(ees+evdw1)
 203      & +wang*ebe+wtor*fact(1)*etors+wscloc*escloc
 204      & +wstrain*ehpb+wcorr*fact(3)*ecorr+wcorr5*fact(4)*ecorr5
 205      & +wcorr6*fact(5)*ecorr6+wturn4*fact(3)*eello_turn4
 206      & +wturn3*fact(2)*eello_turn3+wturn6*fact(5)*eturn6
 207      & +wel_loc*fact(2)*eel_loc+edihcnstr+wtor_d*fact(2)*etors_d
 208      & +wbond*estr+wsccor*fact(1)*esccor+ethetacnstr
 209      & +wliptran*eliptran+wsaxs*esaxs_constr
 210       endif
 211 #endif
 212       energia(0)=etot
 213       energia(1)=evdw
 214 #ifdef SCP14
 215       energia(2)=evdw2-evdw2_14
 216       energia(17)=evdw2_14
 217 #else
 218       energia(2)=evdw2
 219       energia(17)=0.0d0
 220 #endif
 221 #ifdef SPLITELE
 222       energia(3)=ees
 223       energia(16)=evdw1
 224 #else
 225       energia(3)=ees+evdw1
 226       energia(16)=0.0d0
 227 #endif
 228       energia(4)=ecorr
 229       energia(5)=ecorr5
 230       energia(6)=ecorr6
 231       energia(7)=eel_loc
 232       energia(8)=eello_turn3
 233       energia(9)=eello_turn4
 234       energia(10)=eturn6
 235       energia(11)=ebe
 236       energia(12)=escloc
 237       energia(13)=etors
 238       energia(14)=etors_d
 239       energia(15)=ehpb
 240       energia(18)=estr
 241       energia(19)=esccor
 242       energia(20)=edihcnstr
 243       energia(21)=evdw_t
 244       energia(24)=ethetacnstr
 245       energia(22)=eliptran
 246       energia(26)=esaxs_constr
 247 c detecting NaNQ
 248 #ifdef ISNAN
 249 #ifdef AIX
 250       if (isnan(etot).ne.0) energia(0)=1.0d+99
 251 #else
 252       if (isnan(etot)) energia(0)=1.0d+99
 253 #endif
 254 #else
 255       i=0
 256 #ifdef WINPGI
 257       idumm=proc_proc(etot,i)
 258 #else
 259       call proc_proc(etot,i)
 260 #endif
 261       if(i.eq.1)energia(0)=1.0d+99
 262 #endif
 263 #ifdef MPL
 264 c     endif
 265 #endif
 266 #ifdef DEBUG
 267       call enerprint(energia,fact)
 268 #endif
 269       if (calc_grad) then
 270 C
 271 C Sum up the components of the Cartesian gradient.
 272 C
 273 #ifdef SPLITELE
 274       do i=1,nct
 275         do j=1,3
 276       if (shield_mode.eq.0) then
 277           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 278      &                welec*fact(1)*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 279      &                wbond*gradb(j,i)+
 280      &                wstrain*ghpbc(j,i)+
 281      &                wcorr*fact(3)*gradcorr(j,i)+
 282      &                wel_loc*fact(2)*gel_loc(j,i)+
 283      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 284      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 285      &                wcorr5*fact(4)*gradcorr5(j,i)+
 286      &                wcorr6*fact(5)*gradcorr6(j,i)+
 287      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 288      &                wsccor*fact(2)*gsccorc(j,i)
 289      &               +wliptran*gliptranc(j,i)
 290           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 291      &                  wbond*gradbx(j,i)+
 292      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 293      &                  wsccor*fact(2)*gsccorx(j,i)
 294      &                 +wliptran*gliptranx(j,i)
 295         else
 296           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)
 297      &                +fact(1)*wscp*gvdwc_scp(j,i)+
 298      &               welec*fact(1)*gelc(j,i)+fact(1)*wvdwpp*gvdwpp(j,i)+
 299      &                wbond*gradb(j,i)+
 300      &                wstrain*ghpbc(j,i)+
 301      &                wcorr*fact(3)*gradcorr(j,i)+
 302      &                wel_loc*fact(2)*gel_loc(j,i)+
 303      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 304      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 305      &                wcorr5*fact(4)*gradcorr5(j,i)+
 306      &                wcorr6*fact(5)*gradcorr6(j,i)+
 307      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 308      &                wsccor*fact(2)*gsccorc(j,i)
 309      &               +wliptran*gliptranc(j,i)
 310      &                 +welec*gshieldc(j,i)
 311      &                 +welec*gshieldc_loc(j,i)
 312      &                 +wcorr*gshieldc_ec(j,i)
 313      &                 +wcorr*gshieldc_loc_ec(j,i)
 314      &                 +wturn3*gshieldc_t3(j,i)
 315      &                 +wturn3*gshieldc_loc_t3(j,i)
 316      &                 +wturn4*gshieldc_t4(j,i)
 317      &                 +wturn4*gshieldc_loc_t4(j,i)
 318      &                 +wel_loc*gshieldc_ll(j,i)
 319      &                 +wel_loc*gshieldc_loc_ll(j,i)
 320
 321           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)
 322      &                 +fact(1)*wscp*gradx_scp(j,i)+
 323      &                  wbond*gradbx(j,i)+
 324      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 325      &                  wsccor*fact(2)*gsccorx(j,i)
 326      &                 +wliptran*gliptranx(j,i)
 327      &                 +welec*gshieldx(j,i)
 328      &                 +wcorr*gshieldx_ec(j,i)
 329      &                 +wturn3*gshieldx_t3(j,i)
 330      &                 +wturn4*gshieldx_t4(j,i)
 331      &                 +wel_loc*gshieldx_ll(j,i)
 332
 333
 334         endif
 335         enddo
 336 #else
 337       do i=1,nct
 338         do j=1,3
 339                 if (shield_mode.eq.0) then
 340           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 341      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 342      &                wbond*gradb(j,i)+
 343      &                wcorr*fact(3)*gradcorr(j,i)+
 344      &                wel_loc*fact(2)*gel_loc(j,i)+
 345      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 346      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 347      &                wcorr5*fact(4)*gradcorr5(j,i)+
 348      &                wcorr6*fact(5)*gradcorr6(j,i)+
 349      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 350      &                wsccor*fact(2)*gsccorc(j,i)
 351      &               +wliptran*gliptranc(j,i)
 352           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 353      &                  wbond*gradbx(j,i)+
 354      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 355      &                  wsccor*fact(1)*gsccorx(j,i)
 356      &                 +wliptran*gliptranx(j,i)
 357               else
 358           gradc(j,i,icg)=fact(1)*wsc*gvdwc(j,i)+
 359      &                   fact(1)*wscp*gvdwc_scp(j,i)+
 360      &                welec*fact(1)*gelc(j,i)+wstrain*ghpbc(j,i)+
 361      &                wbond*gradb(j,i)+
 362      &                wcorr*fact(3)*gradcorr(j,i)+
 363      &                wel_loc*fact(2)*gel_loc(j,i)+
 364      &                wturn3*fact(2)*gcorr3_turn(j,i)+
 365      &                wturn4*fact(3)*gcorr4_turn(j,i)+
 366      &                wcorr5*fact(4)*gradcorr5(j,i)+
 367      &                wcorr6*fact(5)*gradcorr6(j,i)+
 368      &                wturn6*fact(5)*gcorr6_turn(j,i)+
 369      &                wsccor*fact(2)*gsccorc(j,i)
 370      &               +wliptran*gliptranc(j,i)
 371      &                 +welec*gshieldc(j,i)
 372      &                 +welec*gshieldc_loc(j,i)
 373      &                 +wcorr*gshieldc_ec(j,i)
 374      &                 +wcorr*gshieldc_loc_ec(j,i)
 375      &                 +wturn3*gshieldc_t3(j,i)
 376      &                 +wturn3*gshieldc_loc_t3(j,i)
 377      &                 +wturn4*gshieldc_t4(j,i)
 378      &                 +wturn4*gshieldc_loc_t4(j,i)
 379      &                 +wel_loc*gshieldc_ll(j,i)
 380      &                 +wel_loc*gshieldc_loc_ll(j,i)
 381
 382           gradx(j,i,icg)=fact(1)*wsc*gvdwx(j,i)+
 383      &                  fact(1)*wscp*gradx_scp(j,i)+
 384      &                  wbond*gradbx(j,i)+
 385      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 386      &                  wsccor*fact(1)*gsccorx(j,i)
 387      &                 +wliptran*gliptranx(j,i)
 388      &                 +welec*gshieldx(j,i)
 389      &                 +wcorr*gshieldx_ec(j,i)
 390      &                 +wturn3*gshieldx_t3(j,i)
 391      &                 +wturn4*gshieldx_t4(j,i)
 392      &                 +wel_loc*gshieldx_ll(j,i)
 393
 394          endif
 395         enddo
 396 #endif
 397       enddo
 398
 399
 400       do i=1,nres-3
 401         gloc(i,icg)=gloc(i,icg)+wcorr*fact(3)*gcorr_loc(i)
 402      &   +wcorr5*fact(4)*g_corr5_loc(i)
 403      &   +wcorr6*fact(5)*g_corr6_loc(i)
 404      &   +wturn4*fact(3)*gel_loc_turn4(i)
 405      &   +wturn3*fact(2)*gel_loc_turn3(i)
 406      &   +wturn6*fact(5)*gel_loc_turn6(i)
 407      &   +wel_loc*fact(2)*gel_loc_loc(i)
 408 c     &   +wsccor*fact(1)*gsccor_loc(i)
 409 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 410       enddo
 411       endif
 412       if (dyn_ss) call dyn_set_nss
 413       return
 414       end
 415 C------------------------------------------------------------------------
 416       subroutine enerprint(energia,fact)
 417       implicit real*8 (a-h,o-z)
 418       include 'DIMENSIONS'
 419       include 'DIMENSIONS.ZSCOPT'
 420       include 'COMMON.IOUNITS'
 421       include 'COMMON.FFIELD'
 422       include 'COMMON.SBRIDGE'
 423       include 'COMMON.CONTROL'
 424       double precision energia(0:max_ene),fact(6)
 425       etot=energia(0)
 426       evdw=energia(1)+fact(6)*energia(21)
 427 #ifdef SCP14
 428       evdw2=energia(2)+energia(17)
 429 #else
 430       evdw2=energia(2)
 431 #endif
 432       ees=energia(3)
 433 #ifdef SPLITELE
 434       evdw1=energia(16)
 435 #endif
 436       ecorr=energia(4)
 437       ecorr5=energia(5)
 438       ecorr6=energia(6)
 439       eel_loc=energia(7)
 440       eello_turn3=energia(8)
 441       eello_turn4=energia(9)
 442       eello_turn6=energia(10)
 443       ebe=energia(11)
 444       escloc=energia(12)
 445       etors=energia(13)
 446       etors_d=energia(14)
 447       ehpb=energia(15)
 448       esccor=energia(19)
 449       edihcnstr=energia(20)
 450       estr=energia(18)
 451       ethetacnstr=energia(24)
 452       eliptran=energia(22)
 453       esaxs=energia(26)
 454 #ifdef SPLITELE
 455       if (shield_mode.gt.0) then
 456       write (iout,10) evdw,wsc*fact(1),evdw2,wscp*fact(1),ees,
 457      &  welec*fact(1),evdw1,wvdwpp*fact(1),
 458      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 459      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 460      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 461      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 462      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 463      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 464      & eliptran,wliptran,esaxs,wsaxs,etot
 465       else
 466       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),evdw1,
 467      &  wvdwpp,
 468      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor*fact(1),
 469      &  etors_d,wtor_d*fact(2),ehpb,wstrain,
 470      &  ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),ecorr6,wcorr6*fact(5),
 471      &  eel_loc,wel_loc*fact(2),eello_turn3,wturn3*fact(2),
 472      &  eello_turn4,wturn4*fact(3),eello_turn6,wturn6*fact(5),
 473      &  esccor,wsccor*fact(1),edihcnstr,ethetacnstr,ebr*nss,
 474      & eliptran,wliptran,esaxs,wsaxs,etot
 475       endif
 476    10 format (/'Virtual-chain energies:'//
 477      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 478      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 479      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 480      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 481      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 482      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 483      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 484      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 485      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 486      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 487      & ' (SS bridges & dist. cnstr.)'/
 488      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 489      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 490      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 491      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 492      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 493      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 494      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 495      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 496      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 497      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 498      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 499      & 'ELT=   ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
 500      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
 501      & 'ETOT=  ',1pE16.6,' (total)')
 502 #else
 503       if (shield_mode.gt.0) then
 504       write (iout,10) evdw,wsc*fact(1),evdw2,wscp*fact(2),ees,
 505      &  welec*fact(1),estr,wbond,
 506      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 507      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 508      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 509      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 510      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 511      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,esaxs,wsaxs,etot
 512       else
 513       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec*fact(1),estr,wbond,
 514      &  ebe,wang,escloc,wscloc,etors,wtor*fact(1),etors_d,wtor_d*fact2,
 515      &  ehpb,wstrain,ecorr,wcorr*fact(3),ecorr5,wcorr5*fact(4),
 516      &  ecorr6,wcorr6*fact(5),eel_loc,wel_loc*fact(2),
 517      &  eello_turn3,wturn3*fact(2),eello_turn4,wturn4*fact(3),
 518      &  eello_turn6,wturn6*fact(5),esccor*fact(1),wsccor,
 519      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,esaxs,wsaxs,etot
 520       endif
 521    10 format (/'Virtual-chain energies:'//
 522      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 523      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 524      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 525      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 526      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 527      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 528      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 529      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 530      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 531      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 532      & ' (SS bridges & dist. cnstr.)'/
 533      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 534      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 535      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 536      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 537      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 538      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 539      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 540      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 541      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
 542      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
 543      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 544      & 'ELT=   ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
 545      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
 546      & 'ETOT=  ',1pE16.6,' (total)')
 547 #endif
 548       return
 549       end
 550 C-----------------------------------------------------------------------
 551       subroutine elj(evdw,evdw_t)
 552 C
 553 C This subroutine calculates the interaction energy of nonbonded side chains
 554 C assuming the LJ potential of interaction.
 555 C
 556       implicit real*8 (a-h,o-z)
 557       include 'DIMENSIONS'
 558       include 'DIMENSIONS.ZSCOPT'
 559       include "DIMENSIONS.COMPAR"
 560       parameter (accur=1.0d-10)
 561       include 'COMMON.GEO'
 562       include 'COMMON.VAR'
 563       include 'COMMON.LOCAL'
 564       include 'COMMON.CHAIN'
 565       include 'COMMON.DERIV'
 566       include 'COMMON.INTERACT'
 567       include 'COMMON.TORSION'
 568       include 'COMMON.ENEPS'
 569       include 'COMMON.SBRIDGE'
 570       include 'COMMON.NAMES'
 571       include 'COMMON.IOUNITS'
 572       include 'COMMON.CONTACTS'
 573       dimension gg(3)
 574       integer icant
 575       external icant
 576 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 577 c ROZNICA z cluster
 578       do i=1,210
 579         do j=1,2
 580           eneps_temp(j,i)=0.0d0
 581         enddo
 582       enddo
 583 cROZNICA
 584
 585       evdw=0.0D0
 586       evdw_t=0.0d0
 587       do i=iatsc_s,iatsc_e
 588         itypi=iabs(itype(i))
 589         if (itypi.eq.ntyp1) cycle
 590         itypi1=iabs(itype(i+1))
 591         xi=c(1,nres+i)
 592         yi=c(2,nres+i)
 593         zi=c(3,nres+i)
 594 C Change 12/1/95
 595         num_conti=0
 596 C
 597 C Calculate SC interaction energy.
 598 C
 599         do iint=1,nint_gr(i)
 600 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 601 cd   &                  'iend=',iend(i,iint)
 602           do j=istart(i,iint),iend(i,iint)
 603             itypj=iabs(itype(j))
 604             if (itypj.eq.ntyp1) cycle
 605             xj=c(1,nres+j)-xi
 606             yj=c(2,nres+j)-yi
 607             zj=c(3,nres+j)-zi
 608 C Change 12/1/95 to calculate four-body interactions
 609             rij=xj*xj+yj*yj+zj*zj
 610             rrij=1.0D0/rij
 611 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 612             eps0ij=eps(itypi,itypj)
 613             fac=rrij**expon2
 614             e1=fac*fac*aa
 615             e2=fac*bb
 616             evdwij=e1+e2
 617             ij=icant(itypi,itypj)
 618 c ROZNICA z cluster
 619             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 620             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 621 c
 622
 623 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 624 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 625 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 626 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 627 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 628 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 629             if (bb.gt.0.0d0) then
 630               evdw=evdw+evdwij
 631             else
 632               evdw_t=evdw_t+evdwij
 633             endif
 634             if (calc_grad) then
 635 C
 636 C Calculate the components of the gradient in DC and X
 637 C
 638             fac=-rrij*(e1+evdwij)
 639             gg(1)=xj*fac
 640             gg(2)=yj*fac
 641             gg(3)=zj*fac
 642             do k=1,3
 643               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 644               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 645             enddo
 646             do k=i,j-1
 647               do l=1,3
 648                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 649               enddo
 650             enddo
 651             endif
 652 C
 653 C 12/1/95, revised on 5/20/97
 654 C
 655 C Calculate the contact function. The ith column of the array JCONT will
 656 C contain the numbers of atoms that make contacts with the atom I (of numbers
 657 C greater than I). The arrays FACONT and GACONT will contain the values of
 658 C the contact function and its derivative.
 659 C
 660 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 661 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 662 C Uncomment next line, if the correlation interactions are contact function only
 663             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 664               rij=dsqrt(rij)
 665               sigij=sigma(itypi,itypj)
 666               r0ij=rs0(itypi,itypj)
 667 C
 668 C Check whether the SC's are not too far to make a contact.
 669 C
 670               rcut=1.5d0*r0ij
 671               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 672 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 673 C
 674               if (fcont.gt.0.0D0) then
 675 C If the SC-SC distance if close to sigma, apply spline.
 676 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 677 cAdam &             fcont1,fprimcont1)
 678 cAdam           fcont1=1.0d0-fcont1
 679 cAdam           if (fcont1.gt.0.0d0) then
 680 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 681 cAdam             fcont=fcont*fcont1
 682 cAdam           endif
 683 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 684 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 685 cga             do k=1,3
 686 cga               gg(k)=gg(k)*eps0ij
 687 cga             enddo
 688 cga             eps0ij=-evdwij*eps0ij
 689 C Uncomment for AL's type of SC correlation interactions.
 690 cadam           eps0ij=-evdwij
 691                 num_conti=num_conti+1
 692                 jcont(num_conti,i)=j
 693                 facont(num_conti,i)=fcont*eps0ij
 694                 fprimcont=eps0ij*fprimcont/rij
 695                 fcont=expon*fcont
 696 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 697 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 698 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 699 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 700                 gacont(1,num_conti,i)=-fprimcont*xj
 701                 gacont(2,num_conti,i)=-fprimcont*yj
 702                 gacont(3,num_conti,i)=-fprimcont*zj
 703 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 704 cd              write (iout,'(2i3,3f10.5)')
 705 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 706               endif
 707             endif
 708           enddo      ! j
 709         enddo        ! iint
 710 C Change 12/1/95
 711         num_cont(i)=num_conti
 712       enddo          ! i
 713       if (calc_grad) then
 714       do i=1,nct
 715         do j=1,3
 716           gvdwc(j,i)=expon*gvdwc(j,i)
 717           gvdwx(j,i)=expon*gvdwx(j,i)
 718         enddo
 719       enddo
 720       endif
 721 C******************************************************************************
 722 C
 723 C                              N O T E !!!
 724 C
 725 C To save time, the factor of EXPON has been extracted from ALL components
 726 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 727 C use!
 728 C
 729 C******************************************************************************
 730       return
 731       end
 732 C-----------------------------------------------------------------------------
 733       subroutine eljk(evdw,evdw_t)
 734 C
 735 C This subroutine calculates the interaction energy of nonbonded side chains
 736 C assuming the LJK potential of interaction.
 737 C
 738       implicit real*8 (a-h,o-z)
 739       include 'DIMENSIONS'
 740       include 'DIMENSIONS.ZSCOPT'
 741       include "DIMENSIONS.COMPAR"
 742       include 'COMMON.GEO'
 743       include 'COMMON.VAR'
 744       include 'COMMON.LOCAL'
 745       include 'COMMON.CHAIN'
 746       include 'COMMON.DERIV'
 747       include 'COMMON.INTERACT'
 748       include 'COMMON.ENEPS'
 749       include 'COMMON.IOUNITS'
 750       include 'COMMON.NAMES'
 751       dimension gg(3)
 752       logical scheck
 753       integer icant
 754       external icant
 755 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 756       do i=1,210
 757         do j=1,2
 758           eneps_temp(j,i)=0.0d0
 759         enddo
 760       enddo
 761       evdw=0.0D0
 762       evdw_t=0.0d0
 763       do i=iatsc_s,iatsc_e
 764         itypi=iabs(itype(i))
 765         if (itypi.eq.ntyp1) cycle
 766         itypi1=iabs(itype(i+1))
 767         xi=c(1,nres+i)
 768         yi=c(2,nres+i)
 769         zi=c(3,nres+i)
 770 C
 771 C Calculate SC interaction energy.
 772 C
 773         do iint=1,nint_gr(i)
 774           do j=istart(i,iint),iend(i,iint)
 775             itypj=iabs(itype(j))
 776             if (itypj.eq.ntyp1) cycle
 777             xj=c(1,nres+j)-xi
 778             yj=c(2,nres+j)-yi
 779             zj=c(3,nres+j)-zi
 780             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 781             fac_augm=rrij**expon
 782             e_augm=augm(itypi,itypj)*fac_augm
 783             r_inv_ij=dsqrt(rrij)
 784             rij=1.0D0/r_inv_ij
 785             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 786             fac=r_shift_inv**expon
 787             e1=fac*fac*aa
 788             e2=fac*bb
 789             evdwij=e_augm+e1+e2
 790             ij=icant(itypi,itypj)
 791             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 792      &        /dabs(eps(itypi,itypj))
 793             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 794 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 795 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 796 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 797 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 798 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 799 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 800 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 801             if (bb.gt.0.0d0) then
 802               evdw=evdw+evdwij
 803             else
 804               evdw_t=evdw_t+evdwij
 805             endif
 806             if (calc_grad) then
 807 C
 808 C Calculate the components of the gradient in DC and X
 809 C
 810             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 811             gg(1)=xj*fac
 812             gg(2)=yj*fac
 813             gg(3)=zj*fac
 814             do k=1,3
 815               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 816               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 817             enddo
 818             do k=i,j-1
 819               do l=1,3
 820                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 821               enddo
 822             enddo
 823             endif
 824           enddo      ! j
 825         enddo        ! iint
 826       enddo          ! i
 827       if (calc_grad) then
 828       do i=1,nct
 829         do j=1,3
 830           gvdwc(j,i)=expon*gvdwc(j,i)
 831           gvdwx(j,i)=expon*gvdwx(j,i)
 832         enddo
 833       enddo
 834       endif
 835       return
 836       end
 837 C-----------------------------------------------------------------------------
 838       subroutine ebp(evdw,evdw_t)
 839 C
 840 C This subroutine calculates the interaction energy of nonbonded side chains
 841 C assuming the Berne-Pechukas potential of interaction.
 842 C
 843       implicit real*8 (a-h,o-z)
 844       include 'DIMENSIONS'
 845       include 'DIMENSIONS.ZSCOPT'
 846       include "DIMENSIONS.COMPAR"
 847       include 'COMMON.GEO'
 848       include 'COMMON.VAR'
 849       include 'COMMON.LOCAL'
 850       include 'COMMON.CHAIN'
 851       include 'COMMON.DERIV'
 852       include 'COMMON.NAMES'
 853       include 'COMMON.INTERACT'
 854       include 'COMMON.ENEPS'
 855       include 'COMMON.IOUNITS'
 856       include 'COMMON.CALC'
 857       common /srutu/ icall
 858 c     double precision rrsave(maxdim)
 859       logical lprn
 860       integer icant
 861       external icant
 862       do i=1,210
 863         do j=1,2
 864           eneps_temp(j,i)=0.0d0
 865         enddo
 866       enddo
 867       evdw=0.0D0
 868       evdw_t=0.0d0
 869 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 870 c     if (icall.eq.0) then
 871 c       lprn=.true.
 872 c     else
 873         lprn=.false.
 874 c     endif
 875       ind=0
 876       do i=iatsc_s,iatsc_e
 877         itypi=iabs(itype(i))
 878         if (itypi.eq.ntyp1) cycle
 879         itypi1=iabs(itype(i+1))
 880         xi=c(1,nres+i)
 881         yi=c(2,nres+i)
 882         zi=c(3,nres+i)
 883         dxi=dc_norm(1,nres+i)
 884         dyi=dc_norm(2,nres+i)
 885         dzi=dc_norm(3,nres+i)
 886         dsci_inv=vbld_inv(i+nres)
 887 C
 888 C Calculate SC interaction energy.
 889 C
 890         do iint=1,nint_gr(i)
 891           do j=istart(i,iint),iend(i,iint)
 892             ind=ind+1
 893             itypj=iabs(itype(j))
 894             if (itypj.eq.ntyp1) cycle
 895             dscj_inv=vbld_inv(j+nres)
 896             chi1=chi(itypi,itypj)
 897             chi2=chi(itypj,itypi)
 898             chi12=chi1*chi2
 899             chip1=chip(itypi)
 900             chip2=chip(itypj)
 901             chip12=chip1*chip2
 902             alf1=alp(itypi)
 903             alf2=alp(itypj)
 904             alf12=0.5D0*(alf1+alf2)
 905 C For diagnostics only!!!
 906 c           chi1=0.0D0
 907 c           chi2=0.0D0
 908 c           chi12=0.0D0
 909 c           chip1=0.0D0
 910 c           chip2=0.0D0
 911 c           chip12=0.0D0
 912 c           alf1=0.0D0
 913 c           alf2=0.0D0
 914 c           alf12=0.0D0
 915             xj=c(1,nres+j)-xi
 916             yj=c(2,nres+j)-yi
 917             zj=c(3,nres+j)-zi
 918             dxj=dc_norm(1,nres+j)
 919             dyj=dc_norm(2,nres+j)
 920             dzj=dc_norm(3,nres+j)
 921             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 922 cd          if (icall.eq.0) then
 923 cd            rrsave(ind)=rrij
 924 cd          else
 925 cd            rrij=rrsave(ind)
 926 cd          endif
 927             rij=dsqrt(rrij)
 928 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 929             call sc_angular
 930 C Calculate whole angle-dependent part of epsilon and contributions
 931 C to its derivatives
 932             fac=(rrij*sigsq)**expon2
 933             e1=fac*fac*aa
 934             e2=fac*bb
 935             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 936             eps2der=evdwij*eps3rt
 937             eps3der=evdwij*eps2rt
 938             evdwij=evdwij*eps2rt*eps3rt
 939             ij=icant(itypi,itypj)
 940             aux=eps1*eps2rt**2*eps3rt**2
 941             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 942      &        /dabs(eps(itypi,itypj))
 943             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 944             if (bb.gt.0.0d0) then
 945               evdw=evdw+evdwij
 946             else
 947               evdw_t=evdw_t+evdwij
 948             endif
 949             if (calc_grad) then
 950             if (lprn) then
 951             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
 952             epsi=bb**2/aa
 953             write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 954      &        restyp(itypi),i,restyp(itypj),j,
 955      &        epsi,sigm,chi1,chi2,chip1,chip2,
 956      &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 957      &        om1,om2,om12,1.0D0/dsqrt(rrij),
 958      &        evdwij
 959             endif
 960 C Calculate gradient components.
 961             e1=e1*eps1*eps2rt**2*eps3rt**2
 962             fac=-expon*(e1+evdwij)
 963             sigder=fac/sigsq
 964             fac=rrij*fac
 965 C Calculate radial part of the gradient
 966             gg(1)=xj*fac
 967             gg(2)=yj*fac
 968             gg(3)=zj*fac
 969 C Calculate the angular part of the gradient and sum add the contributions
 970 C to the appropriate components of the Cartesian gradient.
 971             call sc_grad
 972             endif
 973           enddo      ! j
 974         enddo        ! iint
 975       enddo          ! i
 976 c     stop
 977       return
 978       end
 979 C-----------------------------------------------------------------------------
 980       subroutine egb(evdw,evdw_t)
 981 C
 982 C This subroutine calculates the interaction energy of nonbonded side chains
 983 C assuming the Gay-Berne potential of interaction.
 984 C
 985       implicit real*8 (a-h,o-z)
 986       include 'DIMENSIONS'
 987       include 'DIMENSIONS.ZSCOPT'
 988       include "DIMENSIONS.COMPAR"
 989       include 'COMMON.CONTROL'
 990       include 'COMMON.GEO'
 991       include 'COMMON.VAR'
 992       include 'COMMON.LOCAL'
 993       include 'COMMON.CHAIN'
 994       include 'COMMON.DERIV'
 995       include 'COMMON.NAMES'
 996       include 'COMMON.INTERACT'
 997       include 'COMMON.ENEPS'
 998       include 'COMMON.IOUNITS'
 999       include 'COMMON.CALC'
1000       include 'COMMON.SBRIDGE'
1001       logical lprn
1002       common /srutu/icall
1003       integer icant,xshift,yshift,zshift
1004       external icant
1005       do i=1,210
1006         do j=1,2
1007           eneps_temp(j,i)=0.0d0
1008         enddo
1009       enddo
1010 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1011       evdw=0.0D0
1012       evdw_t=0.0d0
1013       lprn=.false.
1014 c      if (icall.gt.0) lprn=.true.
1015       ind=0
1016       do i=iatsc_s,iatsc_e
1017         itypi=iabs(itype(i))
1018         if (itypi.eq.ntyp1) cycle
1019         itypi1=iabs(itype(i+1))
1020         xi=c(1,nres+i)
1021         yi=c(2,nres+i)
1022         zi=c(3,nres+i)
1023 C returning the ith atom to box
1024           xi=mod(xi,boxxsize)
1025           if (xi.lt.0) xi=xi+boxxsize
1026           yi=mod(yi,boxysize)
1027           if (yi.lt.0) yi=yi+boxysize
1028           zi=mod(zi,boxzsize)
1029           if (zi.lt.0) zi=zi+boxzsize
1030        if ((zi.gt.bordlipbot)
1031      &.and.(zi.lt.bordliptop)) then
1032 C the energy transfer exist
1033         if (zi.lt.buflipbot) then
1034 C what fraction I am in
1035          fracinbuf=1.0d0-
1036      &        ((zi-bordlipbot)/lipbufthick)
1037 C lipbufthick is thickenes of lipid buffore
1038          sslipi=sscalelip(fracinbuf)
1039          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1040         elseif (zi.gt.bufliptop) then
1041          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1042          sslipi=sscalelip(fracinbuf)
1043          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1044         else
1045          sslipi=1.0d0
1046          ssgradlipi=0.0
1047         endif
1048        else
1049          sslipi=0.0d0
1050          ssgradlipi=0.0
1051        endif
1052
1053         dxi=dc_norm(1,nres+i)
1054         dyi=dc_norm(2,nres+i)
1055         dzi=dc_norm(3,nres+i)
1056         dsci_inv=vbld_inv(i+nres)
1057 C
1058 C Calculate SC interaction energy.
1059 C
1060         do iint=1,nint_gr(i)
1061           do j=istart(i,iint),iend(i,iint)
1062             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1063               call dyn_ssbond_ene(i,j,evdwij)
1064               evdw=evdw+evdwij
1065 C            write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1066 C     &                        'evdw',i,j,evdwij,' ss',evdw,evdw_t
1067 C triple bond artifac removal
1068              do k=j+1,iend(i,iint)
1069 C search over all next residues
1070               if (dyn_ss_mask(k)) then
1071 C check if they are cysteins
1072 C              write(iout,*) 'k=',k
1073               call triple_ssbond_ene(i,j,k,evdwij)
1074 C call the energy function that removes the artifical triple disulfide
1075 C bond the soubroutine is located in ssMD.F
1076               evdw=evdw+evdwij
1077 C             write (iout,'(a6,2i5,0pf7.3,a3,2f10.3)')
1078 C     &                        'evdw',i,j,evdwij,'tss',evdw,evdw_t
1079               endif!dyn_ss_mask(k)
1080              enddo! k
1081             ELSE
1082             ind=ind+1
1083             itypj=iabs(itype(j))
1084             if (itypj.eq.ntyp1) cycle
1085             dscj_inv=vbld_inv(j+nres)
1086             sig0ij=sigma(itypi,itypj)
1087             chi1=chi(itypi,itypj)
1088             chi2=chi(itypj,itypi)
1089             chi12=chi1*chi2
1090             chip1=chip(itypi)
1091             chip2=chip(itypj)
1092             chip12=chip1*chip2
1093             alf1=alp(itypi)
1094             alf2=alp(itypj)
1095             alf12=0.5D0*(alf1+alf2)
1096 C For diagnostics only!!!
1097 c           chi1=0.0D0
1098 c           chi2=0.0D0
1099 c           chi12=0.0D0
1100 c           chip1=0.0D0
1101 c           chip2=0.0D0
1102 c           chip12=0.0D0
1103 c           alf1=0.0D0
1104 c           alf2=0.0D0
1105 c           alf12=0.0D0
1106             xj=c(1,nres+j)
1107             yj=c(2,nres+j)
1108             zj=c(3,nres+j)
1109 C returning jth atom to box
1110           xj=mod(xj,boxxsize)
1111           if (xj.lt.0) xj=xj+boxxsize
1112           yj=mod(yj,boxysize)
1113           if (yj.lt.0) yj=yj+boxysize
1114           zj=mod(zj,boxzsize)
1115           if (zj.lt.0) zj=zj+boxzsize
1116        if ((zj.gt.bordlipbot)
1117      &.and.(zj.lt.bordliptop)) then
1118 C the energy transfer exist
1119         if (zj.lt.buflipbot) then
1120 C what fraction I am in
1121          fracinbuf=1.0d0-
1122      &        ((zj-bordlipbot)/lipbufthick)
1123 C lipbufthick is thickenes of lipid buffore
1124          sslipj=sscalelip(fracinbuf)
1125          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1126         elseif (zj.gt.bufliptop) then
1127          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1128          sslipj=sscalelip(fracinbuf)
1129          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1130         else
1131          sslipj=1.0d0
1132          ssgradlipj=0.0
1133         endif
1134        else
1135          sslipj=0.0d0
1136          ssgradlipj=0.0
1137        endif
1138       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1139      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1140       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1141      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1142 C       if (aa.ne.aa_aq(itypi,itypj)) then
1143
1144 C      write(iout,*) "tu,", i,j,aa_aq(itypi,itypj)-aa,
1145 C     & bb_aq(itypi,itypj)-bb,
1146 C     & sslipi,sslipj
1147 C         endif
1148
1149 C        write(iout,*),aa,aa_lip(itypi,itypj),aa_aq(itypi,itypj)
1150 C checking the distance
1151       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1152       xj_safe=xj
1153       yj_safe=yj
1154       zj_safe=zj
1155       subchap=0
1156 C finding the closest
1157       do xshift=-1,1
1158       do yshift=-1,1
1159       do zshift=-1,1
1160           xj=xj_safe+xshift*boxxsize
1161           yj=yj_safe+yshift*boxysize
1162           zj=zj_safe+zshift*boxzsize
1163           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1164           if(dist_temp.lt.dist_init) then
1165             dist_init=dist_temp
1166             xj_temp=xj
1167             yj_temp=yj
1168             zj_temp=zj
1169             subchap=1
1170           endif
1171        enddo
1172        enddo
1173        enddo
1174        if (subchap.eq.1) then
1175           xj=xj_temp-xi
1176           yj=yj_temp-yi
1177           zj=zj_temp-zi
1178        else
1179           xj=xj_safe-xi
1180           yj=yj_safe-yi
1181           zj=zj_safe-zi
1182        endif
1183
1184             dxj=dc_norm(1,nres+j)
1185             dyj=dc_norm(2,nres+j)
1186             dzj=dc_norm(3,nres+j)
1187 c            write (iout,*) i,j,xj,yj,zj
1188             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1189             rij=dsqrt(rrij)
1190             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1191             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1192             if (sss.le.0.0) cycle
1193 C Calculate angle-dependent terms of energy and contributions to their
1194 C derivatives.
1195
1196             call sc_angular
1197             sigsq=1.0D0/sigsq
1198             sig=sig0ij*dsqrt(sigsq)
1199             rij_shift=1.0D0/rij-sig+sig0ij
1200 C I hate to put IF's in the loops, but here don't have another choice!!!!
1201             if (rij_shift.le.0.0D0) then
1202               evdw=1.0D20
1203               return
1204             endif
1205             sigder=-sig*sigsq
1206 c---------------------------------------------------------------
1207             rij_shift=1.0D0/rij_shift
1208             fac=rij_shift**expon
1209             e1=fac*fac*aa
1210             e2=fac*bb
1211             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1212             eps2der=evdwij*eps3rt
1213             eps3der=evdwij*eps2rt
1214             evdwij=evdwij*eps2rt*eps3rt
1215             if (bb.gt.0) then
1216               evdw=evdw+evdwij*sss
1217             else
1218               evdw_t=evdw_t+evdwij*sss
1219             endif
1220             ij=icant(itypi,itypj)
1221             aux=eps1*eps2rt**2*eps3rt**2
1222             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1223      &        /dabs(eps(itypi,itypj))
1224             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1225 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1226 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1227 c     &         aux*e2/eps(itypi,itypj)
1228 c            if (lprn) then
1229             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1230             epsi=bb**2/aa
1231 c#define DEBUG
1232 #ifdef DEBUG
1233             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1234      &        restyp(itypi),i,restyp(itypj),j,
1235      &        epsi,sigm,chi1,chi2,chip1,chip2,
1236      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1237      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1238      &        evdwij
1239              write (iout,*) "partial sum", evdw, evdw_t
1240 #endif
1241 c#undef DEBUG
1242 c            endif
1243             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1244      &                        'evdw',i,j,evdwij
1245             if (calc_grad) then
1246 C Calculate gradient components.
1247             e1=e1*eps1*eps2rt**2*eps3rt**2
1248             fac=-expon*(e1+evdwij)*rij_shift
1249             sigder=fac*sigder
1250             fac=rij*fac
1251             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1252 C Calculate the radial part of the gradient
1253             gg(1)=xj*fac
1254             gg(2)=yj*fac
1255             gg(3)=zj*fac
1256 C Calculate angular part of the gradient.
1257             call sc_grad
1258             endif
1259 C            write(iout,*)  "partial sum", evdw, evdw_t
1260             ENDIF    ! dyn_ss
1261           enddo      ! j
1262         enddo        ! iint
1263       enddo          ! i
1264       return
1265       end
1266 C-----------------------------------------------------------------------------
1267       subroutine egbv(evdw,evdw_t)
1268 C
1269 C This subroutine calculates the interaction energy of nonbonded side chains
1270 C assuming the Gay-Berne-Vorobjev potential of interaction.
1271 C
1272       implicit real*8 (a-h,o-z)
1273       include 'DIMENSIONS'
1274       include 'DIMENSIONS.ZSCOPT'
1275       include "DIMENSIONS.COMPAR"
1276       include 'COMMON.GEO'
1277       include 'COMMON.VAR'
1278       include 'COMMON.LOCAL'
1279       include 'COMMON.CHAIN'
1280       include 'COMMON.DERIV'
1281       include 'COMMON.NAMES'
1282       include 'COMMON.INTERACT'
1283       include 'COMMON.ENEPS'
1284       include 'COMMON.IOUNITS'
1285       include 'COMMON.CALC'
1286       common /srutu/ icall
1287       logical lprn
1288       integer icant
1289       external icant
1290       do i=1,210
1291         do j=1,2
1292           eneps_temp(j,i)=0.0d0
1293         enddo
1294       enddo
1295       evdw=0.0D0
1296       evdw_t=0.0d0
1297 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1298       evdw=0.0D0
1299       lprn=.false.
1300 c      if (icall.gt.0) lprn=.true.
1301       ind=0
1302       do i=iatsc_s,iatsc_e
1303         itypi=iabs(itype(i))
1304         if (itypi.eq.ntyp1) cycle
1305         itypi1=iabs(itype(i+1))
1306         xi=c(1,nres+i)
1307         yi=c(2,nres+i)
1308         zi=c(3,nres+i)
1309         dxi=dc_norm(1,nres+i)
1310         dyi=dc_norm(2,nres+i)
1311         dzi=dc_norm(3,nres+i)
1312         dsci_inv=vbld_inv(i+nres)
1313 C
1314 C Calculate SC interaction energy.
1315 C
1316         do iint=1,nint_gr(i)
1317           do j=istart(i,iint),iend(i,iint)
1318             ind=ind+1
1319             itypj=iabs(itype(j))
1320             if (itypj.eq.ntyp1) cycle
1321             dscj_inv=vbld_inv(j+nres)
1322             sig0ij=sigma(itypi,itypj)
1323             r0ij=r0(itypi,itypj)
1324             chi1=chi(itypi,itypj)
1325             chi2=chi(itypj,itypi)
1326             chi12=chi1*chi2
1327             chip1=chip(itypi)
1328             chip2=chip(itypj)
1329             chip12=chip1*chip2
1330             alf1=alp(itypi)
1331             alf2=alp(itypj)
1332             alf12=0.5D0*(alf1+alf2)
1333 C For diagnostics only!!!
1334 c           chi1=0.0D0
1335 c           chi2=0.0D0
1336 c           chi12=0.0D0
1337 c           chip1=0.0D0
1338 c           chip2=0.0D0
1339 c           chip12=0.0D0
1340 c           alf1=0.0D0
1341 c           alf2=0.0D0
1342 c           alf12=0.0D0
1343             xj=c(1,nres+j)-xi
1344             yj=c(2,nres+j)-yi
1345             zj=c(3,nres+j)-zi
1346             dxj=dc_norm(1,nres+j)
1347             dyj=dc_norm(2,nres+j)
1348             dzj=dc_norm(3,nres+j)
1349             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1350             rij=dsqrt(rrij)
1351 C Calculate angle-dependent terms of energy and contributions to their
1352 C derivatives.
1353             call sc_angular
1354             sigsq=1.0D0/sigsq
1355             sig=sig0ij*dsqrt(sigsq)
1356             rij_shift=1.0D0/rij-sig+r0ij
1357 C I hate to put IF's in the loops, but here don't have another choice!!!!
1358             if (rij_shift.le.0.0D0) then
1359               evdw=1.0D20
1360               return
1361             endif
1362             sigder=-sig*sigsq
1363 c---------------------------------------------------------------
1364             rij_shift=1.0D0/rij_shift
1365             fac=rij_shift**expon
1366             e1=fac*fac*aa
1367             e2=fac*bb
1368             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1369             eps2der=evdwij*eps3rt
1370             eps3der=evdwij*eps2rt
1371             fac_augm=rrij**expon
1372             e_augm=augm(itypi,itypj)*fac_augm
1373             evdwij=evdwij*eps2rt*eps3rt
1374             if (bb.gt.0.0d0) then
1375               evdw=evdw+evdwij+e_augm
1376             else
1377               evdw_t=evdw_t+evdwij+e_augm
1378             endif
1379             ij=icant(itypi,itypj)
1380             aux=eps1*eps2rt**2*eps3rt**2
1381             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1382      &        /dabs(eps(itypi,itypj))
1383             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1384 c            eneps_temp(ij)=eneps_temp(ij)
1385 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1386 c            if (lprn) then
1387 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1388 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1389 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1390 c     &        restyp(itypi),i,restyp(itypj),j,
1391 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1392 c     &        chi1,chi2,chip1,chip2,
1393 c     &        eps1,eps2rt**2,eps3rt**2,
1394 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1395 c     &        evdwij+e_augm
1396 c            endif
1397             if (calc_grad) then
1398 C Calculate gradient components.
1399             e1=e1*eps1*eps2rt**2*eps3rt**2
1400             fac=-expon*(e1+evdwij)*rij_shift
1401             sigder=fac*sigder
1402             fac=rij*fac-2*expon*rrij*e_augm
1403 C Calculate the radial part of the gradient
1404             gg(1)=xj*fac
1405             gg(2)=yj*fac
1406             gg(3)=zj*fac
1407 C Calculate angular part of the gradient.
1408             call sc_grad
1409             endif
1410           enddo      ! j
1411         enddo        ! iint
1412       enddo          ! i
1413       return
1414       end
1415 C-----------------------------------------------------------------------------
1416       subroutine sc_angular
1417 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1418 C om12. Called by ebp, egb, and egbv.
1419       implicit none
1420       include 'COMMON.CALC'
1421       erij(1)=xj*rij
1422       erij(2)=yj*rij
1423       erij(3)=zj*rij
1424       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1425       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1426       om12=dxi*dxj+dyi*dyj+dzi*dzj
1427       chiom12=chi12*om12
1428 C Calculate eps1(om12) and its derivative in om12
1429       faceps1=1.0D0-om12*chiom12
1430       faceps1_inv=1.0D0/faceps1
1431       eps1=dsqrt(faceps1_inv)
1432 C Following variable is eps1*deps1/dom12
1433       eps1_om12=faceps1_inv*chiom12
1434 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1435 C and om12.
1436       om1om2=om1*om2
1437       chiom1=chi1*om1
1438       chiom2=chi2*om2
1439       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1440       sigsq=1.0D0-facsig*faceps1_inv
1441       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1442       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1443       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1444 C Calculate eps2 and its derivatives in om1, om2, and om12.
1445       chipom1=chip1*om1
1446       chipom2=chip2*om2
1447       chipom12=chip12*om12
1448       facp=1.0D0-om12*chipom12
1449       facp_inv=1.0D0/facp
1450       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1451 C Following variable is the square root of eps2
1452       eps2rt=1.0D0-facp1*facp_inv
1453 C Following three variables are the derivatives of the square root of eps
1454 C in om1, om2, and om12.
1455       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1456       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1457       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1458 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1459       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1460 C Calculate whole angle-dependent part of epsilon and contributions
1461 C to its derivatives
1462       return
1463       end
1464 C----------------------------------------------------------------------------
1465       subroutine sc_grad
1466       implicit real*8 (a-h,o-z)
1467       include 'DIMENSIONS'
1468       include 'DIMENSIONS.ZSCOPT'
1469       include 'COMMON.CHAIN'
1470       include 'COMMON.DERIV'
1471       include 'COMMON.CALC'
1472       double precision dcosom1(3),dcosom2(3)
1473       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1474       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1475       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1476      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1477       do k=1,3
1478         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1479         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1480       enddo
1481       do k=1,3
1482         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1483       enddo
1484       do k=1,3
1485         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1486      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1487      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1488         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1489      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1490      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1491       enddo
1492 C
1493 C Calculate the components of the gradient in DC and X
1494 C
1495       do k=i,j-1
1496         do l=1,3
1497           gvdwc(l,k)=gvdwc(l,k)+gg(l)
1498         enddo
1499       enddo
1500       return
1501       end
1502 c------------------------------------------------------------------------------
1503       subroutine vec_and_deriv
1504       implicit real*8 (a-h,o-z)
1505       include 'DIMENSIONS'
1506       include 'DIMENSIONS.ZSCOPT'
1507       include 'COMMON.IOUNITS'
1508       include 'COMMON.GEO'
1509       include 'COMMON.VAR'
1510       include 'COMMON.LOCAL'
1511       include 'COMMON.CHAIN'
1512       include 'COMMON.VECTORS'
1513       include 'COMMON.DERIV'
1514       include 'COMMON.INTERACT'
1515       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
1516 C Compute the local reference systems. For reference system (i), the
1517 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
1518 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
1519       do i=1,nres-1
1520 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
1521           if (i.eq.nres-1) then
1522 C Case of the last full residue
1523 C Compute the Z-axis
1524             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
1525             costh=dcos(pi-theta(nres))
1526             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1527 c            write (iout,*) "i",i," dc_norm",dc_norm(:,i),dc_norm(:,i-1),
1528 c     &         " uz",uz(:,i)
1529             do k=1,3
1530               uz(k,i)=fac*uz(k,i)
1531             enddo
1532             if (calc_grad) then
1533 C Compute the derivatives of uz
1534             uzder(1,1,1)= 0.0d0
1535             uzder(2,1,1)=-dc_norm(3,i-1)
1536             uzder(3,1,1)= dc_norm(2,i-1)
1537             uzder(1,2,1)= dc_norm(3,i-1)
1538             uzder(2,2,1)= 0.0d0
1539             uzder(3,2,1)=-dc_norm(1,i-1)
1540             uzder(1,3,1)=-dc_norm(2,i-1)
1541             uzder(2,3,1)= dc_norm(1,i-1)
1542             uzder(3,3,1)= 0.0d0
1543             uzder(1,1,2)= 0.0d0
1544             uzder(2,1,2)= dc_norm(3,i)
1545             uzder(3,1,2)=-dc_norm(2,i)
1546             uzder(1,2,2)=-dc_norm(3,i)
1547             uzder(2,2,2)= 0.0d0
1548             uzder(3,2,2)= dc_norm(1,i)
1549             uzder(1,3,2)= dc_norm(2,i)
1550             uzder(2,3,2)=-dc_norm(1,i)
1551             uzder(3,3,2)= 0.0d0
1552             endif ! calc_grad
1553 C Compute the Y-axis
1554             facy=fac
1555             do k=1,3
1556               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
1557             enddo
1558             if (calc_grad) then
1559 C Compute the derivatives of uy
1560             do j=1,3
1561               do k=1,3
1562                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
1563      &                        -dc_norm(k,i)*dc_norm(j,i-1)
1564                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1565               enddo
1566               uyder(j,j,1)=uyder(j,j,1)-costh
1567               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1568             enddo
1569             do j=1,2
1570               do k=1,3
1571                 do l=1,3
1572                   uygrad(l,k,j,i)=uyder(l,k,j)
1573                   uzgrad(l,k,j,i)=uzder(l,k,j)
1574                 enddo
1575               enddo
1576             enddo
1577             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1578             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1579             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1580             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1581             endif
1582           else
1583 C Other residues
1584 C Compute the Z-axis
1585             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
1586             costh=dcos(pi-theta(i+2))
1587             fac=1.0d0/dsqrt(1.0d0-costh*costh)
1588             do k=1,3
1589               uz(k,i)=fac*uz(k,i)
1590             enddo
1591             if (calc_grad) then
1592 C Compute the derivatives of uz
1593             uzder(1,1,1)= 0.0d0
1594             uzder(2,1,1)=-dc_norm(3,i+1)
1595             uzder(3,1,1)= dc_norm(2,i+1)
1596             uzder(1,2,1)= dc_norm(3,i+1)
1597             uzder(2,2,1)= 0.0d0
1598             uzder(3,2,1)=-dc_norm(1,i+1)
1599             uzder(1,3,1)=-dc_norm(2,i+1)
1600             uzder(2,3,1)= dc_norm(1,i+1)
1601             uzder(3,3,1)= 0.0d0
1602             uzder(1,1,2)= 0.0d0
1603             uzder(2,1,2)= dc_norm(3,i)
1604             uzder(3,1,2)=-dc_norm(2,i)
1605             uzder(1,2,2)=-dc_norm(3,i)
1606             uzder(2,2,2)= 0.0d0
1607             uzder(3,2,2)= dc_norm(1,i)
1608             uzder(1,3,2)= dc_norm(2,i)
1609             uzder(2,3,2)=-dc_norm(1,i)
1610             uzder(3,3,2)= 0.0d0
1611             endif
1612 C Compute the Y-axis
1613             facy=fac
1614             do k=1,3
1615               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
1616             enddo
1617             if (calc_grad) then
1618 C Compute the derivatives of uy
1619             do j=1,3
1620               do k=1,3
1621                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
1622      &                        -dc_norm(k,i)*dc_norm(j,i+1)
1623                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
1624               enddo
1625               uyder(j,j,1)=uyder(j,j,1)-costh
1626               uyder(j,j,2)=1.0d0+uyder(j,j,2)
1627             enddo
1628             do j=1,2
1629               do k=1,3
1630                 do l=1,3
1631                   uygrad(l,k,j,i)=uyder(l,k,j)
1632                   uzgrad(l,k,j,i)=uzder(l,k,j)
1633                 enddo
1634               enddo
1635             enddo
1636             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
1637             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
1638             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
1639             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
1640           endif
1641           endif
1642       enddo
1643       if (calc_grad) then
1644       do i=1,nres-1
1645         vbld_inv_temp(1)=vbld_inv(i+1)
1646         if (i.lt.nres-1) then
1647           vbld_inv_temp(2)=vbld_inv(i+2)
1648         else
1649           vbld_inv_temp(2)=vbld_inv(i)
1650         endif
1651         do j=1,2
1652           do k=1,3
1653             do l=1,3
1654               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
1655               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
1656             enddo
1657           enddo
1658         enddo
1659       enddo
1660       endif
1661       return
1662       end
1663 C--------------------------------------------------------------------------
1664       subroutine set_matrices
1665       implicit real*8 (a-h,o-z)
1666       include 'DIMENSIONS'
1667 #ifdef MPI
1668       include "mpif.h"
1669       integer IERR
1670       integer status(MPI_STATUS_SIZE)
1671 #endif
1672       include 'DIMENSIONS.ZSCOPT'
1673       include 'COMMON.IOUNITS'
1674       include 'COMMON.GEO'
1675       include 'COMMON.VAR'
1676       include 'COMMON.LOCAL'
1677       include 'COMMON.CHAIN'
1678       include 'COMMON.DERIV'
1679       include 'COMMON.INTERACT'
1680       include 'COMMON.CONTACTS'
1681       include 'COMMON.TORSION'
1682       include 'COMMON.VECTORS'
1683       include 'COMMON.FFIELD'
1684       double precision auxvec(2),auxmat(2,2)
1685 C
1686 C Compute the virtual-bond-torsional-angle dependent quantities needed
1687 C to calculate the el-loc multibody terms of various order.
1688 C
1689 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
1690       do i=3,nres+1
1691         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1692           iti = itype2loc(itype(i-2))
1693         else
1694           iti=nloctyp
1695         endif
1696 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1697         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1698           iti1 = itype2loc(itype(i-1))
1699         else
1700           iti1=nloctyp
1701         endif
1702 #ifdef NEWCORR
1703         cost1=dcos(theta(i-1))
1704         sint1=dsin(theta(i-1))
1705         sint1sq=sint1*sint1
1706         sint1cub=sint1sq*sint1
1707         sint1cost1=2*sint1*cost1
1708 #ifdef DEBUG
1709         write (iout,*) "bnew1",i,iti
1710         write (iout,*) (bnew1(k,1,iti),k=1,3)
1711         write (iout,*) (bnew1(k,2,iti),k=1,3)
1712         write (iout,*) "bnew2",i,iti
1713         write (iout,*) (bnew2(k,1,iti),k=1,3)
1714         write (iout,*) (bnew2(k,2,iti),k=1,3)
1715 #endif
1716         do k=1,2
1717           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
1718           b1(k,i-2)=sint1*b1k
1719           gtb1(k,i-2)=cost1*b1k-sint1sq*
1720      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
1721           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
1722           b2(k,i-2)=sint1*b2k
1723           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
1724      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
1725         enddo
1726         do k=1,2
1727           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
1728           cc(1,k,i-2)=sint1sq*aux
1729           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
1730      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
1731           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
1732           dd(1,k,i-2)=sint1sq*aux
1733           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
1734      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
1735         enddo
1736         cc(2,1,i-2)=cc(1,2,i-2)
1737         cc(2,2,i-2)=-cc(1,1,i-2)
1738         gtcc(2,1,i-2)=gtcc(1,2,i-2)
1739         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
1740         dd(2,1,i-2)=dd(1,2,i-2)
1741         dd(2,2,i-2)=-dd(1,1,i-2)
1742         gtdd(2,1,i-2)=gtdd(1,2,i-2)
1743         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
1744         do k=1,2
1745           do l=1,2
1746             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
1747             EE(l,k,i-2)=sint1sq*aux
1748             if (calc_grad)
1749      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
1750           enddo
1751         enddo
1752         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
1753         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
1754         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
1755         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
1756         if (calc_grad) then
1757         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
1758         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
1759         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
1760         endif
1761 c        b1tilde(1,i-2)=b1(1,i-2)
1762 c        b1tilde(2,i-2)=-b1(2,i-2)
1763 c        b2tilde(1,i-2)=b2(1,i-2)
1764 c        b2tilde(2,i-2)=-b2(2,i-2)
1765 #ifdef DEBUG
1766         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
1767         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1768         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1769         write (iout,*) 'theta=', theta(i-1)
1770 #endif
1771 #else
1772 c        if (i.gt. nnt+2 .and. i.lt.nct+2) then
1773 c          iti = itype2loc(itype(i-2))
1774 c        else
1775 c          iti=nloctyp
1776 c        endif
1777 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1778 c        if (i.gt. nnt+1 .and. i.lt.nct+1) then
1779 c          iti1 = itype2loc(itype(i-1))
1780 c        else
1781 c          iti1=nloctyp
1782 c        endif
1783         b1(1,i-2)=b(3,iti)
1784         b1(2,i-2)=b(5,iti)
1785         b2(1,i-2)=b(2,iti)
1786         b2(2,i-2)=b(4,iti)
1787         do k=1,2
1788           do l=1,2
1789            CC(k,l,i-2)=ccold(k,l,iti)
1790            DD(k,l,i-2)=ddold(k,l,iti)
1791            EE(k,l,i-2)=eeold(k,l,iti)
1792           enddo
1793         enddo
1794 #endif
1795         b1tilde(1,i-2)= b1(1,i-2)
1796         b1tilde(2,i-2)=-b1(2,i-2)
1797         b2tilde(1,i-2)= b2(1,i-2)
1798         b2tilde(2,i-2)=-b2(2,i-2)
1799 c
1800         Ctilde(1,1,i-2)= CC(1,1,i-2)
1801         Ctilde(1,2,i-2)= CC(1,2,i-2)
1802         Ctilde(2,1,i-2)=-CC(2,1,i-2)
1803         Ctilde(2,2,i-2)=-CC(2,2,i-2)
1804 c
1805         Dtilde(1,1,i-2)= DD(1,1,i-2)
1806         Dtilde(1,2,i-2)= DD(1,2,i-2)
1807         Dtilde(2,1,i-2)=-DD(2,1,i-2)
1808         Dtilde(2,2,i-2)=-DD(2,2,i-2)
1809 #ifdef DEBUG
1810         write(iout,*) "i",i," iti",iti
1811         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
1812         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
1813 #endif
1814       enddo
1815       do i=3,nres+1
1816         if (i .lt. nres+1) then
1817           sin1=dsin(phi(i))
1818           cos1=dcos(phi(i))
1819           sintab(i-2)=sin1
1820           costab(i-2)=cos1
1821           obrot(1,i-2)=cos1
1822           obrot(2,i-2)=sin1
1823           sin2=dsin(2*phi(i))
1824           cos2=dcos(2*phi(i))
1825           sintab2(i-2)=sin2
1826           costab2(i-2)=cos2
1827           obrot2(1,i-2)=cos2
1828           obrot2(2,i-2)=sin2
1829           Ug(1,1,i-2)=-cos1
1830           Ug(1,2,i-2)=-sin1
1831           Ug(2,1,i-2)=-sin1
1832           Ug(2,2,i-2)= cos1
1833           Ug2(1,1,i-2)=-cos2
1834           Ug2(1,2,i-2)=-sin2
1835           Ug2(2,1,i-2)=-sin2
1836           Ug2(2,2,i-2)= cos2
1837         else
1838           costab(i-2)=1.0d0
1839           sintab(i-2)=0.0d0
1840           obrot(1,i-2)=1.0d0
1841           obrot(2,i-2)=0.0d0
1842           obrot2(1,i-2)=0.0d0
1843           obrot2(2,i-2)=0.0d0
1844           Ug(1,1,i-2)=1.0d0
1845           Ug(1,2,i-2)=0.0d0
1846           Ug(2,1,i-2)=0.0d0
1847           Ug(2,2,i-2)=1.0d0
1848           Ug2(1,1,i-2)=0.0d0
1849           Ug2(1,2,i-2)=0.0d0
1850           Ug2(2,1,i-2)=0.0d0
1851           Ug2(2,2,i-2)=0.0d0
1852         endif
1853         if (i .gt. 3 .and. i .lt. nres+1) then
1854           obrot_der(1,i-2)=-sin1
1855           obrot_der(2,i-2)= cos1
1856           Ugder(1,1,i-2)= sin1
1857           Ugder(1,2,i-2)=-cos1
1858           Ugder(2,1,i-2)=-cos1
1859           Ugder(2,2,i-2)=-sin1
1860           dwacos2=cos2+cos2
1861           dwasin2=sin2+sin2
1862           obrot2_der(1,i-2)=-dwasin2
1863           obrot2_der(2,i-2)= dwacos2
1864           Ug2der(1,1,i-2)= dwasin2
1865           Ug2der(1,2,i-2)=-dwacos2
1866           Ug2der(2,1,i-2)=-dwacos2
1867           Ug2der(2,2,i-2)=-dwasin2
1868         else
1869           obrot_der(1,i-2)=0.0d0
1870           obrot_der(2,i-2)=0.0d0
1871           Ugder(1,1,i-2)=0.0d0
1872           Ugder(1,2,i-2)=0.0d0
1873           Ugder(2,1,i-2)=0.0d0
1874           Ugder(2,2,i-2)=0.0d0
1875           obrot2_der(1,i-2)=0.0d0
1876           obrot2_der(2,i-2)=0.0d0
1877           Ug2der(1,1,i-2)=0.0d0
1878           Ug2der(1,2,i-2)=0.0d0
1879           Ug2der(2,1,i-2)=0.0d0
1880           Ug2der(2,2,i-2)=0.0d0
1881         endif
1882 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
1883         if (i.gt. nnt+2 .and. i.lt.nct+2) then
1884           iti = itype2loc(itype(i-2))
1885         else
1886           iti=nloctyp
1887         endif
1888 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1889         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1890           iti1 = itype2loc(itype(i-1))
1891         else
1892           iti1=nloctyp
1893         endif
1894 cd        write (iout,*) '*******i',i,' iti1',iti
1895 cd        write (iout,*) 'b1',b1(:,iti)
1896 cd        write (iout,*) 'b2',b2(:,iti)
1897 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
1898 c        if (i .gt. iatel_s+2) then
1899         if (i .gt. nnt+2) then
1900           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
1901 #ifdef NEWCORR
1902           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
1903 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
1904 #endif
1905 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
1906 c     &    EE(1,2,iti),EE(2,2,i)
1907           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
1908           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
1909 c          write(iout,*) "Macierz EUG",
1910 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
1911 c     &    eug(2,2,i-2)
1912           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
1913      &    then
1914           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
1915           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
1916           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
1917           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
1918           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
1919           endif
1920         else
1921           do k=1,2
1922             Ub2(k,i-2)=0.0d0
1923             Ctobr(k,i-2)=0.0d0
1924             Dtobr2(k,i-2)=0.0d0
1925             do l=1,2
1926               EUg(l,k,i-2)=0.0d0
1927               CUg(l,k,i-2)=0.0d0
1928               DUg(l,k,i-2)=0.0d0
1929               DtUg2(l,k,i-2)=0.0d0
1930             enddo
1931           enddo
1932         endif
1933         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
1934         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
1935         do k=1,2
1936           muder(k,i-2)=Ub2der(k,i-2)
1937         enddo
1938 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
1939         if (i.gt. nnt+1 .and. i.lt.nct+1) then
1940           if (itype(i-1).le.ntyp) then
1941             iti1 = itype2loc(itype(i-1))
1942           else
1943             iti1=nloctyp
1944           endif
1945         else
1946           iti1=nloctyp
1947         endif
1948         do k=1,2
1949           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
1950         enddo
1951 #ifdef MUOUT
1952         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
1953      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
1954      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
1955      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
1956      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
1957      &      ((ee(l,k,i-2),l=1,2),k=1,2)
1958 #endif
1959 cd        write (iout,*) 'mu1',mu1(:,i-2)
1960 cd        write (iout,*) 'mu2',mu2(:,i-2)
1961         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
1962      &  then
1963         if (calc_grad) then
1964         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
1965         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
1966         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
1967         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
1968         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
1969         endif
1970 C Vectors and matrices dependent on a single virtual-bond dihedral.
1971         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
1972         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
1973         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
1974         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
1975         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
1976         if (calc_grad) then
1977         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
1978         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
1979         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
1980         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
1981         endif
1982         endif
1983       enddo
1984 C Matrices dependent on two consecutive virtual-bond dihedrals.
1985 C The order of matrices is from left to right.
1986       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
1987      &then
1988       do i=2,nres-1
1989         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
1990         if (calc_grad) then
1991         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
1992         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
1993         endif
1994         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
1995         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
1996         if (calc_grad) then
1997         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
1998         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
1999         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2000         endif
2001       enddo
2002       endif
2003       return
2004       end
2005 C--------------------------------------------------------------------------
2006       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2007 C
2008 C This subroutine calculates the average interaction energy and its gradient
2009 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2010 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2011 C The potential depends both on the distance of peptide-group centers and on
2012 C the orientation of the CA-CA virtual bonds.
2013 C
2014       implicit real*8 (a-h,o-z)
2015 #ifdef MPI
2016       include 'mpif.h'
2017 #endif
2018       include 'DIMENSIONS'
2019       include 'DIMENSIONS.ZSCOPT'
2020       include 'COMMON.CONTROL'
2021       include 'COMMON.IOUNITS'
2022       include 'COMMON.GEO'
2023       include 'COMMON.VAR'
2024       include 'COMMON.LOCAL'
2025       include 'COMMON.CHAIN'
2026       include 'COMMON.DERIV'
2027       include 'COMMON.INTERACT'
2028       include 'COMMON.CONTACTS'
2029       include 'COMMON.TORSION'
2030       include 'COMMON.VECTORS'
2031       include 'COMMON.FFIELD'
2032       include 'COMMON.TIME1'
2033       include 'COMMON.SPLITELE'
2034       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2035      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2036       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2037      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
2038       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2039      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2040      &    num_conti,j1,j2
2041 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2042 #ifdef MOMENT
2043       double precision scal_el /1.0d0/
2044 #else
2045       double precision scal_el /0.5d0/
2046 #endif
2047 C 12/13/98
2048 C 13-go grudnia roku pamietnego...
2049       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2050      &                   0.0d0,1.0d0,0.0d0,
2051      &                   0.0d0,0.0d0,1.0d0/
2052 cd      write(iout,*) 'In EELEC'
2053 cd      do i=1,nloctyp
2054 cd        write(iout,*) 'Type',i
2055 cd        write(iout,*) 'B1',B1(:,i)
2056 cd        write(iout,*) 'B2',B2(:,i)
2057 cd        write(iout,*) 'CC',CC(:,:,i)
2058 cd        write(iout,*) 'DD',DD(:,:,i)
2059 cd        write(iout,*) 'EE',EE(:,:,i)
2060 cd      enddo
2061 cd      call check_vecgrad
2062 cd      stop
2063       if (icheckgrad.eq.1) then
2064         do i=1,nres-1
2065           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2066           do k=1,3
2067             dc_norm(k,i)=dc(k,i)*fac
2068           enddo
2069 c          write (iout,*) 'i',i,' fac',fac
2070         enddo
2071       endif
2072       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2073      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2074      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2075 c        call vec_and_deriv
2076 #ifdef TIMING
2077         time01=MPI_Wtime()
2078 #endif
2079         call set_matrices
2080 #ifdef TIMING
2081         time_mat=time_mat+MPI_Wtime()-time01
2082 #endif
2083       endif
2084 cd      do i=1,nres-1
2085 cd        write (iout,*) 'i=',i
2086 cd        do k=1,3
2087 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2088 cd        enddo
2089 cd        do k=1,3
2090 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2091 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2092 cd        enddo
2093 cd      enddo
2094       t_eelecij=0.0d0
2095       ees=0.0D0
2096       evdw1=0.0D0
2097       eel_loc=0.0d0
2098       eello_turn3=0.0d0
2099       eello_turn4=0.0d0
2100       ind=0
2101       do i=1,nres
2102         num_cont_hb(i)=0
2103       enddo
2104 cd      print '(a)','Enter EELEC'
2105 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2106       do i=1,nres
2107         gel_loc_loc(i)=0.0d0
2108         gcorr_loc(i)=0.0d0
2109       enddo
2110 c
2111 c
2112 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2113 C
2114 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2115 C
2116 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
2117       do i=iturn3_start,iturn3_end
2118 c        if (i.le.1) cycle
2119 C        write(iout,*) "tu jest i",i
2120         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2121 C changes suggested by Ana to avoid out of bounds
2122 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
2123 c     & .or.((i+4).gt.nres)
2124 c     & .or.((i-1).le.0)
2125 C end of changes by Ana
2126 C dobra zmiana wycofana
2127      &  .or. itype(i+2).eq.ntyp1
2128      &  .or. itype(i+3).eq.ntyp1) cycle
2129 C Adam: Instructions below will switch off existing interactions
2130 c        if(i.gt.1)then
2131 c          if(itype(i-1).eq.ntyp1)cycle
2132 c        end if
2133 c        if(i.LT.nres-3)then
2134 c          if (itype(i+4).eq.ntyp1) cycle
2135 c        end if
2136         dxi=dc(1,i)
2137         dyi=dc(2,i)
2138         dzi=dc(3,i)
2139         dx_normi=dc_norm(1,i)
2140         dy_normi=dc_norm(2,i)
2141         dz_normi=dc_norm(3,i)
2142         xmedi=c(1,i)+0.5d0*dxi
2143         ymedi=c(2,i)+0.5d0*dyi
2144         zmedi=c(3,i)+0.5d0*dzi
2145           xmedi=mod(xmedi,boxxsize)
2146           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2147           ymedi=mod(ymedi,boxysize)
2148           if (ymedi.lt.0) ymedi=ymedi+boxysize
2149           zmedi=mod(zmedi,boxzsize)
2150           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2151         num_conti=0
2152         call eelecij(i,i+2,ees,evdw1,eel_loc)
2153         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2154         num_cont_hb(i)=num_conti
2155       enddo
2156       do i=iturn4_start,iturn4_end
2157         if (i.lt.1) cycle
2158         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2159 C changes suggested by Ana to avoid out of bounds
2160 c     & .or.((i+5).gt.nres)
2161 c     & .or.((i-1).le.0)
2162 C end of changes suggested by Ana
2163      &    .or. itype(i+3).eq.ntyp1
2164      &    .or. itype(i+4).eq.ntyp1
2165 c     &    .or. itype(i+5).eq.ntyp1
2166 c     &    .or. itype(i).eq.ntyp1
2167 c     &    .or. itype(i-1).eq.ntyp1
2168      &                             ) cycle
2169         dxi=dc(1,i)
2170         dyi=dc(2,i)
2171         dzi=dc(3,i)
2172         dx_normi=dc_norm(1,i)
2173         dy_normi=dc_norm(2,i)
2174         dz_normi=dc_norm(3,i)
2175         xmedi=c(1,i)+0.5d0*dxi
2176         ymedi=c(2,i)+0.5d0*dyi
2177         zmedi=c(3,i)+0.5d0*dzi
2178 C Return atom into box, boxxsize is size of box in x dimension
2179 c  194   continue
2180 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2181 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2182 C Condition for being inside the proper box
2183 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
2184 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
2185 c        go to 194
2186 c        endif
2187 c  195   continue
2188 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
2189 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2190 C Condition for being inside the proper box
2191 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
2192 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
2193 c        go to 195
2194 c        endif
2195 c  196   continue
2196 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2197 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2198 C Condition for being inside the proper box
2199 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
2200 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
2201 c        go to 196
2202 c        endif
2203           xmedi=mod(xmedi,boxxsize)
2204           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2205           ymedi=mod(ymedi,boxysize)
2206           if (ymedi.lt.0) ymedi=ymedi+boxysize
2207           zmedi=mod(zmedi,boxzsize)
2208           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2209
2210         num_conti=num_cont_hb(i)
2211 c        write(iout,*) "JESTEM W PETLI"
2212         call eelecij(i,i+3,ees,evdw1,eel_loc)
2213         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2214      &   call eturn4(i,eello_turn4)
2215         num_cont_hb(i)=num_conti
2216       enddo   ! i
2217 C Loop over all neighbouring boxes
2218 C      do xshift=-1,1
2219 C      do yshift=-1,1
2220 C      do zshift=-1,1
2221 c
2222 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2223 c
2224 CTU KURWA
2225       do i=iatel_s,iatel_e
2226 C        do i=75,75
2227 c        if (i.le.1) cycle
2228         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2229 C changes suggested by Ana to avoid out of bounds
2230 c     & .or.((i+2).gt.nres)
2231 c     & .or.((i-1).le.0)
2232 C end of changes by Ana
2233 c     &  .or. itype(i+2).eq.ntyp1
2234 c     &  .or. itype(i-1).eq.ntyp1
2235      &                ) cycle
2236         dxi=dc(1,i)
2237         dyi=dc(2,i)
2238         dzi=dc(3,i)
2239         dx_normi=dc_norm(1,i)
2240         dy_normi=dc_norm(2,i)
2241         dz_normi=dc_norm(3,i)
2242         xmedi=c(1,i)+0.5d0*dxi
2243         ymedi=c(2,i)+0.5d0*dyi
2244         zmedi=c(3,i)+0.5d0*dzi
2245           xmedi=mod(xmedi,boxxsize)
2246           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2247           ymedi=mod(ymedi,boxysize)
2248           if (ymedi.lt.0) ymedi=ymedi+boxysize
2249           zmedi=mod(zmedi,boxzsize)
2250           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2251 C          xmedi=xmedi+xshift*boxxsize
2252 C          ymedi=ymedi+yshift*boxysize
2253 C          zmedi=zmedi+zshift*boxzsize
2254
2255 C Return tom into box, boxxsize is size of box in x dimension
2256 c  164   continue
2257 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
2258 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
2259 C Condition for being inside the proper box
2260 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
2261 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
2262 c        go to 164
2263 c        endif
2264 c  165   continue
2265 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
2266 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
2267 C Condition for being inside the proper box
2268 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
2269 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
2270 c        go to 165
2271 c        endif
2272 c  166   continue
2273 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
2274 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
2275 cC Condition for being inside the proper box
2276 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
2277 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
2278 c        go to 166
2279 c        endif
2280
2281 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2282         num_conti=num_cont_hb(i)
2283 C I TU KURWA
2284         do j=ielstart(i),ielend(i)
2285 C          do j=16,17
2286 C          write (iout,*) i,j
2287 C         if (j.le.1) cycle
2288           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
2289 C changes suggested by Ana to avoid out of bounds
2290 c     & .or.((j+2).gt.nres)
2291 c     & .or.((j-1).le.0)
2292 C end of changes by Ana
2293 c     & .or.itype(j+2).eq.ntyp1
2294 c     & .or.itype(j-1).eq.ntyp1
2295      &) cycle
2296           call eelecij(i,j,ees,evdw1,eel_loc)
2297         enddo ! j
2298         num_cont_hb(i)=num_conti
2299       enddo   ! i
2300 C     enddo   ! zshift
2301 C      enddo   ! yshift
2302 C      enddo   ! xshift
2303
2304 c      write (iout,*) "Number of loop steps in EELEC:",ind
2305 cd      do i=1,nres
2306 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2307 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2308 cd      enddo
2309 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2310 ccc      eel_loc=eel_loc+eello_turn3
2311 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2312       return
2313       end
2314 C-------------------------------------------------------------------------------
2315       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2316       implicit real*8 (a-h,o-z)
2317       include 'DIMENSIONS'
2318       include 'DIMENSIONS.ZSCOPT'
2319 #ifdef MPI
2320       include "mpif.h"
2321 #endif
2322       include 'COMMON.CONTROL'
2323       include 'COMMON.IOUNITS'
2324       include 'COMMON.GEO'
2325       include 'COMMON.VAR'
2326       include 'COMMON.LOCAL'
2327       include 'COMMON.CHAIN'
2328       include 'COMMON.DERIV'
2329       include 'COMMON.INTERACT'
2330       include 'COMMON.CONTACTS'
2331       include 'COMMON.TORSION'
2332       include 'COMMON.VECTORS'
2333       include 'COMMON.FFIELD'
2334       include 'COMMON.TIME1'
2335       include 'COMMON.SPLITELE'
2336       include 'COMMON.SHIELD'
2337       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2338      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2339       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2340      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
2341      &    gmuij2(4),gmuji2(4)
2342       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2343      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2344      &    num_conti,j1,j2
2345 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2346 #ifdef MOMENT
2347       double precision scal_el /1.0d0/
2348 #else
2349       double precision scal_el /0.5d0/
2350 #endif
2351 C 12/13/98
2352 C 13-go grudnia roku pamietnego...
2353       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2354      &                   0.0d0,1.0d0,0.0d0,
2355      &                   0.0d0,0.0d0,1.0d0/
2356        integer xshift,yshift,zshift
2357 c          time00=MPI_Wtime()
2358 cd      write (iout,*) "eelecij",i,j
2359 c          ind=ind+1
2360           iteli=itel(i)
2361           itelj=itel(j)
2362           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2363           aaa=app(iteli,itelj)
2364           bbb=bpp(iteli,itelj)
2365           ael6i=ael6(iteli,itelj)
2366           ael3i=ael3(iteli,itelj)
2367           dxj=dc(1,j)
2368           dyj=dc(2,j)
2369           dzj=dc(3,j)
2370           dx_normj=dc_norm(1,j)
2371           dy_normj=dc_norm(2,j)
2372           dz_normj=dc_norm(3,j)
2373 C          xj=c(1,j)+0.5D0*dxj-xmedi
2374 C          yj=c(2,j)+0.5D0*dyj-ymedi
2375 C          zj=c(3,j)+0.5D0*dzj-zmedi
2376           xj=c(1,j)+0.5D0*dxj
2377           yj=c(2,j)+0.5D0*dyj
2378           zj=c(3,j)+0.5D0*dzj
2379           xj=mod(xj,boxxsize)
2380           if (xj.lt.0) xj=xj+boxxsize
2381           yj=mod(yj,boxysize)
2382           if (yj.lt.0) yj=yj+boxysize
2383           zj=mod(zj,boxzsize)
2384           if (zj.lt.0) zj=zj+boxzsize
2385           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
2386       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2387       xj_safe=xj
2388       yj_safe=yj
2389       zj_safe=zj
2390       isubchap=0
2391       do xshift=-1,1
2392       do yshift=-1,1
2393       do zshift=-1,1
2394           xj=xj_safe+xshift*boxxsize
2395           yj=yj_safe+yshift*boxysize
2396           zj=zj_safe+zshift*boxzsize
2397           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2398           if(dist_temp.lt.dist_init) then
2399             dist_init=dist_temp
2400             xj_temp=xj
2401             yj_temp=yj
2402             zj_temp=zj
2403             isubchap=1
2404           endif
2405        enddo
2406        enddo
2407        enddo
2408        if (isubchap.eq.1) then
2409           xj=xj_temp-xmedi
2410           yj=yj_temp-ymedi
2411           zj=zj_temp-zmedi
2412        else
2413           xj=xj_safe-xmedi
2414           yj=yj_safe-ymedi
2415           zj=zj_safe-zmedi
2416        endif
2417 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
2418 c  174   continue
2419 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
2420 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
2421 C Condition for being inside the proper box
2422 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
2423 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
2424 c        go to 174
2425 c        endif
2426 c  175   continue
2427 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
2428 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
2429 C Condition for being inside the proper box
2430 c        if ((yj.gt.((0.5d0)*boxysize)).or.
2431 c     &       (yj.lt.((-0.5d0)*boxysize))) then
2432 c        go to 175
2433 c        endif
2434 c  176   continue
2435 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
2436 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
2437 C Condition for being inside the proper box
2438 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
2439 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
2440 c        go to 176
2441 c        endif
2442 C        endif !endPBC condintion
2443 C        xj=xj-xmedi
2444 C        yj=yj-ymedi
2445 C        zj=zj-zmedi
2446           rij=xj*xj+yj*yj+zj*zj
2447
2448             sss=sscale(sqrt(rij))
2449             sssgrad=sscagrad(sqrt(rij))
2450 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
2451 c     &       " rlamb",rlamb," sss",sss
2452 c            if (sss.gt.0.0d0) then
2453           rrmij=1.0D0/rij
2454           rij=dsqrt(rij)
2455           rmij=1.0D0/rij
2456           r3ij=rrmij*rmij
2457           r6ij=r3ij*r3ij
2458           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2459           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2460           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2461           fac=cosa-3.0D0*cosb*cosg
2462           ev1=aaa*r6ij*r6ij
2463 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2464           if (j.eq.i+2) ev1=scal_el*ev1
2465           ev2=bbb*r6ij
2466           fac3=ael6i*r6ij
2467           fac4=ael3i*r3ij
2468           evdwij=(ev1+ev2)
2469           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2470           el2=fac4*fac
2471 C MARYSIA
2472 C          eesij=(el1+el2)
2473 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2474           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2475           if (shield_mode.gt.0) then
2476 C          fac_shield(i)=0.4
2477 C          fac_shield(j)=0.6
2478           el1=el1*fac_shield(i)**2*fac_shield(j)**2
2479           el2=el2*fac_shield(i)**2*fac_shield(j)**2
2480           eesij=(el1+el2)
2481           ees=ees+eesij
2482           else
2483           fac_shield(i)=1.0
2484           fac_shield(j)=1.0
2485           eesij=(el1+el2)
2486           ees=ees+eesij
2487           endif
2488           evdw1=evdw1+evdwij*sss
2489 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2490 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2491 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2492 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2493
2494           if (energy_dec) then
2495               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
2496      &'evdw1',i,j,evdwij
2497      &,iteli,itelj,aaa,evdw1,sss
2498               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
2499      &fac_shield(i),fac_shield(j)
2500           endif
2501
2502 C
2503 C Calculate contributions to the Cartesian gradient.
2504 C
2505 #ifdef SPLITELE
2506           facvdw=-6*rrmij*(ev1+evdwij)*sss
2507           facel=-3*rrmij*(el1+eesij)
2508           fac1=fac
2509           erij(1)=xj*rmij
2510           erij(2)=yj*rmij
2511           erij(3)=zj*rmij
2512
2513 *
2514 * Radial derivatives. First process both termini of the fragment (i,j)
2515 *
2516           if (calc_grad) then
2517           ggg(1)=facel*xj
2518           ggg(2)=facel*yj
2519           ggg(3)=facel*zj
2520           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2521      &  (shield_mode.gt.0)) then
2522 C          print *,i,j
2523           do ilist=1,ishield_list(i)
2524            iresshield=shield_list(ilist,i)
2525            do k=1,3
2526            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
2527      &      *2.0
2528            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2529      &              rlocshield
2530      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
2531             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2532 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2533 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2534 C             if (iresshield.gt.i) then
2535 C               do ishi=i+1,iresshield-1
2536 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2537 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2538 C
2539 C              enddo
2540 C             else
2541 C               do ishi=iresshield,i
2542 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2543 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
2544 C
2545 C               enddo
2546 C              endif
2547            enddo
2548           enddo
2549           do ilist=1,ishield_list(j)
2550            iresshield=shield_list(ilist,j)
2551            do k=1,3
2552            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
2553      &     *2.0
2554            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
2555      &              rlocshield
2556      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
2557            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
2558
2559 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2560 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
2561 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2562 C             if (iresshield.gt.j) then
2563 C               do ishi=j+1,iresshield-1
2564 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
2565 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2566 C
2567 C               enddo
2568 C            else
2569 C               do ishi=iresshield,j
2570 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
2571 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
2572 C               enddo
2573 C              endif
2574            enddo
2575           enddo
2576
2577           do k=1,3
2578             gshieldc(k,i)=gshieldc(k,i)+
2579      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2580             gshieldc(k,j)=gshieldc(k,j)+
2581      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2582             gshieldc(k,i-1)=gshieldc(k,i-1)+
2583      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
2584             gshieldc(k,j-1)=gshieldc(k,j-1)+
2585      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
2586
2587            enddo
2588            endif
2589 c          do k=1,3
2590 c            ghalf=0.5D0*ggg(k)
2591 c            gelc(k,i)=gelc(k,i)+ghalf
2592 c            gelc(k,j)=gelc(k,j)+ghalf
2593 c          enddo
2594 c 9/28/08 AL Gradient compotents will be summed only at the end
2595 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
2596           do k=1,3
2597             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2598 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2599             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2600 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2601 C            gelc_long(k,i-1)=gelc_long(k,i-1)
2602 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
2603 C            gelc_long(k,j-1)=gelc_long(k,j-1)
2604 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
2605           enddo
2606 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
2607
2608 *
2609 * Loop over residues i+1 thru j-1.
2610 *
2611 cgrad          do k=i+1,j-1
2612 cgrad            do l=1,3
2613 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2614 cgrad            enddo
2615 cgrad          enddo
2616           if (sss.gt.0.0) then
2617           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2618           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2619           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2620           else
2621           ggg(1)=0.0
2622           ggg(2)=0.0
2623           ggg(3)=0.0
2624           endif
2625 c          do k=1,3
2626 c            ghalf=0.5D0*ggg(k)
2627 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
2628 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
2629 c          enddo
2630 c 9/28/08 AL Gradient compotents will be summed only at the end
2631           do k=1,3
2632             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2633             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2634           enddo
2635 *
2636 * Loop over residues i+1 thru j-1.
2637 *
2638 cgrad          do k=i+1,j-1
2639 cgrad            do l=1,3
2640 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
2641 cgrad            enddo
2642 cgrad          enddo
2643           endif ! calc_grad
2644 #else
2645 C MARYSIA
2646           facvdw=(ev1+evdwij)*sss
2647           facel=(el1+eesij)
2648           fac1=fac
2649           fac=-3*rrmij*(facvdw+facvdw+facel)
2650           erij(1)=xj*rmij
2651           erij(2)=yj*rmij
2652           erij(3)=zj*rmij
2653 *
2654 * Radial derivatives. First process both termini of the fragment (i,j)
2655 *
2656           if (calc_grad) then
2657           ggg(1)=fac*xj
2658 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
2659           ggg(2)=fac*yj
2660 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
2661           ggg(3)=fac*zj
2662 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
2663 c          do k=1,3
2664 c            ghalf=0.5D0*ggg(k)
2665 c            gelc(k,i)=gelc(k,i)+ghalf
2666 c            gelc(k,j)=gelc(k,j)+ghalf
2667 c          enddo
2668 c 9/28/08 AL Gradient compotents will be summed only at the end
2669           do k=1,3
2670             gelc_long(k,j)=gelc(k,j)+ggg(k)
2671             gelc_long(k,i)=gelc(k,i)-ggg(k)
2672           enddo
2673 *
2674 * Loop over residues i+1 thru j-1.
2675 *
2676 cgrad          do k=i+1,j-1
2677 cgrad            do l=1,3
2678 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2679 cgrad            enddo
2680 cgrad          enddo
2681 c 9/28/08 AL Gradient compotents will be summed only at the end
2682           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
2683           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
2684           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
2685           do k=1,3
2686             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2687             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2688           enddo
2689           endif ! calc_grad
2690 #endif
2691 *
2692 * Angular part
2693 *
2694           if (calc_grad) then
2695           ecosa=2.0D0*fac3*fac1+fac4
2696           fac4=-3.0D0*fac4
2697           fac3=-6.0D0*fac3
2698           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
2699           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
2700           do k=1,3
2701             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
2702             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
2703           enddo
2704 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
2705 cd   &          (dcosg(k),k=1,3)
2706           do k=1,3
2707             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
2708      &      fac_shield(i)**2*fac_shield(j)**2
2709           enddo
2710 c          do k=1,3
2711 c            ghalf=0.5D0*ggg(k)
2712 c            gelc(k,i)=gelc(k,i)+ghalf
2713 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2714 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
2715 c            gelc(k,j)=gelc(k,j)+ghalf
2716 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2717 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
2718 c          enddo
2719 cgrad          do k=i+1,j-1
2720 cgrad            do l=1,3
2721 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2722 cgrad            enddo
2723 cgrad          enddo
2724 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
2725           do k=1,3
2726             gelc(k,i)=gelc(k,i)
2727      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
2728      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
2729      &           *fac_shield(i)**2*fac_shield(j)**2
2730             gelc(k,j)=gelc(k,j)
2731      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
2732      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
2733      &           *fac_shield(i)**2*fac_shield(j)**2
2734             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
2735             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
2736           enddo
2737 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
2738
2739 C MARYSIA
2740 c          endif !sscale
2741           endif ! calc_grad
2742           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2743      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
2744      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
2745 C
2746 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
2747 C   energy of a peptide unit is assumed in the form of a second-order
2748 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
2749 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
2750 C   are computed for EVERY pair of non-contiguous peptide groups.
2751 C
2752
2753           if (j.lt.nres-1) then
2754             j1=j+1
2755             j2=j-1
2756           else
2757             j1=j-1
2758             j2=j-2
2759           endif
2760           kkk=0
2761           lll=0
2762           do k=1,2
2763             do l=1,2
2764               kkk=kkk+1
2765               muij(kkk)=mu(k,i)*mu(l,j)
2766 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
2767 #ifdef NEWCORR
2768              if (calc_grad) then
2769              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
2770 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
2771              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
2772              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
2773 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
2774              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
2775              endif
2776 #endif
2777             enddo
2778           enddo
2779 #ifdef DEBUG
2780           write (iout,*) 'EELEC: i',i,' j',j
2781           write (iout,*) 'j',j,' j1',j1,' j2',j2
2782           write(iout,*) 'muij',muij
2783           write (iout,*) "uy",uy(:,i)
2784           write (iout,*) "uz",uz(:,j)
2785           write (iout,*) "erij",erij
2786 #endif
2787           ury=scalar(uy(1,i),erij)
2788           urz=scalar(uz(1,i),erij)
2789           vry=scalar(uy(1,j),erij)
2790           vrz=scalar(uz(1,j),erij)
2791           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
2792           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
2793           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
2794           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
2795           fac=dsqrt(-ael6i)*r3ij
2796           a22=a22*fac
2797           a23=a23*fac
2798           a32=a32*fac
2799           a33=a33*fac
2800 cd          write (iout,'(4i5,4f10.5)')
2801 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
2802 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
2803 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
2804 cd     &      uy(:,j),uz(:,j)
2805 cd          write (iout,'(4f10.5)')
2806 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
2807 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
2808 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
2809 cd           write (iout,'(9f10.5/)')
2810 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
2811 C Derivatives of the elements of A in virtual-bond vectors
2812           if (calc_grad) then
2813           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
2814           do k=1,3
2815             uryg(k,1)=scalar(erder(1,k),uy(1,i))
2816             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
2817             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
2818             urzg(k,1)=scalar(erder(1,k),uz(1,i))
2819             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
2820             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
2821             vryg(k,1)=scalar(erder(1,k),uy(1,j))
2822             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
2823             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
2824             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
2825             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
2826             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
2827           enddo
2828 C Compute radial contributions to the gradient
2829           facr=-3.0d0*rrmij
2830           a22der=a22*facr
2831           a23der=a23*facr
2832           a32der=a32*facr
2833           a33der=a33*facr
2834           agg(1,1)=a22der*xj
2835           agg(2,1)=a22der*yj
2836           agg(3,1)=a22der*zj
2837           agg(1,2)=a23der*xj
2838           agg(2,2)=a23der*yj
2839           agg(3,2)=a23der*zj
2840           agg(1,3)=a32der*xj
2841           agg(2,3)=a32der*yj
2842           agg(3,3)=a32der*zj
2843           agg(1,4)=a33der*xj
2844           agg(2,4)=a33der*yj
2845           agg(3,4)=a33der*zj
2846 C Add the contributions coming from er
2847           fac3=-3.0d0*fac
2848           do k=1,3
2849             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
2850             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
2851             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
2852             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
2853           enddo
2854           do k=1,3
2855 C Derivatives in DC(i)
2856 cgrad            ghalf1=0.5d0*agg(k,1)
2857 cgrad            ghalf2=0.5d0*agg(k,2)
2858 cgrad            ghalf3=0.5d0*agg(k,3)
2859 cgrad            ghalf4=0.5d0*agg(k,4)
2860             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
2861      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
2862             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
2863      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
2864             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
2865      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
2866             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
2867      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
2868 C Derivatives in DC(i+1)
2869             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
2870      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
2871             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
2872      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
2873             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
2874      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
2875             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
2876      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
2877 C Derivatives in DC(j)
2878             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
2879      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
2880             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
2881      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
2882             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
2883      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
2884             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
2885      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
2886 C Derivatives in DC(j+1) or DC(nres-1)
2887             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
2888      &      -3.0d0*vryg(k,3)*ury)
2889             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
2890      &      -3.0d0*vrzg(k,3)*ury)
2891             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
2892      &      -3.0d0*vryg(k,3)*urz)
2893             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
2894      &      -3.0d0*vrzg(k,3)*urz)
2895 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
2896 cgrad              do l=1,4
2897 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
2898 cgrad              enddo
2899 cgrad            endif
2900           enddo
2901           endif ! calc_grad
2902           acipa(1,1)=a22
2903           acipa(1,2)=a23
2904           acipa(2,1)=a32
2905           acipa(2,2)=a33
2906           a22=-a22
2907           a23=-a23
2908           if (calc_grad) then
2909           do l=1,2
2910             do k=1,3
2911               agg(k,l)=-agg(k,l)
2912               aggi(k,l)=-aggi(k,l)
2913               aggi1(k,l)=-aggi1(k,l)
2914               aggj(k,l)=-aggj(k,l)
2915               aggj1(k,l)=-aggj1(k,l)
2916             enddo
2917           enddo
2918           endif ! calc_grad
2919           if (j.lt.nres-1) then
2920             a22=-a22
2921             a32=-a32
2922             do l=1,3,2
2923               do k=1,3
2924                 agg(k,l)=-agg(k,l)
2925                 aggi(k,l)=-aggi(k,l)
2926                 aggi1(k,l)=-aggi1(k,l)
2927                 aggj(k,l)=-aggj(k,l)
2928                 aggj1(k,l)=-aggj1(k,l)
2929               enddo
2930             enddo
2931           else
2932             a22=-a22
2933             a23=-a23
2934             a32=-a32
2935             a33=-a33
2936             do l=1,4
2937               do k=1,3
2938                 agg(k,l)=-agg(k,l)
2939                 aggi(k,l)=-aggi(k,l)
2940                 aggi1(k,l)=-aggi1(k,l)
2941                 aggj(k,l)=-aggj(k,l)
2942                 aggj1(k,l)=-aggj1(k,l)
2943               enddo
2944             enddo
2945           endif
2946           ENDIF ! WCORR
2947           IF (wel_loc.gt.0.0d0) THEN
2948 C Contribution to the local-electrostatic energy coming from the i-j pair
2949           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
2950      &     +a33*muij(4)
2951 #ifdef DEBUG
2952           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
2953      &     " a33",a33
2954           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
2955      &     " wel_loc",wel_loc
2956 #endif
2957           if (shield_mode.eq.0) then
2958            fac_shield(i)=1.0
2959            fac_shield(j)=1.0
2960 C          else
2961 C           fac_shield(i)=0.4
2962 C           fac_shield(j)=0.6
2963           endif
2964           eel_loc_ij=eel_loc_ij
2965      &    *fac_shield(i)*fac_shield(j)
2966           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
2967      &            'eelloc',i,j,eel_loc_ij
2968 c           if (eel_loc_ij.ne.0)
2969 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
2970 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
2971
2972           eel_loc=eel_loc+eel_loc_ij
2973 C Now derivative over eel_loc
2974           if (calc_grad) then
2975           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
2976      &  (shield_mode.gt.0)) then
2977 C          print *,i,j
2978
2979           do ilist=1,ishield_list(i)
2980            iresshield=shield_list(ilist,i)
2981            do k=1,3
2982            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
2983      &                                          /fac_shield(i)
2984 C     &      *2.0
2985            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2986      &              rlocshield
2987      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
2988             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
2989      &      +rlocshield
2990            enddo
2991           enddo
2992           do ilist=1,ishield_list(j)
2993            iresshield=shield_list(ilist,j)
2994            do k=1,3
2995            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
2996      &                                       /fac_shield(j)
2997 C     &     *2.0
2998            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
2999      &              rlocshield
3000      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
3001            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
3002      &             +rlocshield
3003
3004            enddo
3005           enddo
3006
3007           do k=1,3
3008             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
3009      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3010             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
3011      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3012             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
3013      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
3014             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
3015      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
3016            enddo
3017            endif
3018
3019
3020 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
3021 c     &                     ' eel_loc_ij',eel_loc_ij
3022 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
3023 C Calculate patrial derivative for theta angle
3024 #ifdef NEWCORR
3025          geel_loc_ij=(a22*gmuij1(1)
3026      &     +a23*gmuij1(2)
3027      &     +a32*gmuij1(3)
3028      &     +a33*gmuij1(4))
3029      &    *fac_shield(i)*fac_shield(j)
3030 c         write(iout,*) "derivative over thatai"
3031 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
3032 c     &   a33*gmuij1(4)
3033          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
3034      &      geel_loc_ij*wel_loc
3035 c         write(iout,*) "derivative over thatai-1"
3036 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
3037 c     &   a33*gmuij2(4)
3038          geel_loc_ij=
3039      &     a22*gmuij2(1)
3040      &     +a23*gmuij2(2)
3041      &     +a32*gmuij2(3)
3042      &     +a33*gmuij2(4)
3043          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
3044      &      geel_loc_ij*wel_loc
3045      &    *fac_shield(i)*fac_shield(j)
3046
3047 c  Derivative over j residue
3048          geel_loc_ji=a22*gmuji1(1)
3049      &     +a23*gmuji1(2)
3050      &     +a32*gmuji1(3)
3051      &     +a33*gmuji1(4)
3052 c         write(iout,*) "derivative over thataj"
3053 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
3054 c     &   a33*gmuji1(4)
3055
3056         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
3057      &      geel_loc_ji*wel_loc
3058      &    *fac_shield(i)*fac_shield(j)
3059
3060          geel_loc_ji=
3061      &     +a22*gmuji2(1)
3062      &     +a23*gmuji2(2)
3063      &     +a32*gmuji2(3)
3064      &     +a33*gmuji2(4)
3065 c         write(iout,*) "derivative over thataj-1"
3066 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
3067 c     &   a33*gmuji2(4)
3068          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
3069      &      geel_loc_ji*wel_loc
3070      &    *fac_shield(i)*fac_shield(j)
3071 #endif
3072 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3073
3074 C Partial derivatives in virtual-bond dihedral angles gamma
3075           if (i.gt.1)
3076      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3077      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3078      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
3079      &    *fac_shield(i)*fac_shield(j)
3080
3081           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3082      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3083      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
3084      &    *fac_shield(i)*fac_shield(j)
3085 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3086           do l=1,3
3087             ggg(l)=(agg(l,1)*muij(1)+
3088      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
3089      &    *fac_shield(i)*fac_shield(j)
3090             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3091             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3092 cgrad            ghalf=0.5d0*ggg(l)
3093 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3094 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3095           enddo
3096 cgrad          do k=i+1,j2
3097 cgrad            do l=1,3
3098 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3099 cgrad            enddo
3100 cgrad          enddo
3101 C Remaining derivatives of eello
3102           do l=1,3
3103             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
3104      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
3105      &    *fac_shield(i)*fac_shield(j)
3106
3107             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
3108      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
3109      &    *fac_shield(i)*fac_shield(j)
3110
3111             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
3112      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
3113      &    *fac_shield(i)*fac_shield(j)
3114
3115             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
3116      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
3117      &    *fac_shield(i)*fac_shield(j)
3118
3119           enddo
3120           endif ! calc_grad
3121           ENDIF
3122
3123
3124 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3125 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3126           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3127      &       .and. num_conti.le.maxconts) then
3128 c            write (iout,*) i,j," entered corr"
3129 C
3130 C Calculate the contact function. The ith column of the array JCONT will
3131 C contain the numbers of atoms that make contacts with the atom I (of numbers
3132 C greater than I). The arrays FACONT and GACONT will contain the values of
3133 C the contact function and its derivative.
3134 c           r0ij=1.02D0*rpp(iteli,itelj)
3135 c           r0ij=1.11D0*rpp(iteli,itelj)
3136             r0ij=2.20D0*rpp(iteli,itelj)
3137 c           r0ij=1.55D0*rpp(iteli,itelj)
3138             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3139             if (fcont.gt.0.0D0) then
3140               num_conti=num_conti+1
3141               if (num_conti.gt.maxconts) then
3142                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3143      &                         ' will skip next contacts for this conf.'
3144               else
3145                 jcont_hb(num_conti,i)=j
3146 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3147 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3148                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3149      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3150 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3151 C  terms.
3152                 d_cont(num_conti,i)=rij
3153 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3154 C     --- Electrostatic-interaction matrix ---
3155                 a_chuj(1,1,num_conti,i)=a22
3156                 a_chuj(1,2,num_conti,i)=a23
3157                 a_chuj(2,1,num_conti,i)=a32
3158                 a_chuj(2,2,num_conti,i)=a33
3159 C     --- Gradient of rij
3160                 if (calc_grad) then
3161                 do kkk=1,3
3162                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3163                 enddo
3164                 kkll=0
3165                 do k=1,2
3166                   do l=1,2
3167                     kkll=kkll+1
3168                     do m=1,3
3169                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3170                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3171                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3172                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3173                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3174                     enddo
3175                   enddo
3176                 enddo
3177                 endif ! calc_grad
3178                 ENDIF
3179                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3180 C Calculate contact energies
3181                 cosa4=4.0D0*cosa
3182                 wij=cosa-3.0D0*cosb*cosg
3183                 cosbg1=cosb+cosg
3184                 cosbg2=cosb-cosg
3185 c               fac3=dsqrt(-ael6i)/r0ij**3
3186                 fac3=dsqrt(-ael6i)*r3ij
3187 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3188                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3189                 if (ees0tmp.gt.0) then
3190                   ees0pij=dsqrt(ees0tmp)
3191                 else
3192                   ees0pij=0
3193                 endif
3194 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3195                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3196                 if (ees0tmp.gt.0) then
3197                   ees0mij=dsqrt(ees0tmp)
3198                 else
3199                   ees0mij=0
3200                 endif
3201 c               ees0mij=0.0D0
3202                 if (shield_mode.eq.0) then
3203                 fac_shield(i)=1.0d0
3204                 fac_shield(j)=1.0d0
3205                 else
3206                 ees0plist(num_conti,i)=j
3207 C                fac_shield(i)=0.4d0
3208 C                fac_shield(j)=0.6d0
3209                 endif
3210                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3211      &          *fac_shield(i)*fac_shield(j)
3212                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3213      &          *fac_shield(i)*fac_shield(j)
3214 C Diagnostics. Comment out or remove after debugging!
3215 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3216 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3217 c               ees0m(num_conti,i)=0.0D0
3218 C End diagnostics.
3219 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3220 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3221 C Angular derivatives of the contact function
3222
3223                 ees0pij1=fac3/ees0pij
3224                 ees0mij1=fac3/ees0mij
3225                 fac3p=-3.0D0*fac3*rrmij
3226                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3227                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3228 c               ees0mij1=0.0D0
3229                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3230                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3231                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3232                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3233                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3234                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3235                 ecosap=ecosa1+ecosa2
3236                 ecosbp=ecosb1+ecosb2
3237                 ecosgp=ecosg1+ecosg2
3238                 ecosam=ecosa1-ecosa2
3239                 ecosbm=ecosb1-ecosb2
3240                 ecosgm=ecosg1-ecosg2
3241 C Diagnostics
3242 c               ecosap=ecosa1
3243 c               ecosbp=ecosb1
3244 c               ecosgp=ecosg1
3245 c               ecosam=0.0D0
3246 c               ecosbm=0.0D0
3247 c               ecosgm=0.0D0
3248 C End diagnostics
3249                 facont_hb(num_conti,i)=fcont
3250
3251                 if (calc_grad) then
3252                 fprimcont=fprimcont/rij
3253 cd              facont_hb(num_conti,i)=1.0D0
3254 C Following line is for diagnostics.
3255 cd              fprimcont=0.0D0
3256                 do k=1,3
3257                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3258                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3259                 enddo
3260                 do k=1,3
3261                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3262                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3263                 enddo
3264                 gggp(1)=gggp(1)+ees0pijp*xj
3265                 gggp(2)=gggp(2)+ees0pijp*yj
3266                 gggp(3)=gggp(3)+ees0pijp*zj
3267                 gggm(1)=gggm(1)+ees0mijp*xj
3268                 gggm(2)=gggm(2)+ees0mijp*yj
3269                 gggm(3)=gggm(3)+ees0mijp*zj
3270 C Derivatives due to the contact function
3271                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3272                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3273                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3274                 do k=1,3
3275 c
3276 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3277 c          following the change of gradient-summation algorithm.
3278 c
3279 cgrad                  ghalfp=0.5D0*gggp(k)
3280 cgrad                  ghalfm=0.5D0*gggm(k)
3281                   gacontp_hb1(k,num_conti,i)=!ghalfp
3282      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3283      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3284      &          *fac_shield(i)*fac_shield(j)
3285
3286                   gacontp_hb2(k,num_conti,i)=!ghalfp
3287      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3288      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3289      &          *fac_shield(i)*fac_shield(j)
3290
3291                   gacontp_hb3(k,num_conti,i)=gggp(k)
3292      &          *fac_shield(i)*fac_shield(j)
3293
3294                   gacontm_hb1(k,num_conti,i)=!ghalfm
3295      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3296      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3297      &          *fac_shield(i)*fac_shield(j)
3298
3299                   gacontm_hb2(k,num_conti,i)=!ghalfm
3300      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3301      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3302      &          *fac_shield(i)*fac_shield(j)
3303
3304                   gacontm_hb3(k,num_conti,i)=gggm(k)
3305      &          *fac_shield(i)*fac_shield(j)
3306
3307                 enddo
3308 C Diagnostics. Comment out or remove after debugging!
3309 cdiag           do k=1,3
3310 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3311 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3312 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3313 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3314 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3315 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3316 cdiag           enddo
3317
3318                  endif ! calc_grad
3319
3320               ENDIF ! wcorr
3321               endif  ! num_conti.le.maxconts
3322             endif  ! fcont.gt.0
3323           endif    ! j.gt.i+1
3324           if (calc_grad) then
3325           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3326             do k=1,4
3327               do l=1,3
3328                 ghalf=0.5d0*agg(l,k)
3329                 aggi(l,k)=aggi(l,k)+ghalf
3330                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3331                 aggj(l,k)=aggj(l,k)+ghalf
3332               enddo
3333             enddo
3334             if (j.eq.nres-1 .and. i.lt.j-2) then
3335               do k=1,4
3336                 do l=1,3
3337                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3338                 enddo
3339               enddo
3340             endif
3341           endif
3342           endif ! calc_grad
3343 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3344       return
3345       end
3346 C-----------------------------------------------------------------------------
3347       subroutine eturn3(i,eello_turn3)
3348 C Third- and fourth-order contributions from turns
3349       implicit real*8 (a-h,o-z)
3350       include 'DIMENSIONS'
3351       include 'DIMENSIONS.ZSCOPT'
3352       include 'COMMON.IOUNITS'
3353       include 'COMMON.GEO'
3354       include 'COMMON.VAR'
3355       include 'COMMON.LOCAL'
3356       include 'COMMON.CHAIN'
3357       include 'COMMON.DERIV'
3358       include 'COMMON.INTERACT'
3359       include 'COMMON.CONTACTS'
3360       include 'COMMON.TORSION'
3361       include 'COMMON.VECTORS'
3362       include 'COMMON.FFIELD'
3363       include 'COMMON.CONTROL'
3364       include 'COMMON.SHIELD'
3365       dimension ggg(3)
3366       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3367      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3368      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
3369      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
3370      &  auxgmat2(2,2),auxgmatt2(2,2)
3371       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3372      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3373       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3374      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3375      &    num_conti,j1,j2
3376       j=i+2
3377 c      write (iout,*) "eturn3",i,j,j1,j2
3378       a_temp(1,1)=a22
3379       a_temp(1,2)=a23
3380       a_temp(2,1)=a32
3381       a_temp(2,2)=a33
3382 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3383 C
3384 C               Third-order contributions
3385 C
3386 C                 (i+2)o----(i+3)
3387 C                      | |
3388 C                      | |
3389 C                 (i+1)o----i
3390 C
3391 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3392 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3393         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3394 c auxalary matices for theta gradient
3395 c auxalary matrix for i+1 and constant i+2
3396         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
3397 c auxalary matrix for i+2 and constant i+1
3398         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
3399         call transpose2(auxmat(1,1),auxmat1(1,1))
3400         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
3401         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
3402         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3403         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
3404         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
3405         if (shield_mode.eq.0) then
3406         fac_shield(i)=1.0
3407         fac_shield(j)=1.0
3408 C        else
3409 C        fac_shield(i)=0.4
3410 C        fac_shield(j)=0.6
3411         endif
3412         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3413      &  *fac_shield(i)*fac_shield(j)
3414         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
3415      &  *fac_shield(i)*fac_shield(j)
3416         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
3417      &    eello_t3
3418         if (calc_grad) then
3419 C#ifdef NEWCORR
3420 C Derivatives in theta
3421         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3422      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
3423      &   *fac_shield(i)*fac_shield(j)
3424         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
3425      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
3426      &   *fac_shield(i)*fac_shield(j)
3427 C#endif
3428
3429 C Derivatives in shield mode
3430           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3431      &  (shield_mode.gt.0)) then
3432 C          print *,i,j
3433
3434           do ilist=1,ishield_list(i)
3435            iresshield=shield_list(ilist,i)
3436            do k=1,3
3437            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
3438 C     &      *2.0
3439            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3440      &              rlocshield
3441      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
3442             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3443      &      +rlocshield
3444            enddo
3445           enddo
3446           do ilist=1,ishield_list(j)
3447            iresshield=shield_list(ilist,j)
3448            do k=1,3
3449            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
3450 C     &     *2.0
3451            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
3452      &              rlocshield
3453      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
3454            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
3455      &             +rlocshield
3456
3457            enddo
3458           enddo
3459
3460           do k=1,3
3461             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
3462      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3463             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
3464      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3465             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
3466      &              grad_shield(k,i)*eello_t3/fac_shield(i)
3467             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
3468      &              grad_shield(k,j)*eello_t3/fac_shield(j)
3469            enddo
3470            endif
3471
3472 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3473 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3474 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3475 cd     &    ' eello_turn3_num',4*eello_turn3_num
3476 C Derivatives in gamma(i)
3477         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3478         call transpose2(auxmat2(1,1),auxmat3(1,1))
3479         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3480         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3481      &   *fac_shield(i)*fac_shield(j)
3482 C Derivatives in gamma(i+1)
3483         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3484         call transpose2(auxmat2(1,1),auxmat3(1,1))
3485         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3486         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3487      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3488      &   *fac_shield(i)*fac_shield(j)
3489 C Cartesian derivatives
3490         do l=1,3
3491 c            ghalf1=0.5d0*agg(l,1)
3492 c            ghalf2=0.5d0*agg(l,2)
3493 c            ghalf3=0.5d0*agg(l,3)
3494 c            ghalf4=0.5d0*agg(l,4)
3495           a_temp(1,1)=aggi(l,1)!+ghalf1
3496           a_temp(1,2)=aggi(l,2)!+ghalf2
3497           a_temp(2,1)=aggi(l,3)!+ghalf3
3498           a_temp(2,2)=aggi(l,4)!+ghalf4
3499           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3500           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3501      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3502      &   *fac_shield(i)*fac_shield(j)
3503
3504           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3505           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3506           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3507           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3508           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3509           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3510      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3511      &   *fac_shield(i)*fac_shield(j)
3512           a_temp(1,1)=aggj(l,1)!+ghalf1
3513           a_temp(1,2)=aggj(l,2)!+ghalf2
3514           a_temp(2,1)=aggj(l,3)!+ghalf3
3515           a_temp(2,2)=aggj(l,4)!+ghalf4
3516           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3517           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3518      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3519      &   *fac_shield(i)*fac_shield(j)
3520           a_temp(1,1)=aggj1(l,1)
3521           a_temp(1,2)=aggj1(l,2)
3522           a_temp(2,1)=aggj1(l,3)
3523           a_temp(2,2)=aggj1(l,4)
3524           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3525           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3526      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3527      &   *fac_shield(i)*fac_shield(j)
3528         enddo
3529
3530         endif ! calc_grad
3531
3532       return
3533       end
3534 C-------------------------------------------------------------------------------
3535       subroutine eturn4(i,eello_turn4)
3536 C Third- and fourth-order contributions from turns
3537       implicit real*8 (a-h,o-z)
3538       include 'DIMENSIONS'
3539       include 'DIMENSIONS.ZSCOPT'
3540       include 'COMMON.IOUNITS'
3541       include 'COMMON.GEO'
3542       include 'COMMON.VAR'
3543       include 'COMMON.LOCAL'
3544       include 'COMMON.CHAIN'
3545       include 'COMMON.DERIV'
3546       include 'COMMON.INTERACT'
3547       include 'COMMON.CONTACTS'
3548       include 'COMMON.TORSION'
3549       include 'COMMON.VECTORS'
3550       include 'COMMON.FFIELD'
3551       include 'COMMON.CONTROL'
3552       include 'COMMON.SHIELD'
3553       dimension ggg(3)
3554       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3555      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3556      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
3557      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
3558      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
3559      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
3560      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
3561       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3562      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3563       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3564      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3565      &    num_conti,j1,j2
3566       j=i+3
3567 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3568 C
3569 C               Fourth-order contributions
3570 C
3571 C                 (i+3)o----(i+4)
3572 C                     /  |
3573 C               (i+2)o   |
3574 C                     \  |
3575 C                 (i+1)o----i
3576 C
3577 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3578 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3579 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3580 c        write(iout,*)"WCHODZE W PROGRAM"
3581         a_temp(1,1)=a22
3582         a_temp(1,2)=a23
3583         a_temp(2,1)=a32
3584         a_temp(2,2)=a33
3585         iti1=itype2loc(itype(i+1))
3586         iti2=itype2loc(itype(i+2))
3587         iti3=itype2loc(itype(i+3))
3588 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3589         call transpose2(EUg(1,1,i+1),e1t(1,1))
3590         call transpose2(Eug(1,1,i+2),e2t(1,1))
3591         call transpose2(Eug(1,1,i+3),e3t(1,1))
3592 C Ematrix derivative in theta
3593         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
3594         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
3595         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
3596         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3597 c       eta1 in derivative theta
3598         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
3599         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3600 c       auxgvec is derivative of Ub2 so i+3 theta
3601         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
3602 c       auxalary matrix of E i+1
3603         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
3604 c        s1=0.0
3605 c        gs1=0.0
3606         s1=scalar2(b1(1,i+2),auxvec(1))
3607 c derivative of theta i+2 with constant i+3
3608         gs23=scalar2(gtb1(1,i+2),auxvec(1))
3609 c derivative of theta i+2 with constant i+2
3610         gs32=scalar2(b1(1,i+2),auxgvec(1))
3611 c derivative of E matix in theta of i+1
3612         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
3613
3614         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3615 c       ea31 in derivative theta
3616         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
3617         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3618 c auxilary matrix auxgvec of Ub2 with constant E matirx
3619         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
3620 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
3621         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
3622
3623 c        s2=0.0
3624 c        gs2=0.0
3625         s2=scalar2(b1(1,i+1),auxvec(1))
3626 c derivative of theta i+1 with constant i+3
3627         gs13=scalar2(gtb1(1,i+1),auxvec(1))
3628 c derivative of theta i+2 with constant i+1
3629         gs21=scalar2(b1(1,i+1),auxgvec(1))
3630 c derivative of theta i+3 with constant i+1
3631         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
3632 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
3633 c     &  gtb1(1,i+1)
3634         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3635 c two derivatives over diffetent matrices
3636 c gtae3e2 is derivative over i+3
3637         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
3638 c ae3gte2 is derivative over i+2
3639         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
3640         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3641 c three possible derivative over theta E matices
3642 c i+1
3643         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
3644 c i+2
3645         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
3646 c i+3
3647         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
3648         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3649
3650         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
3651         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
3652         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
3653         if (shield_mode.eq.0) then
3654         fac_shield(i)=1.0
3655         fac_shield(j)=1.0
3656 C        else
3657 C        fac_shield(i)=0.6
3658 C        fac_shield(j)=0.4
3659         endif
3660         eello_turn4=eello_turn4-(s1+s2+s3)
3661      &  *fac_shield(i)*fac_shield(j)
3662         eello_t4=-(s1+s2+s3)
3663      &  *fac_shield(i)*fac_shield(j)
3664 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
3665         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
3666      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
3667 C Now derivative over shield:
3668           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3669      &  (shield_mode.gt.0)) then
3670 C          print *,i,j
3671
3672           do ilist=1,ishield_list(i)
3673            iresshield=shield_list(ilist,i)
3674            do k=1,3
3675            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
3676 C     &      *2.0
3677            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3678      &              rlocshield
3679      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
3680             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3681      &      +rlocshield
3682            enddo
3683           enddo
3684           do ilist=1,ishield_list(j)
3685            iresshield=shield_list(ilist,j)
3686            do k=1,3
3687            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
3688 C     &     *2.0
3689            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
3690      &              rlocshield
3691      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
3692            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
3693      &             +rlocshield
3694
3695            enddo
3696           enddo
3697
3698           do k=1,3
3699             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
3700      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3701             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
3702      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3703             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
3704      &              grad_shield(k,i)*eello_t4/fac_shield(i)
3705             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
3706      &              grad_shield(k,j)*eello_t4/fac_shield(j)
3707            enddo
3708            endif
3709 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3710 cd     &    ' eello_turn4_num',8*eello_turn4_num
3711 #ifdef NEWCORR
3712         gloc(nphi+i,icg)=gloc(nphi+i,icg)
3713      &                  -(gs13+gsE13+gsEE1)*wturn4
3714      &  *fac_shield(i)*fac_shield(j)
3715         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
3716      &                    -(gs23+gs21+gsEE2)*wturn4
3717      &  *fac_shield(i)*fac_shield(j)
3718
3719         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
3720      &                    -(gs32+gsE31+gsEE3)*wturn4
3721      &  *fac_shield(i)*fac_shield(j)
3722
3723 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
3724 c     &   gs2
3725 #endif
3726         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3727      &      'eturn4',i,j,-(s1+s2+s3)
3728 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3729 c     &    ' eello_turn4_num',8*eello_turn4_num
3730 C Derivatives in gamma(i)
3731         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3732         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3733         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3734         s1=scalar2(b1(1,i+2),auxvec(1))
3735         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3736         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3737         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3738      &  *fac_shield(i)*fac_shield(j)
3739 C Derivatives in gamma(i+1)
3740         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3741         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3742         s2=scalar2(b1(1,i+1),auxvec(1))
3743         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3744         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3745         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3746         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3747      &  *fac_shield(i)*fac_shield(j)
3748 C Derivatives in gamma(i+2)
3749         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3750         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3751         s1=scalar2(b1(1,i+2),auxvec(1))
3752         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3753         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3754         s2=scalar2(b1(1,i+1),auxvec(1))
3755         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3756         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3757         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3758         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3759      &  *fac_shield(i)*fac_shield(j)
3760         if (calc_grad) then
3761 C Cartesian derivatives
3762 C Derivatives of this turn contributions in DC(i+2)
3763         if (j.lt.nres-1) then
3764           do l=1,3
3765             a_temp(1,1)=agg(l,1)
3766             a_temp(1,2)=agg(l,2)
3767             a_temp(2,1)=agg(l,3)
3768             a_temp(2,2)=agg(l,4)
3769             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3770             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3771             s1=scalar2(b1(1,i+2),auxvec(1))
3772             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3773             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3774             s2=scalar2(b1(1,i+1),auxvec(1))
3775             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3776             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3777             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3778             ggg(l)=-(s1+s2+s3)
3779             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3780      &  *fac_shield(i)*fac_shield(j)
3781           enddo
3782         endif
3783 C Remaining derivatives of this turn contribution
3784         do l=1,3
3785           a_temp(1,1)=aggi(l,1)
3786           a_temp(1,2)=aggi(l,2)
3787           a_temp(2,1)=aggi(l,3)
3788           a_temp(2,2)=aggi(l,4)
3789           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3790           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3791           s1=scalar2(b1(1,i+2),auxvec(1))
3792           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3793           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3794           s2=scalar2(b1(1,i+1),auxvec(1))
3795           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3796           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3797           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3798           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3799      &  *fac_shield(i)*fac_shield(j)
3800           a_temp(1,1)=aggi1(l,1)
3801           a_temp(1,2)=aggi1(l,2)
3802           a_temp(2,1)=aggi1(l,3)
3803           a_temp(2,2)=aggi1(l,4)
3804           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3805           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3806           s1=scalar2(b1(1,i+2),auxvec(1))
3807           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3808           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3809           s2=scalar2(b1(1,i+1),auxvec(1))
3810           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3811           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3812           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3813           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3814      &  *fac_shield(i)*fac_shield(j)
3815           a_temp(1,1)=aggj(l,1)
3816           a_temp(1,2)=aggj(l,2)
3817           a_temp(2,1)=aggj(l,3)
3818           a_temp(2,2)=aggj(l,4)
3819           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3820           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3821           s1=scalar2(b1(1,i+2),auxvec(1))
3822           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3823           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3824           s2=scalar2(b1(1,i+1),auxvec(1))
3825           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3826           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3827           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3828           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3829      &  *fac_shield(i)*fac_shield(j)
3830           a_temp(1,1)=aggj1(l,1)
3831           a_temp(1,2)=aggj1(l,2)
3832           a_temp(2,1)=aggj1(l,3)
3833           a_temp(2,2)=aggj1(l,4)
3834           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3835           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3836           s1=scalar2(b1(1,i+2),auxvec(1))
3837           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3838           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3839           s2=scalar2(b1(1,i+1),auxvec(1))
3840           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3841           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3842           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3843 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3844           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3845      &  *fac_shield(i)*fac_shield(j)
3846         enddo
3847
3848         endif ! calc_grad
3849
3850       return
3851       end
3852 C-----------------------------------------------------------------------------
3853       subroutine vecpr(u,v,w)
3854       implicit real*8(a-h,o-z)
3855       dimension u(3),v(3),w(3)
3856       w(1)=u(2)*v(3)-u(3)*v(2)
3857       w(2)=-u(1)*v(3)+u(3)*v(1)
3858       w(3)=u(1)*v(2)-u(2)*v(1)
3859       return
3860       end
3861 C-----------------------------------------------------------------------------
3862       subroutine unormderiv(u,ugrad,unorm,ungrad)
3863 C This subroutine computes the derivatives of a normalized vector u, given
3864 C the derivatives computed without normalization conditions, ugrad. Returns
3865 C ungrad.
3866       implicit none
3867       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3868       double precision vec(3)
3869       double precision scalar
3870       integer i,j
3871 c      write (2,*) 'ugrad',ugrad
3872 c      write (2,*) 'u',u
3873       do i=1,3
3874         vec(i)=scalar(ugrad(1,i),u(1))
3875       enddo
3876 c      write (2,*) 'vec',vec
3877       do i=1,3
3878         do j=1,3
3879           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3880         enddo
3881       enddo
3882 c      write (2,*) 'ungrad',ungrad
3883       return
3884       end
3885 C-----------------------------------------------------------------------------
3886       subroutine escp(evdw2,evdw2_14)
3887 C
3888 C This subroutine calculates the excluded-volume interaction energy between
3889 C peptide-group centers and side chains and its gradient in virtual-bond and
3890 C side-chain vectors.
3891 C
3892       implicit real*8 (a-h,o-z)
3893       include 'DIMENSIONS'
3894       include 'DIMENSIONS.ZSCOPT'
3895       include 'COMMON.CONTROL'
3896       include 'COMMON.GEO'
3897       include 'COMMON.VAR'
3898       include 'COMMON.LOCAL'
3899       include 'COMMON.CHAIN'
3900       include 'COMMON.DERIV'
3901       include 'COMMON.INTERACT'
3902       include 'COMMON.FFIELD'
3903       include 'COMMON.IOUNITS'
3904       dimension ggg(3)
3905       evdw2=0.0D0
3906       evdw2_14=0.0d0
3907 cd    print '(a)','Enter ESCP'
3908 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
3909 c     &  ' scal14',scal14
3910       do i=iatscp_s,iatscp_e
3911         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3912         iteli=itel(i)
3913 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
3914 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
3915         if (iteli.eq.0) goto 1225
3916         xi=0.5D0*(c(1,i)+c(1,i+1))
3917         yi=0.5D0*(c(2,i)+c(2,i+1))
3918         zi=0.5D0*(c(3,i)+c(3,i+1))
3919 C Returning the ith atom to box
3920           xi=mod(xi,boxxsize)
3921           if (xi.lt.0) xi=xi+boxxsize
3922           yi=mod(yi,boxysize)
3923           if (yi.lt.0) yi=yi+boxysize
3924           zi=mod(zi,boxzsize)
3925           if (zi.lt.0) zi=zi+boxzsize
3926         do iint=1,nscp_gr(i)
3927
3928         do j=iscpstart(i,iint),iscpend(i,iint)
3929           itypj=iabs(itype(j))
3930           if (itypj.eq.ntyp1) cycle
3931 C Uncomment following three lines for SC-p interactions
3932 c         xj=c(1,nres+j)-xi
3933 c         yj=c(2,nres+j)-yi
3934 c         zj=c(3,nres+j)-zi
3935 C Uncomment following three lines for Ca-p interactions
3936           xj=c(1,j)
3937           yj=c(2,j)
3938           zj=c(3,j)
3939 C returning the jth atom to box
3940           xj=mod(xj,boxxsize)
3941           if (xj.lt.0) xj=xj+boxxsize
3942           yj=mod(yj,boxysize)
3943           if (yj.lt.0) yj=yj+boxysize
3944           zj=mod(zj,boxzsize)
3945           if (zj.lt.0) zj=zj+boxzsize
3946       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3947       xj_safe=xj
3948       yj_safe=yj
3949       zj_safe=zj
3950       subchap=0
3951 C Finding the closest jth atom
3952       do xshift=-1,1
3953       do yshift=-1,1
3954       do zshift=-1,1
3955           xj=xj_safe+xshift*boxxsize
3956           yj=yj_safe+yshift*boxysize
3957           zj=zj_safe+zshift*boxzsize
3958           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
3959           if(dist_temp.lt.dist_init) then
3960             dist_init=dist_temp
3961             xj_temp=xj
3962             yj_temp=yj
3963             zj_temp=zj
3964             subchap=1
3965           endif
3966        enddo
3967        enddo
3968        enddo
3969        if (subchap.eq.1) then
3970           xj=xj_temp-xi
3971           yj=yj_temp-yi
3972           zj=zj_temp-zi
3973        else
3974           xj=xj_safe-xi
3975           yj=yj_safe-yi
3976           zj=zj_safe-zi
3977        endif
3978           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
3979 C sss is scaling function for smoothing the cutoff gradient otherwise
3980 C the gradient would not be continuouse
3981           sss=sscale(1.0d0/(dsqrt(rrij)))
3982           if (sss.le.0.0d0) cycle
3983           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
3984           fac=rrij**expon2
3985           e1=fac*fac*aad(itypj,iteli)
3986           e2=fac*bad(itypj,iteli)
3987           if (iabs(j-i) .le. 2) then
3988             e1=scal14*e1
3989             e2=scal14*e2
3990             evdw2_14=evdw2_14+(e1+e2)*sss
3991           endif
3992           evdwij=e1+e2
3993 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3994 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3995 c     &       bad(itypj,iteli)
3996           evdw2=evdw2+evdwij*sss
3997           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
3998      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
3999      &       bad(itypj,iteli)
4000
4001           if (calc_grad) then
4002 C
4003 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4004 C
4005           fac=-(evdwij+e1)*rrij*sss
4006           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
4007           ggg(1)=xj*fac
4008           ggg(2)=yj*fac
4009           ggg(3)=zj*fac
4010           if (j.lt.i) then
4011 cd          write (iout,*) 'j<i'
4012 C Uncomment following three lines for SC-p interactions
4013 c           do k=1,3
4014 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4015 c           enddo
4016           else
4017 cd          write (iout,*) 'j>i'
4018             do k=1,3
4019               ggg(k)=-ggg(k)
4020 C Uncomment following line for SC-p interactions
4021 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4022             enddo
4023           endif
4024           do k=1,3
4025             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4026           enddo
4027           kstart=min0(i+1,j)
4028           kend=max0(i-1,j-1)
4029 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4030 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4031           do k=kstart,kend
4032             do l=1,3
4033               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4034             enddo
4035           enddo
4036           endif ! calc_grad
4037         enddo
4038         enddo ! iint
4039  1225   continue
4040       enddo ! i
4041       do i=1,nct
4042         do j=1,3
4043           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4044           gradx_scp(j,i)=expon*gradx_scp(j,i)
4045         enddo
4046       enddo
4047 C******************************************************************************
4048 C
4049 C                              N O T E !!!
4050 C
4051 C To save time the factor EXPON has been extracted from ALL components
4052 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4053 C use!
4054 C
4055 C******************************************************************************
4056       return
4057       end
4058 C--------------------------------------------------------------------------
4059       subroutine edis(ehpb)
4060 C
4061 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4062 C
4063       implicit real*8 (a-h,o-z)
4064       include 'DIMENSIONS'
4065       include 'DIMENSIONS.ZSCOPT'
4066       include 'COMMON.SBRIDGE'
4067       include 'COMMON.CHAIN'
4068       include 'COMMON.DERIV'
4069       include 'COMMON.VAR'
4070       include 'COMMON.INTERACT'
4071       include 'COMMON.CONTROL'
4072       include 'COMMON.IOUNITS'
4073       dimension ggg(3),ggg_peak(3,1000)
4074       ehpb=0.0D0
4075       do i=1,3
4076        ggg(i)=0.0d0
4077       enddo
4078 c 8/21/18 AL: added explicit restraints on reference coords
4079 c      write (iout,*) "restr_on_coord",restr_on_coord
4080       if (restr_on_coord) then
4081
4082       do i=nnt,nct
4083         ecoor=0.0d0
4084         if (itype(i).eq.ntyp1) cycle
4085         do j=1,3
4086           ecoor=ecoor+(c(j,i)-cref(j,i))**2
4087           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
4088         enddo
4089         if (itype(i).ne.10) then
4090           do j=1,3
4091             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
4092             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
4093           enddo
4094         endif
4095         if (energy_dec) write (iout,*)
4096      &     "i",i," bfac",bfac(i)," ecoor",ecoor
4097         ehpb=ehpb+0.5d0*bfac(i)*ecoor
4098       enddo
4099
4100       endif
4101
4102 C      write (iout,*) ,"link_end",link_end,constr_dist
4103 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4104 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
4105 c     &  " constr_dist",constr_dist
4106       if (link_end.eq.0.and.link_end_peak.eq.0) return
4107       do i=link_start_peak,link_end_peak
4108         ehpb_peak=0.0d0
4109 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
4110 c     &   ipeak(1,i),ipeak(2,i)
4111         do ip=ipeak(1,i),ipeak(2,i)
4112           ii=ihpb_peak(ip)
4113           jj=jhpb_peak(ip)
4114           dd=dist(ii,jj)
4115           iip=ip-ipeak(1,i)+1
4116 C iii and jjj point to the residues for which the distance is assigned.
4117 c          if (ii.gt.nres) then
4118 c            iii=ii-nres
4119 c            jjj=jj-nres
4120 c          else
4121 c            iii=ii
4122 c            jjj=jj
4123 c          endif
4124           if (ii.gt.nres) then
4125             iii=ii-nres
4126           else
4127             iii=ii
4128           endif
4129           if (jj.gt.nres) then
4130             jjj=jj-nres
4131           else
4132             jjj=jj
4133           endif
4134           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
4135           aux=dexp(-scal_peak*aux)
4136           ehpb_peak=ehpb_peak+aux
4137           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
4138      &      forcon_peak(ip))*aux/dd
4139           do j=1,3
4140             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
4141           enddo
4142           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
4143      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
4144      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
4145         enddo
4146 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
4147         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
4148         do ip=ipeak(1,i),ipeak(2,i)
4149           iip=ip-ipeak(1,i)+1
4150           do j=1,3
4151             ggg(j)=ggg_peak(j,iip)/ehpb_peak
4152           enddo
4153           ii=ihpb_peak(ip)
4154           jj=jhpb_peak(ip)
4155 C iii and jjj point to the residues for which the distance is assigned.
4156           if (ii.gt.nres) then
4157             iii=ii-nres
4158             jjj=jj-nres
4159           else
4160             iii=ii
4161             jjj=jj
4162           endif
4163           if (iii.lt.ii) then
4164             do j=1,3
4165               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4166             enddo
4167           endif
4168           if (jjj.lt.jj) then
4169             do j=1,3
4170               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4171             enddo
4172           endif
4173           do k=1,3
4174             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4175             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4176           enddo
4177         enddo
4178       enddo
4179       do i=link_start,link_end
4180 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4181 C CA-CA distance used in regularization of structure.
4182         ii=ihpb(i)
4183         jj=jhpb(i)
4184 C iii and jjj point to the residues for which the distance is assigned.
4185         if (ii.gt.nres) then
4186           iii=ii-nres
4187         else
4188           iii=ii
4189         endif
4190         if (jj.gt.nres) then
4191           jjj=jj-nres
4192         else
4193           jjj=jj
4194         endif
4195 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4196 c     &    dhpb(i),dhpb1(i),forcon(i)
4197 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4198 C    distance and angle dependent SS bond potential.
4199 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4200 C     & iabs(itype(jjj)).eq.1) then
4201 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4202 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4203         if (.not.dyn_ss .and. i.le.nss) then
4204 C 15/02/13 CC dynamic SSbond - additional check
4205           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4206      &        iabs(itype(jjj)).eq.1) then
4207            call ssbond_ene(iii,jjj,eij)
4208            ehpb=ehpb+2*eij
4209          endif
4210 cd          write (iout,*) "eij",eij
4211 cd   &   ' waga=',waga,' fac=',fac
4212 !        else if (ii.gt.nres .and. jj.gt.nres) then
4213         else
4214 C Calculate the distance between the two points and its difference from the
4215 C target distance.
4216           dd=dist(ii,jj)
4217           if (irestr_type(i).eq.11) then
4218             ehpb=ehpb+fordepth(i)!**4.0d0
4219      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4220             fac=fordepth(i)!**4.0d0
4221      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4222             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
4223      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4224      &        ehpb,irestr_type(i)
4225           else if (irestr_type(i).eq.10) then
4226 c AL 6//19/2018 cross-link restraints
4227             xdis = 0.5d0*(dd/forcon(i))**2
4228             expdis = dexp(-xdis)
4229 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
4230             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
4231 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
4232 c     &          " wboltzd",wboltzd
4233             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
4234 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
4235             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
4236      &           *expdis/(aux*forcon(i)**2)
4237             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
4238      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
4239      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
4240           else if (irestr_type(i).eq.2) then
4241 c Quartic restraints
4242             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4243             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4244      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4245      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
4246             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4247           else
4248 c Quadratic restraints
4249             rdis=dd-dhpb(i)
4250 C Get the force constant corresponding to this distance.
4251             waga=forcon(i)
4252 C Calculate the contribution to energy.
4253             ehpb=ehpb+0.5d0*waga*rdis*rdis
4254             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
4255      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
4256      &       0.5d0*waga*rdis*rdis,irestr_type(i)
4257 C
4258 C Evaluate gradient.
4259 C
4260             fac=waga*rdis/dd
4261           endif
4262 c Calculate Cartesian gradient
4263           do j=1,3
4264             ggg(j)=fac*(c(j,jj)-c(j,ii))
4265           enddo
4266 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4267 C If this is a SC-SC distance, we need to calculate the contributions to the
4268 C Cartesian gradient in the SC vectors (ghpbx).
4269           if (iii.lt.ii) then
4270             do j=1,3
4271               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4272             enddo
4273           endif
4274           if (jjj.lt.jj) then
4275             do j=1,3
4276               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4277             enddo
4278           endif
4279           do k=1,3
4280             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4281             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4282           enddo
4283         endif
4284       enddo
4285       return
4286       end
4287 C--------------------------------------------------------------------------
4288       subroutine ssbond_ene(i,j,eij)
4289 C
4290 C Calculate the distance and angle dependent SS-bond potential energy
4291 C using a free-energy function derived based on RHF/6-31G** ab initio
4292 C calculations of diethyl disulfide.
4293 C
4294 C A. Liwo and U. Kozlowska, 11/24/03
4295 C
4296       implicit real*8 (a-h,o-z)
4297       include 'DIMENSIONS'
4298       include 'DIMENSIONS.ZSCOPT'
4299       include 'COMMON.SBRIDGE'
4300       include 'COMMON.CHAIN'
4301       include 'COMMON.DERIV'
4302       include 'COMMON.LOCAL'
4303       include 'COMMON.INTERACT'
4304       include 'COMMON.VAR'
4305       include 'COMMON.IOUNITS'
4306       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4307       itypi=iabs(itype(i))
4308       xi=c(1,nres+i)
4309       yi=c(2,nres+i)
4310       zi=c(3,nres+i)
4311       dxi=dc_norm(1,nres+i)
4312       dyi=dc_norm(2,nres+i)
4313       dzi=dc_norm(3,nres+i)
4314       dsci_inv=dsc_inv(itypi)
4315       itypj=iabs(itype(j))
4316       dscj_inv=dsc_inv(itypj)
4317       xj=c(1,nres+j)-xi
4318       yj=c(2,nres+j)-yi
4319       zj=c(3,nres+j)-zi
4320       dxj=dc_norm(1,nres+j)
4321       dyj=dc_norm(2,nres+j)
4322       dzj=dc_norm(3,nres+j)
4323       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4324       rij=dsqrt(rrij)
4325       erij(1)=xj*rij
4326       erij(2)=yj*rij
4327       erij(3)=zj*rij
4328       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4329       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4330       om12=dxi*dxj+dyi*dyj+dzi*dzj
4331       do k=1,3
4332         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4333         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4334       enddo
4335       rij=1.0d0/rij
4336       deltad=rij-d0cm
4337       deltat1=1.0d0-om1
4338       deltat2=1.0d0+om2
4339       deltat12=om2-om1+2.0d0
4340       cosphi=om12-om1*om2
4341       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4342      &  +akct*deltad*deltat12
4343      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
4344 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4345 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4346 c     &  " deltat12",deltat12," eij",eij
4347       ed=2*akcm*deltad+akct*deltat12
4348       pom1=akct*deltad
4349       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4350       eom1=-2*akth*deltat1-pom1-om2*pom2
4351       eom2= 2*akth*deltat2+pom1-om1*pom2
4352       eom12=pom2
4353       do k=1,3
4354         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4355       enddo
4356       do k=1,3
4357         ghpbx(k,i)=ghpbx(k,i)-gg(k)
4358      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
4359         ghpbx(k,j)=ghpbx(k,j)+gg(k)
4360      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
4361       enddo
4362 C
4363 C Calculate the components of the gradient in DC and X
4364 C
4365       do k=i,j-1
4366         do l=1,3
4367           ghpbc(l,k)=ghpbc(l,k)+gg(l)
4368         enddo
4369       enddo
4370       return
4371       end
4372 C--------------------------------------------------------------------------
4373       subroutine ebond(estr)
4374 c
4375 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4376 c
4377       implicit real*8 (a-h,o-z)
4378       include 'DIMENSIONS'
4379       include 'DIMENSIONS.ZSCOPT'
4380       include 'COMMON.LOCAL'
4381       include 'COMMON.GEO'
4382       include 'COMMON.INTERACT'
4383       include 'COMMON.DERIV'
4384       include 'COMMON.VAR'
4385       include 'COMMON.CHAIN'
4386       include 'COMMON.IOUNITS'
4387       include 'COMMON.NAMES'
4388       include 'COMMON.FFIELD'
4389       include 'COMMON.CONTROL'
4390       double precision u(3),ud(3)
4391       estr=0.0d0
4392       estr1=0.0d0
4393 c      write (iout,*) "distchainmax",distchainmax
4394       do i=nnt+1,nct
4395         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
4396 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4397 C          do j=1,3
4398 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4399 C     &      *dc(j,i-1)/vbld(i)
4400 C          enddo
4401 C          if (energy_dec) write(iout,*)
4402 C     &       "estr1",i,vbld(i),distchainmax,
4403 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
4404 C        else
4405          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4406         diff = vbld(i)-vbldpDUM
4407 C         write(iout,*) i,diff
4408          else
4409           diff = vbld(i)-vbldp0
4410 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
4411          endif
4412           estr=estr+diff*diff
4413           do j=1,3
4414             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4415           enddo
4416 C        endif
4417 C        write (iout,'(a7,i5,4f7.3)')
4418 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4419       enddo
4420       estr=0.5d0*AKP*estr+estr1
4421 c
4422 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4423 c
4424       do i=nnt,nct
4425         iti=iabs(itype(i))
4426         if (iti.ne.10 .and. iti.ne.ntyp1) then
4427           nbi=nbondterm(iti)
4428           if (nbi.eq.1) then
4429             diff=vbld(i+nres)-vbldsc0(1,iti)
4430 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4431 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4432             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4433             do j=1,3
4434               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4435             enddo
4436           else
4437             do j=1,nbi
4438               diff=vbld(i+nres)-vbldsc0(j,iti)
4439               ud(j)=aksc(j,iti)*diff
4440               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4441             enddo
4442             uprod=u(1)
4443             do j=2,nbi
4444               uprod=uprod*u(j)
4445             enddo
4446             usum=0.0d0
4447             usumsqder=0.0d0
4448             do j=1,nbi
4449               uprod1=1.0d0
4450               uprod2=1.0d0
4451               do k=1,nbi
4452                 if (k.ne.j) then
4453                   uprod1=uprod1*u(k)
4454                   uprod2=uprod2*u(k)*u(k)
4455                 endif
4456               enddo
4457               usum=usum+uprod1
4458               usumsqder=usumsqder+ud(j)*uprod2
4459             enddo
4460 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
4461 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
4462             estr=estr+uprod/usum
4463             do j=1,3
4464              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4465             enddo
4466           endif
4467         endif
4468       enddo
4469       return
4470       end
4471 #ifdef CRYST_THETA
4472 C--------------------------------------------------------------------------
4473       subroutine ebend(etheta,ethetacnstr)
4474 C
4475 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4476 C angles gamma and its derivatives in consecutive thetas and gammas.
4477 C
4478       implicit real*8 (a-h,o-z)
4479       include 'DIMENSIONS'
4480       include 'DIMENSIONS.ZSCOPT'
4481       include 'COMMON.LOCAL'
4482       include 'COMMON.GEO'
4483       include 'COMMON.INTERACT'
4484       include 'COMMON.DERIV'
4485       include 'COMMON.VAR'
4486       include 'COMMON.CHAIN'
4487       include 'COMMON.IOUNITS'
4488       include 'COMMON.NAMES'
4489       include 'COMMON.FFIELD'
4490       include 'COMMON.TORCNSTR'
4491       common /calcthet/ term1,term2,termm,diffak,ratak,
4492      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4493      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4494       double precision y(2),z(2)
4495       delta=0.02d0*pi
4496 c      time11=dexp(-2*time)
4497 c      time12=1.0d0
4498       etheta=0.0D0
4499 c      write (iout,*) "nres",nres
4500 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4501 c      write (iout,*) ithet_start,ithet_end
4502       do i=ithet_start,ithet_end
4503 C        if (itype(i-1).eq.ntyp1) cycle
4504         if (i.le.2) cycle
4505         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4506      &  .or.itype(i).eq.ntyp1) cycle
4507 C Zero the energy function and its derivative at 0 or pi.
4508         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4509         it=itype(i-1)
4510         ichir1=isign(1,itype(i-2))
4511         ichir2=isign(1,itype(i))
4512          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4513          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4514          if (itype(i-1).eq.10) then
4515           itype1=isign(10,itype(i-2))
4516           ichir11=isign(1,itype(i-2))
4517           ichir12=isign(1,itype(i-2))
4518           itype2=isign(10,itype(i))
4519           ichir21=isign(1,itype(i))
4520           ichir22=isign(1,itype(i))
4521          endif
4522          if (i.eq.3) then
4523           y(1)=0.0D0
4524           y(2)=0.0D0
4525           else
4526
4527         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4528 #ifdef OSF
4529           phii=phi(i)
4530 c          icrc=0
4531 c          call proc_proc(phii,icrc)
4532           if (icrc.eq.1) phii=150.0
4533 #else
4534           phii=phi(i)
4535 #endif
4536           y(1)=dcos(phii)
4537           y(2)=dsin(phii)
4538         else
4539           y(1)=0.0D0
4540           y(2)=0.0D0
4541         endif
4542         endif
4543         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4544 #ifdef OSF
4545           phii1=phi(i+1)
4546 c          icrc=0
4547 c          call proc_proc(phii1,icrc)
4548           if (icrc.eq.1) phii1=150.0
4549           phii1=pinorm(phii1)
4550           z(1)=cos(phii1)
4551 #else
4552           phii1=phi(i+1)
4553           z(1)=dcos(phii1)
4554 #endif
4555           z(2)=dsin(phii1)
4556         else
4557           z(1)=0.0D0
4558           z(2)=0.0D0
4559         endif
4560 C Calculate the "mean" value of theta from the part of the distribution
4561 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4562 C In following comments this theta will be referred to as t_c.
4563         thet_pred_mean=0.0d0
4564         do k=1,2
4565             athetk=athet(k,it,ichir1,ichir2)
4566             bthetk=bthet(k,it,ichir1,ichir2)
4567           if (it.eq.10) then
4568              athetk=athet(k,itype1,ichir11,ichir12)
4569              bthetk=bthet(k,itype2,ichir21,ichir22)
4570           endif
4571           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4572         enddo
4573 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4574         dthett=thet_pred_mean*ssd
4575         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4576 c        write (iout,*) "thet_pred_mean",thet_pred_mean
4577 C Derivatives of the "mean" values in gamma1 and gamma2.
4578         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4579      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4580          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4581      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4582          if (it.eq.10) then
4583       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4584      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4585         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4586      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4587          endif
4588         if (theta(i).gt.pi-delta) then
4589           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4590      &         E_tc0)
4591           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4592           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4593           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4594      &        E_theta)
4595           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4596      &        E_tc)
4597         else if (theta(i).lt.delta) then
4598           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4599           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4600           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4601      &        E_theta)
4602           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4603           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4604      &        E_tc)
4605         else
4606           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4607      &        E_theta,E_tc)
4608         endif
4609         etheta=etheta+ethetai
4610 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
4611 c     &      'ebend',i,ethetai,theta(i),itype(i)
4612 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
4613 c     &    rad2deg*phii,rad2deg*phii1,ethetai
4614         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4615         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4616         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4617 c 1215   continue
4618       enddo
4619       ethetacnstr=0.0d0
4620 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
4621       do i=1,ntheta_constr
4622         itheta=itheta_constr(i)
4623         thetiii=theta(itheta)
4624         difi=pinorm(thetiii-theta_constr0(i))
4625         if (difi.gt.theta_drange(i)) then
4626           difi=difi-theta_drange(i)
4627           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4628           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4629      &    +for_thet_constr(i)*difi**3
4630         else if (difi.lt.-drange(i)) then
4631           difi=difi+drange(i)
4632           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
4633           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4634      &    +for_thet_constr(i)*difi**3
4635         else
4636           difi=0.0
4637         endif
4638 C       if (energy_dec) then
4639 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4640 C     &    i,itheta,rad2deg*thetiii,
4641 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4642 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4643 C     &    gloc(itheta+nphi-2,icg)
4644 C        endif
4645       enddo
4646 C Ufff.... We've done all this!!!
4647       return
4648       end
4649 C---------------------------------------------------------------------------
4650       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4651      &     E_tc)
4652       implicit real*8 (a-h,o-z)
4653       include 'DIMENSIONS'
4654       include 'COMMON.LOCAL'
4655       include 'COMMON.IOUNITS'
4656       common /calcthet/ term1,term2,termm,diffak,ratak,
4657      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4658      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4659 C Calculate the contributions to both Gaussian lobes.
4660 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4661 C The "polynomial part" of the "standard deviation" of this part of
4662 C the distribution.
4663         sig=polthet(3,it)
4664         do j=2,0,-1
4665           sig=sig*thet_pred_mean+polthet(j,it)
4666         enddo
4667 C Derivative of the "interior part" of the "standard deviation of the"
4668 C gamma-dependent Gaussian lobe in t_c.
4669         sigtc=3*polthet(3,it)
4670         do j=2,1,-1
4671           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4672         enddo
4673         sigtc=sig*sigtc
4674 C Set the parameters of both Gaussian lobes of the distribution.
4675 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4676         fac=sig*sig+sigc0(it)
4677         sigcsq=fac+fac
4678         sigc=1.0D0/sigcsq
4679 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4680         sigsqtc=-4.0D0*sigcsq*sigtc
4681 c       print *,i,sig,sigtc,sigsqtc
4682 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4683         sigtc=-sigtc/(fac*fac)
4684 C Following variable is sigma(t_c)**(-2)
4685         sigcsq=sigcsq*sigcsq
4686         sig0i=sig0(it)
4687         sig0inv=1.0D0/sig0i**2
4688         delthec=thetai-thet_pred_mean
4689         delthe0=thetai-theta0i
4690         term1=-0.5D0*sigcsq*delthec*delthec
4691         term2=-0.5D0*sig0inv*delthe0*delthe0
4692 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4693 C NaNs in taking the logarithm. We extract the largest exponent which is added
4694 C to the energy (this being the log of the distribution) at the end of energy
4695 C term evaluation for this virtual-bond angle.
4696         if (term1.gt.term2) then
4697           termm=term1
4698           term2=dexp(term2-termm)
4699           term1=1.0d0
4700         else
4701           termm=term2
4702           term1=dexp(term1-termm)
4703           term2=1.0d0
4704         endif
4705 C The ratio between the gamma-independent and gamma-dependent lobes of
4706 C the distribution is a Gaussian function of thet_pred_mean too.
4707         diffak=gthet(2,it)-thet_pred_mean
4708         ratak=diffak/gthet(3,it)**2
4709         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4710 C Let's differentiate it in thet_pred_mean NOW.
4711         aktc=ak*ratak
4712 C Now put together the distribution terms to make complete distribution.
4713         termexp=term1+ak*term2
4714         termpre=sigc+ak*sig0i
4715 C Contribution of the bending energy from this theta is just the -log of
4716 C the sum of the contributions from the two lobes and the pre-exponential
4717 C factor. Simple enough, isn't it?
4718         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4719 C NOW the derivatives!!!
4720 C 6/6/97 Take into account the deformation.
4721         E_theta=(delthec*sigcsq*term1
4722      &       +ak*delthe0*sig0inv*term2)/termexp
4723         E_tc=((sigtc+aktc*sig0i)/termpre
4724      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4725      &       aktc*term2)/termexp)
4726       return
4727       end
4728 c-----------------------------------------------------------------------------
4729       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4730       implicit real*8 (a-h,o-z)
4731       include 'DIMENSIONS'
4732       include 'COMMON.LOCAL'
4733       include 'COMMON.IOUNITS'
4734       common /calcthet/ term1,term2,termm,diffak,ratak,
4735      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4736      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4737       delthec=thetai-thet_pred_mean
4738       delthe0=thetai-theta0i
4739 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4740       t3 = thetai-thet_pred_mean
4741       t6 = t3**2
4742       t9 = term1
4743       t12 = t3*sigcsq
4744       t14 = t12+t6*sigsqtc
4745       t16 = 1.0d0
4746       t21 = thetai-theta0i
4747       t23 = t21**2
4748       t26 = term2
4749       t27 = t21*t26
4750       t32 = termexp
4751       t40 = t32**2
4752       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4753      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4754      & *(-t12*t9-ak*sig0inv*t27)
4755       return
4756       end
4757 #else
4758 C--------------------------------------------------------------------------
4759       subroutine ebend(etheta)
4760 C
4761 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4762 C angles gamma and its derivatives in consecutive thetas and gammas.
4763 C ab initio-derived potentials from
4764 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4765 C
4766       implicit real*8 (a-h,o-z)
4767       include 'DIMENSIONS'
4768       include 'DIMENSIONS.ZSCOPT'
4769       include 'COMMON.LOCAL'
4770       include 'COMMON.GEO'
4771       include 'COMMON.INTERACT'
4772       include 'COMMON.DERIV'
4773       include 'COMMON.VAR'
4774       include 'COMMON.CHAIN'
4775       include 'COMMON.IOUNITS'
4776       include 'COMMON.NAMES'
4777       include 'COMMON.FFIELD'
4778       include 'COMMON.CONTROL'
4779       include 'COMMON.TORCNSTR'
4780       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4781      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4782      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4783      & sinph1ph2(maxdouble,maxdouble)
4784       logical lprn /.false./, lprn1 /.false./
4785       etheta=0.0D0
4786 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
4787       do i=ithet_start,ithet_end
4788 C         if (i.eq.2) cycle
4789 C        if (itype(i-1).eq.ntyp1) cycle
4790         if (i.le.2) cycle
4791         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
4792      &  .or.itype(i).eq.ntyp1) cycle
4793         if (iabs(itype(i+1)).eq.20) iblock=2
4794         if (iabs(itype(i+1)).ne.20) iblock=1
4795         dethetai=0.0d0
4796         dephii=0.0d0
4797         dephii1=0.0d0
4798         theti2=0.5d0*theta(i)
4799         ityp2=ithetyp((itype(i-1)))
4800         do k=1,nntheterm
4801           coskt(k)=dcos(k*theti2)
4802           sinkt(k)=dsin(k*theti2)
4803         enddo
4804         if (i.eq.3) then
4805           phii=0.0d0
4806           ityp1=nthetyp+1
4807           do k=1,nsingle
4808             cosph1(k)=0.0d0
4809             sinph1(k)=0.0d0
4810           enddo
4811         else
4812         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4813 #ifdef OSF
4814           phii=phi(i)
4815           if (phii.ne.phii) phii=150.0
4816 #else
4817           phii=phi(i)
4818 #endif
4819           ityp1=ithetyp((itype(i-2)))
4820           do k=1,nsingle
4821             cosph1(k)=dcos(k*phii)
4822             sinph1(k)=dsin(k*phii)
4823           enddo
4824         else
4825           phii=0.0d0
4826 c          ityp1=nthetyp+1
4827           do k=1,nsingle
4828             ityp1=ithetyp((itype(i-2)))
4829             cosph1(k)=0.0d0
4830             sinph1(k)=0.0d0
4831           enddo
4832         endif
4833         endif
4834         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4835 #ifdef OSF
4836           phii1=phi(i+1)
4837           if (phii1.ne.phii1) phii1=150.0
4838           phii1=pinorm(phii1)
4839 #else
4840           phii1=phi(i+1)
4841 #endif
4842           ityp3=ithetyp((itype(i)))
4843           do k=1,nsingle
4844             cosph2(k)=dcos(k*phii1)
4845             sinph2(k)=dsin(k*phii1)
4846           enddo
4847         else
4848           phii1=0.0d0
4849 c          ityp3=nthetyp+1
4850           ityp3=ithetyp((itype(i)))
4851           do k=1,nsingle
4852             cosph2(k)=0.0d0
4853             sinph2(k)=0.0d0
4854           enddo
4855         endif
4856 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
4857 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
4858 c        call flush(iout)
4859         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4860         do k=1,ndouble
4861           do l=1,k-1
4862             ccl=cosph1(l)*cosph2(k-l)
4863             ssl=sinph1(l)*sinph2(k-l)
4864             scl=sinph1(l)*cosph2(k-l)
4865             csl=cosph1(l)*sinph2(k-l)
4866             cosph1ph2(l,k)=ccl-ssl
4867             cosph1ph2(k,l)=ccl+ssl
4868             sinph1ph2(l,k)=scl+csl
4869             sinph1ph2(k,l)=scl-csl
4870           enddo
4871         enddo
4872         if (lprn) then
4873         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4874      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4875         write (iout,*) "coskt and sinkt"
4876         do k=1,nntheterm
4877           write (iout,*) k,coskt(k),sinkt(k)
4878         enddo
4879         endif
4880         do k=1,ntheterm
4881           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4882           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4883      &      *coskt(k)
4884           if (lprn)
4885      &    write (iout,*) "k",k,"
4886      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4887      &     " ethetai",ethetai
4888         enddo
4889         if (lprn) then
4890         write (iout,*) "cosph and sinph"
4891         do k=1,nsingle
4892           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4893         enddo
4894         write (iout,*) "cosph1ph2 and sinph2ph2"
4895         do k=2,ndouble
4896           do l=1,k-1
4897             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4898      &         sinph1ph2(l,k),sinph1ph2(k,l)
4899           enddo
4900         enddo
4901         write(iout,*) "ethetai",ethetai
4902         endif
4903         do m=1,ntheterm2
4904           do k=1,nsingle
4905             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4906      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4907      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4908      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4909             ethetai=ethetai+sinkt(m)*aux
4910             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4911             dephii=dephii+k*sinkt(m)*(
4912      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4913      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4914             dephii1=dephii1+k*sinkt(m)*(
4915      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4916      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4917             if (lprn)
4918      &      write (iout,*) "m",m," k",k," bbthet",
4919      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4920      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4921      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4922      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4923           enddo
4924         enddo
4925         if (lprn)
4926      &  write(iout,*) "ethetai",ethetai
4927         do m=1,ntheterm3
4928           do k=2,ndouble
4929             do l=1,k-1
4930               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4931      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4932      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4933      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4934               ethetai=ethetai+sinkt(m)*aux
4935               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4936               dephii=dephii+l*sinkt(m)*(
4937      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4938      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4939      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4940      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4941               dephii1=dephii1+(k-l)*sinkt(m)*(
4942      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4943      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4944      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4945      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4946               if (lprn) then
4947               write (iout,*) "m",m," k",k," l",l," ffthet",
4948      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4949      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4950      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4951      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4952      &            " ethetai",ethetai
4953               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4954      &            cosph1ph2(k,l)*sinkt(m),
4955      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4956               endif
4957             enddo
4958           enddo
4959         enddo
4960 10      continue
4961         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4962      &   i,theta(i)*rad2deg,phii*rad2deg,
4963      &   phii1*rad2deg,ethetai
4964         etheta=etheta+ethetai
4965         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4966         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4967 c        gloc(nphi+i-2,icg)=wang*dethetai
4968         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4969       enddo
4970       return
4971       end
4972 #endif
4973 #ifdef CRYST_SC
4974 c-----------------------------------------------------------------------------
4975       subroutine esc(escloc)
4976 C Calculate the local energy of a side chain and its derivatives in the
4977 C corresponding virtual-bond valence angles THETA and the spherical angles
4978 C ALPHA and OMEGA.
4979       implicit real*8 (a-h,o-z)
4980       include 'DIMENSIONS'
4981       include 'DIMENSIONS.ZSCOPT'
4982       include 'COMMON.GEO'
4983       include 'COMMON.LOCAL'
4984       include 'COMMON.VAR'
4985       include 'COMMON.INTERACT'
4986       include 'COMMON.DERIV'
4987       include 'COMMON.CHAIN'
4988       include 'COMMON.IOUNITS'
4989       include 'COMMON.NAMES'
4990       include 'COMMON.FFIELD'
4991       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4992      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4993       common /sccalc/ time11,time12,time112,theti,it,nlobit
4994       delta=0.02d0*pi
4995       escloc=0.0D0
4996 C      write (iout,*) 'ESC'
4997       do i=loc_start,loc_end
4998         it=itype(i)
4999         if (it.eq.ntyp1) cycle
5000         if (it.eq.10) goto 1
5001         nlobit=nlob(iabs(it))
5002 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
5003 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
5004         theti=theta(i+1)-pipol
5005         x(1)=dtan(theti)
5006         x(2)=alph(i)
5007         x(3)=omeg(i)
5008 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
5009
5010         if (x(2).gt.pi-delta) then
5011           xtemp(1)=x(1)
5012           xtemp(2)=pi-delta
5013           xtemp(3)=x(3)
5014           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5015           xtemp(2)=pi
5016           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5017           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
5018      &        escloci,dersc(2))
5019           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5020      &        ddersc0(1),dersc(1))
5021           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
5022      &        ddersc0(3),dersc(3))
5023           xtemp(2)=pi-delta
5024           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5025           xtemp(2)=pi
5026           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5027           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
5028      &            dersc0(2),esclocbi,dersc02)
5029           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
5030      &            dersc12,dersc01)
5031           call splinthet(x(2),0.5d0*delta,ss,ssd)
5032           dersc0(1)=dersc01
5033           dersc0(2)=dersc02
5034           dersc0(3)=0.0d0
5035           do k=1,3
5036             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5037           enddo
5038           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5039           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5040      &             esclocbi,ss,ssd
5041           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5042 c         escloci=esclocbi
5043 c         write (iout,*) escloci
5044         else if (x(2).lt.delta) then
5045           xtemp(1)=x(1)
5046           xtemp(2)=delta
5047           xtemp(3)=x(3)
5048           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
5049           xtemp(2)=0.0d0
5050           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
5051           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
5052      &        escloci,dersc(2))
5053           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5054      &        ddersc0(1),dersc(1))
5055           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
5056      &        ddersc0(3),dersc(3))
5057           xtemp(2)=delta
5058           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
5059           xtemp(2)=0.0d0
5060           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
5061           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
5062      &            dersc0(2),esclocbi,dersc02)
5063           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
5064      &            dersc12,dersc01)
5065           dersc0(1)=dersc01
5066           dersc0(2)=dersc02
5067           dersc0(3)=0.0d0
5068           call splinthet(x(2),0.5d0*delta,ss,ssd)
5069           do k=1,3
5070             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5071           enddo
5072           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5073 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5074 c     &             esclocbi,ss,ssd
5075           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5076 C         write (iout,*) 'i=',i, escloci
5077         else
5078           call enesc(x,escloci,dersc,ddummy,.false.)
5079         endif
5080
5081         escloc=escloc+escloci
5082 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5083             write (iout,'(a6,i5,0pf7.3)')
5084      &     'escloc',i,escloci
5085
5086         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5087      &   wscloc*dersc(1)
5088         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5089         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5090     1   continue
5091       enddo
5092       return
5093       end
5094 C---------------------------------------------------------------------------
5095       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5096       implicit real*8 (a-h,o-z)
5097       include 'DIMENSIONS'
5098       include 'COMMON.GEO'
5099       include 'COMMON.LOCAL'
5100       include 'COMMON.IOUNITS'
5101       common /sccalc/ time11,time12,time112,theti,it,nlobit
5102       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5103       double precision contr(maxlob,-1:1)
5104       logical mixed
5105 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5106         escloc_i=0.0D0
5107         do j=1,3
5108           dersc(j)=0.0D0
5109           if (mixed) ddersc(j)=0.0d0
5110         enddo
5111         x3=x(3)
5112
5113 C Because of periodicity of the dependence of the SC energy in omega we have
5114 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5115 C To avoid underflows, first compute & store the exponents.
5116
5117         do iii=-1,1
5118
5119           x(3)=x3+iii*dwapi
5120
5121           do j=1,nlobit
5122             do k=1,3
5123               z(k)=x(k)-censc(k,j,it)
5124             enddo
5125             do k=1,3
5126               Axk=0.0D0
5127               do l=1,3
5128                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5129               enddo
5130               Ax(k,j,iii)=Axk
5131             enddo
5132             expfac=0.0D0
5133             do k=1,3
5134               expfac=expfac+Ax(k,j,iii)*z(k)
5135             enddo
5136             contr(j,iii)=expfac
5137           enddo ! j
5138
5139         enddo ! iii
5140
5141         x(3)=x3
5142 C As in the case of ebend, we want to avoid underflows in exponentiation and
5143 C subsequent NaNs and INFs in energy calculation.
5144 C Find the largest exponent
5145         emin=contr(1,-1)
5146         do iii=-1,1
5147           do j=1,nlobit
5148             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5149           enddo
5150         enddo
5151         emin=0.5D0*emin
5152 cd      print *,'it=',it,' emin=',emin
5153
5154 C Compute the contribution to SC energy and derivatives
5155         do iii=-1,1
5156
5157           do j=1,nlobit
5158             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5159 cd          print *,'j=',j,' expfac=',expfac
5160             escloc_i=escloc_i+expfac
5161             do k=1,3
5162               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5163             enddo
5164             if (mixed) then
5165               do k=1,3,2
5166                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5167      &            +gaussc(k,2,j,it))*expfac
5168               enddo
5169             endif
5170           enddo
5171
5172         enddo ! iii
5173
5174         dersc(1)=dersc(1)/cos(theti)**2
5175         ddersc(1)=ddersc(1)/cos(theti)**2
5176         ddersc(3)=ddersc(3)
5177
5178         escloci=-(dlog(escloc_i)-emin)
5179         do j=1,3
5180           dersc(j)=dersc(j)/escloc_i
5181         enddo
5182         if (mixed) then
5183           do j=1,3,2
5184             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5185           enddo
5186         endif
5187       return
5188       end
5189 C------------------------------------------------------------------------------
5190       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5191       implicit real*8 (a-h,o-z)
5192       include 'DIMENSIONS'
5193       include 'COMMON.GEO'
5194       include 'COMMON.LOCAL'
5195       include 'COMMON.IOUNITS'
5196       common /sccalc/ time11,time12,time112,theti,it,nlobit
5197       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5198       double precision contr(maxlob)
5199       logical mixed
5200
5201       escloc_i=0.0D0
5202
5203       do j=1,3
5204         dersc(j)=0.0D0
5205       enddo
5206
5207       do j=1,nlobit
5208         do k=1,2
5209           z(k)=x(k)-censc(k,j,it)
5210         enddo
5211         z(3)=dwapi
5212         do k=1,3
5213           Axk=0.0D0
5214           do l=1,3
5215             Axk=Axk+gaussc(l,k,j,it)*z(l)
5216           enddo
5217           Ax(k,j)=Axk
5218         enddo
5219         expfac=0.0D0
5220         do k=1,3
5221           expfac=expfac+Ax(k,j)*z(k)
5222         enddo
5223         contr(j)=expfac
5224       enddo ! j
5225
5226 C As in the case of ebend, we want to avoid underflows in exponentiation and
5227 C subsequent NaNs and INFs in energy calculation.
5228 C Find the largest exponent
5229       emin=contr(1)
5230       do j=1,nlobit
5231         if (emin.gt.contr(j)) emin=contr(j)
5232       enddo
5233       emin=0.5D0*emin
5234
5235 C Compute the contribution to SC energy and derivatives
5236
5237       dersc12=0.0d0
5238       do j=1,nlobit
5239         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5240         escloc_i=escloc_i+expfac
5241         do k=1,2
5242           dersc(k)=dersc(k)+Ax(k,j)*expfac
5243         enddo
5244         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5245      &            +gaussc(1,2,j,it))*expfac
5246         dersc(3)=0.0d0
5247       enddo
5248
5249       dersc(1)=dersc(1)/cos(theti)**2
5250       dersc12=dersc12/cos(theti)**2
5251       escloci=-(dlog(escloc_i)-emin)
5252       do j=1,2
5253         dersc(j)=dersc(j)/escloc_i
5254       enddo
5255       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5256       return
5257       end
5258 #else
5259 c----------------------------------------------------------------------------------
5260       subroutine esc(escloc)
5261 C Calculate the local energy of a side chain and its derivatives in the
5262 C corresponding virtual-bond valence angles THETA and the spherical angles
5263 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5264 C added by Urszula Kozlowska. 07/11/2007
5265 C
5266       implicit real*8 (a-h,o-z)
5267       include 'DIMENSIONS'
5268       include 'DIMENSIONS.ZSCOPT'
5269       include 'COMMON.GEO'
5270       include 'COMMON.LOCAL'
5271       include 'COMMON.VAR'
5272       include 'COMMON.SCROT'
5273       include 'COMMON.INTERACT'
5274       include 'COMMON.DERIV'
5275       include 'COMMON.CHAIN'
5276       include 'COMMON.IOUNITS'
5277       include 'COMMON.NAMES'
5278       include 'COMMON.FFIELD'
5279       include 'COMMON.CONTROL'
5280       include 'COMMON.VECTORS'
5281       double precision x_prime(3),y_prime(3),z_prime(3)
5282      &    , sumene,dsc_i,dp2_i,x(65),
5283      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5284      &    de_dxx,de_dyy,de_dzz,de_dt
5285       double precision s1_t,s1_6_t,s2_t,s2_6_t
5286       double precision
5287      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5288      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5289      & dt_dCi(3),dt_dCi1(3)
5290       common /sccalc/ time11,time12,time112,theti,it,nlobit
5291       delta=0.02d0*pi
5292       escloc=0.0D0
5293       do i=loc_start,loc_end
5294         if (itype(i).eq.ntyp1) cycle
5295         costtab(i+1) =dcos(theta(i+1))
5296         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5297         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5298         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5299         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5300         cosfac=dsqrt(cosfac2)
5301         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5302         sinfac=dsqrt(sinfac2)
5303         it=iabs(itype(i))
5304         if (it.eq.10) goto 1
5305 c
5306 C  Compute the axes of tghe local cartesian coordinates system; store in
5307 c   x_prime, y_prime and z_prime
5308 c
5309         do j=1,3
5310           x_prime(j) = 0.00
5311           y_prime(j) = 0.00
5312           z_prime(j) = 0.00
5313         enddo
5314 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5315 C     &   dc_norm(3,i+nres)
5316         do j = 1,3
5317           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5318           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5319         enddo
5320         do j = 1,3
5321           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5322         enddo
5323 c       write (2,*) "i",i
5324 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5325 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5326 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5327 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5328 c      & " xy",scalar(x_prime(1),y_prime(1)),
5329 c      & " xz",scalar(x_prime(1),z_prime(1)),
5330 c      & " yy",scalar(y_prime(1),y_prime(1)),
5331 c      & " yz",scalar(y_prime(1),z_prime(1)),
5332 c      & " zz",scalar(z_prime(1),z_prime(1))
5333 c
5334 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5335 C to local coordinate system. Store in xx, yy, zz.
5336 c
5337         xx=0.0d0
5338         yy=0.0d0
5339         zz=0.0d0
5340         do j = 1,3
5341           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5342           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5343           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5344         enddo
5345
5346         xxtab(i)=xx
5347         yytab(i)=yy
5348         zztab(i)=zz
5349 C
5350 C Compute the energy of the ith side cbain
5351 C
5352 c        write (2,*) "xx",xx," yy",yy," zz",zz
5353         it=iabs(itype(i))
5354         do j = 1,65
5355           x(j) = sc_parmin(j,it)
5356         enddo
5357 #ifdef CHECK_COORD
5358 Cc diagnostics - remove later
5359         xx1 = dcos(alph(2))
5360         yy1 = dsin(alph(2))*dcos(omeg(2))
5361         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
5362         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5363      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5364      &    xx1,yy1,zz1
5365 C,"  --- ", xx_w,yy_w,zz_w
5366 c end diagnostics
5367 #endif
5368         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5369      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5370      &   + x(10)*yy*zz
5371         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5372      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5373      & + x(20)*yy*zz
5374         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5375      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5376      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5377      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5378      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5379      &  +x(40)*xx*yy*zz
5380         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5381      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5382      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5383      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5384      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5385      &  +x(60)*xx*yy*zz
5386         dsc_i   = 0.743d0+x(61)
5387         dp2_i   = 1.9d0+x(62)
5388         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5389      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5390         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5391      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5392         s1=(1+x(63))/(0.1d0 + dscp1)
5393         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5394         s2=(1+x(65))/(0.1d0 + dscp2)
5395         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5396         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5397      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5398 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5399 c     &   sumene4,
5400 c     &   dscp1,dscp2,sumene
5401 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5402         escloc = escloc + sumene
5403 c        write (2,*) "escloc",escloc
5404 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
5405 c     &  zz,xx,yy
5406         if (.not. calc_grad) goto 1
5407 #ifdef DEBUG
5408 C
5409 C This section to check the numerical derivatives of the energy of ith side
5410 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5411 C #define DEBUG in the code to turn it on.
5412 C
5413         write (2,*) "sumene               =",sumene
5414         aincr=1.0d-7
5415         xxsave=xx
5416         xx=xx+aincr
5417         write (2,*) xx,yy,zz
5418         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5419         de_dxx_num=(sumenep-sumene)/aincr
5420         xx=xxsave
5421         write (2,*) "xx+ sumene from enesc=",sumenep
5422         yysave=yy
5423         yy=yy+aincr
5424         write (2,*) xx,yy,zz
5425         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5426         de_dyy_num=(sumenep-sumene)/aincr
5427         yy=yysave
5428         write (2,*) "yy+ sumene from enesc=",sumenep
5429         zzsave=zz
5430         zz=zz+aincr
5431         write (2,*) xx,yy,zz
5432         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5433         de_dzz_num=(sumenep-sumene)/aincr
5434         zz=zzsave
5435         write (2,*) "zz+ sumene from enesc=",sumenep
5436         costsave=cost2tab(i+1)
5437         sintsave=sint2tab(i+1)
5438         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5439         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5440         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5441         de_dt_num=(sumenep-sumene)/aincr
5442         write (2,*) " t+ sumene from enesc=",sumenep
5443         cost2tab(i+1)=costsave
5444         sint2tab(i+1)=sintsave
5445 C End of diagnostics section.
5446 #endif
5447 C
5448 C Compute the gradient of esc
5449 C
5450         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5451         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5452         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5453         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5454         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5455         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5456         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5457         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5458         pom1=(sumene3*sint2tab(i+1)+sumene1)
5459      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5460         pom2=(sumene4*cost2tab(i+1)+sumene2)
5461      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5462         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5463         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5464      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5465      &  +x(40)*yy*zz
5466         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5467         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5468      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5469      &  +x(60)*yy*zz
5470         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5471      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5472      &        +(pom1+pom2)*pom_dx
5473 #ifdef DEBUG
5474         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
5475 #endif
5476 C
5477         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5478         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5479      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5480      &  +x(40)*xx*zz
5481         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5482         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5483      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5484      &  +x(59)*zz**2 +x(60)*xx*zz
5485         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5486      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5487      &        +(pom1-pom2)*pom_dy
5488 #ifdef DEBUG
5489         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
5490 #endif
5491 C
5492         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5493      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5494      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5495      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5496      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5497      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5498      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5499      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5500 #ifdef DEBUG
5501         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
5502 #endif
5503 C
5504         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5505      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5506      &  +pom1*pom_dt1+pom2*pom_dt2
5507 #ifdef DEBUG
5508         write(2,*), "de_dt = ", de_dt,de_dt_num
5509 #endif
5510 c
5511 C
5512        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5513        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5514        cosfac2xx=cosfac2*xx
5515        sinfac2yy=sinfac2*yy
5516        do k = 1,3
5517          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5518      &      vbld_inv(i+1)
5519          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5520      &      vbld_inv(i)
5521          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5522          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5523 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5524 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5525 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5526 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5527          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5528          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5529          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5530          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5531          dZZ_Ci1(k)=0.0d0
5532          dZZ_Ci(k)=0.0d0
5533          do j=1,3
5534            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5535      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5536            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5537      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5538          enddo
5539
5540          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5541          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5542          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
5543 c
5544          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5545          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5546        enddo
5547
5548        do k=1,3
5549          dXX_Ctab(k,i)=dXX_Ci(k)
5550          dXX_C1tab(k,i)=dXX_Ci1(k)
5551          dYY_Ctab(k,i)=dYY_Ci(k)
5552          dYY_C1tab(k,i)=dYY_Ci1(k)
5553          dZZ_Ctab(k,i)=dZZ_Ci(k)
5554          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5555          dXX_XYZtab(k,i)=dXX_XYZ(k)
5556          dYY_XYZtab(k,i)=dYY_XYZ(k)
5557          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5558        enddo
5559
5560        do k = 1,3
5561 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5562 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5563 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5564 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5565 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5566 c     &    dt_dci(k)
5567 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5568 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5569          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5570      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5571          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5572      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5573          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5574      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5575        enddo
5576 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5577 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5578
5579 C to check gradient call subroutine check_grad
5580
5581     1 continue
5582       enddo
5583       return
5584       end
5585 #endif
5586 c------------------------------------------------------------------------------
5587       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5588 C
5589 C This procedure calculates two-body contact function g(rij) and its derivative:
5590 C
5591 C           eps0ij                                     !       x < -1
5592 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5593 C            0                                         !       x > 1
5594 C
5595 C where x=(rij-r0ij)/delta
5596 C
5597 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5598 C
5599       implicit none
5600       double precision rij,r0ij,eps0ij,fcont,fprimcont
5601       double precision x,x2,x4,delta
5602 c     delta=0.02D0*r0ij
5603 c      delta=0.2D0*r0ij
5604       x=(rij-r0ij)/delta
5605       if (x.lt.-1.0D0) then
5606         fcont=eps0ij
5607         fprimcont=0.0D0
5608       else if (x.le.1.0D0) then
5609         x2=x*x
5610         x4=x2*x2
5611         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5612         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5613       else
5614         fcont=0.0D0
5615         fprimcont=0.0D0
5616       endif
5617       return
5618       end
5619 c------------------------------------------------------------------------------
5620       subroutine splinthet(theti,delta,ss,ssder)
5621       implicit real*8 (a-h,o-z)
5622       include 'DIMENSIONS'
5623       include 'DIMENSIONS.ZSCOPT'
5624       include 'COMMON.VAR'
5625       include 'COMMON.GEO'
5626       thetup=pi-delta
5627       thetlow=delta
5628       if (theti.gt.pipol) then
5629         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5630       else
5631         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5632         ssder=-ssder
5633       endif
5634       return
5635       end
5636 c------------------------------------------------------------------------------
5637       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5638       implicit none
5639       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5640       double precision ksi,ksi2,ksi3,a1,a2,a3
5641       a1=fprim0*delta/(f1-f0)
5642       a2=3.0d0-2.0d0*a1
5643       a3=a1-2.0d0
5644       ksi=(x-x0)/delta
5645       ksi2=ksi*ksi
5646       ksi3=ksi2*ksi
5647       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5648       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5649       return
5650       end
5651 c------------------------------------------------------------------------------
5652       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5653       implicit none
5654       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5655       double precision ksi,ksi2,ksi3,a1,a2,a3
5656       ksi=(x-x0)/delta
5657       ksi2=ksi*ksi
5658       ksi3=ksi2*ksi
5659       a1=fprim0x*delta
5660       a2=3*(f1x-f0x)-2*fprim0x*delta
5661       a3=fprim0x*delta-2*(f1x-f0x)
5662       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5663       return
5664       end
5665 C-----------------------------------------------------------------------------
5666 #ifdef CRYST_TOR
5667 C-----------------------------------------------------------------------------
5668       subroutine etor(etors,fact)
5669       implicit real*8 (a-h,o-z)
5670       include 'DIMENSIONS'
5671       include 'DIMENSIONS.ZSCOPT'
5672       include 'COMMON.VAR'
5673       include 'COMMON.GEO'
5674       include 'COMMON.LOCAL'
5675       include 'COMMON.TORSION'
5676       include 'COMMON.INTERACT'
5677       include 'COMMON.DERIV'
5678       include 'COMMON.CHAIN'
5679       include 'COMMON.NAMES'
5680       include 'COMMON.IOUNITS'
5681       include 'COMMON.FFIELD'
5682       include 'COMMON.TORCNSTR'
5683       logical lprn
5684 C Set lprn=.true. for debugging
5685       lprn=.false.
5686 c      lprn=.true.
5687       etors=0.0D0
5688       do i=iphi_start,iphi_end
5689         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5690      &      .or. itype(i).eq.ntyp1) cycle
5691         itori=itortyp(itype(i-2))
5692         itori1=itortyp(itype(i-1))
5693         phii=phi(i)
5694         gloci=0.0D0
5695 C Proline-Proline pair is a special case...
5696         if (itori.eq.3 .and. itori1.eq.3) then
5697           if (phii.gt.-dwapi3) then
5698             cosphi=dcos(3*phii)
5699             fac=1.0D0/(1.0D0-cosphi)
5700             etorsi=v1(1,3,3)*fac
5701             etorsi=etorsi+etorsi
5702             etors=etors+etorsi-v1(1,3,3)
5703             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5704           endif
5705           do j=1,3
5706             v1ij=v1(j+1,itori,itori1)
5707             v2ij=v2(j+1,itori,itori1)
5708             cosphi=dcos(j*phii)
5709             sinphi=dsin(j*phii)
5710             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5711             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5712           enddo
5713         else
5714           do j=1,nterm_old
5715             v1ij=v1(j,itori,itori1)
5716             v2ij=v2(j,itori,itori1)
5717             cosphi=dcos(j*phii)
5718             sinphi=dsin(j*phii)
5719             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5720             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5721           enddo
5722         endif
5723         if (lprn)
5724      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5725      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5726      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5727         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5728 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5729       enddo
5730       return
5731       end
5732 c------------------------------------------------------------------------------
5733 #else
5734       subroutine etor(etors,fact)
5735       implicit real*8 (a-h,o-z)
5736       include 'DIMENSIONS'
5737       include 'DIMENSIONS.ZSCOPT'
5738       include 'COMMON.VAR'
5739       include 'COMMON.GEO'
5740       include 'COMMON.LOCAL'
5741       include 'COMMON.TORSION'
5742       include 'COMMON.INTERACT'
5743       include 'COMMON.DERIV'
5744       include 'COMMON.CHAIN'
5745       include 'COMMON.NAMES'
5746       include 'COMMON.IOUNITS'
5747       include 'COMMON.FFIELD'
5748       include 'COMMON.TORCNSTR'
5749       logical lprn
5750 C Set lprn=.true. for debugging
5751       lprn=.false.
5752 c      lprn=.true.
5753       etors=0.0D0
5754       do i=iphi_start,iphi_end
5755         if (i.le.2) cycle
5756         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5757      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5758 C        if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5759 C     &       .or. itype(i).eq.ntyp1) cycle
5760         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
5761          if (iabs(itype(i)).eq.20) then
5762          iblock=2
5763          else
5764          iblock=1
5765          endif
5766         itori=itortyp(itype(i-2))
5767         itori1=itortyp(itype(i-1))
5768         phii=phi(i)
5769         gloci=0.0D0
5770 C Regular cosine and sine terms
5771         do j=1,nterm(itori,itori1,iblock)
5772           v1ij=v1(j,itori,itori1,iblock)
5773           v2ij=v2(j,itori,itori1,iblock)
5774           cosphi=dcos(j*phii)
5775           sinphi=dsin(j*phii)
5776           etors=etors+v1ij*cosphi+v2ij*sinphi
5777           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5778         enddo
5779 C Lorentz terms
5780 C                         v1
5781 C  E = SUM ----------------------------------- - v1
5782 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5783 C
5784         cosphi=dcos(0.5d0*phii)
5785         sinphi=dsin(0.5d0*phii)
5786         do j=1,nlor(itori,itori1,iblock)
5787           vl1ij=vlor1(j,itori,itori1)
5788           vl2ij=vlor2(j,itori,itori1)
5789           vl3ij=vlor3(j,itori,itori1)
5790           pom=vl2ij*cosphi+vl3ij*sinphi
5791           pom1=1.0d0/(pom*pom+1.0d0)
5792           etors=etors+vl1ij*pom1
5793 c          if (energy_dec) etors_ii=etors_ii+
5794 c     &                vl1ij*pom1
5795           pom=-pom*pom1*pom1
5796           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5797         enddo
5798 C Subtract the constant term
5799         etors=etors-v0(itori,itori1,iblock)
5800         if (lprn)
5801      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5802      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5803      &  (v1(j,itori,itori1,1),j=1,6),(v2(j,itori,itori1,1),j=1,6)
5804         gloc(i-3,icg)=gloc(i-3,icg)+wtor*fact*gloci
5805 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5806  1215   continue
5807       enddo
5808       return
5809       end
5810 c----------------------------------------------------------------------------
5811       subroutine etor_d(etors_d,fact2)
5812 C 6/23/01 Compute double torsional energy
5813       implicit real*8 (a-h,o-z)
5814       include 'DIMENSIONS'
5815       include 'DIMENSIONS.ZSCOPT'
5816       include 'COMMON.VAR'
5817       include 'COMMON.GEO'
5818       include 'COMMON.LOCAL'
5819       include 'COMMON.TORSION'
5820       include 'COMMON.INTERACT'
5821       include 'COMMON.DERIV'
5822       include 'COMMON.CHAIN'
5823       include 'COMMON.NAMES'
5824       include 'COMMON.IOUNITS'
5825       include 'COMMON.FFIELD'
5826       include 'COMMON.TORCNSTR'
5827       logical lprn
5828 C Set lprn=.true. for debugging
5829       lprn=.false.
5830 c     lprn=.true.
5831       etors_d=0.0D0
5832       do i=iphi_start,iphi_end-1
5833         if (i.le.3) cycle
5834 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5835 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5836          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
5837      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
5838      &  (itype(i+1).eq.ntyp1)) cycle
5839         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
5840      &     goto 1215
5841         itori=itortyp(itype(i-2))
5842         itori1=itortyp(itype(i-1))
5843         itori2=itortyp(itype(i))
5844         phii=phi(i)
5845         phii1=phi(i+1)
5846         gloci1=0.0D0
5847         gloci2=0.0D0
5848         iblock=1
5849         if (iabs(itype(i+1)).eq.20) iblock=2
5850 C Regular cosine and sine terms
5851         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5852           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5853           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5854           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5855           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5856           cosphi1=dcos(j*phii)
5857           sinphi1=dsin(j*phii)
5858           cosphi2=dcos(j*phii1)
5859           sinphi2=dsin(j*phii1)
5860           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5861      &     v2cij*cosphi2+v2sij*sinphi2
5862           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5863           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5864         enddo
5865         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5866           do l=1,k-1
5867             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5868             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5869             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5870             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5871             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5872             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5873             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5874             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5875             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5876      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5877             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5878      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5879             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5880      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5881           enddo
5882         enddo
5883         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*fact2*gloci1
5884         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*fact2*gloci2
5885  1215   continue
5886       enddo
5887       return
5888       end
5889 #endif
5890 c---------------------------------------------------------------------------
5891 C The rigorous attempt to derive energy function
5892       subroutine etor_kcc(etors,fact)
5893       implicit real*8 (a-h,o-z)
5894       include 'DIMENSIONS'
5895       include 'DIMENSIONS.ZSCOPT'
5896       include 'COMMON.VAR'
5897       include 'COMMON.GEO'
5898       include 'COMMON.LOCAL'
5899       include 'COMMON.TORSION'
5900       include 'COMMON.INTERACT'
5901       include 'COMMON.DERIV'
5902       include 'COMMON.CHAIN'
5903       include 'COMMON.NAMES'
5904       include 'COMMON.IOUNITS'
5905       include 'COMMON.FFIELD'
5906       include 'COMMON.TORCNSTR'
5907       include 'COMMON.CONTROL'
5908       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
5909       logical lprn
5910 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
5911 C Set lprn=.true. for debugging
5912       lprn=energy_dec
5913 c     lprn=.true.
5914 C      print *,"wchodze kcc"
5915       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
5916       etors=0.0D0
5917       do i=iphi_start,iphi_end
5918 C ANY TWO ARE DUMMY ATOMS in row CYCLE
5919 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
5920 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
5921 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
5922         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5923      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
5924         itori=itortyp(itype(i-2))
5925         itori1=itortyp(itype(i-1))
5926         phii=phi(i)
5927         glocig=0.0D0
5928         glocit1=0.0d0
5929         glocit2=0.0d0
5930 C to avoid multiple devision by 2
5931 c        theti22=0.5d0*theta(i)
5932 C theta 12 is the theta_1 /2
5933 C theta 22 is theta_2 /2
5934 c        theti12=0.5d0*theta(i-1)
5935 C and appropriate sinus function
5936         sinthet1=dsin(theta(i-1))
5937         sinthet2=dsin(theta(i))
5938         costhet1=dcos(theta(i-1))
5939         costhet2=dcos(theta(i))
5940 C to speed up lets store its mutliplication
5941         sint1t2=sinthet2*sinthet1
5942         sint1t2n=1.0d0
5943 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
5944 C +d_n*sin(n*gamma)) *
5945 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
5946 C we have two sum 1) Non-Chebyshev which is with n and gamma
5947         nval=nterm_kcc_Tb(itori,itori1)
5948         c1(0)=0.0d0
5949         c2(0)=0.0d0
5950         c1(1)=1.0d0
5951         c2(1)=1.0d0
5952         do j=2,nval
5953           c1(j)=c1(j-1)*costhet1
5954           c2(j)=c2(j-1)*costhet2
5955         enddo
5956         etori=0.0d0
5957         do j=1,nterm_kcc(itori,itori1)
5958           cosphi=dcos(j*phii)
5959           sinphi=dsin(j*phii)
5960           sint1t2n1=sint1t2n
5961           sint1t2n=sint1t2n*sint1t2
5962           sumvalc=0.0d0
5963           gradvalct1=0.0d0
5964           gradvalct2=0.0d0
5965           do k=1,nval
5966             do l=1,nval
5967               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5968               gradvalct1=gradvalct1+
5969      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5970               gradvalct2=gradvalct2+
5971      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5972             enddo
5973           enddo
5974           gradvalct1=-gradvalct1*sinthet1
5975           gradvalct2=-gradvalct2*sinthet2
5976           sumvals=0.0d0
5977           gradvalst1=0.0d0
5978           gradvalst2=0.0d0
5979           do k=1,nval
5980             do l=1,nval
5981               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
5982               gradvalst1=gradvalst1+
5983      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
5984               gradvalst2=gradvalst2+
5985      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
5986             enddo
5987           enddo
5988           gradvalst1=-gradvalst1*sinthet1
5989           gradvalst2=-gradvalst2*sinthet2
5990           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
5991 C glocig is the gradient local i site in gamma
5992           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
5993 C now gradient over theta_1
5994           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
5995      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
5996           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
5997      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
5998         enddo ! j
5999         etors=etors+etori
6000 C derivative over gamma
6001         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
6002 C derivative over theta1
6003         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
6004 C now derivative over theta2
6005         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
6006         if (lprn) then
6007           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
6008      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
6009           write (iout,*) "c1",(c1(k),k=0,nval),
6010      &    " c2",(c2(k),k=0,nval)
6011           write (iout,*) "sumvalc",sumvalc," sumvals",sumvals
6012         endif
6013       enddo
6014       return
6015       end
6016 c---------------------------------------------------------------------------------------------
6017       subroutine etor_constr(edihcnstr)
6018       implicit real*8 (a-h,o-z)
6019       include 'DIMENSIONS'
6020       include 'DIMENSIONS.ZSCOPT'
6021       include 'COMMON.VAR'
6022       include 'COMMON.GEO'
6023       include 'COMMON.LOCAL'
6024       include 'COMMON.TORSION'
6025       include 'COMMON.INTERACT'
6026       include 'COMMON.DERIV'
6027       include 'COMMON.CHAIN'
6028       include 'COMMON.NAMES'
6029       include 'COMMON.IOUNITS'
6030       include 'COMMON.FFIELD'
6031       include 'COMMON.TORCNSTR'
6032       include 'COMMON.CONTROL'
6033 ! 6/20/98 - dihedral angle constraints
6034       edihcnstr=0.0d0
6035 c      do i=1,ndih_constr
6036 c      write (iout,*) "idihconstr_start",idihconstr_start,
6037 c     &  " idihconstr_end",idihconstr_end
6038
6039       if (raw_psipred) then
6040         do i=idihconstr_start,idihconstr_end
6041           itori=idih_constr(i)
6042           phii=phi(itori)
6043           gaudih_i=vpsipred(1,i)
6044           gauder_i=0.0d0
6045           do j=1,2
6046             s = sdihed(j,i)
6047             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
6048             dexpcos_i=dexp(-cos_i*cos_i)
6049             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
6050             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
6051      &            *cos_i*dexpcos_i/s**2
6052           enddo
6053           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
6054           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
6055           if (energy_dec)
6056      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
6057      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
6058      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
6059      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
6060      &     -wdihc*dlog(gaudih_i)
6061         enddo
6062       else
6063
6064       do i=idihconstr_start,idihconstr_end
6065         itori=idih_constr(i)
6066         phii=phi(itori)
6067         difi=pinorm(phii-phi0(i))
6068         if (difi.gt.drange(i)) then
6069           difi=difi-drange(i)
6070           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6071           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6072         else if (difi.lt.-drange(i)) then
6073           difi=difi+drange(i)
6074           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
6075           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
6076         else
6077           difi=0.0
6078         endif
6079       enddo
6080
6081       endif
6082
6083 c      write (iout,*) "ETOR_CONSTR",edihcnstr
6084       return
6085       end
6086 c----------------------------------------------------------------------------
6087 C The rigorous attempt to derive energy function
6088       subroutine ebend_kcc(etheta)
6089
6090       implicit real*8 (a-h,o-z)
6091       include 'DIMENSIONS'
6092       include 'DIMENSIONS.ZSCOPT'
6093       include 'COMMON.VAR'
6094       include 'COMMON.GEO'
6095       include 'COMMON.LOCAL'
6096       include 'COMMON.TORSION'
6097       include 'COMMON.INTERACT'
6098       include 'COMMON.DERIV'
6099       include 'COMMON.CHAIN'
6100       include 'COMMON.NAMES'
6101       include 'COMMON.IOUNITS'
6102       include 'COMMON.FFIELD'
6103       include 'COMMON.TORCNSTR'
6104       include 'COMMON.CONTROL'
6105       logical lprn
6106       double precision thybt1(maxang_kcc)
6107 C Set lprn=.true. for debugging
6108       lprn=energy_dec
6109 c     lprn=.true.
6110 C      print *,"wchodze kcc"
6111       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
6112       etheta=0.0D0
6113       do i=ithet_start,ithet_end
6114 c        print *,i,itype(i-1),itype(i),itype(i-2)
6115         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6116      &  .or.itype(i).eq.ntyp1) cycle
6117         iti=iabs(itortyp(itype(i-1)))
6118         sinthet=dsin(theta(i))
6119         costhet=dcos(theta(i))
6120         do j=1,nbend_kcc_Tb(iti)
6121           thybt1(j)=v1bend_chyb(j,iti)
6122         enddo
6123         sumth1thyb=v1bend_chyb(0,iti)+
6124      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
6125         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
6126      &    sumth1thyb
6127         ihelp=nbend_kcc_Tb(iti)-1
6128         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
6129         etheta=etheta+sumth1thyb
6130 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
6131         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
6132       enddo
6133       return
6134       end
6135 c-------------------------------------------------------------------------------------
6136       subroutine etheta_constr(ethetacnstr)
6137
6138       implicit real*8 (a-h,o-z)
6139       include 'DIMENSIONS'
6140       include 'DIMENSIONS.ZSCOPT'
6141       include 'COMMON.VAR'
6142       include 'COMMON.GEO'
6143       include 'COMMON.LOCAL'
6144       include 'COMMON.TORSION'
6145       include 'COMMON.INTERACT'
6146       include 'COMMON.DERIV'
6147       include 'COMMON.CHAIN'
6148       include 'COMMON.NAMES'
6149       include 'COMMON.IOUNITS'
6150       include 'COMMON.FFIELD'
6151       include 'COMMON.TORCNSTR'
6152       include 'COMMON.CONTROL'
6153       ethetacnstr=0.0d0
6154 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6155       do i=ithetaconstr_start,ithetaconstr_end
6156         itheta=itheta_constr(i)
6157         thetiii=theta(itheta)
6158         difi=pinorm(thetiii-theta_constr0(i))
6159         if (difi.gt.theta_drange(i)) then
6160           difi=difi-theta_drange(i)
6161           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6162           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6163      &    +for_thet_constr(i)*difi**3
6164         else if (difi.lt.-drange(i)) then
6165           difi=difi+drange(i)
6166           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6167           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6168      &    +for_thet_constr(i)*difi**3
6169         else
6170           difi=0.0
6171         endif
6172        if (energy_dec) then
6173         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6174      &    i,itheta,rad2deg*thetiii,
6175      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6176      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6177      &    gloc(itheta+nphi-2,icg)
6178         endif
6179       enddo
6180       return
6181       end
6182 c------------------------------------------------------------------------------
6183 c------------------------------------------------------------------------------
6184       subroutine eback_sc_corr(esccor)
6185 c 7/21/2007 Correlations between the backbone-local and side-chain-local
6186 c        conformational states; temporarily implemented as differences
6187 c        between UNRES torsional potentials (dependent on three types of
6188 c        residues) and the torsional potentials dependent on all 20 types
6189 c        of residues computed from AM1 energy surfaces of terminally-blocked
6190 c        amino-acid residues.
6191       implicit real*8 (a-h,o-z)
6192       include 'DIMENSIONS'
6193       include 'DIMENSIONS.ZSCOPT'
6194       include 'COMMON.VAR'
6195       include 'COMMON.GEO'
6196       include 'COMMON.LOCAL'
6197       include 'COMMON.TORSION'
6198       include 'COMMON.SCCOR'
6199       include 'COMMON.INTERACT'
6200       include 'COMMON.DERIV'
6201       include 'COMMON.CHAIN'
6202       include 'COMMON.NAMES'
6203       include 'COMMON.IOUNITS'
6204       include 'COMMON.FFIELD'
6205       include 'COMMON.CONTROL'
6206       logical lprn
6207 C Set lprn=.true. for debugging
6208       lprn=.false.
6209 c      lprn=.true.
6210 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
6211       esccor=0.0D0
6212       do i=itau_start,itau_end
6213         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
6214         esccor_ii=0.0D0
6215         isccori=isccortyp(itype(i-2))
6216         isccori1=isccortyp(itype(i-1))
6217         phii=phi(i)
6218         do intertyp=1,3 !intertyp
6219 cc Added 09 May 2012 (Adasko)
6220 cc  Intertyp means interaction type of backbone mainchain correlation:
6221 c   1 = SC...Ca...Ca...Ca
6222 c   2 = Ca...Ca...Ca...SC
6223 c   3 = SC...Ca...Ca...SCi
6224         gloci=0.0D0
6225         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
6226      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
6227      &      (itype(i-1).eq.ntyp1)))
6228      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
6229      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
6230      &     .or.(itype(i).eq.ntyp1)))
6231      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
6232      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
6233      &      (itype(i-3).eq.ntyp1)))) cycle
6234         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
6235         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
6236      & cycle
6237        do j=1,nterm_sccor(isccori,isccori1)
6238           v1ij=v1sccor(j,intertyp,isccori,isccori1)
6239           v2ij=v2sccor(j,intertyp,isccori,isccori1)
6240           cosphi=dcos(j*tauangle(intertyp,i))
6241           sinphi=dsin(j*tauangle(intertyp,i))
6242            esccor=esccor+v1ij*cosphi+v2ij*sinphi
6243            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
6244          enddo
6245 C      write (iout,*)"EBACK_SC_COR",esccor,i
6246 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
6247 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
6248 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
6249         if (lprn)
6250      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
6251      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
6252      &  (v1sccor(j,1,itori,itori1),j=1,6)
6253      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
6254 c        gsccor_loc(i-3)=gloci
6255        enddo !intertyp
6256       enddo
6257       return
6258       end
6259 c------------------------------------------------------------------------------
6260       subroutine multibody(ecorr)
6261 C This subroutine calculates multi-body contributions to energy following
6262 C the idea of Skolnick et al. If side chains I and J make a contact and
6263 C at the same time side chains I+1 and J+1 make a contact, an extra
6264 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6265       implicit real*8 (a-h,o-z)
6266       include 'DIMENSIONS'
6267       include 'COMMON.IOUNITS'
6268       include 'COMMON.DERIV'
6269       include 'COMMON.INTERACT'
6270       include 'COMMON.CONTACTS'
6271       double precision gx(3),gx1(3)
6272       logical lprn
6273
6274 C Set lprn=.true. for debugging
6275       lprn=.false.
6276
6277       if (lprn) then
6278         write (iout,'(a)') 'Contact function values:'
6279         do i=nnt,nct-2
6280           write (iout,'(i2,20(1x,i2,f10.5))')
6281      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6282         enddo
6283       endif
6284       ecorr=0.0D0
6285       do i=nnt,nct
6286         do j=1,3
6287           gradcorr(j,i)=0.0D0
6288           gradxorr(j,i)=0.0D0
6289         enddo
6290       enddo
6291       do i=nnt,nct-2
6292
6293         DO ISHIFT = 3,4
6294
6295         i1=i+ishift
6296         num_conti=num_cont(i)
6297         num_conti1=num_cont(i1)
6298         do jj=1,num_conti
6299           j=jcont(jj,i)
6300           do kk=1,num_conti1
6301             j1=jcont(kk,i1)
6302             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6303 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6304 cd   &                   ' ishift=',ishift
6305 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6306 C The system gains extra energy.
6307               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6308             endif   ! j1==j+-ishift
6309           enddo     ! kk
6310         enddo       ! jj
6311
6312         ENDDO ! ISHIFT
6313
6314       enddo         ! i
6315       return
6316       end
6317 c------------------------------------------------------------------------------
6318       double precision function esccorr(i,j,k,l,jj,kk)
6319       implicit real*8 (a-h,o-z)
6320       include 'DIMENSIONS'
6321       include 'COMMON.IOUNITS'
6322       include 'COMMON.DERIV'
6323       include 'COMMON.INTERACT'
6324       include 'COMMON.CONTACTS'
6325       double precision gx(3),gx1(3)
6326       logical lprn
6327       lprn=.false.
6328       eij=facont(jj,i)
6329       ekl=facont(kk,k)
6330 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6331 C Calculate the multi-body contribution to energy.
6332 C Calculate multi-body contributions to the gradient.
6333 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6334 cd   & k,l,(gacont(m,kk,k),m=1,3)
6335       do m=1,3
6336         gx(m) =ekl*gacont(m,jj,i)
6337         gx1(m)=eij*gacont(m,kk,k)
6338         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6339         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6340         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6341         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6342       enddo
6343       do m=i,j-1
6344         do ll=1,3
6345           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6346         enddo
6347       enddo
6348       do m=k,l-1
6349         do ll=1,3
6350           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6351         enddo
6352       enddo
6353       esccorr=-eij*ekl
6354       return
6355       end
6356 c------------------------------------------------------------------------------
6357       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6358 C This subroutine calculates multi-body contributions to hydrogen-bonding
6359       implicit real*8 (a-h,o-z)
6360       include 'DIMENSIONS'
6361       include 'DIMENSIONS.ZSCOPT'
6362       include 'COMMON.IOUNITS'
6363       include 'COMMON.FFIELD'
6364       include 'COMMON.DERIV'
6365       include 'COMMON.INTERACT'
6366       include 'COMMON.CONTACTS'
6367       double precision gx(3),gx1(3)
6368       logical lprn,ldone
6369
6370 C Set lprn=.true. for debugging
6371       lprn=.false.
6372       if (lprn) then
6373         write (iout,'(a)') 'Contact function values:'
6374         do i=nnt,nct-2
6375           write (iout,'(2i3,50(1x,i2,f5.2))')
6376      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6377      &    j=1,num_cont_hb(i))
6378         enddo
6379       endif
6380       ecorr=0.0D0
6381 C Remove the loop below after debugging !!!
6382       do i=nnt,nct
6383         do j=1,3
6384           gradcorr(j,i)=0.0D0
6385           gradxorr(j,i)=0.0D0
6386         enddo
6387       enddo
6388 C Calculate the local-electrostatic correlation terms
6389       do i=iatel_s,iatel_e+1
6390         i1=i+1
6391         num_conti=num_cont_hb(i)
6392         num_conti1=num_cont_hb(i+1)
6393         do jj=1,num_conti
6394           j=jcont_hb(jj,i)
6395           do kk=1,num_conti1
6396             j1=jcont_hb(kk,i1)
6397 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6398 c     &         ' jj=',jj,' kk=',kk
6399             if (j1.eq.j+1 .or. j1.eq.j-1) then
6400 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6401 C The system gains extra energy.
6402               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6403               n_corr=n_corr+1
6404             else if (j1.eq.j) then
6405 C Contacts I-J and I-(J+1) occur simultaneously.
6406 C The system loses extra energy.
6407 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6408             endif
6409           enddo ! kk
6410           do kk=1,num_conti
6411             j1=jcont_hb(kk,i)
6412 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6413 c    &         ' jj=',jj,' kk=',kk
6414             if (j1.eq.j+1) then
6415 C Contacts I-J and (I+1)-J occur simultaneously.
6416 C The system loses extra energy.
6417 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6418             endif ! j1==j+1
6419           enddo ! kk
6420         enddo ! jj
6421       enddo ! i
6422       return
6423       end
6424 c------------------------------------------------------------------------------
6425       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6426      &  n_corr1)
6427 C This subroutine calculates multi-body contributions to hydrogen-bonding
6428       implicit real*8 (a-h,o-z)
6429       include 'DIMENSIONS'
6430       include 'DIMENSIONS.ZSCOPT'
6431       include 'COMMON.IOUNITS'
6432 #ifdef MPI
6433       include "mpif.h"
6434 #endif
6435       include 'COMMON.FFIELD'
6436       include 'COMMON.DERIV'
6437       include 'COMMON.LOCAL'
6438       include 'COMMON.INTERACT'
6439       include 'COMMON.CONTACTS'
6440       include 'COMMON.CHAIN'
6441       include 'COMMON.CONTROL'
6442       include 'COMMON.SHIELD'
6443       double precision gx(3),gx1(3)
6444       integer num_cont_hb_old(maxres)
6445       logical lprn,ldone
6446       double precision eello4,eello5,eelo6,eello_turn6
6447       external eello4,eello5,eello6,eello_turn6
6448 C Set lprn=.true. for debugging
6449       lprn=.false.
6450       eturn6=0.0d0
6451       if (lprn) then
6452         write (iout,'(a)') 'Contact function values:'
6453         do i=nnt,nct-2
6454           write (iout,'(2i3,50(1x,i2,5f6.3))')
6455      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6456      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6457         enddo
6458       endif
6459       ecorr=0.0D0
6460       ecorr5=0.0d0
6461       ecorr6=0.0d0
6462 C Remove the loop below after debugging !!!
6463       do i=nnt,nct
6464         do j=1,3
6465           gradcorr(j,i)=0.0D0
6466           gradxorr(j,i)=0.0D0
6467         enddo
6468       enddo
6469 C Calculate the dipole-dipole interaction energies
6470       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6471       do i=iatel_s,iatel_e+1
6472         num_conti=num_cont_hb(i)
6473         do jj=1,num_conti
6474           j=jcont_hb(jj,i)
6475 #ifdef MOMENT
6476           call dipole(i,j,jj)
6477 #endif
6478         enddo
6479       enddo
6480       endif
6481 C Calculate the local-electrostatic correlation terms
6482 c                write (iout,*) "gradcorr5 in eello5 before loop"
6483 c                do iii=1,nres
6484 c                  write (iout,'(i5,3f10.5)')
6485 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6486 c                enddo
6487       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6488 c        write (iout,*) "corr loop i",i
6489         i1=i+1
6490         num_conti=num_cont_hb(i)
6491         num_conti1=num_cont_hb(i+1)
6492         do jj=1,num_conti
6493           j=jcont_hb(jj,i)
6494           jp=iabs(j)
6495           do kk=1,num_conti1
6496             j1=jcont_hb(kk,i1)
6497             jp1=iabs(j1)
6498 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6499 c     &         ' jj=',jj,' kk=',kk
6500 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6501             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6502      &          .or. j.lt.0 .and. j1.gt.0) .and.
6503      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6504 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6505 C The system gains extra energy.
6506               n_corr=n_corr+1
6507               sqd1=dsqrt(d_cont(jj,i))
6508               sqd2=dsqrt(d_cont(kk,i1))
6509               sred_geom = sqd1*sqd2
6510               IF (sred_geom.lt.cutoff_corr) THEN
6511                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6512      &            ekont,fprimcont)
6513 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6514 cd     &         ' jj=',jj,' kk=',kk
6515                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6516                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6517                 do l=1,3
6518                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6519                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6520                 enddo
6521                 n_corr1=n_corr1+1
6522 cd               write (iout,*) 'sred_geom=',sred_geom,
6523 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6524 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6525 cd               write (iout,*) "g_contij",g_contij
6526 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6527 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6528                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6529                 if (wcorr4.gt.0.0d0)
6530      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6531 CC     &            *fac_shield(i)**2*fac_shield(j)**2
6532                   if (energy_dec.and.wcorr4.gt.0.0d0)
6533      1                 write (iout,'(a6,4i5,0pf7.3)')
6534      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6535 c                write (iout,*) "gradcorr5 before eello5"
6536 c                do iii=1,nres
6537 c                  write (iout,'(i5,3f10.5)')
6538 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6539 c                enddo
6540                 if (wcorr5.gt.0.0d0)
6541      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6542 c                write (iout,*) "gradcorr5 after eello5"
6543 c                do iii=1,nres
6544 c                  write (iout,'(i5,3f10.5)')
6545 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6546 c                enddo
6547                   if (energy_dec.and.wcorr5.gt.0.0d0)
6548      1                 write (iout,'(a6,4i5,0pf7.3)')
6549      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6550 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6551 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6552                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6553      &               .or. wturn6.eq.0.0d0))then
6554 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6555                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6556                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6557      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6558 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6559 cd     &            'ecorr6=',ecorr6
6560 cd                write (iout,'(4e15.5)') sred_geom,
6561 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6562 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6563 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6564                 else if (wturn6.gt.0.0d0
6565      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6566 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6567                   eturn6=eturn6+eello_turn6(i,jj,kk)
6568                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6569      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6570 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6571                 endif
6572               ENDIF
6573 1111          continue
6574             endif
6575           enddo ! kk
6576         enddo ! jj
6577       enddo ! i
6578       do i=1,nres
6579         num_cont_hb(i)=num_cont_hb_old(i)
6580       enddo
6581 c                write (iout,*) "gradcorr5 in eello5"
6582 c                do iii=1,nres
6583 c                  write (iout,'(i5,3f10.5)')
6584 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6585 c                enddo
6586       return
6587       end
6588 c------------------------------------------------------------------------------
6589       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6590       implicit real*8 (a-h,o-z)
6591       include 'DIMENSIONS'
6592       include 'DIMENSIONS.ZSCOPT'
6593       include 'COMMON.IOUNITS'
6594       include 'COMMON.DERIV'
6595       include 'COMMON.INTERACT'
6596       include 'COMMON.CONTACTS'
6597       include 'COMMON.SHIELD'
6598       include 'COMMON.CONTROL'
6599       double precision gx(3),gx1(3)
6600       logical lprn
6601       lprn=.false.
6602 C      print *,"wchodze",fac_shield(i),shield_mode
6603       eij=facont_hb(jj,i)
6604       ekl=facont_hb(kk,k)
6605       ees0pij=ees0p(jj,i)
6606       ees0pkl=ees0p(kk,k)
6607       ees0mij=ees0m(jj,i)
6608       ees0mkl=ees0m(kk,k)
6609       ekont=eij*ekl
6610       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6611 C*
6612 C     & fac_shield(i)**2*fac_shield(j)**2
6613 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6614 C Following 4 lines for diagnostics.
6615 cd    ees0pkl=0.0D0
6616 cd    ees0pij=1.0D0
6617 cd    ees0mkl=0.0D0
6618 cd    ees0mij=1.0D0
6619 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6620 c     & 'Contacts ',i,j,
6621 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6622 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6623 c     & 'gradcorr_long'
6624 C Calculate the multi-body contribution to energy.
6625 C      ecorr=ecorr+ekont*ees
6626 C Calculate multi-body contributions to the gradient.
6627       coeffpees0pij=coeffp*ees0pij
6628       coeffmees0mij=coeffm*ees0mij
6629       coeffpees0pkl=coeffp*ees0pkl
6630       coeffmees0mkl=coeffm*ees0mkl
6631       do ll=1,3
6632 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6633         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6634      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6635      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6636         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6637      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6638      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6639 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6640         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6641      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6642      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6643         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6644      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6645      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6646         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6647      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6648      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6649         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6650         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6651         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6652      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6653      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6654         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6655         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6656 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6657       enddo
6658 c      write (iout,*)
6659 cgrad      do m=i+1,j-1
6660 cgrad        do ll=1,3
6661 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6662 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6663 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6664 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6665 cgrad        enddo
6666 cgrad      enddo
6667 cgrad      do m=k+1,l-1
6668 cgrad        do ll=1,3
6669 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6670 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6671 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6672 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6673 cgrad        enddo
6674 cgrad      enddo
6675 c      write (iout,*) "ehbcorr",ekont*ees
6676 C      print *,ekont,ees,i,k
6677       ehbcorr=ekont*ees
6678 C now gradient over shielding
6679 C      return
6680       if (shield_mode.gt.0) then
6681        j=ees0plist(jj,i)
6682        l=ees0plist(kk,k)
6683 C        print *,i,j,fac_shield(i),fac_shield(j),
6684 C     &fac_shield(k),fac_shield(l)
6685         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
6686      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
6687           do ilist=1,ishield_list(i)
6688            iresshield=shield_list(ilist,i)
6689            do m=1,3
6690            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
6691 C     &      *2.0
6692            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6693      &              rlocshield
6694      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
6695             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6696      &+rlocshield
6697            enddo
6698           enddo
6699           do ilist=1,ishield_list(j)
6700            iresshield=shield_list(ilist,j)
6701            do m=1,3
6702            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
6703 C     &     *2.0
6704            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6705      &              rlocshield
6706      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
6707            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6708      &     +rlocshield
6709            enddo
6710           enddo
6711
6712           do ilist=1,ishield_list(k)
6713            iresshield=shield_list(ilist,k)
6714            do m=1,3
6715            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
6716 C     &     *2.0
6717            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6718      &              rlocshield
6719      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
6720            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6721      &     +rlocshield
6722            enddo
6723           enddo
6724           do ilist=1,ishield_list(l)
6725            iresshield=shield_list(ilist,l)
6726            do m=1,3
6727            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
6728 C     &     *2.0
6729            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
6730      &              rlocshield
6731      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
6732            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
6733      &     +rlocshield
6734            enddo
6735           enddo
6736 C          print *,gshieldx(m,iresshield)
6737           do m=1,3
6738             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
6739      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6740             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
6741      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6742             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
6743      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
6744             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
6745      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
6746
6747             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
6748      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6749             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
6750      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6751             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
6752      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
6753             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
6754      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
6755
6756            enddo
6757       endif
6758       endif
6759       return
6760       end
6761 #ifdef MOMENT
6762 C---------------------------------------------------------------------------
6763       subroutine dipole(i,j,jj)
6764       implicit real*8 (a-h,o-z)
6765       include 'DIMENSIONS'
6766       include 'DIMENSIONS.ZSCOPT'
6767       include 'COMMON.IOUNITS'
6768       include 'COMMON.CHAIN'
6769       include 'COMMON.FFIELD'
6770       include 'COMMON.DERIV'
6771       include 'COMMON.INTERACT'
6772       include 'COMMON.CONTACTS'
6773       include 'COMMON.TORSION'
6774       include 'COMMON.VAR'
6775       include 'COMMON.GEO'
6776       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6777      &  auxmat(2,2)
6778       iti1 = itortyp(itype(i+1))
6779       if (j.lt.nres-1) then
6780         itj1 = itype2loc(itype(j+1))
6781       else
6782         itj1=nloctyp
6783       endif
6784       do iii=1,2
6785         dipi(iii,1)=Ub2(iii,i)
6786         dipderi(iii)=Ub2der(iii,i)
6787         dipi(iii,2)=b1(iii,i+1)
6788         dipj(iii,1)=Ub2(iii,j)
6789         dipderj(iii)=Ub2der(iii,j)
6790         dipj(iii,2)=b1(iii,j+1)
6791       enddo
6792       kkk=0
6793       do iii=1,2
6794         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
6795         do jjj=1,2
6796           kkk=kkk+1
6797           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6798         enddo
6799       enddo
6800       do kkk=1,5
6801         do lll=1,3
6802           mmm=0
6803           do iii=1,2
6804             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
6805      &        auxvec(1))
6806             do jjj=1,2
6807               mmm=mmm+1
6808               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
6809             enddo
6810           enddo
6811         enddo
6812       enddo
6813       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
6814       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
6815       do iii=1,2
6816         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
6817       enddo
6818       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
6819       do iii=1,2
6820         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
6821       enddo
6822       return
6823       end
6824 #endif
6825 C---------------------------------------------------------------------------
6826       subroutine calc_eello(i,j,k,l,jj,kk)
6827 C
6828 C This subroutine computes matrices and vectors needed to calculate
6829 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
6830 C
6831       implicit real*8 (a-h,o-z)
6832       include 'DIMENSIONS'
6833       include 'DIMENSIONS.ZSCOPT'
6834       include 'COMMON.IOUNITS'
6835       include 'COMMON.CHAIN'
6836       include 'COMMON.DERIV'
6837       include 'COMMON.INTERACT'
6838       include 'COMMON.CONTACTS'
6839       include 'COMMON.TORSION'
6840       include 'COMMON.VAR'
6841       include 'COMMON.GEO'
6842       include 'COMMON.FFIELD'
6843       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
6844      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
6845       logical lprn
6846       common /kutas/ lprn
6847 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
6848 cd     & ' jj=',jj,' kk=',kk
6849 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
6850 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
6851 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
6852       do iii=1,2
6853         do jjj=1,2
6854           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
6855           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
6856         enddo
6857       enddo
6858       call transpose2(aa1(1,1),aa1t(1,1))
6859       call transpose2(aa2(1,1),aa2t(1,1))
6860       do kkk=1,5
6861         do lll=1,3
6862           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
6863      &      aa1tder(1,1,lll,kkk))
6864           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
6865      &      aa2tder(1,1,lll,kkk))
6866         enddo
6867       enddo
6868       if (l.eq.j+1) then
6869 C parallel orientation of the two CA-CA-CA frames.
6870         if (i.gt.1) then
6871           iti=itype2loc(itype(i))
6872         else
6873           iti=nloctyp
6874         endif
6875         itk1=itype2loc(itype(k+1))
6876         itj=itype2loc(itype(j))
6877         if (l.lt.nres-1) then
6878           itl1=itype2loc(itype(l+1))
6879         else
6880           itl1=nloctyp
6881         endif
6882 C A1 kernel(j+1) A2T
6883 cd        do iii=1,2
6884 cd          write (iout,'(3f10.5,5x,3f10.5)')
6885 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
6886 cd        enddo
6887         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6888      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
6889      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
6890 C Following matrices are needed only for 6-th order cumulants
6891         IF (wcorr6.gt.0.0d0) THEN
6892         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6893      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
6894      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
6895         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6896      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
6897      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
6898      &   ADtEAderx(1,1,1,1,1,1))
6899         lprn=.false.
6900         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
6901      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
6902      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
6903      &   ADtEA1derx(1,1,1,1,1,1))
6904         ENDIF
6905 C End 6-th order cumulants
6906 cd        lprn=.false.
6907 cd        if (lprn) then
6908 cd        write (2,*) 'In calc_eello6'
6909 cd        do iii=1,2
6910 cd          write (2,*) 'iii=',iii
6911 cd          do kkk=1,5
6912 cd            write (2,*) 'kkk=',kkk
6913 cd            do jjj=1,2
6914 cd              write (2,'(3(2f10.5),5x)')
6915 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
6916 cd            enddo
6917 cd          enddo
6918 cd        enddo
6919 cd        endif
6920         call transpose2(EUgder(1,1,k),auxmat(1,1))
6921         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
6922         call transpose2(EUg(1,1,k),auxmat(1,1))
6923         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
6924         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
6925         do iii=1,2
6926           do kkk=1,5
6927             do lll=1,3
6928               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
6929      &          EAEAderx(1,1,lll,kkk,iii,1))
6930             enddo
6931           enddo
6932         enddo
6933 C A1T kernel(i+1) A2
6934         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6935      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
6936      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
6937 C Following matrices are needed only for 6-th order cumulants
6938         IF (wcorr6.gt.0.0d0) THEN
6939         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6940      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
6941      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
6942         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6943      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
6944      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
6945      &   ADtEAderx(1,1,1,1,1,2))
6946         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
6947      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
6948      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
6949      &   ADtEA1derx(1,1,1,1,1,2))
6950         ENDIF
6951 C End 6-th order cumulants
6952         call transpose2(EUgder(1,1,l),auxmat(1,1))
6953         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
6954         call transpose2(EUg(1,1,l),auxmat(1,1))
6955         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
6956         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
6957         do iii=1,2
6958           do kkk=1,5
6959             do lll=1,3
6960               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
6961      &          EAEAderx(1,1,lll,kkk,iii,2))
6962             enddo
6963           enddo
6964         enddo
6965 C AEAb1 and AEAb2
6966 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
6967 C They are needed only when the fifth- or the sixth-order cumulants are
6968 C indluded.
6969         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
6970         call transpose2(AEA(1,1,1),auxmat(1,1))
6971         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
6972         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
6973         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
6974         call transpose2(AEAderg(1,1,1),auxmat(1,1))
6975         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
6976         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
6977         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
6978         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
6979         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
6980         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
6981         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
6982         call transpose2(AEA(1,1,2),auxmat(1,1))
6983         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
6984         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
6985         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
6986         call transpose2(AEAderg(1,1,2),auxmat(1,1))
6987         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
6988         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
6989         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
6990         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
6991         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
6992         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
6993         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
6994 C Calculate the Cartesian derivatives of the vectors.
6995         do iii=1,2
6996           do kkk=1,5
6997             do lll=1,3
6998               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
6999               call matvec2(auxmat(1,1),b1(1,i),
7000      &          AEAb1derx(1,lll,kkk,iii,1,1))
7001               call matvec2(auxmat(1,1),Ub2(1,i),
7002      &          AEAb2derx(1,lll,kkk,iii,1,1))
7003               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7004      &          AEAb1derx(1,lll,kkk,iii,2,1))
7005               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7006      &          AEAb2derx(1,lll,kkk,iii,2,1))
7007               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7008               call matvec2(auxmat(1,1),b1(1,j),
7009      &          AEAb1derx(1,lll,kkk,iii,1,2))
7010               call matvec2(auxmat(1,1),Ub2(1,j),
7011      &          AEAb2derx(1,lll,kkk,iii,1,2))
7012               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
7013      &          AEAb1derx(1,lll,kkk,iii,2,2))
7014               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7015      &          AEAb2derx(1,lll,kkk,iii,2,2))
7016             enddo
7017           enddo
7018         enddo
7019         ENDIF
7020 C End vectors
7021       else
7022 C Antiparallel orientation of the two CA-CA-CA frames.
7023         if (i.gt.1) then
7024           iti=itype2loc(itype(i))
7025         else
7026           iti=nloctyp
7027         endif
7028         itk1=itype2loc(itype(k+1))
7029         itl=itype2loc(itype(l))
7030         itj=itype2loc(itype(j))
7031         if (j.lt.nres-1) then
7032           itj1=itype2loc(itype(j+1))
7033         else
7034           itj1=nloctyp
7035         endif
7036 C A2 kernel(j-1)T A1T
7037         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7038      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7039      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7040 C Following matrices are needed only for 6-th order cumulants
7041         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7042      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7043         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7044      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7045      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7046         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7047      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7048      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7049      &   ADtEAderx(1,1,1,1,1,1))
7050         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7051      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7052      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7053      &   ADtEA1derx(1,1,1,1,1,1))
7054         ENDIF
7055 C End 6-th order cumulants
7056         call transpose2(EUgder(1,1,k),auxmat(1,1))
7057         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7058         call transpose2(EUg(1,1,k),auxmat(1,1))
7059         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7060         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7061         do iii=1,2
7062           do kkk=1,5
7063             do lll=1,3
7064               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7065      &          EAEAderx(1,1,lll,kkk,iii,1))
7066             enddo
7067           enddo
7068         enddo
7069 C A2T kernel(i+1)T A1
7070         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7071      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7072      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7073 C Following matrices are needed only for 6-th order cumulants
7074         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7075      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7076         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7077      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7078      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7079         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7080      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7081      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7082      &   ADtEAderx(1,1,1,1,1,2))
7083         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7084      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7085      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7086      &   ADtEA1derx(1,1,1,1,1,2))
7087         ENDIF
7088 C End 6-th order cumulants
7089         call transpose2(EUgder(1,1,j),auxmat(1,1))
7090         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7091         call transpose2(EUg(1,1,j),auxmat(1,1))
7092         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7093         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7094         do iii=1,2
7095           do kkk=1,5
7096             do lll=1,3
7097               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7098      &          EAEAderx(1,1,lll,kkk,iii,2))
7099             enddo
7100           enddo
7101         enddo
7102 C AEAb1 and AEAb2
7103 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7104 C They are needed only when the fifth- or the sixth-order cumulants are
7105 C indluded.
7106         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7107      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7108         call transpose2(AEA(1,1,1),auxmat(1,1))
7109         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
7110         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7111         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7112         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7113         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
7114         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7115         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
7116         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
7117         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7118         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7119         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7120         call transpose2(AEA(1,1,2),auxmat(1,1))
7121         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
7122         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7123         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7124         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7125         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
7126         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7127         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
7128         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
7129         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7130         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7131         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7132 C Calculate the Cartesian derivatives of the vectors.
7133         do iii=1,2
7134           do kkk=1,5
7135             do lll=1,3
7136               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7137               call matvec2(auxmat(1,1),b1(1,i),
7138      &          AEAb1derx(1,lll,kkk,iii,1,1))
7139               call matvec2(auxmat(1,1),Ub2(1,i),
7140      &          AEAb2derx(1,lll,kkk,iii,1,1))
7141               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
7142      &          AEAb1derx(1,lll,kkk,iii,2,1))
7143               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7144      &          AEAb2derx(1,lll,kkk,iii,2,1))
7145               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7146               call matvec2(auxmat(1,1),b1(1,l),
7147      &          AEAb1derx(1,lll,kkk,iii,1,2))
7148               call matvec2(auxmat(1,1),Ub2(1,l),
7149      &          AEAb2derx(1,lll,kkk,iii,1,2))
7150               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
7151      &          AEAb1derx(1,lll,kkk,iii,2,2))
7152               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7153      &          AEAb2derx(1,lll,kkk,iii,2,2))
7154             enddo
7155           enddo
7156         enddo
7157         ENDIF
7158 C End vectors
7159       endif
7160       return
7161       end
7162 C---------------------------------------------------------------------------
7163       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7164      &  KK,KKderg,AKA,AKAderg,AKAderx)
7165       implicit none
7166       integer nderg
7167       logical transp
7168       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7169      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7170      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7171       integer iii,kkk,lll
7172       integer jjj,mmm
7173       logical lprn
7174       common /kutas/ lprn
7175       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7176       do iii=1,nderg
7177         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7178      &    AKAderg(1,1,iii))
7179       enddo
7180 cd      if (lprn) write (2,*) 'In kernel'
7181       do kkk=1,5
7182 cd        if (lprn) write (2,*) 'kkk=',kkk
7183         do lll=1,3
7184           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7185      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7186 cd          if (lprn) then
7187 cd            write (2,*) 'lll=',lll
7188 cd            write (2,*) 'iii=1'
7189 cd            do jjj=1,2
7190 cd              write (2,'(3(2f10.5),5x)')
7191 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7192 cd            enddo
7193 cd          endif
7194           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7195      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7196 cd          if (lprn) then
7197 cd            write (2,*) 'lll=',lll
7198 cd            write (2,*) 'iii=2'
7199 cd            do jjj=1,2
7200 cd              write (2,'(3(2f10.5),5x)')
7201 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7202 cd            enddo
7203 cd          endif
7204         enddo
7205       enddo
7206       return
7207       end
7208 C---------------------------------------------------------------------------
7209       double precision function eello4(i,j,k,l,jj,kk)
7210       implicit real*8 (a-h,o-z)
7211       include 'DIMENSIONS'
7212       include 'DIMENSIONS.ZSCOPT'
7213       include 'COMMON.IOUNITS'
7214       include 'COMMON.CHAIN'
7215       include 'COMMON.DERIV'
7216       include 'COMMON.INTERACT'
7217       include 'COMMON.CONTACTS'
7218       include 'COMMON.TORSION'
7219       include 'COMMON.VAR'
7220       include 'COMMON.GEO'
7221       double precision pizda(2,2),ggg1(3),ggg2(3)
7222 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7223 cd        eello4=0.0d0
7224 cd        return
7225 cd      endif
7226 cd      print *,'eello4:',i,j,k,l,jj,kk
7227 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7228 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7229 cold      eij=facont_hb(jj,i)
7230 cold      ekl=facont_hb(kk,k)
7231 cold      ekont=eij*ekl
7232       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7233       if (calc_grad) then
7234 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7235       gcorr_loc(k-1)=gcorr_loc(k-1)
7236      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7237       if (l.eq.j+1) then
7238         gcorr_loc(l-1)=gcorr_loc(l-1)
7239      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7240       else
7241         gcorr_loc(j-1)=gcorr_loc(j-1)
7242      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7243       endif
7244       do iii=1,2
7245         do kkk=1,5
7246           do lll=1,3
7247             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7248      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7249 cd            derx(lll,kkk,iii)=0.0d0
7250           enddo
7251         enddo
7252       enddo
7253 cd      gcorr_loc(l-1)=0.0d0
7254 cd      gcorr_loc(j-1)=0.0d0
7255 cd      gcorr_loc(k-1)=0.0d0
7256 cd      eel4=1.0d0
7257 cd      write (iout,*)'Contacts have occurred for peptide groups',
7258 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7259 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7260       if (j.lt.nres-1) then
7261         j1=j+1
7262         j2=j-1
7263       else
7264         j1=j-1
7265         j2=j-2
7266       endif
7267       if (l.lt.nres-1) then
7268         l1=l+1
7269         l2=l-1
7270       else
7271         l1=l-1
7272         l2=l-2
7273       endif
7274       do ll=1,3
7275 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7276 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7277         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7278         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7279 cgrad        ghalf=0.5d0*ggg1(ll)
7280         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7281         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7282         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7283         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7284         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7285         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7286 cgrad        ghalf=0.5d0*ggg2(ll)
7287         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7288         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7289         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7290         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7291         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7292         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7293       enddo
7294 cgrad      do m=i+1,j-1
7295 cgrad        do ll=1,3
7296 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7297 cgrad        enddo
7298 cgrad      enddo
7299 cgrad      do m=k+1,l-1
7300 cgrad        do ll=1,3
7301 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7302 cgrad        enddo
7303 cgrad      enddo
7304 cgrad      do m=i+2,j2
7305 cgrad        do ll=1,3
7306 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7307 cgrad        enddo
7308 cgrad      enddo
7309 cgrad      do m=k+2,l2
7310 cgrad        do ll=1,3
7311 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7312 cgrad        enddo
7313 cgrad      enddo
7314 cd      do iii=1,nres-3
7315 cd        write (2,*) iii,gcorr_loc(iii)
7316 cd      enddo
7317       endif ! calc_grad
7318       eello4=ekont*eel4
7319 cd      write (2,*) 'ekont',ekont
7320 cd      write (iout,*) 'eello4',ekont*eel4
7321       return
7322       end
7323 C---------------------------------------------------------------------------
7324       double precision function eello5(i,j,k,l,jj,kk)
7325       implicit real*8 (a-h,o-z)
7326       include 'DIMENSIONS'
7327       include 'DIMENSIONS.ZSCOPT'
7328       include 'COMMON.IOUNITS'
7329       include 'COMMON.CHAIN'
7330       include 'COMMON.DERIV'
7331       include 'COMMON.INTERACT'
7332       include 'COMMON.CONTACTS'
7333       include 'COMMON.TORSION'
7334       include 'COMMON.VAR'
7335       include 'COMMON.GEO'
7336       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7337       double precision ggg1(3),ggg2(3)
7338 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7339 C                                                                              C
7340 C                            Parallel chains                                   C
7341 C                                                                              C
7342 C          o             o                   o             o                   C
7343 C         /l\           / \             \   / \           / \   /              C
7344 C        /   \         /   \             \ /   \         /   \ /               C
7345 C       j| o |l1       | o |              o| o |         | o |o                C
7346 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7347 C      \i/   \         /   \ /             /   \         /   \                 C
7348 C       o    k1             o                                                  C
7349 C         (I)          (II)                (III)          (IV)                 C
7350 C                                                                              C
7351 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7352 C                                                                              C
7353 C                            Antiparallel chains                               C
7354 C                                                                              C
7355 C          o             o                   o             o                   C
7356 C         /j\           / \             \   / \           / \   /              C
7357 C        /   \         /   \             \ /   \         /   \ /               C
7358 C      j1| o |l        | o |              o| o |         | o |o                C
7359 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7360 C      \i/   \         /   \ /             /   \         /   \                 C
7361 C       o     k1            o                                                  C
7362 C         (I)          (II)                (III)          (IV)                 C
7363 C                                                                              C
7364 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7365 C                                                                              C
7366 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7367 C                                                                              C
7368 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7369 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7370 cd        eello5=0.0d0
7371 cd        return
7372 cd      endif
7373 cd      write (iout,*)
7374 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7375 cd     &   ' and',k,l
7376       itk=itype2loc(itype(k))
7377       itl=itype2loc(itype(l))
7378       itj=itype2loc(itype(j))
7379       eello5_1=0.0d0
7380       eello5_2=0.0d0
7381       eello5_3=0.0d0
7382       eello5_4=0.0d0
7383 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7384 cd     &   eel5_3_num,eel5_4_num)
7385       do iii=1,2
7386         do kkk=1,5
7387           do lll=1,3
7388             derx(lll,kkk,iii)=0.0d0
7389           enddo
7390         enddo
7391       enddo
7392 cd      eij=facont_hb(jj,i)
7393 cd      ekl=facont_hb(kk,k)
7394 cd      ekont=eij*ekl
7395 cd      write (iout,*)'Contacts have occurred for peptide groups',
7396 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7397 cd      goto 1111
7398 C Contribution from the graph I.
7399 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7400 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7401       call transpose2(EUg(1,1,k),auxmat(1,1))
7402       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7403       vv(1)=pizda(1,1)-pizda(2,2)
7404       vv(2)=pizda(1,2)+pizda(2,1)
7405       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7406      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7407       if (calc_grad) then
7408 C Explicit gradient in virtual-dihedral angles.
7409       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7410      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7411      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7412       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7413       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7414       vv(1)=pizda(1,1)-pizda(2,2)
7415       vv(2)=pizda(1,2)+pizda(2,1)
7416       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7417      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7418      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7419       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7420       vv(1)=pizda(1,1)-pizda(2,2)
7421       vv(2)=pizda(1,2)+pizda(2,1)
7422       if (l.eq.j+1) then
7423         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7424      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7425      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7426       else
7427         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7428      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7429      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7430       endif
7431 C Cartesian gradient
7432       do iii=1,2
7433         do kkk=1,5
7434           do lll=1,3
7435             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7436      &        pizda(1,1))
7437             vv(1)=pizda(1,1)-pizda(2,2)
7438             vv(2)=pizda(1,2)+pizda(2,1)
7439             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7440      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7441      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7442           enddo
7443         enddo
7444       enddo
7445       endif ! calc_grad
7446 c      goto 1112
7447 c1111  continue
7448 C Contribution from graph II
7449       call transpose2(EE(1,1,k),auxmat(1,1))
7450       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7451       vv(1)=pizda(1,1)+pizda(2,2)
7452       vv(2)=pizda(2,1)-pizda(1,2)
7453       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
7454      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7455       if (calc_grad) then
7456 C Explicit gradient in virtual-dihedral angles.
7457       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7458      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7459       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7460       vv(1)=pizda(1,1)+pizda(2,2)
7461       vv(2)=pizda(2,1)-pizda(1,2)
7462       if (l.eq.j+1) then
7463         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7464      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7465      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7466       else
7467         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7468      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
7469      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7470       endif
7471 C Cartesian gradient
7472       do iii=1,2
7473         do kkk=1,5
7474           do lll=1,3
7475             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7476      &        pizda(1,1))
7477             vv(1)=pizda(1,1)+pizda(2,2)
7478             vv(2)=pizda(2,1)-pizda(1,2)
7479             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7480      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
7481      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7482           enddo
7483         enddo
7484       enddo
7485       endif ! calc_grad
7486 cd      goto 1112
7487 cd1111  continue
7488       if (l.eq.j+1) then
7489 cd        goto 1110
7490 C Parallel orientation
7491 C Contribution from graph III
7492         call transpose2(EUg(1,1,l),auxmat(1,1))
7493         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7494         vv(1)=pizda(1,1)-pizda(2,2)
7495         vv(2)=pizda(1,2)+pizda(2,1)
7496         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7497      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7498         if (calc_grad) then
7499 C Explicit gradient in virtual-dihedral angles.
7500         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7501      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7502      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7503         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7504         vv(1)=pizda(1,1)-pizda(2,2)
7505         vv(2)=pizda(1,2)+pizda(2,1)
7506         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7507      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7508      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7509         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7510         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7511         vv(1)=pizda(1,1)-pizda(2,2)
7512         vv(2)=pizda(1,2)+pizda(2,1)
7513         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7514      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7515      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7516 C Cartesian gradient
7517         do iii=1,2
7518           do kkk=1,5
7519             do lll=1,3
7520               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7521      &          pizda(1,1))
7522               vv(1)=pizda(1,1)-pizda(2,2)
7523               vv(2)=pizda(1,2)+pizda(2,1)
7524               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7525      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7526      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7527             enddo
7528           enddo
7529         enddo
7530 cd        goto 1112
7531 C Contribution from graph IV
7532 cd1110    continue
7533         call transpose2(EE(1,1,l),auxmat(1,1))
7534         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7535         vv(1)=pizda(1,1)+pizda(2,2)
7536         vv(2)=pizda(2,1)-pizda(1,2)
7537         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
7538      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7539 C Explicit gradient in virtual-dihedral angles.
7540         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7541      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7542         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7543         vv(1)=pizda(1,1)+pizda(2,2)
7544         vv(2)=pizda(2,1)-pizda(1,2)
7545         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7546      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
7547      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7548 C Cartesian gradient
7549         do iii=1,2
7550           do kkk=1,5
7551             do lll=1,3
7552               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7553      &          pizda(1,1))
7554               vv(1)=pizda(1,1)+pizda(2,2)
7555               vv(2)=pizda(2,1)-pizda(1,2)
7556               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7557      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
7558      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7559             enddo
7560           enddo
7561         enddo
7562         endif ! calc_grad
7563       else
7564 C Antiparallel orientation
7565 C Contribution from graph III
7566 c        goto 1110
7567         call transpose2(EUg(1,1,j),auxmat(1,1))
7568         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7569         vv(1)=pizda(1,1)-pizda(2,2)
7570         vv(2)=pizda(1,2)+pizda(2,1)
7571         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7572      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7573         if (calc_grad) then
7574 C Explicit gradient in virtual-dihedral angles.
7575         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7576      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7577      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7578         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7579         vv(1)=pizda(1,1)-pizda(2,2)
7580         vv(2)=pizda(1,2)+pizda(2,1)
7581         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7582      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7583      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7584         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7585         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7586         vv(1)=pizda(1,1)-pizda(2,2)
7587         vv(2)=pizda(1,2)+pizda(2,1)
7588         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7589      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7590      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7591 C Cartesian gradient
7592         do iii=1,2
7593           do kkk=1,5
7594             do lll=1,3
7595               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7596      &          pizda(1,1))
7597               vv(1)=pizda(1,1)-pizda(2,2)
7598               vv(2)=pizda(1,2)+pizda(2,1)
7599               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7600      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7601      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7602             enddo
7603           enddo
7604         enddo
7605         endif ! calc_grad
7606 cd        goto 1112
7607 C Contribution from graph IV
7608 1110    continue
7609         call transpose2(EE(1,1,j),auxmat(1,1))
7610         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7611         vv(1)=pizda(1,1)+pizda(2,2)
7612         vv(2)=pizda(2,1)-pizda(1,2)
7613         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
7614      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7615         if (calc_grad) then
7616 C Explicit gradient in virtual-dihedral angles.
7617         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7618      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7619         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7620         vv(1)=pizda(1,1)+pizda(2,2)
7621         vv(2)=pizda(2,1)-pizda(1,2)
7622         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7623      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
7624      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7625 C Cartesian gradient
7626         do iii=1,2
7627           do kkk=1,5
7628             do lll=1,3
7629               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7630      &          pizda(1,1))
7631               vv(1)=pizda(1,1)+pizda(2,2)
7632               vv(2)=pizda(2,1)-pizda(1,2)
7633               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7634      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
7635      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7636             enddo
7637           enddo
7638         enddo
7639         endif ! calc_grad
7640       endif
7641 1112  continue
7642       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7643 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7644 cd        write (2,*) 'ijkl',i,j,k,l
7645 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7646 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7647 cd      endif
7648 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7649 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7650 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7651 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7652       if (calc_grad) then
7653       if (j.lt.nres-1) then
7654         j1=j+1
7655         j2=j-1
7656       else
7657         j1=j-1
7658         j2=j-2
7659       endif
7660       if (l.lt.nres-1) then
7661         l1=l+1
7662         l2=l-1
7663       else
7664         l1=l-1
7665         l2=l-2
7666       endif
7667 cd      eij=1.0d0
7668 cd      ekl=1.0d0
7669 cd      ekont=1.0d0
7670 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7671 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7672 C        summed up outside the subrouine as for the other subroutines
7673 C        handling long-range interactions. The old code is commented out
7674 C        with "cgrad" to keep track of changes.
7675       do ll=1,3
7676 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7677 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7678         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7679         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7680 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7681 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7682 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7683 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7684 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7685 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7686 c     &   gradcorr5ij,
7687 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7688 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7689 cgrad        ghalf=0.5d0*ggg1(ll)
7690 cd        ghalf=0.0d0
7691         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7692         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7693         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7694         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7695         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7696         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7697 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7698 cgrad        ghalf=0.5d0*ggg2(ll)
7699 cd        ghalf=0.0d0
7700         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7701         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7702         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7703         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7704         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7705         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7706       enddo
7707       endif ! calc_grad
7708 cd      goto 1112
7709 cgrad      do m=i+1,j-1
7710 cgrad        do ll=1,3
7711 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7712 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7713 cgrad        enddo
7714 cgrad      enddo
7715 cgrad      do m=k+1,l-1
7716 cgrad        do ll=1,3
7717 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7718 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7719 cgrad        enddo
7720 cgrad      enddo
7721 c1112  continue
7722 cgrad      do m=i+2,j2
7723 cgrad        do ll=1,3
7724 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7725 cgrad        enddo
7726 cgrad      enddo
7727 cgrad      do m=k+2,l2
7728 cgrad        do ll=1,3
7729 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7730 cgrad        enddo
7731 cgrad      enddo
7732 cd      do iii=1,nres-3
7733 cd        write (2,*) iii,g_corr5_loc(iii)
7734 cd      enddo
7735       eello5=ekont*eel5
7736 cd      write (2,*) 'ekont',ekont
7737 cd      write (iout,*) 'eello5',ekont*eel5
7738       return
7739       end
7740 c--------------------------------------------------------------------------
7741       double precision function eello6(i,j,k,l,jj,kk)
7742       implicit real*8 (a-h,o-z)
7743       include 'DIMENSIONS'
7744       include 'DIMENSIONS.ZSCOPT'
7745       include 'COMMON.IOUNITS'
7746       include 'COMMON.CHAIN'
7747       include 'COMMON.DERIV'
7748       include 'COMMON.INTERACT'
7749       include 'COMMON.CONTACTS'
7750       include 'COMMON.TORSION'
7751       include 'COMMON.VAR'
7752       include 'COMMON.GEO'
7753       include 'COMMON.FFIELD'
7754       double precision ggg1(3),ggg2(3)
7755 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7756 cd        eello6=0.0d0
7757 cd        return
7758 cd      endif
7759 cd      write (iout,*)
7760 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7761 cd     &   ' and',k,l
7762       eello6_1=0.0d0
7763       eello6_2=0.0d0
7764       eello6_3=0.0d0
7765       eello6_4=0.0d0
7766       eello6_5=0.0d0
7767       eello6_6=0.0d0
7768 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7769 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7770       do iii=1,2
7771         do kkk=1,5
7772           do lll=1,3
7773             derx(lll,kkk,iii)=0.0d0
7774           enddo
7775         enddo
7776       enddo
7777 cd      eij=facont_hb(jj,i)
7778 cd      ekl=facont_hb(kk,k)
7779 cd      ekont=eij*ekl
7780 cd      eij=1.0d0
7781 cd      ekl=1.0d0
7782 cd      ekont=1.0d0
7783       if (l.eq.j+1) then
7784         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7785         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7786         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7787         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7788         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7789         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7790       else
7791         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7792         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7793         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7794         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7795         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7796           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7797         else
7798           eello6_5=0.0d0
7799         endif
7800         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7801       endif
7802 C If turn contributions are considered, they will be handled separately.
7803       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
7804 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
7805 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
7806 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
7807 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
7808 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
7809 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
7810 cd      goto 1112
7811       if (calc_grad) then
7812       if (j.lt.nres-1) then
7813         j1=j+1
7814         j2=j-1
7815       else
7816         j1=j-1
7817         j2=j-2
7818       endif
7819       if (l.lt.nres-1) then
7820         l1=l+1
7821         l2=l-1
7822       else
7823         l1=l-1
7824         l2=l-2
7825       endif
7826       do ll=1,3
7827 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
7828 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
7829 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
7830 cgrad        ghalf=0.5d0*ggg1(ll)
7831 cd        ghalf=0.0d0
7832         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
7833         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
7834         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
7835         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
7836         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
7837         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
7838         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
7839         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
7840 cgrad        ghalf=0.5d0*ggg2(ll)
7841 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
7842 cd        ghalf=0.0d0
7843         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
7844         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
7845         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
7846         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
7847         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
7848         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
7849       enddo
7850       endif ! calc_grad
7851 cd      goto 1112
7852 cgrad      do m=i+1,j-1
7853 cgrad        do ll=1,3
7854 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
7855 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
7856 cgrad        enddo
7857 cgrad      enddo
7858 cgrad      do m=k+1,l-1
7859 cgrad        do ll=1,3
7860 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
7861 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
7862 cgrad        enddo
7863 cgrad      enddo
7864 cgrad1112  continue
7865 cgrad      do m=i+2,j2
7866 cgrad        do ll=1,3
7867 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
7868 cgrad        enddo
7869 cgrad      enddo
7870 cgrad      do m=k+2,l2
7871 cgrad        do ll=1,3
7872 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
7873 cgrad        enddo
7874 cgrad      enddo
7875 cd      do iii=1,nres-3
7876 cd        write (2,*) iii,g_corr6_loc(iii)
7877 cd      enddo
7878       eello6=ekont*eel6
7879 cd      write (2,*) 'ekont',ekont
7880 cd      write (iout,*) 'eello6',ekont*eel6
7881       return
7882       end
7883 c--------------------------------------------------------------------------
7884       double precision function eello6_graph1(i,j,k,l,imat,swap)
7885       implicit real*8 (a-h,o-z)
7886       include 'DIMENSIONS'
7887       include 'DIMENSIONS.ZSCOPT'
7888       include 'COMMON.IOUNITS'
7889       include 'COMMON.CHAIN'
7890       include 'COMMON.DERIV'
7891       include 'COMMON.INTERACT'
7892       include 'COMMON.CONTACTS'
7893       include 'COMMON.TORSION'
7894       include 'COMMON.VAR'
7895       include 'COMMON.GEO'
7896       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
7897       logical swap
7898       logical lprn
7899       common /kutas/ lprn
7900 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7901 C                                                                              C
7902 C      Parallel       Antiparallel                                             C
7903 C                                                                              C
7904 C          o             o                                                     C
7905 C         /l\           /j\                                                    C
7906 C        /   \         /   \                                                   C
7907 C       /| o |         | o |\                                                  C
7908 C     \ j|/k\|  /   \  |/k\|l /                                                C
7909 C      \ /   \ /     \ /   \ /                                                 C
7910 C       o     o       o     o                                                  C
7911 C       i             i                                                        C
7912 C                                                                              C
7913 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7914       itk=itype2loc(itype(k))
7915       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
7916       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
7917       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
7918       call transpose2(EUgC(1,1,k),auxmat(1,1))
7919       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7920       vv1(1)=pizda1(1,1)-pizda1(2,2)
7921       vv1(2)=pizda1(1,2)+pizda1(2,1)
7922       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7923       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
7924       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
7925       s5=scalar2(vv(1),Dtobr2(1,i))
7926 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
7927       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
7928       if (calc_grad) then
7929       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
7930      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
7931      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
7932      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
7933      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
7934      & +scalar2(vv(1),Dtobr2der(1,i)))
7935       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
7936       vv1(1)=pizda1(1,1)-pizda1(2,2)
7937       vv1(2)=pizda1(1,2)+pizda1(2,1)
7938       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
7939       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
7940       if (l.eq.j+1) then
7941         g_corr6_loc(l-1)=g_corr6_loc(l-1)
7942      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7943      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7944      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7945      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7946       else
7947         g_corr6_loc(j-1)=g_corr6_loc(j-1)
7948      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
7949      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
7950      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
7951      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
7952       endif
7953       call transpose2(EUgCder(1,1,k),auxmat(1,1))
7954       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
7955       vv1(1)=pizda1(1,1)-pizda1(2,2)
7956       vv1(2)=pizda1(1,2)+pizda1(2,1)
7957       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
7958      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
7959      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
7960      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
7961       do iii=1,2
7962         if (swap) then
7963           ind=3-iii
7964         else
7965           ind=iii
7966         endif
7967         do kkk=1,5
7968           do lll=1,3
7969             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
7970             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
7971             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
7972             call transpose2(EUgC(1,1,k),auxmat(1,1))
7973             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
7974      &        pizda1(1,1))
7975             vv1(1)=pizda1(1,1)-pizda1(2,2)
7976             vv1(2)=pizda1(1,2)+pizda1(2,1)
7977             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
7978             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
7979      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
7980             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
7981      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
7982             s5=scalar2(vv(1),Dtobr2(1,i))
7983             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
7984           enddo
7985         enddo
7986       enddo
7987       endif ! calc_grad
7988       return
7989       end
7990 c----------------------------------------------------------------------------
7991       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
7992       implicit real*8 (a-h,o-z)
7993       include 'DIMENSIONS'
7994       include 'DIMENSIONS.ZSCOPT'
7995       include 'COMMON.IOUNITS'
7996       include 'COMMON.CHAIN'
7997       include 'COMMON.DERIV'
7998       include 'COMMON.INTERACT'
7999       include 'COMMON.CONTACTS'
8000       include 'COMMON.TORSION'
8001       include 'COMMON.VAR'
8002       include 'COMMON.GEO'
8003       logical swap
8004       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8005      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8006       logical lprn
8007       common /kutas/ lprn
8008 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8009 C                                                                              C
8010 C      Parallel       Antiparallel                                             C
8011 C                                                                              C
8012 C          o             o                                                     C
8013 C     \   /l\           /j\   /                                                C
8014 C      \ /   \         /   \ /                                                 C
8015 C       o| o |         | o |o                                                  C
8016 C     \ j|/k\|      \  |/k\|l                                                  C
8017 C      \ /   \       \ /   \                                                   C
8018 C       o             o                                                        C
8019 C       i             i                                                        C
8020 C                                                                              C
8021 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8022 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8023 C AL 7/4/01 s1 would occur in the sixth-order moment,
8024 C           but not in a cluster cumulant
8025 #ifdef MOMENT
8026       s1=dip(1,jj,i)*dip(1,kk,k)
8027 #endif
8028       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8029       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8030       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8031       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8032       call transpose2(EUg(1,1,k),auxmat(1,1))
8033       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8034       vv(1)=pizda(1,1)-pizda(2,2)
8035       vv(2)=pizda(1,2)+pizda(2,1)
8036       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8037 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8038 #ifdef MOMENT
8039       eello6_graph2=-(s1+s2+s3+s4)
8040 #else
8041       eello6_graph2=-(s2+s3+s4)
8042 #endif
8043 c      eello6_graph2=-s3
8044 C Derivatives in gamma(i-1)
8045       if (calc_grad) then
8046       if (i.gt.1) then
8047 #ifdef MOMENT
8048         s1=dipderg(1,jj,i)*dip(1,kk,k)
8049 #endif
8050         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8051         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8052         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8053         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8054 #ifdef MOMENT
8055         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8056 #else
8057         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8058 #endif
8059 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8060       endif
8061 C Derivatives in gamma(k-1)
8062 #ifdef MOMENT
8063       s1=dip(1,jj,i)*dipderg(1,kk,k)
8064 #endif
8065       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8066       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8067       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8068       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8069       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8070       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8071       vv(1)=pizda(1,1)-pizda(2,2)
8072       vv(2)=pizda(1,2)+pizda(2,1)
8073       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8074 #ifdef MOMENT
8075       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8076 #else
8077       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8078 #endif
8079 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8080 C Derivatives in gamma(j-1) or gamma(l-1)
8081       if (j.gt.1) then
8082 #ifdef MOMENT
8083         s1=dipderg(3,jj,i)*dip(1,kk,k)
8084 #endif
8085         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8086         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8087         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8088         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8089         vv(1)=pizda(1,1)-pizda(2,2)
8090         vv(2)=pizda(1,2)+pizda(2,1)
8091         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8092 #ifdef MOMENT
8093         if (swap) then
8094           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8095         else
8096           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8097         endif
8098 #endif
8099         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8100 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8101       endif
8102 C Derivatives in gamma(l-1) or gamma(j-1)
8103       if (l.gt.1) then
8104 #ifdef MOMENT
8105         s1=dip(1,jj,i)*dipderg(3,kk,k)
8106 #endif
8107         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8108         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8109         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8110         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8111         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8112         vv(1)=pizda(1,1)-pizda(2,2)
8113         vv(2)=pizda(1,2)+pizda(2,1)
8114         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8115 #ifdef MOMENT
8116         if (swap) then
8117           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8118         else
8119           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8120         endif
8121 #endif
8122         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8123 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8124       endif
8125 C Cartesian derivatives.
8126       if (lprn) then
8127         write (2,*) 'In eello6_graph2'
8128         do iii=1,2
8129           write (2,*) 'iii=',iii
8130           do kkk=1,5
8131             write (2,*) 'kkk=',kkk
8132             do jjj=1,2
8133               write (2,'(3(2f10.5),5x)')
8134      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8135             enddo
8136           enddo
8137         enddo
8138       endif
8139       do iii=1,2
8140         do kkk=1,5
8141           do lll=1,3
8142 #ifdef MOMENT
8143             if (iii.eq.1) then
8144               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8145             else
8146               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8147             endif
8148 #endif
8149             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8150      &        auxvec(1))
8151             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8152             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8153      &        auxvec(1))
8154             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8155             call transpose2(EUg(1,1,k),auxmat(1,1))
8156             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8157      &        pizda(1,1))
8158             vv(1)=pizda(1,1)-pizda(2,2)
8159             vv(2)=pizda(1,2)+pizda(2,1)
8160             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8161 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8162 #ifdef MOMENT
8163             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8164 #else
8165             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8166 #endif
8167             if (swap) then
8168               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8169             else
8170               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8171             endif
8172           enddo
8173         enddo
8174       enddo
8175       endif ! calc_grad
8176       return
8177       end
8178 c----------------------------------------------------------------------------
8179       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8180       implicit real*8 (a-h,o-z)
8181       include 'DIMENSIONS'
8182       include 'DIMENSIONS.ZSCOPT'
8183       include 'COMMON.IOUNITS'
8184       include 'COMMON.CHAIN'
8185       include 'COMMON.DERIV'
8186       include 'COMMON.INTERACT'
8187       include 'COMMON.CONTACTS'
8188       include 'COMMON.TORSION'
8189       include 'COMMON.VAR'
8190       include 'COMMON.GEO'
8191       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8192       logical swap
8193 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8194 C                                                                              C
8195 C      Parallel       Antiparallel                                             C
8196 C                                                                              C
8197 C          o             o                                                     C
8198 C         /l\   /   \   /j\                                                    C
8199 C        /   \ /     \ /   \                                                   C
8200 C       /| o |o       o| o |\                                                  C
8201 C       j|/k\|  /      |/k\|l /                                                C
8202 C        /   \ /       /   \ /                                                 C
8203 C       /     o       /     o                                                  C
8204 C       i             i                                                        C
8205 C                                                                              C
8206 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8207 C
8208 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8209 C           energy moment and not to the cluster cumulant.
8210       iti=itortyp(itype(i))
8211       if (j.lt.nres-1) then
8212         itj1=itype2loc(itype(j+1))
8213       else
8214         itj1=nloctyp
8215       endif
8216       itk=itype2loc(itype(k))
8217       itk1=itype2loc(itype(k+1))
8218       if (l.lt.nres-1) then
8219         itl1=itype2loc(itype(l+1))
8220       else
8221         itl1=nloctyp
8222       endif
8223 #ifdef MOMENT
8224       s1=dip(4,jj,i)*dip(4,kk,k)
8225 #endif
8226       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
8227       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8228       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
8229       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8230       call transpose2(EE(1,1,k),auxmat(1,1))
8231       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8232       vv(1)=pizda(1,1)+pizda(2,2)
8233       vv(2)=pizda(2,1)-pizda(1,2)
8234       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8235 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8236 cd     & "sum",-(s2+s3+s4)
8237 #ifdef MOMENT
8238       eello6_graph3=-(s1+s2+s3+s4)
8239 #else
8240       eello6_graph3=-(s2+s3+s4)
8241 #endif
8242 c      eello6_graph3=-s4
8243 C Derivatives in gamma(k-1)
8244       if (calc_grad) then
8245       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
8246       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8247       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8248       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8249 C Derivatives in gamma(l-1)
8250       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
8251       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8252       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8253       vv(1)=pizda(1,1)+pizda(2,2)
8254       vv(2)=pizda(2,1)-pizda(1,2)
8255       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8256       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8257 C Cartesian derivatives.
8258       do iii=1,2
8259         do kkk=1,5
8260           do lll=1,3
8261 #ifdef MOMENT
8262             if (iii.eq.1) then
8263               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8264             else
8265               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8266             endif
8267 #endif
8268             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8269      &        auxvec(1))
8270             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
8271             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8272      &        auxvec(1))
8273             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
8274             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8275      &        pizda(1,1))
8276             vv(1)=pizda(1,1)+pizda(2,2)
8277             vv(2)=pizda(2,1)-pizda(1,2)
8278             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8279 #ifdef MOMENT
8280             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8281 #else
8282             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8283 #endif
8284             if (swap) then
8285               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8286             else
8287               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8288             endif
8289 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8290           enddo
8291         enddo
8292       enddo
8293       endif ! calc_grad
8294       return
8295       end
8296 c----------------------------------------------------------------------------
8297       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8298       implicit real*8 (a-h,o-z)
8299       include 'DIMENSIONS'
8300       include 'DIMENSIONS.ZSCOPT'
8301       include 'COMMON.IOUNITS'
8302       include 'COMMON.CHAIN'
8303       include 'COMMON.DERIV'
8304       include 'COMMON.INTERACT'
8305       include 'COMMON.CONTACTS'
8306       include 'COMMON.TORSION'
8307       include 'COMMON.VAR'
8308       include 'COMMON.GEO'
8309       include 'COMMON.FFIELD'
8310       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8311      & auxvec1(2),auxmat1(2,2)
8312       logical swap
8313 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8314 C                                                                              C
8315 C      Parallel       Antiparallel                                             C
8316 C                                                                              C
8317 C          o             o                                                     C
8318 C         /l\   /   \   /j\                                                    C
8319 C        /   \ /     \ /   \                                                   C
8320 C       /| o |o       o| o |\                                                  C
8321 C     \ j|/k\|      \  |/k\|l                                                  C
8322 C      \ /   \       \ /   \                                                   C
8323 C       o     \       o     \                                                  C
8324 C       i             i                                                        C
8325 C                                                                              C
8326 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8327 C
8328 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8329 C           energy moment and not to the cluster cumulant.
8330 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8331       iti=itype2loc(itype(i))
8332       itj=itype2loc(itype(j))
8333       if (j.lt.nres-1) then
8334         itj1=itype2loc(itype(j+1))
8335       else
8336         itj1=nloctyp
8337       endif
8338       itk=itype2loc(itype(k))
8339       if (k.lt.nres-1) then
8340         itk1=itype2loc(itype(k+1))
8341       else
8342         itk1=nloctyp
8343       endif
8344       itl=itype2loc(itype(l))
8345       if (l.lt.nres-1) then
8346         itl1=itype2loc(itype(l+1))
8347       else
8348         itl1=nloctyp
8349       endif
8350 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8351 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8352 cd     & ' itl',itl,' itl1',itl1
8353 #ifdef MOMENT
8354       if (imat.eq.1) then
8355         s1=dip(3,jj,i)*dip(3,kk,k)
8356       else
8357         s1=dip(2,jj,j)*dip(2,kk,l)
8358       endif
8359 #endif
8360       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8361       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8362       if (j.eq.l+1) then
8363         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
8364         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8365       else
8366         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
8367         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8368       endif
8369       call transpose2(EUg(1,1,k),auxmat(1,1))
8370       call matmat2(AECA(1,1,imat),auxmat(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),Dtobr2(1,i))
8374 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8375 #ifdef MOMENT
8376       eello6_graph4=-(s1+s2+s3+s4)
8377 #else
8378       eello6_graph4=-(s2+s3+s4)
8379 #endif
8380 C Derivatives in gamma(i-1)
8381       if (calc_grad) then
8382       if (i.gt.1) then
8383 #ifdef MOMENT
8384         if (imat.eq.1) then
8385           s1=dipderg(2,jj,i)*dip(3,kk,k)
8386         else
8387           s1=dipderg(4,jj,j)*dip(2,kk,l)
8388         endif
8389 #endif
8390         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8391         if (j.eq.l+1) then
8392           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
8393           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8394         else
8395           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
8396           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8397         endif
8398         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8399         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8400 cd          write (2,*) 'turn6 derivatives'
8401 #ifdef MOMENT
8402           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8403 #else
8404           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8405 #endif
8406         else
8407 #ifdef MOMENT
8408           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8409 #else
8410           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8411 #endif
8412         endif
8413       endif
8414 C Derivatives in gamma(k-1)
8415 #ifdef MOMENT
8416       if (imat.eq.1) then
8417         s1=dip(3,jj,i)*dipderg(2,kk,k)
8418       else
8419         s1=dip(2,jj,j)*dipderg(4,kk,l)
8420       endif
8421 #endif
8422       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8423       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8424       if (j.eq.l+1) then
8425         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
8426         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
8427       else
8428         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
8429         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
8430       endif
8431       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8432       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8433       vv(1)=pizda(1,1)-pizda(2,2)
8434       vv(2)=pizda(2,1)+pizda(1,2)
8435       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8436       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8437 #ifdef MOMENT
8438         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8439 #else
8440         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8441 #endif
8442       else
8443 #ifdef MOMENT
8444         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8445 #else
8446         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8447 #endif
8448       endif
8449 C Derivatives in gamma(j-1) or gamma(l-1)
8450       if (l.eq.j+1 .and. l.gt.1) then
8451         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8452         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8453         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8454         vv(1)=pizda(1,1)-pizda(2,2)
8455         vv(2)=pizda(2,1)+pizda(1,2)
8456         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8457         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8458       else if (j.gt.1) then
8459         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8460         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8461         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8462         vv(1)=pizda(1,1)-pizda(2,2)
8463         vv(2)=pizda(2,1)+pizda(1,2)
8464         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8465         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8466           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8467         else
8468           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8469         endif
8470       endif
8471 C Cartesian derivatives.
8472       do iii=1,2
8473         do kkk=1,5
8474           do lll=1,3
8475 #ifdef MOMENT
8476             if (iii.eq.1) then
8477               if (imat.eq.1) then
8478                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8479               else
8480                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8481               endif
8482             else
8483               if (imat.eq.1) then
8484                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8485               else
8486                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8487               endif
8488             endif
8489 #endif
8490             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8491      &        auxvec(1))
8492             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8493             if (j.eq.l+1) then
8494               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8495      &          b1(1,j+1),auxvec(1))
8496               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
8497             else
8498               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8499      &          b1(1,l+1),auxvec(1))
8500               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
8501             endif
8502             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8503      &        pizda(1,1))
8504             vv(1)=pizda(1,1)-pizda(2,2)
8505             vv(2)=pizda(2,1)+pizda(1,2)
8506             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8507             if (swap) then
8508               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8509 #ifdef MOMENT
8510                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8511      &             -(s1+s2+s4)
8512 #else
8513                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8514      &             -(s2+s4)
8515 #endif
8516                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8517               else
8518 #ifdef MOMENT
8519                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8520 #else
8521                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8522 #endif
8523                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8524               endif
8525             else
8526 #ifdef MOMENT
8527               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8528 #else
8529               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8530 #endif
8531               if (l.eq.j+1) then
8532                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8533               else
8534                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8535               endif
8536             endif
8537           enddo
8538         enddo
8539       enddo
8540       endif ! calc_grad
8541       return
8542       end
8543 c----------------------------------------------------------------------------
8544       double precision function eello_turn6(i,jj,kk)
8545       implicit real*8 (a-h,o-z)
8546       include 'DIMENSIONS'
8547       include 'DIMENSIONS.ZSCOPT'
8548       include 'COMMON.IOUNITS'
8549       include 'COMMON.CHAIN'
8550       include 'COMMON.DERIV'
8551       include 'COMMON.INTERACT'
8552       include 'COMMON.CONTACTS'
8553       include 'COMMON.TORSION'
8554       include 'COMMON.VAR'
8555       include 'COMMON.GEO'
8556       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8557      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8558      &  ggg1(3),ggg2(3)
8559       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8560      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8561 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8562 C           the respective energy moment and not to the cluster cumulant.
8563       s1=0.0d0
8564       s8=0.0d0
8565       s13=0.0d0
8566 c
8567       eello_turn6=0.0d0
8568       j=i+4
8569       k=i+1
8570       l=i+3
8571       iti=itype2loc(itype(i))
8572       itk=itype2loc(itype(k))
8573       itk1=itype2loc(itype(k+1))
8574       itl=itype2loc(itype(l))
8575       itj=itype2loc(itype(j))
8576 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8577 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8578 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8579 cd        eello6=0.0d0
8580 cd        return
8581 cd      endif
8582 cd      write (iout,*)
8583 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8584 cd     &   ' and',k,l
8585 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8586       do iii=1,2
8587         do kkk=1,5
8588           do lll=1,3
8589             derx_turn(lll,kkk,iii)=0.0d0
8590           enddo
8591         enddo
8592       enddo
8593 cd      eij=1.0d0
8594 cd      ekl=1.0d0
8595 cd      ekont=1.0d0
8596       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8597 cd      eello6_5=0.0d0
8598 cd      write (2,*) 'eello6_5',eello6_5
8599 #ifdef MOMENT
8600       call transpose2(AEA(1,1,1),auxmat(1,1))
8601       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8602       ss1=scalar2(Ub2(1,i+2),b1(1,l))
8603       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8604 #endif
8605       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8606       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8607       s2 = scalar2(b1(1,k),vtemp1(1))
8608 #ifdef MOMENT
8609       call transpose2(AEA(1,1,2),atemp(1,1))
8610       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8611       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
8612       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8613 #endif
8614       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8615       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8616       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8617 #ifdef MOMENT
8618       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8619       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8620       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8621       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8622       ss13 = scalar2(b1(1,k),vtemp4(1))
8623       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8624 #endif
8625 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8626 c      s1=0.0d0
8627 c      s2=0.0d0
8628 c      s8=0.0d0
8629 c      s12=0.0d0
8630 c      s13=0.0d0
8631       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8632 C Derivatives in gamma(i+2)
8633       if (calc_grad) then
8634       s1d =0.0d0
8635       s8d =0.0d0
8636 #ifdef MOMENT
8637       call transpose2(AEA(1,1,1),auxmatd(1,1))
8638       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8639       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8640       call transpose2(AEAderg(1,1,2),atempd(1,1))
8641       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8642       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8643 #endif
8644       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8645       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8646       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8647 c      s1d=0.0d0
8648 c      s2d=0.0d0
8649 c      s8d=0.0d0
8650 c      s12d=0.0d0
8651 c      s13d=0.0d0
8652       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8653 C Derivatives in gamma(i+3)
8654 #ifdef MOMENT
8655       call transpose2(AEA(1,1,1),auxmatd(1,1))
8656       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8657       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
8658       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8659 #endif
8660       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
8661       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8662       s2d = scalar2(b1(1,k),vtemp1d(1))
8663 #ifdef MOMENT
8664       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
8665       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
8666 #endif
8667       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8668 #ifdef MOMENT
8669       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8670       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8671       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8672 #endif
8673 c      s1d=0.0d0
8674 c      s2d=0.0d0
8675 c      s8d=0.0d0
8676 c      s12d=0.0d0
8677 c      s13d=0.0d0
8678 #ifdef MOMENT
8679       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8680      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8681 #else
8682       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8683      &               -0.5d0*ekont*(s2d+s12d)
8684 #endif
8685 C Derivatives in gamma(i+4)
8686       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8687       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8688       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8689 #ifdef MOMENT
8690       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8691       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8692       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8693 #endif
8694 c      s1d=0.0d0
8695 c      s2d=0.0d0
8696 c      s8d=0.0d0
8697 C      s12d=0.0d0
8698 c      s13d=0.0d0
8699 #ifdef MOMENT
8700       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8701 #else
8702       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8703 #endif
8704 C Derivatives in gamma(i+5)
8705 #ifdef MOMENT
8706       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8707       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8708       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8709 #endif
8710       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
8711       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8712       s2d = scalar2(b1(1,k),vtemp1d(1))
8713 #ifdef MOMENT
8714       call transpose2(AEA(1,1,2),atempd(1,1))
8715       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8716       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
8717 #endif
8718       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8719       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8720 #ifdef MOMENT
8721       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8722       ss13d = scalar2(b1(1,k),vtemp4d(1))
8723       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8724 #endif
8725 c      s1d=0.0d0
8726 c      s2d=0.0d0
8727 c      s8d=0.0d0
8728 c      s12d=0.0d0
8729 c      s13d=0.0d0
8730 #ifdef MOMENT
8731       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8732      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8733 #else
8734       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8735      &               -0.5d0*ekont*(s2d+s12d)
8736 #endif
8737 C Cartesian derivatives
8738       do iii=1,2
8739         do kkk=1,5
8740           do lll=1,3
8741 #ifdef MOMENT
8742             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8743             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8744             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8745 #endif
8746             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
8747             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8748      &          vtemp1d(1))
8749             s2d = scalar2(b1(1,k),vtemp1d(1))
8750 #ifdef MOMENT
8751             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8752             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8753             s8d = -(atempd(1,1)+atempd(2,2))*
8754      &           scalar2(cc(1,1,l),vtemp2(1))
8755 #endif
8756             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8757      &           auxmatd(1,1))
8758             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8759             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8760 c      s1d=0.0d0
8761 c      s2d=0.0d0
8762 c      s8d=0.0d0
8763 c      s12d=0.0d0
8764 c      s13d=0.0d0
8765 #ifdef MOMENT
8766             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8767      &        - 0.5d0*(s1d+s2d)
8768 #else
8769             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8770      &        - 0.5d0*s2d
8771 #endif
8772 #ifdef MOMENT
8773             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8774      &        - 0.5d0*(s8d+s12d)
8775 #else
8776             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8777      &        - 0.5d0*s12d
8778 #endif
8779           enddo
8780         enddo
8781       enddo
8782 #ifdef MOMENT
8783       do kkk=1,5
8784         do lll=1,3
8785           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8786      &      achuj_tempd(1,1))
8787           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8788           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8789           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8790           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8791           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8792      &      vtemp4d(1))
8793           ss13d = scalar2(b1(1,k),vtemp4d(1))
8794           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8795           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8796         enddo
8797       enddo
8798 #endif
8799 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8800 cd     &  16*eel_turn6_num
8801 cd      goto 1112
8802       if (j.lt.nres-1) then
8803         j1=j+1
8804         j2=j-1
8805       else
8806         j1=j-1
8807         j2=j-2
8808       endif
8809       if (l.lt.nres-1) then
8810         l1=l+1
8811         l2=l-1
8812       else
8813         l1=l-1
8814         l2=l-2
8815       endif
8816       do ll=1,3
8817 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8818 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
8819 cgrad        ghalf=0.5d0*ggg1(ll)
8820 cd        ghalf=0.0d0
8821         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
8822         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
8823         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
8824      &    +ekont*derx_turn(ll,2,1)
8825         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
8826         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
8827      &    +ekont*derx_turn(ll,4,1)
8828         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
8829         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
8830         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
8831 cgrad        ghalf=0.5d0*ggg2(ll)
8832 cd        ghalf=0.0d0
8833         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
8834      &    +ekont*derx_turn(ll,2,2)
8835         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
8836         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
8837      &    +ekont*derx_turn(ll,4,2)
8838         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
8839         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
8840         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
8841       enddo
8842 cd      goto 1112
8843 cgrad      do m=i+1,j-1
8844 cgrad        do ll=1,3
8845 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
8846 cgrad        enddo
8847 cgrad      enddo
8848 cgrad      do m=k+1,l-1
8849 cgrad        do ll=1,3
8850 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
8851 cgrad        enddo
8852 cgrad      enddo
8853 cgrad1112  continue
8854 cgrad      do m=i+2,j2
8855 cgrad        do ll=1,3
8856 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
8857 cgrad        enddo
8858 cgrad      enddo
8859 cgrad      do m=k+2,l2
8860 cgrad        do ll=1,3
8861 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
8862 cgrad        enddo
8863 cgrad      enddo
8864 cd      do iii=1,nres-3
8865 cd        write (2,*) iii,g_corr6_loc(iii)
8866 cd      enddo
8867       endif ! calc_grad
8868       eello_turn6=ekont*eel_turn6
8869 cd      write (2,*) 'ekont',ekont
8870 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
8871       return
8872       end
8873
8874 crc-------------------------------------------------
8875 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8876       subroutine Eliptransfer(eliptran)
8877       implicit real*8 (a-h,o-z)
8878       include 'DIMENSIONS'
8879       include 'DIMENSIONS.ZSCOPT'
8880       include 'COMMON.GEO'
8881       include 'COMMON.VAR'
8882       include 'COMMON.LOCAL'
8883       include 'COMMON.CHAIN'
8884       include 'COMMON.DERIV'
8885       include 'COMMON.INTERACT'
8886       include 'COMMON.IOUNITS'
8887       include 'COMMON.CALC'
8888       include 'COMMON.CONTROL'
8889       include 'COMMON.SPLITELE'
8890       include 'COMMON.SBRIDGE'
8891 C this is done by Adasko
8892 C      print *,"wchodze"
8893 C structure of box:
8894 C      water
8895 C--bordliptop-- buffore starts
8896 C--bufliptop--- here true lipid starts
8897 C      lipid
8898 C--buflipbot--- lipid ends buffore starts
8899 C--bordlipbot--buffore ends
8900       eliptran=0.0
8901       do i=1,nres
8902 C       do i=1,1
8903         if (itype(i).eq.ntyp1) cycle
8904
8905         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
8906         if (positi.le.0) positi=positi+boxzsize
8907 C        print *,i
8908 C first for peptide groups
8909 c for each residue check if it is in lipid or lipid water border area
8910        if ((positi.gt.bordlipbot)
8911      &.and.(positi.lt.bordliptop)) then
8912 C the energy transfer exist
8913         if (positi.lt.buflipbot) then
8914 C what fraction I am in
8915          fracinbuf=1.0d0-
8916      &        ((positi-bordlipbot)/lipbufthick)
8917 C lipbufthick is thickenes of lipid buffore
8918          sslip=sscalelip(fracinbuf)
8919          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8920          eliptran=eliptran+sslip*pepliptran
8921          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8922          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8923 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8924         elseif (positi.gt.bufliptop) then
8925          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
8926          sslip=sscalelip(fracinbuf)
8927          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8928          eliptran=eliptran+sslip*pepliptran
8929          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
8930          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
8931 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
8932 C          print *, "doing sscalefor top part"
8933 C         print *,i,sslip,fracinbuf,ssgradlip
8934         else
8935          eliptran=eliptran+pepliptran
8936 C         print *,"I am in true lipid"
8937         endif
8938 C       else
8939 C       eliptran=elpitran+0.0 ! I am in water
8940        endif
8941        enddo
8942 C       print *, "nic nie bylo w lipidzie?"
8943 C now multiply all by the peptide group transfer factor
8944 C       eliptran=eliptran*pepliptran
8945 C now the same for side chains
8946 CV       do i=1,1
8947        do i=1,nres
8948         if (itype(i).eq.ntyp1) cycle
8949         positi=(mod(c(3,i+nres),boxzsize))
8950         if (positi.le.0) positi=positi+boxzsize
8951 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
8952 c for each residue check if it is in lipid or lipid water border area
8953 C       respos=mod(c(3,i+nres),boxzsize)
8954 C       print *,positi,bordlipbot,buflipbot
8955        if ((positi.gt.bordlipbot)
8956      & .and.(positi.lt.bordliptop)) then
8957 C the energy transfer exist
8958         if (positi.lt.buflipbot) then
8959          fracinbuf=1.0d0-
8960      &     ((positi-bordlipbot)/lipbufthick)
8961 C lipbufthick is thickenes of lipid buffore
8962          sslip=sscalelip(fracinbuf)
8963          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
8964          eliptran=eliptran+sslip*liptranene(itype(i))
8965          gliptranx(3,i)=gliptranx(3,i)
8966      &+ssgradlip*liptranene(itype(i))
8967          gliptranc(3,i-1)= gliptranc(3,i-1)
8968      &+ssgradlip*liptranene(itype(i))
8969 C         print *,"doing sccale for lower part"
8970         elseif (positi.gt.bufliptop) then
8971          fracinbuf=1.0d0-
8972      &((bordliptop-positi)/lipbufthick)
8973          sslip=sscalelip(fracinbuf)
8974          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
8975          eliptran=eliptran+sslip*liptranene(itype(i))
8976          gliptranx(3,i)=gliptranx(3,i)
8977      &+ssgradlip*liptranene(itype(i))
8978          gliptranc(3,i-1)= gliptranc(3,i-1)
8979      &+ssgradlip*liptranene(itype(i))
8980 C          print *, "doing sscalefor top part",sslip,fracinbuf
8981         else
8982          eliptran=eliptran+liptranene(itype(i))
8983 C         print *,"I am in true lipid"
8984         endif
8985         endif ! if in lipid or buffor
8986 C       else
8987 C       eliptran=elpitran+0.0 ! I am in water
8988        enddo
8989        return
8990        end
8991
8992
8993 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8994
8995       SUBROUTINE MATVEC2(A1,V1,V2)
8996       implicit real*8 (a-h,o-z)
8997       include 'DIMENSIONS'
8998       DIMENSION A1(2,2),V1(2),V2(2)
8999 c      DO 1 I=1,2
9000 c        VI=0.0
9001 c        DO 3 K=1,2
9002 c    3     VI=VI+A1(I,K)*V1(K)
9003 c        Vaux(I)=VI
9004 c    1 CONTINUE
9005
9006       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9007       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9008
9009       v2(1)=vaux1
9010       v2(2)=vaux2
9011       END
9012 C---------------------------------------
9013       SUBROUTINE MATMAT2(A1,A2,A3)
9014       implicit real*8 (a-h,o-z)
9015       include 'DIMENSIONS'
9016       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9017 c      DIMENSION AI3(2,2)
9018 c        DO  J=1,2
9019 c          A3IJ=0.0
9020 c          DO K=1,2
9021 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9022 c          enddo
9023 c          A3(I,J)=A3IJ
9024 c       enddo
9025 c      enddo
9026
9027       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9028       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9029       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9030       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9031
9032       A3(1,1)=AI3_11
9033       A3(2,1)=AI3_21
9034       A3(1,2)=AI3_12
9035       A3(2,2)=AI3_22
9036       END
9037
9038 c-------------------------------------------------------------------------
9039       double precision function scalar2(u,v)
9040       implicit none
9041       double precision u(2),v(2)
9042       double precision sc
9043       integer i
9044       scalar2=u(1)*v(1)+u(2)*v(2)
9045       return
9046       end
9047
9048 C-----------------------------------------------------------------------------
9049
9050       subroutine transpose2(a,at)
9051       implicit none
9052       double precision a(2,2),at(2,2)
9053       at(1,1)=a(1,1)
9054       at(1,2)=a(2,1)
9055       at(2,1)=a(1,2)
9056       at(2,2)=a(2,2)
9057       return
9058       end
9059 c--------------------------------------------------------------------------
9060       subroutine transpose(n,a,at)
9061       implicit none
9062       integer n,i,j
9063       double precision a(n,n),at(n,n)
9064       do i=1,n
9065         do j=1,n
9066           at(j,i)=a(i,j)
9067         enddo
9068       enddo
9069       return
9070       end
9071 C---------------------------------------------------------------------------
9072       subroutine prodmat3(a1,a2,kk,transp,prod)
9073       implicit none
9074       integer i,j
9075       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9076       logical transp
9077 crc      double precision auxmat(2,2),prod_(2,2)
9078
9079       if (transp) then
9080 crc        call transpose2(kk(1,1),auxmat(1,1))
9081 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9082 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9083
9084            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9085      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9086            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9087      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9088            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9089      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9090            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9091      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9092
9093       else
9094 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9095 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9096
9097            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9098      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9099            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9100      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9101            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9102      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9103            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9104      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9105
9106       endif
9107 c      call transpose2(a2(1,1),a2t(1,1))
9108
9109 crc      print *,transp
9110 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9111 crc      print *,((prod(i,j),i=1,2),j=1,2)
9112
9113       return
9114       end
9115 C-----------------------------------------------------------------------------
9116       double precision function scalar(u,v)
9117       implicit none
9118       double precision u(3),v(3)
9119       double precision sc
9120       integer i
9121       sc=0.0d0
9122       do i=1,3
9123         sc=sc+u(i)*v(i)
9124       enddo
9125       scalar=sc
9126       return
9127       end
9128 C-----------------------------------------------------------------------
9129       double precision function sscale(r)
9130       double precision r,gamm
9131       include "COMMON.SPLITELE"
9132       if(r.lt.r_cut-rlamb) then
9133         sscale=1.0d0
9134       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9135         gamm=(r-(r_cut-rlamb))/rlamb
9136         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9137       else
9138         sscale=0d0
9139       endif
9140       return
9141       end
9142 C-----------------------------------------------------------------------
9143 C-----------------------------------------------------------------------
9144       double precision function sscagrad(r)
9145       double precision r,gamm
9146       include "COMMON.SPLITELE"
9147       if(r.lt.r_cut-rlamb) then
9148         sscagrad=0.0d0
9149       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9150         gamm=(r-(r_cut-rlamb))/rlamb
9151         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
9152       else
9153         sscagrad=0.0d0
9154       endif
9155       return
9156       end
9157 C-----------------------------------------------------------------------
9158 C-----------------------------------------------------------------------
9159       double precision function sscalelip(r)
9160       double precision r,gamm
9161       include "COMMON.SPLITELE"
9162 C      if(r.lt.r_cut-rlamb) then
9163 C        sscale=1.0d0
9164 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9165 C        gamm=(r-(r_cut-rlamb))/rlamb
9166         sscalelip=1.0d0+r*r*(2*r-3.0d0)
9167 C      else
9168 C        sscale=0d0
9169 C      endif
9170       return
9171       end
9172 C-----------------------------------------------------------------------
9173       double precision function sscagradlip(r)
9174       double precision r,gamm
9175       include "COMMON.SPLITELE"
9176 C     if(r.lt.r_cut-rlamb) then
9177 C        sscagrad=0.0d0
9178 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
9179 C        gamm=(r-(r_cut-rlamb))/rlamb
9180         sscagradlip=r*(6*r-6.0d0)
9181 C      else
9182 C        sscagrad=0.0d0
9183 C      endif
9184       return
9185       end
9186
9187 C-----------------------------------------------------------------------
9188        subroutine set_shield_fac
9189       implicit real*8 (a-h,o-z)
9190       include 'DIMENSIONS'
9191       include 'DIMENSIONS.ZSCOPT'
9192       include 'COMMON.CHAIN'
9193       include 'COMMON.DERIV'
9194       include 'COMMON.IOUNITS'
9195       include 'COMMON.SHIELD'
9196       include 'COMMON.INTERACT'
9197 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9198       double precision div77_81/0.974996043d0/,
9199      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9200
9201 C the vector between center of side_chain and peptide group
9202        double precision pep_side(3),long,side_calf(3),
9203      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9204      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9205 C the line belowe needs to be changed for FGPROC>1
9206       do i=1,nres-1
9207       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9208       ishield_list(i)=0
9209 Cif there two consequtive dummy atoms there is no peptide group between them
9210 C the line below has to be changed for FGPROC>1
9211       VolumeTotal=0.0
9212       do k=1,nres
9213        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9214        dist_pep_side=0.0
9215        dist_side_calf=0.0
9216        do j=1,3
9217 C first lets set vector conecting the ithe side-chain with kth side-chain
9218       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9219 C      pep_side(j)=2.0d0
9220 C and vector conecting the side-chain with its proper calfa
9221       side_calf(j)=c(j,k+nres)-c(j,k)
9222 C      side_calf(j)=2.0d0
9223       pept_group(j)=c(j,i)-c(j,i+1)
9224 C lets have their lenght
9225       dist_pep_side=pep_side(j)**2+dist_pep_side
9226       dist_side_calf=dist_side_calf+side_calf(j)**2
9227       dist_pept_group=dist_pept_group+pept_group(j)**2
9228       enddo
9229        dist_pep_side=dsqrt(dist_pep_side)
9230        dist_pept_group=dsqrt(dist_pept_group)
9231        dist_side_calf=dsqrt(dist_side_calf)
9232       do j=1,3
9233         pep_side_norm(j)=pep_side(j)/dist_pep_side
9234         side_calf_norm(j)=dist_side_calf
9235       enddo
9236 C now sscale fraction
9237        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9238 C       print *,buff_shield,"buff"
9239 C now sscale
9240         if (sh_frac_dist.le.0.0) cycle
9241 C If we reach here it means that this side chain reaches the shielding sphere
9242 C Lets add him to the list for gradient
9243         ishield_list(i)=ishield_list(i)+1
9244 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9245 C this list is essential otherwise problem would be O3
9246         shield_list(ishield_list(i),i)=k
9247 C Lets have the sscale value
9248         if (sh_frac_dist.gt.1.0) then
9249          scale_fac_dist=1.0d0
9250          do j=1,3
9251          sh_frac_dist_grad(j)=0.0d0
9252          enddo
9253         else
9254          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9255      &                   *(2.0*sh_frac_dist-3.0d0)
9256          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
9257      &                  /dist_pep_side/buff_shield*0.5
9258 C remember for the final gradient multiply sh_frac_dist_grad(j)
9259 C for side_chain by factor -2 !
9260          do j=1,3
9261          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9262 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9263 C     &                    sh_frac_dist_grad(j)
9264          enddo
9265         endif
9266 C        if ((i.eq.3).and.(k.eq.2)) then
9267 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
9268 C     & ,"TU"
9269 C        endif
9270
9271 C this is what is now we have the distance scaling now volume...
9272       short=short_r_sidechain(itype(k))
9273       long=long_r_sidechain(itype(k))
9274       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
9275 C now costhet_grad
9276 C       costhet=0.0d0
9277        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
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.0
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.0-cosalfa**2
9293       fac_alfa_sin=dsqrt(fac_alfa_sin)
9294       rkprim=fac_alfa_sin*(long-short)+short
9295 C now costhet_grad
9296        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
9297        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
9298
9299        do j=1,3
9300          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9301      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9302      &*(long-short)/fac_alfa_sin*cosalfa/
9303      &((dist_pep_side*dist_side_calf))*
9304      &((side_calf(j))-cosalfa*
9305      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9306
9307         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
9308      &*(long-short)/fac_alfa_sin*cosalfa
9309      &/((dist_pep_side*dist_side_calf))*
9310      &(pep_side(j)-
9311      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9312        enddo
9313
9314       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
9315      &                    /VSolvSphere_div
9316      &                    *wshield
9317 C now the gradient...
9318 C grad_shield is gradient of Calfa for peptide groups
9319 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
9320 C     &               costhet,cosphi
9321 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
9322 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
9323       do j=1,3
9324       grad_shield(j,i)=grad_shield(j,i)
9325 C gradient po skalowaniu
9326      &                +(sh_frac_dist_grad(j)
9327 C  gradient po costhet
9328      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
9329      &-scale_fac_dist*(cosphi_grad_long(j))
9330      &/(1.0-cosphi) )*div77_81
9331      &*VofOverlap
9332 C grad_shield_side is Cbeta sidechain gradient
9333       grad_shield_side(j,ishield_list(i),i)=
9334      &        (sh_frac_dist_grad(j)*(-2.0d0)
9335      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
9336      &       +scale_fac_dist*(cosphi_grad_long(j))
9337      &        *2.0d0/(1.0-cosphi))
9338      &        *div77_81*VofOverlap
9339
9340        grad_shield_loc(j,ishield_list(i),i)=
9341      &   scale_fac_dist*cosphi_grad_loc(j)
9342      &        *2.0d0/(1.0-cosphi)
9343      &        *div77_81*VofOverlap
9344       enddo
9345       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9346       enddo
9347       fac_shield(i)=VolumeTotal*div77_81+div4_81
9348 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
9349       enddo
9350       return
9351       end
9352 C--------------------------------------------------------------------------
9353 C first for shielding is setting of function of side-chains
9354        subroutine set_shield_fac2
9355       implicit real*8 (a-h,o-z)
9356       include 'DIMENSIONS'
9357       include 'DIMENSIONS.ZSCOPT'
9358       include 'COMMON.CHAIN'
9359       include 'COMMON.DERIV'
9360       include 'COMMON.IOUNITS'
9361       include 'COMMON.SHIELD'
9362       include 'COMMON.INTERACT'
9363 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
9364       double precision div77_81/0.974996043d0/,
9365      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
9366
9367 C the vector between center of side_chain and peptide group
9368        double precision pep_side(3),long,side_calf(3),
9369      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
9370      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
9371 C the line belowe needs to be changed for FGPROC>1
9372       do i=1,nres-1
9373       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
9374       ishield_list(i)=0
9375 Cif there two consequtive dummy atoms there is no peptide group between them
9376 C the line below has to be changed for FGPROC>1
9377       VolumeTotal=0.0
9378       do k=1,nres
9379        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
9380        dist_pep_side=0.0
9381        dist_side_calf=0.0
9382        do j=1,3
9383 C first lets set vector conecting the ithe side-chain with kth side-chain
9384       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
9385 C      pep_side(j)=2.0d0
9386 C and vector conecting the side-chain with its proper calfa
9387       side_calf(j)=c(j,k+nres)-c(j,k)
9388 C      side_calf(j)=2.0d0
9389       pept_group(j)=c(j,i)-c(j,i+1)
9390 C lets have their lenght
9391       dist_pep_side=pep_side(j)**2+dist_pep_side
9392       dist_side_calf=dist_side_calf+side_calf(j)**2
9393       dist_pept_group=dist_pept_group+pept_group(j)**2
9394       enddo
9395        dist_pep_side=dsqrt(dist_pep_side)
9396        dist_pept_group=dsqrt(dist_pept_group)
9397        dist_side_calf=dsqrt(dist_side_calf)
9398       do j=1,3
9399         pep_side_norm(j)=pep_side(j)/dist_pep_side
9400         side_calf_norm(j)=dist_side_calf
9401       enddo
9402 C now sscale fraction
9403        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
9404 C       print *,buff_shield,"buff"
9405 C now sscale
9406         if (sh_frac_dist.le.0.0) cycle
9407 C If we reach here it means that this side chain reaches the shielding sphere
9408 C Lets add him to the list for gradient
9409         ishield_list(i)=ishield_list(i)+1
9410 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
9411 C this list is essential otherwise problem would be O3
9412         shield_list(ishield_list(i),i)=k
9413 C Lets have the sscale value
9414         if (sh_frac_dist.gt.1.0) then
9415          scale_fac_dist=1.0d0
9416          do j=1,3
9417          sh_frac_dist_grad(j)=0.0d0
9418          enddo
9419         else
9420          scale_fac_dist=-sh_frac_dist*sh_frac_dist
9421      &                   *(2.0d0*sh_frac_dist-3.0d0)
9422          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
9423      &                  /dist_pep_side/buff_shield*0.5d0
9424 C remember for the final gradient multiply sh_frac_dist_grad(j)
9425 C for side_chain by factor -2 !
9426          do j=1,3
9427          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
9428 C         sh_frac_dist_grad(j)=0.0d0
9429 C         scale_fac_dist=1.0d0
9430 C         print *,"jestem",scale_fac_dist,fac_help_scale,
9431 C     &                    sh_frac_dist_grad(j)
9432          enddo
9433         endif
9434 C this is what is now we have the distance scaling now volume...
9435       short=short_r_sidechain(itype(k))
9436       long=long_r_sidechain(itype(k))
9437       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
9438       sinthet=short/dist_pep_side*costhet
9439 C now costhet_grad
9440 C       costhet=0.6d0
9441 C       sinthet=0.8
9442        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
9443 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
9444 C     &             -short/dist_pep_side**2/costhet)
9445 C       costhet_fac=0.0d0
9446        do j=1,3
9447          costhet_grad(j)=costhet_fac*pep_side(j)
9448        enddo
9449 C remember for the final gradient multiply costhet_grad(j)
9450 C for side_chain by factor -2 !
9451 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
9452 C pep_side0pept_group is vector multiplication
9453       pep_side0pept_group=0.0d0
9454       do j=1,3
9455       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
9456       enddo
9457       cosalfa=(pep_side0pept_group/
9458      & (dist_pep_side*dist_side_calf))
9459       fac_alfa_sin=1.0d0-cosalfa**2
9460       fac_alfa_sin=dsqrt(fac_alfa_sin)
9461       rkprim=fac_alfa_sin*(long-short)+short
9462 C      rkprim=short
9463
9464 C now costhet_grad
9465        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
9466 C       cosphi=0.6
9467        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
9468        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
9469      &      dist_pep_side**2)
9470 C       sinphi=0.8
9471        do j=1,3
9472          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
9473      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9474      &*(long-short)/fac_alfa_sin*cosalfa/
9475      &((dist_pep_side*dist_side_calf))*
9476      &((side_calf(j))-cosalfa*
9477      &((pep_side(j)/dist_pep_side)*dist_side_calf))
9478 C       cosphi_grad_long(j)=0.0d0
9479         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
9480      &*(long-short)/fac_alfa_sin*cosalfa
9481      &/((dist_pep_side*dist_side_calf))*
9482      &(pep_side(j)-
9483      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
9484 C       cosphi_grad_loc(j)=0.0d0
9485        enddo
9486 C      print *,sinphi,sinthet
9487       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
9488      &                    /VSolvSphere_div
9489 C     &                    *wshield
9490 C now the gradient...
9491       do j=1,3
9492       grad_shield(j,i)=grad_shield(j,i)
9493 C gradient po skalowaniu
9494      &                +(sh_frac_dist_grad(j)*VofOverlap
9495 C  gradient po costhet
9496      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
9497      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9498      &       sinphi/sinthet*costhet*costhet_grad(j)
9499      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9500      & )*wshield
9501 C grad_shield_side is Cbeta sidechain gradient
9502       grad_shield_side(j,ishield_list(i),i)=
9503      &        (sh_frac_dist_grad(j)*(-2.0d0)
9504      &        *VofOverlap
9505      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9506      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
9507      &       sinphi/sinthet*costhet*costhet_grad(j)
9508      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
9509      &       )*wshield
9510
9511        grad_shield_loc(j,ishield_list(i),i)=
9512      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
9513      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
9514      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
9515      &        ))
9516      &        *wshield
9517       enddo
9518       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
9519       enddo
9520       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
9521 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
9522 c     &  " wshield",wshield
9523 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
9524       enddo
9525       return
9526       end
9527 C--------------------------------------------------------------------------
9528       double precision function tschebyshev(m,n,x,y)
9529       implicit none
9530       include "DIMENSIONS"
9531       integer i,m,n
9532       double precision x(n),y,yy(0:maxvar),aux
9533 c Tschebyshev polynomial. Note that the first term is omitted
9534 c m=0: the constant term is included
9535 c m=1: the constant term is not included
9536       yy(0)=1.0d0
9537       yy(1)=y
9538       do i=2,n
9539         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
9540       enddo
9541       aux=0.0d0
9542       do i=m,n
9543         aux=aux+x(i)*yy(i)
9544       enddo
9545       tschebyshev=aux
9546       return
9547       end
9548 C--------------------------------------------------------------------------
9549       double precision function gradtschebyshev(m,n,x,y)
9550       implicit none
9551       include "DIMENSIONS"
9552       integer i,m,n
9553       double precision x(n+1),y,yy(0:maxvar),aux
9554 c Tschebyshev polynomial. Note that the first term is omitted
9555 c m=0: the constant term is included
9556 c m=1: the constant term is not included
9557       yy(0)=1.0d0
9558       yy(1)=2.0d0*y
9559       do i=2,n
9560         yy(i)=2*y*yy(i-1)-yy(i-2)
9561       enddo
9562       aux=0.0d0
9563       do i=m,n
9564         aux=aux+x(i+1)*yy(i)*(i+1)
9565 C        print *, x(i+1),yy(i),i
9566       enddo
9567       gradtschebyshev=aux
9568       return
9569       end
9570 c----------------------------------------------------------------------------
9571       double precision function sscale2(r,r_cut,r0,rlamb)
9572       implicit none
9573       double precision r,gamm,r_cut,r0,rlamb,rr
9574       rr = dabs(r-r0)
9575 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
9576 c      write (2,*) "rr",rr
9577       if(rr.lt.r_cut-rlamb) then
9578         sscale2=1.0d0
9579       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9580         gamm=(rr-(r_cut-rlamb))/rlamb
9581         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
9582       else
9583         sscale2=0d0
9584       endif
9585       return
9586       end
9587 C-----------------------------------------------------------------------
9588       double precision function sscalgrad2(r,r_cut,r0,rlamb)
9589       implicit none
9590       double precision r,gamm,r_cut,r0,rlamb,rr
9591       rr = dabs(r-r0)
9592       if(rr.lt.r_cut-rlamb) then
9593         sscalgrad2=0.0d0
9594       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
9595         gamm=(rr-(r_cut-rlamb))/rlamb
9596         if (r.ge.r0) then
9597           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
9598         else
9599           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
9600         endif
9601       else
9602         sscalgrad2=0.0d0
9603       endif
9604       return
9605       end
9606 c----------------------------------------------------------------------------
9607       subroutine e_saxs(Esaxs_constr)
9608       implicit none
9609       include 'DIMENSIONS'
9610       include 'DIMENSIONS.ZSCOPT'
9611       include 'DIMENSIONS.FREE'
9612 #ifdef MPI
9613       include "mpif.h"
9614       include "COMMON.SETUP"
9615       integer IERR
9616 #endif
9617       include 'COMMON.SBRIDGE'
9618       include 'COMMON.CHAIN'
9619       include 'COMMON.GEO'
9620       include 'COMMON.LOCAL'
9621       include 'COMMON.INTERACT'
9622       include 'COMMON.VAR'
9623       include 'COMMON.IOUNITS'
9624       include 'COMMON.DERIV'
9625       include 'COMMON.CONTROL'
9626       include 'COMMON.NAMES'
9627       include 'COMMON.FFIELD'
9628       include 'COMMON.LANGEVIN'
9629 c
9630       double precision Esaxs_constr
9631       integer i,iint,j,k,l
9632       double precision PgradC(maxSAXS,3,maxres),
9633      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
9634 #ifdef MPI
9635       double precision PgradC_(maxSAXS,3,maxres),
9636      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
9637 #endif
9638       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
9639      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
9640      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
9641      & auxX,auxX1,CACAgrad,Cnorm
9642       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
9643       double precision dist
9644       external dist
9645 c  SAXS restraint penalty function
9646 #ifdef DEBUG
9647       write(iout,*) "------- SAXS penalty function start -------"
9648       write (iout,*) "nsaxs",nsaxs
9649       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
9650       write (iout,*) "Psaxs"
9651       do i=1,nsaxs
9652         write (iout,'(i5,e15.5)') i, Psaxs(i)
9653       enddo
9654 #endif
9655       Esaxs_constr = 0.0d0
9656       do k=1,nsaxs
9657         Pcalc(k)=0.0d0
9658         do j=1,nres
9659           do l=1,3
9660             PgradC(k,l,j)=0.0d0
9661             PgradX(k,l,j)=0.0d0
9662           enddo
9663         enddo
9664       enddo
9665       do i=iatsc_s,iatsc_e
9666        if (itype(i).eq.ntyp1) cycle
9667        do iint=1,nint_gr(i)
9668          do j=istart(i,iint),iend(i,iint)
9669            if (itype(j).eq.ntyp1) cycle
9670 #ifdef ALLSAXS
9671            dijCACA=dist(i,j)
9672            dijCASC=dist(i,j+nres)
9673            dijSCCA=dist(i+nres,j)
9674            dijSCSC=dist(i+nres,j+nres)
9675            sigma2CACA=2.0d0/(pstok**2)
9676            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
9677            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
9678            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
9679            do k=1,nsaxs
9680              dk = distsaxs(k)
9681              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9682              if (itype(j).ne.10) then
9683              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
9684              else
9685              endif
9686              expCASC = 0.0d0
9687              if (itype(i).ne.10) then
9688              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
9689              else
9690              expSCCA = 0.0d0
9691              endif
9692              if (itype(i).ne.10 .and. itype(j).ne.10) then
9693              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
9694              else
9695              expSCSC = 0.0d0
9696              endif
9697              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
9698 #ifdef DEBUG
9699              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9700 #endif
9701              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9702              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
9703              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
9704              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
9705              do l=1,3
9706 c CA CA
9707                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9708                PgradC(k,l,i) = PgradC(k,l,i)-aux
9709                PgradC(k,l,j) = PgradC(k,l,j)+aux
9710 c CA SC
9711                if (itype(j).ne.10) then
9712                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
9713                PgradC(k,l,i) = PgradC(k,l,i)-aux
9714                PgradC(k,l,j) = PgradC(k,l,j)+aux
9715                PgradX(k,l,j) = PgradX(k,l,j)+aux
9716                endif
9717 c SC CA
9718                if (itype(i).ne.10) then
9719                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
9720                PgradX(k,l,i) = PgradX(k,l,i)-aux
9721                PgradC(k,l,i) = PgradC(k,l,i)-aux
9722                PgradC(k,l,j) = PgradC(k,l,j)+aux
9723                endif
9724 c SC SC
9725                if (itype(i).ne.10 .and. itype(j).ne.10) then
9726                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
9727                PgradC(k,l,i) = PgradC(k,l,i)-aux
9728                PgradC(k,l,j) = PgradC(k,l,j)+aux
9729                PgradX(k,l,i) = PgradX(k,l,i)-aux
9730                PgradX(k,l,j) = PgradX(k,l,j)+aux
9731                endif
9732              enddo ! l
9733            enddo ! k
9734 #else
9735            dijCACA=dist(i,j)
9736            sigma2CACA=scal_rad**2*0.25d0/
9737      &        (restok(itype(j))**2+restok(itype(i))**2)
9738
9739            IF (saxs_cutoff.eq.0) THEN
9740            do k=1,nsaxs
9741              dk = distsaxs(k)
9742              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
9743              Pcalc(k) = Pcalc(k)+expCACA
9744              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
9745              do l=1,3
9746                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9747                PgradC(k,l,i) = PgradC(k,l,i)-aux
9748                PgradC(k,l,j) = PgradC(k,l,j)+aux
9749              enddo ! l
9750            enddo ! k
9751            ELSE
9752            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
9753            do k=1,nsaxs
9754              dk = distsaxs(k)
9755 c             write (2,*) "ijk",i,j,k
9756              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
9757              if (sss2.eq.0.0d0) cycle
9758              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
9759              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
9760              Pcalc(k) = Pcalc(k)+expCACA
9761 #ifdef DEBUG
9762              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
9763 #endif
9764              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
9765      &             ssgrad2*expCACA/sss2
9766              do l=1,3
9767 c CA CA
9768                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
9769                PgradC(k,l,i) = PgradC(k,l,i)+aux
9770                PgradC(k,l,j) = PgradC(k,l,j)-aux
9771              enddo ! l
9772            enddo ! k
9773            ENDIF
9774 #endif
9775          enddo ! j
9776        enddo ! iint
9777       enddo ! i
9778 #ifdef MPI
9779       if (nfgtasks.gt.1) then
9780         call MPI_Reduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
9781      &    MPI_SUM,king,FG_COMM,IERR)
9782         if (fg_rank.eq.king) then
9783           do k=1,nsaxs
9784             Pcalc(k) = Pcalc_(k)
9785           enddo
9786         endif
9787         call MPI_Reduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
9788      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9789         if (fg_rank.eq.king) then
9790           do i=1,nres
9791             do l=1,3
9792               do k=1,nsaxs
9793                 PgradC(k,l,i) = PgradC_(k,l,i)
9794               enddo
9795             enddo
9796           enddo
9797         endif
9798 #ifdef ALLSAXS
9799         call MPI_Reduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
9800      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9801         if (fg_rank.eq.king) then
9802           do i=1,nres
9803             do l=1,3
9804               do k=1,nsaxs
9805                 PgradX(k,l,i) = PgradX_(k,l,i)
9806               enddo
9807             enddo
9808           enddo
9809         endif
9810 #endif
9811       endif
9812 #endif
9813 #ifdef MPI
9814       if (fg_rank.eq.king) then
9815 #endif
9816       Cnorm = 0.0d0
9817       do k=1,nsaxs
9818         Cnorm = Cnorm + Pcalc(k)
9819       enddo
9820       Esaxs_constr = dlog(Cnorm)-wsaxs0
9821       do k=1,nsaxs
9822         if (Pcalc(k).gt.0.0d0)
9823      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
9824 #ifdef DEBUG
9825         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
9826 #endif
9827       enddo
9828 #ifdef DEBUG
9829       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
9830 #endif
9831       do i=nnt,nct
9832         do l=1,3
9833           auxC=0.0d0
9834           auxC1=0.0d0
9835           auxX=0.0d0
9836           auxX1=0.d0
9837           do k=1,nsaxs
9838             if (Pcalc(k).gt.0)
9839      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
9840             auxC1 = auxC1+PgradC(k,l,i)
9841 #ifdef ALLSAXS
9842             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
9843             auxX1 = auxX1+PgradX(k,l,i)
9844 #endif
9845           enddo
9846           gsaxsC(l,i) = auxC - auxC1/Cnorm
9847 #ifdef ALLSAXS
9848           gsaxsX(l,i) = auxX - auxX1/Cnorm
9849 #endif
9850 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
9851 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
9852         enddo
9853       enddo
9854 #ifdef MPI
9855       endif
9856 #endif
9857       return
9858       end
9859 c----------------------------------------------------------------------------
9860       subroutine e_saxsC(Esaxs_constr)
9861       implicit none
9862       include 'DIMENSIONS'
9863       include 'DIMENSIONS.ZSCOPT'
9864       include 'DIMENSIONS.FREE'
9865 #ifdef MPI
9866       include "mpif.h"
9867       include "COMMON.SETUP"
9868       integer IERR
9869 #endif
9870       include 'COMMON.SBRIDGE'
9871       include 'COMMON.CHAIN'
9872       include 'COMMON.GEO'
9873       include 'COMMON.LOCAL'
9874       include 'COMMON.INTERACT'
9875       include 'COMMON.VAR'
9876       include 'COMMON.IOUNITS'
9877       include 'COMMON.DERIV'
9878       include 'COMMON.CONTROL'
9879       include 'COMMON.NAMES'
9880       include 'COMMON.FFIELD'
9881       include 'COMMON.LANGEVIN'
9882 c
9883       double precision Esaxs_constr
9884       integer i,iint,j,k,l
9885       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
9886 #ifdef MPI
9887       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
9888 #endif
9889       double precision dk,dijCASPH,dijSCSPH,
9890      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
9891      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
9892      & auxX,auxX1,Cnorm
9893 c  SAXS restraint penalty function
9894 #ifdef DEBUG
9895       write(iout,*) "------- SAXS penalty function start -------"
9896       write (iout,*) "nsaxs",nsaxs," isaxs_start",isaxs_start,
9897      & " isaxs_end",isaxs_end
9898       write (iout,*) "nnt",nnt," ntc",nct
9899       do i=nnt,nct
9900         write(iout,'(a6,i5,3f10.5,5x,2f10.5)')
9901      &    "CA",i,(C(j,i),j=1,3),pstok,restok(itype(i))
9902       enddo
9903       do i=nnt,nct
9904         write(iout,'(a6,i5,3f10.5)')"CSaxs",i,(Csaxs(j,i),j=1,3)
9905       enddo
9906 #endif
9907       Esaxs_constr = 0.0d0
9908       logPtot=0.0d0
9909       do j=isaxs_start,isaxs_end
9910         Pcalc=0.0d0
9911         do i=1,nres
9912           do l=1,3
9913             PgradC(l,i)=0.0d0
9914             PgradX(l,i)=0.0d0
9915           enddo
9916         enddo
9917         do i=nnt,nct
9918           dijCASPH=0.0d0
9919           dijSCSPH=0.0d0
9920           do l=1,3
9921             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
9922           enddo
9923           if (itype(i).ne.10) then
9924           do l=1,3
9925             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
9926           enddo
9927           endif
9928           sigma2CA=2.0d0/pstok**2
9929           sigma2SC=4.0d0/restok(itype(i))**2
9930           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
9931           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
9932           Pcalc = Pcalc+expCASPH+expSCSPH
9933 #ifdef DEBUG
9934           write(*,*) "processor i j Pcalc",
9935      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
9936 #endif
9937           CASPHgrad = sigma2CA*expCASPH
9938           SCSPHgrad = sigma2SC*expSCSPH
9939           do l=1,3
9940             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
9941             PgradX(l,i) = PgradX(l,i) + aux
9942             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
9943           enddo ! l
9944         enddo ! i
9945         do i=nnt,nct
9946           do l=1,3
9947             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
9948             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
9949           enddo
9950         enddo
9951         logPtot = logPtot - dlog(Pcalc)
9952 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
9953 c     &    " logPtot",logPtot
9954       enddo ! j
9955 #ifdef MPI
9956       if (nfgtasks.gt.1) then
9957 c        write (iout,*) "logPtot before reduction",logPtot
9958         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
9959      &    MPI_SUM,king,FG_COMM,IERR)
9960         logPtot = logPtot_
9961 c        write (iout,*) "logPtot after reduction",logPtot
9962         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
9963      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9964         if (fg_rank.eq.king) then
9965           do i=1,nres
9966             do l=1,3
9967               gsaxsC(l,i) = gsaxsC_(l,i)
9968             enddo
9969           enddo
9970         endif
9971         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
9972      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
9973         if (fg_rank.eq.king) then
9974           do i=1,nres
9975             do l=1,3
9976               gsaxsX(l,i) = gsaxsX_(l,i)
9977             enddo
9978           enddo
9979         endif
9980       endif
9981 #endif
9982       Esaxs_constr = logPtot
9983       return
9984       end
9985