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