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

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