source/maxlik/src_FPy.org/energy_p_new_sc.F

   1       subroutine etotal(energia)
   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       include 'COMMON.WEIGHTS'
  24       include 'COMMON.WEIGHTDER'
  25 c      write(iout, '(a,i2)')'Calling etotal ipot=',ipot
  26 c      call flush(iout)
  27 cd    print *,'nnt=',nnt,' nct=',nct
  28 C
  29 C Compute the side-chain and electrostatic interaction energy
  30 C
  31       evdw_t=0.0d0
  32       goto (101,102,103,104,105,106) ipot
  33 C Lennard-Jones potential.
  34   101 call elj(evdw)
  35 cd    print '(a)','Exit ELJ'
  36       goto 107
  37 C Lennard-Jones-Kihara potential (shifted).
  38   102 call eljk(evdw)
  39       goto 107
  40 C Berne-Pechukas potential (dilated LJ, angular dependence).
  41   103 call ebp(evdw)
  42       goto 107
  43 C Gay-Berne potential (shifted LJ, angular dependence).
  44   104 call egb(evdw)
  45       goto 107
  46 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
  47   105 call egbv(evdw)
  48       goto 107
  49 C New SC-SC potential
  50   106 call emomo(evdw,evdw_p,evdw_m)
  51 C
  52 C Calculate electrostatic (H-bonding) energy of the main chain.
  53 C
  54   107 continue
  55       call vec_and_deriv
  56       if (shield_mode.eq.1) then
  57        call set_shield_fac
  58       else if  (shield_mode.eq.2) then
  59        call set_shield_fac2
  60       endif
  61       call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
  62 C            write(iout,*) 'po eelec'
  63
  64 C Calculate excluded-volume interaction energy between peptide groups
  65 C and side chains.
  66 C
  67       call escp(evdw2,evdw2_14)
  68 c
  69 c Calculate the bond-stretching energy
  70 c
  71
  72       call ebond(estr)
  73 C       write (iout,*) "estr",estr
  74 C
  75 C Calculate the disulfide-bridge and other energy and the contributions
  76 C from other distance constraints.
  77 cd    print *,'Calling EHPB'
  78       call edis(ehpb)
  79 cd    print *,'EHPB exitted succesfully.'
  80 C
  81 C Calculate the virtual-bond-angle energy.
  82 C
  83 C      print *,'Bend energy finished.'
  84       if (wang.gt.0d0) then
  85        if (tor_mode.eq.0) then
  86          call ebend(ebe)
  87        else
  88 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
  89 C energy function
  90          call ebend_kcc(ebe)
  91        endif
  92       else
  93         ebe=0.0d0
  94       endif
  95       ethetacnstr=0.0d0
  96       if (with_theta_constr) call etheta_constr(ethetacnstr)
  97 c      call ebend(ebe,ethetacnstr)
  98 cd    print *,'Bend energy finished.'
  99 C
 100 C Calculate the SC local energy.
 101 C
 102       call esc(escloc)
 103 C       print *,'SCLOC energy finished.'
 104 C
 105 C Calculate the virtual-bond torsional energy.
 106 C
 107       if (wtor.gt.0.0d0) then
 108          if (tor_mode.eq.0) then
 109            call etor(etors)
 110          else
 111 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 112 C energy function
 113            call etor_kcc(etors)
 114          endif
 115       else
 116         etors=0.0d0
 117       endif
 118       edihcnstr=0.0d0
 119       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 120 c      print *,"Processor",myrank," computed Utor"
 121 C
 122 C 6/23/01 Calculate double-torsional energy
 123 C
 124       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 125         call etor_d(etors_d)
 126       else
 127         etors_d=0
 128       endif
 129 c      print *,"Processor",myrank," computed Utord"
 130 C
 131       call eback_sc_corr(esccor)
 132
 133       if (wliptran.gt.0) then
 134         call Eliptransfer(eliptran)
 135       endif
 136
 137 C
 138 C 12/1/95 Multi-body terms
 139 C
 140       n_corr=0
 141       n_corr1=0
 142       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 143      &    .or. wturn6.gt.0.0d0) then
 144 c         write(iout,*)"calling multibody_eello"
 145          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 146 c         write (iout,*) 'n_corr=',n_corr,' n_corr1=',n_corr1
 147 c         write (iout,*) ecorr,ecorr5,ecorr6,eturn6
 148       else
 149          ecorr=0.0d0
 150          ecorr5=0.0d0
 151          ecorr6=0.0d0
 152          eturn6=0.0d0
 153       endif
 154       if (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) then
 155 c         write (iout,*) "Calling multibody_hbond"
 156          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 157       endif
 158 #ifdef DEBUG
 159       write (iout,*) "evdw",evdw," evdw_t",evdw_t," ees",ees,
 160      & " evdw1",evdw1," ebe",ebe," etors",etors," escloc",escloc,
 161      & " ehpb",ehpb," ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6,
 162      & " eello_turn4",eello_turn4," eello_turn3",eello_turn3,
 163      & " eturn6",eturn6," eel_loc",eel_loc," edihcnstr",edihcnstr,
 164      & " etors_d",etors_d," estr",estr," esccor",esccor," ethetacnstr",
 165      & ethetacnstr," eliptran",eliptran
 166       write (iout,*) "wsc",wsc," welec",welec,
 167      & " wvdwpp",wvdwpp," wang",wang," wtor",wtor," wscloc",wscloc,
 168      & " wstrain",wstrain," wcorr",wcorr," wcorr5",wcorr5,
 169      & " wcorr6",wcorr6,
 170      & " wturn4",wturn4," wturn3",wturn3,
 171      & " wturn6",wturn6," wel_loc",wel_loc,
 172      & " wtor_d",wtor_d," wbon",wbond," wsccor",wsccor,
 173      & " wliptran",wliptran
 174 #endif
 175 #ifdef SPLITELE
 176       if (shield_mode.gt.0) then
 177       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 178      & +welec*ees
 179      & +wvdwpp*evdw1
 180      & +wang*ebe+wtor*etors+wscloc*escloc
 181      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 182      & +wcorr6*ecorr6+wturn4*eello_turn4
 183      & +wturn3*eello_turn3+wturn6*eturn6
 184      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 185      & +wbond*estr+wsccor*esccor+ethetacnstr
 186      & +wliptran*eliptran
 187       else
 188       etot=wsc*(evdw+evdw_t)+wscp*evdw2+welec*ees
 189      & +wvdwpp*evdw1
 190      & +wang*ebe+wtor*etors+wscloc*escloc
 191      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 192      & +wcorr6*ecorr6+wturn4*eello_turn4
 193      & +wturn3*eello_turn3+wturn6*eturn6
 194      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 195      & +wbond*estr+wsccor*esccor+ethetacnstr
 196      & +wliptran*eliptran
 197       endif
 198 #else
 199       if (shield_mode.gt.0) then
 200       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 201      & +welec*(ees+evdw1)
 202      & +wang*ebe+wtor*etors+wscloc*escloc
 203      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 204      & +wcorr6*ecorr6+wturn4*eello_turn4
 205      & +wturn3*eello_turn3+wturn6*eturn6
 206      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 207      & +wbond*estr+wsccor*esccor+ethetacnstr
 208      & +wliptran*eliptran
 209       else
 210       etot=wsc*(evdw+evdw_t)+wscp*evdw2
 211      & +welec*(ees+evdw1)
 212      & +wang*ebe+wtor*etors+wscloc*escloc
 213      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 214      & +wcorr6*ecorr6+wturn4*eello_turn4
 215      & +wturn3*eello_turn3+wturn6*eturn6
 216      & +wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 217      & +wbond*estr+wsccor*esccor+ethetacnstr
 218      & +wliptran*eliptran
 219       endif
 220 #endif
 221 #ifdef DEBUG
 222       write (iout,*) "etot",etot
 223 #endif
 224       energia(0)=etot
 225       energia(1)=evdw
 226 #ifdef SCP14
 227       energia(2)=evdw2-evdw2_14
 228       energia(17)=evdw2_14
 229 #else
 230       energia(2)=evdw2
 231       energia(17)=0.0d0
 232 #endif
 233 #ifdef SPLITELE
 234       energia(3)=ees
 235       energia(16)=evdw1
 236 #else
 237       energia(3)=ees+evdw1
 238       energia(16)=0.0d0
 239 #endif
 240       energia(4)=ecorr
 241       energia(5)=ecorr5
 242       energia(6)=ecorr6
 243       energia(7)=eel_loc
 244       energia(8)=eello_turn3
 245       energia(9)=eello_turn4
 246       energia(10)=eturn6
 247       energia(11)=ebe
 248       energia(12)=escloc
 249       energia(13)=etors
 250       energia(14)=etors_d
 251       energia(15)=ehpb
 252       energia(18)=estr
 253       energia(19)=esccor
 254       energia(20)=edihcnstr
 255       energia(21)=evdw_t
 256       energia(24)=ethetacnstr
 257       energia(22)=eliptran
 258 c detecting NaNQ
 259 #ifdef ISNAN
 260 #ifdef AIX
 261       if (isnan(etot).ne.0) energia(0)=1.0d+99
 262 #else
 263       if (isnan(etot)) energia(0)=1.0d+99
 264 #endif
 265 #else
 266       i=0
 267 #ifdef WINPGI
 268       idumm=proc_proc(etot,i)
 269 #else
 270       call proc_proc(etot,i)
 271 #endif
 272       if(i.eq.1)energia(0)=1.0d+99
 273 #endif
 274 #ifdef MPL
 275 c     endif
 276 #endif
 277 #ifdef DEBUG
 278       call enerprint(energia)
 279 #endif
 280       if (calc_grad) then
 281 C
 282 C Sum up the components of the Cartesian gradient.
 283 C
 284 #ifdef SPLITELE
 285       do i=1,nct
 286         do j=1,3
 287       if (shield_mode.eq.0) then
 288           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 289      &                welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 290      &                wbond*gradb(j,i)+
 291      &                wstrain*ghpbc(j,i)+
 292      &                wcorr*gradcorr(j,i)+
 293      &                wel_loc*gel_loc(j,i)+
 294      &                wturn3*gcorr3_turn(j,i)+
 295      &                wturn4*gcorr4_turn(j,i)+
 296      &                wcorr5*gradcorr5(j,i)+
 297      &                wcorr6*gradcorr6(j,i)+
 298      &                wturn6*gcorr6_turn(j,i)+
 299      &                wsccor*gsccorc(j,i)
 300      &               +wliptran*gliptranc(j,i)
 301           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 302      &                  wbond*gradbx(j,i)+
 303      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 304      &                  wsccor*gsccorx(j,i)
 305      &                 +wliptran*gliptranx(j,i)
 306         else
 307           gradc(j,i,icg)=wsc*gvdwc(j,i)
 308      &                +wscp*gvdwc_scp(j,i)+
 309      &               welec*gelc(j,i)+wvdwpp*gvdwpp(j,i)+
 310      &                wbond*gradb(j,i)+
 311      &                wstrain*ghpbc(j,i)+
 312      &                wcorr*gradcorr(j,i)+
 313      &                wel_loc*gel_loc(j,i)+
 314      &                wturn3*gcorr3_turn(j,i)+
 315      &                wturn4*gcorr4_turn(j,i)+
 316      &                wcorr5*gradcorr5(j,i)+
 317      &                wcorr6*gradcorr6(j,i)+
 318      &                wturn6*gcorr6_turn(j,i)+
 319      &                wsccor*gsccorc(j,i)
 320      &               +wliptran*gliptranc(j,i)
 321      &                 +welec*gshieldc(j,i)
 322      &                 +welec*gshieldc_loc(j,i)
 323      &                 +wcorr*gshieldc_ec(j,i)
 324      &                 +wcorr*gshieldc_loc_ec(j,i)
 325      &                 +wturn3*gshieldc_t3(j,i)
 326      &                 +wturn3*gshieldc_loc_t3(j,i)
 327      &                 +wturn4*gshieldc_t4(j,i)
 328      &                 +wturn4*gshieldc_loc_t4(j,i)
 329      &                 +wel_loc*gshieldc_ll(j,i)
 330      &                 +wel_loc*gshieldc_loc_ll(j,i)
 331
 332           gradx(j,i,icg)=wsc*gvdwx(j,i)
 333      &                 +wscp*gradx_scp(j,i)+
 334      &                  wbond*gradbx(j,i)+
 335      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 336      &                  wsccor*gsccorx(j,i)
 337      &                 +wliptran*gliptranx(j,i)
 338      &                 +welec*gshieldx(j,i)
 339      &                 +wcorr*gshieldx_ec(j,i)
 340      &                 +wturn3*gshieldx_t3(j,i)
 341      &                 +wturn4*gshieldx_t4(j,i)
 342      &                 +wel_loc*gshieldx_ll(j,i)
 343
 344
 345         endif
 346         enddo
 347 #else
 348       do i=1,nct
 349         do j=1,3
 350                 if (shield_mode.eq.0) then
 351           gradc(j,i,icg)=wsc*gvdwc(j,i)+wscp*gvdwc_scp(j,i)+
 352      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 353      &                wbond*gradb(j,i)+
 354      &                wcorr*gradcorr(j,i)+
 355      &                wel_loc*gel_loc(j,i)+
 356      &                wturn3*gcorr3_turn(j,i)+
 357      &                wturn4*gcorr4_turn(j,i)+
 358      &                wcorr5*gradcorr5(j,i)+
 359      &                wcorr6*gradcorr6(j,i)+
 360      &                wturn6*gcorr6_turn(j,i)+
 361      &                wsccor*gsccorc(j,i)
 362      &               +wliptran*gliptranc(j,i)
 363           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 364      &                  wbond*gradbx(j,i)+
 365      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 366      &                  wsccor*gsccorx(j,i)
 367      &                 +wliptran*gliptranx(j,i)
 368               else
 369           gradc(j,i,icg)=wsc*gvdwc(j,i)+
 370      &                   wscp*gvdwc_scp(j,i)+
 371      &                welec*gelc(j,i)+wstrain*ghpbc(j,i)+
 372      &                wbond*gradb(j,i)+
 373      &                wcorr*gradcorr(j,i)+
 374      &                wel_loc*gel_loc(j,i)+
 375      &                wturn3*gcorr3_turn(j,i)+
 376      &                wturn4*gcorr4_turn(j,i)+
 377      &                wcorr5*gradcorr5(j,i)+
 378      &                wcorr6*gradcorr6(j,i)+
 379      &                wturn6*gcorr6_turn(j,i)+
 380      &                wsccor*gsccorc(j,i)
 381      &               +wliptran*gliptranc(j,i)
 382      &                 +welec*gshieldc(j,i)
 383      &                 +welec*gshieldc_loc(j,i)
 384      &                 +wcorr*gshieldc_ec(j,i)
 385      &                 +wcorr*gshieldc_loc_ec(j,i)
 386      &                 +wturn3*gshieldc_t3(j,i)
 387      &                 +wturn3*gshieldc_loc_t3(j,i)
 388      &                 +wturn4*gshieldc_t4(j,i)
 389      &                 +wturn4*gshieldc_loc_t4(j,i)
 390      &                 +wel_loc*gshieldc_ll(j,i)
 391      &                 +wel_loc*gshieldc_loc_ll(j,i)
 392
 393           gradx(j,i,icg)=wsc*gvdwx(j,i)+
 394      &                  wscp*gradx_scp(j,i)+
 395      &                  wbond*gradbx(j,i)+
 396      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 397      &                  wsccor*gsccorx(j,i)
 398      &                 +wliptran*gliptranx(j,i)
 399      &                 +welec*gshieldx(j,i)
 400      &                 +wcorr*gshieldx_ec(j,i)
 401      &                 +wturn3*gshieldx_t3(j,i)
 402      &                 +wturn4*gshieldx_t4(j,i)
 403      &                 +wel_loc*gshieldx_ll(j,i)
 404
 405          endif
 406         enddo
 407 #endif
 408       enddo
 409
 410
 411       do i=1,nres-3
 412         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 413      &   +wcorr5*g_corr5_loc(i)
 414      &   +wcorr6*g_corr6_loc(i)
 415      &   +wturn4*gel_loc_turn4(i)
 416      &   +wturn3*gel_loc_turn3(i)
 417      &   +wturn6*gel_loc_turn6(i)
 418      &   +wel_loc*gel_loc_loc(i)
 419 c     &   +wsccor*gsccor_loc(i)
 420 c BYLA ROZNICA Z CLUSTER< OSTATNIA LINIA DODANA
 421       enddo
 422       endif
 423 c      if (dyn_ss) call dyn_set_nss
 424       return
 425       end
 426 C------------------------------------------------------------------------
 427       subroutine enerprint(energia)
 428       implicit real*8 (a-h,o-z)
 429       include 'DIMENSIONS'
 430       include 'DIMENSIONS.ZSCOPT'
 431       include 'COMMON.IOUNITS'
 432       include 'COMMON.FFIELD'
 433       include 'COMMON.SBRIDGE'
 434       double precision energia(0:max_ene)
 435       etot=energia(0)
 436       evdw=energia(1)+energia(21)
 437 #ifdef SCP14
 438       evdw2=energia(2)+energia(17)
 439 #else
 440       evdw2=energia(2)
 441 #endif
 442       ees=energia(3)
 443 #ifdef SPLITELE
 444       evdw1=energia(16)
 445 #endif
 446       ecorr=energia(4)
 447       ecorr5=energia(5)
 448       ecorr6=energia(6)
 449       eel_loc=energia(7)
 450       eello_turn3=energia(8)
 451       eello_turn4=energia(9)
 452       eello_turn6=energia(10)
 453       ebe=energia(11)
 454       escloc=energia(12)
 455       etors=energia(13)
 456       etors_d=energia(14)
 457       ehpb=energia(15)
 458       esccor=energia(19)
 459       edihcnstr=energia(20)
 460       estr=energia(18)
 461       ethetacnstr=energia(24)
 462       eliptran=energia(22)
 463 #ifdef SPLITELE
 464       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,
 465      &  wvdwpp,
 466      &  estr,wbond,ebe,wang,escloc,wscloc,etors,wtor,
 467      &  etors_d,wtor_d,ehpb,wstrain,
 468      &  ecorr,wcorr,ecorr5,wcorr5,ecorr6,wcorr6,
 469      &  eel_loc,wel_loc,eello_turn3,wturn3,
 470      &  eello_turn4,wturn4,eello_turn6,wturn6,
 471      &  esccor,wsccor,edihcnstr,ethetacnstr,ebr*nss,
 472      & eliptran,wliptran,etot
 473    10 format (/'Virtual-chain energies:'//
 474      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 475      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 476      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p elec)'/
 477      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 478      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 479      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 480      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 481      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 482      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 483      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 484      & ' (SS bridges & dist. cnstr.)'/
 485      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 486      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 487      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 488      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 489      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 490      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 491      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 492      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 493      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 494      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 495      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 496      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 497      & 'ETOT=  ',1pE16.6,' (total)')
 498 #else
 499       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,estr,wbond,
 500      &  ebe,wang,escloc,wscloc,etors,wtor,etors_d,wtor_d,
 501      &  ehpb,wstrain,ecorr,wcorr,ecorr5,wcorr5,
 502      &  ecorr6,wcorr6,eel_loc,wel_loc,
 503      &  eello_turn3,wturn3,eello_turn4,wturn4,
 504      &  eello_turn6,wturn6,esccor,wsccor,
 505      &  edihcnstr,ethetacnstr,ebr*nss,eliptran,wliptran,etot
 506    10 format (/'Virtual-chain energies:'//
 507      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 508      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 509      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 510      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 511      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 512      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 513      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 514      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 515      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 516      & ' (SS bridges & dist. cnstr.)'/
 517      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 518      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 519      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 520      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
 521      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
 522      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
 523      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
 524      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
 525      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
 526      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
 527      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
 528      & 'ELT=',1pE16.6, ' WEIGHT=',1pD16.6,' (Lipid transfer energy)'/
 529      & 'ETOT=  ',1pE16.6,' (total)')
 530 #endif
 531       return
 532       end
 533 C-----------------------------------------------------------------------
 534       subroutine elj(evdw)
 535 C
 536 C This subroutine calculates the interaction energy of nonbonded side chains
 537 C assuming the LJ potential of interaction.
 538 C
 539       implicit real*8 (a-h,o-z)
 540       include 'DIMENSIONS'
 541       include 'DIMENSIONS.ZSCOPT'
 542       parameter (accur=1.0d-10)
 543       include 'COMMON.GEO'
 544       include 'COMMON.VAR'
 545       include 'COMMON.LOCAL'
 546       include 'COMMON.CHAIN'
 547       include 'COMMON.DERIV'
 548       include 'COMMON.INTERACT'
 549       include 'COMMON.TORSION'
 550       include 'COMMON.WEIGHTDER'
 551       include 'COMMON.SBRIDGE'
 552       include 'COMMON.NAMES'
 553       include 'COMMON.IOUNITS'
 554       include 'COMMON.CONTACTS'
 555       dimension gg(3)
 556       integer icant
 557       external icant
 558 cd    print *,'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
 559       do i=1,nntyp
 560         do j=1,2
 561           eneps_temp(j,i)=0.0d0
 562         enddo
 563       enddo
 564       evdw=0.0D0
 565       do i=iatsc_s,iatsc_e
 566         itypi=itype(i)
 567         itypi1=itype(i+1)
 568         xi=c(1,nres+i)
 569         yi=c(2,nres+i)
 570         zi=c(3,nres+i)
 571 C Change 12/1/95
 572         num_conti=0
 573 C
 574 C Calculate SC interaction energy.
 575 C
 576         do iint=1,nint_gr(i)
 577 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
 578 cd   &                  'iend=',iend(i,iint)
 579           do j=istart(i,iint),iend(i,iint)
 580             itypj=itype(j)
 581             xj=c(1,nres+j)-xi
 582             yj=c(2,nres+j)-yi
 583             zj=c(3,nres+j)-zi
 584 C Change 12/1/95 to calculate four-body interactions
 585             rij=xj*xj+yj*yj+zj*zj
 586             rrij=1.0D0/rij
 587 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
 588             eps0ij=eps(itypi,itypj)
 589             fac=rrij**expon2
 590             e1=fac*fac*aa(itypi,itypj)
 591             e2=fac*bb(itypi,itypj)
 592             evdwij=e1+e2
 593             ij=icant(itypi,itypj)
 594             eneps_temp(1,ij)=eneps_temp(1,ij)+e1/dabs(eps0ij)
 595             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps0ij
 596 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 597 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 598 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
 599 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 600 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
 601 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 602             evdw=evdw+evdwij
 603             if (calc_grad) then
 604 C
 605 C Calculate the components of the gradient in DC and X
 606 C
 607             fac=-rrij*(e1+evdwij)
 608             gg(1)=xj*fac
 609             gg(2)=yj*fac
 610             gg(3)=zj*fac
 611             do k=1,3
 612               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 613               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 614             enddo
 615             do k=i,j-1
 616               do l=1,3
 617                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 618               enddo
 619             enddo
 620             endif
 621 C
 622 C 12/1/95, revised on 5/20/97
 623 C
 624 C Calculate the contact function. The ith column of the array JCONT will
 625 C contain the numbers of atoms that make contacts with the atom I (of numbers
 626 C greater than I). The arrays FACONT and GACONT will contain the values of
 627 C the contact function and its derivative.
 628 C
 629 C Uncomment next line, if the correlation interactions include EVDW explicitly.
 630 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
 631 C Uncomment next line, if the correlation interactions are contact function only
 632             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
 633               rij=dsqrt(rij)
 634               sigij=sigma(itypi,itypj)
 635               r0ij=rs0(itypi,itypj)
 636 C
 637 C Check whether the SC's are not too far to make a contact.
 638 C
 639               rcut=1.5d0*r0ij
 640               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
 641 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
 642 C
 643               if (fcont.gt.0.0D0) then
 644 C If the SC-SC distance if close to sigma, apply spline.
 645 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
 646 cAdam &             fcont1,fprimcont1)
 647 cAdam           fcont1=1.0d0-fcont1
 648 cAdam           if (fcont1.gt.0.0d0) then
 649 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
 650 cAdam             fcont=fcont*fcont1
 651 cAdam           endif
 652 C Uncomment following 4 lines to have the geometric average of the epsilon0's
 653 cga             eps0ij=1.0d0/dsqrt(eps0ij)
 654 cga             do k=1,3
 655 cga               gg(k)=gg(k)*eps0ij
 656 cga             enddo
 657 cga             eps0ij=-evdwij*eps0ij
 658 C Uncomment for AL's type of SC correlation interactions.
 659 cadam           eps0ij=-evdwij
 660                 num_conti=num_conti+1
 661                 jcont(num_conti,i)=j
 662                 facont(num_conti,i)=fcont*eps0ij
 663                 fprimcont=eps0ij*fprimcont/rij
 664                 fcont=expon*fcont
 665 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
 666 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
 667 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
 668 C Uncomment following 3 lines for Skolnick's type of SC correlation.
 669                 gacont(1,num_conti,i)=-fprimcont*xj
 670                 gacont(2,num_conti,i)=-fprimcont*yj
 671                 gacont(3,num_conti,i)=-fprimcont*zj
 672 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
 673 cd              write (iout,'(2i3,3f10.5)')
 674 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
 675               endif
 676             endif
 677           enddo      ! j
 678         enddo        ! iint
 679 C Change 12/1/95
 680         num_cont(i)=num_conti
 681       enddo          ! i
 682       if (calc_grad) then
 683       do i=1,nct
 684         do j=1,3
 685           gvdwc(j,i)=expon*gvdwc(j,i)
 686           gvdwx(j,i)=expon*gvdwx(j,i)
 687         enddo
 688       enddo
 689       endif
 690 C******************************************************************************
 691 C
 692 C                              N O T E !!!
 693 C
 694 C To save time, the factor of EXPON has been extracted from ALL components
 695 C of GVDWC and GRADX. Remember to multiply them by this factor before further
 696 C use!
 697 C
 698 C******************************************************************************
 699       return
 700       end
 701 C-----------------------------------------------------------------------------
 702       subroutine eljk(evdw)
 703 C
 704 C This subroutine calculates the interaction energy of nonbonded side chains
 705 C assuming the LJK potential of interaction.
 706 C
 707       implicit real*8 (a-h,o-z)
 708       include 'DIMENSIONS'
 709       include 'DIMENSIONS.ZSCOPT'
 710       include 'COMMON.GEO'
 711       include 'COMMON.VAR'
 712       include 'COMMON.LOCAL'
 713       include 'COMMON.CHAIN'
 714       include 'COMMON.DERIV'
 715       include 'COMMON.INTERACT'
 716       include 'COMMON.WEIGHTDER'
 717       include 'COMMON.IOUNITS'
 718       include 'COMMON.NAMES'
 719       dimension gg(3)
 720       logical scheck
 721       integer icant
 722       external icant
 723 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
 724       do i=1,nntyp
 725         do j=1,2
 726           eneps_temp(j,i)=0.0d0
 727         enddo
 728       enddo
 729       evdw=0.0D0
 730       do i=iatsc_s,iatsc_e
 731         itypi=itype(i)
 732         itypi1=itype(i+1)
 733         xi=c(1,nres+i)
 734         yi=c(2,nres+i)
 735         zi=c(3,nres+i)
 736 C
 737 C Calculate SC interaction energy.
 738 C
 739         do iint=1,nint_gr(i)
 740           do j=istart(i,iint),iend(i,iint)
 741             itypj=itype(j)
 742             xj=c(1,nres+j)-xi
 743             yj=c(2,nres+j)-yi
 744             zj=c(3,nres+j)-zi
 745             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 746             fac_augm=rrij**expon
 747             e_augm=augm(itypi,itypj)*fac_augm
 748             r_inv_ij=dsqrt(rrij)
 749             rij=1.0D0/r_inv_ij
 750             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
 751             fac=r_shift_inv**expon
 752             e1=fac*fac*aa(itypi,itypj)
 753             e2=fac*bb(itypi,itypj)
 754             evdwij=e_augm+e1+e2
 755             ij=icant(itypi,itypj)
 756             eneps_temp(1,ij)=eneps_temp(1,ij)+(e1+a_augm)
 757      &        /dabs(eps(itypi,itypj))
 758             eneps_temp(2,ij)=eneps_temp(2,ij)+e2/eps(itypi,itypj)
 759 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 760 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 761 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
 762 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
 763 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
 764 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
 765 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
 766             evdw=evdw+evdwij
 767             if (calc_grad) then
 768 C
 769 C Calculate the components of the gradient in DC and X
 770 C
 771             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
 772             gg(1)=xj*fac
 773             gg(2)=yj*fac
 774             gg(3)=zj*fac
 775             do k=1,3
 776               gvdwx(k,i)=gvdwx(k,i)-gg(k)
 777               gvdwx(k,j)=gvdwx(k,j)+gg(k)
 778             enddo
 779             do k=i,j-1
 780               do l=1,3
 781                 gvdwc(l,k)=gvdwc(l,k)+gg(l)
 782               enddo
 783             enddo
 784             endif
 785           enddo      ! j
 786         enddo        ! iint
 787       enddo          ! i
 788       if (calc_grad) then
 789       do i=1,nct
 790         do j=1,3
 791           gvdwc(j,i)=expon*gvdwc(j,i)
 792           gvdwx(j,i)=expon*gvdwx(j,i)
 793         enddo
 794       enddo
 795       endif
 796       return
 797       end
 798 C-----------------------------------------------------------------------------
 799       subroutine ebp(evdw)
 800 C
 801 C This subroutine calculates the interaction energy of nonbonded side chains
 802 C assuming the Berne-Pechukas potential of interaction.
 803 C
 804       implicit real*8 (a-h,o-z)
 805       include 'DIMENSIONS'
 806       include 'DIMENSIONS.ZSCOPT'
 807       include 'COMMON.GEO'
 808       include 'COMMON.VAR'
 809       include 'COMMON.LOCAL'
 810       include 'COMMON.CHAIN'
 811       include 'COMMON.DERIV'
 812       include 'COMMON.NAMES'
 813       include 'COMMON.INTERACT'
 814       include 'COMMON.WEIGHTDER'
 815       include 'COMMON.IOUNITS'
 816       include 'COMMON.CALC'
 817       common /srutu/ icall
 818 c     double precision rrsave(maxdim)
 819       logical lprn
 820       integer icant
 821       external icant
 822       do i=1,nntyp
 823         do j=1,2
 824           eneps_temp(j,i)=0.0d0
 825         enddo
 826       enddo
 827       evdw=0.0D0
 828 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
 829       evdw=0.0D0
 830 c     if (icall.eq.0) then
 831 c       lprn=.true.
 832 c     else
 833         lprn=.false.
 834 c     endif
 835       ind=0
 836       do i=iatsc_s,iatsc_e
 837         itypi=itype(i)
 838         itypi1=itype(i+1)
 839         xi=c(1,nres+i)
 840         yi=c(2,nres+i)
 841         zi=c(3,nres+i)
 842         dxi=dc_norm(1,nres+i)
 843         dyi=dc_norm(2,nres+i)
 844         dzi=dc_norm(3,nres+i)
 845         dsci_inv=vbld_inv(i+nres)
 846 C
 847 C Calculate SC interaction energy.
 848 C
 849         do iint=1,nint_gr(i)
 850           do j=istart(i,iint),iend(i,iint)
 851             ind=ind+1
 852             itypj=itype(j)
 853             dscj_inv=vbld_inv(j+nres)
 854             chi1=chi(itypi,itypj)
 855             chi2=chi(itypj,itypi)
 856             chi12=chi1*chi2
 857             chip1=chip(itypi)
 858             chip2=chip(itypj)
 859             chip12=chip1*chip2
 860             alf1=alp(itypi)
 861             alf2=alp(itypj)
 862             alf12=0.5D0*(alf1+alf2)
 863 C For diagnostics only!!!
 864 c           chi1=0.0D0
 865 c           chi2=0.0D0
 866 c           chi12=0.0D0
 867 c           chip1=0.0D0
 868 c           chip2=0.0D0
 869 c           chip12=0.0D0
 870 c           alf1=0.0D0
 871 c           alf2=0.0D0
 872 c           alf12=0.0D0
 873             xj=c(1,nres+j)-xi
 874             yj=c(2,nres+j)-yi
 875             zj=c(3,nres+j)-zi
 876             dxj=dc_norm(1,nres+j)
 877             dyj=dc_norm(2,nres+j)
 878             dzj=dc_norm(3,nres+j)
 879             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
 880 cd          if (icall.eq.0) then
 881 cd            rrsave(ind)=rrij
 882 cd          else
 883 cd            rrij=rrsave(ind)
 884 cd          endif
 885             rij=dsqrt(rrij)
 886 C Calculate the angle-dependent terms of energy & contributions to derivatives.
 887             call sc_angular
 888 C Calculate whole angle-dependent part of epsilon and contributions
 889 C to its derivatives
 890             fac=(rrij*sigsq)**expon2
 891             e1=fac*fac*aa(itypi,itypj)
 892             e2=fac*bb(itypi,itypj)
 893             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
 894             eps2der=evdwij*eps3rt
 895             eps3der=evdwij*eps2rt
 896             evdwij=evdwij*eps2rt*eps3rt
 897             ij=icant(itypi,itypj)
 898             aux=eps1*eps2rt**2*eps3rt**2
 899             eneps_temp(1,ij)=eneps_temp(1,ij)+e1*aux
 900      &        /dabs(eps(itypi,itypj))
 901             eneps_temp(2,ij)=eneps_temp(2,ij)+e2*aux/eps(itypi,itypj)
 902             evdw=evdw+evdwij
 903             if (calc_grad) then
 904             if (lprn) then
 905             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
 906             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
 907 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
 908 cd     &        restyp(itypi),i,restyp(itypj),j,
 909 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
 910 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
 911 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
 912 cd     &        evdwij
 913             endif
 914 C Calculate gradient components.
 915             e1=e1*eps1*eps2rt**2*eps3rt**2
 916             fac=-expon*(e1+evdwij)
 917             sigder=fac/sigsq
 918             fac=rrij*fac
 919 C Calculate radial part of the gradient
 920             gg(1)=xj*fac
 921             gg(2)=yj*fac
 922             gg(3)=zj*fac
 923 C Calculate the angular part of the gradient and sum add the contributions
 924 C to the appropriate components of the Cartesian gradient.
 925             call sc_grad
 926             endif
 927           enddo      ! j
 928         enddo        ! iint
 929       enddo          ! i
 930 c     stop
 931       return
 932       end
 933 C-----------------------------------------------------------------------------
 934       subroutine egb(evdw)
 935 C
 936 C This subroutine calculates the interaction energy of nonbonded side chains
 937 C assuming the Gay-Berne potential of interaction.
 938 C
 939       implicit real*8 (a-h,o-z)
 940       include 'DIMENSIONS'
 941       include 'DIMENSIONS.ZSCOPT'
 942       include 'COMMON.GEO'
 943       include 'COMMON.VAR'
 944       include 'COMMON.LOCAL'
 945       include 'COMMON.CHAIN'
 946       include 'COMMON.DERIV'
 947       include 'COMMON.NAMES'
 948       include 'COMMON.INTERACT'
 949       include 'COMMON.WEIGHTDER'
 950       include 'COMMON.IOUNITS'
 951       include 'COMMON.CALC'
 952       logical lprn
 953       common /srutu/icall
 954       integer icant
 955       external icant
 956       do i=1,nntyp
 957         do j=1,2
 958           eneps_temp(j,i)=0.0d0
 959         enddo
 960       enddo
 961       evdw=0.0D0
 962 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
 963       evdw=0.0D0
 964       lprn=.false.
 965 c      if (icall.gt.0) lprn=.true.
 966       ind=0
 967       do i=iatsc_s,iatsc_e
 968         itypi=itype(i)
 969         itypi1=itype(i+1)
 970         xi=c(1,nres+i)
 971         yi=c(2,nres+i)
 972         zi=c(3,nres+i)
 973         dxi=dc_norm(1,nres+i)
 974         dyi=dc_norm(2,nres+i)
 975         dzi=dc_norm(3,nres+i)
 976         dsci_inv=vbld_inv(i+nres)
 977 C
 978 C Calculate SC interaction energy.
 979 C
 980         do iint=1,nint_gr(i)
 981           do j=istart(i,iint),iend(i,iint)
 982             ind=ind+1
 983             itypj=itype(j)
 984             dscj_inv=vbld_inv(j+nres)
 985             sig0ij=sigma(itypi,itypj)
 986             chi1=chi(itypi,itypj)
 987             chi2=chi(itypj,itypi)
 988             chi12=chi1*chi2
 989             chip1=chip(itypi)
 990             chip2=chip(itypj)
 991             chip12=chip1*chip2
 992             alf1=alp(itypi)
 993             alf2=alp(itypj)
 994             alf12=0.5D0*(alf1+alf2)
 995 C For diagnostics only!!!
 996 c           chi1=0.0D0
 997 c           chi2=0.0D0
 998 c           chi12=0.0D0
 999 c           chip1=0.0D0
1000 c           chip2=0.0D0
1001 c           chip12=0.0D0
1002 c           alf1=0.0D0
1003 c           alf2=0.0D0
1004 c           alf12=0.0D0
1005             xj=c(1,nres+j)-xi
1006             yj=c(2,nres+j)-yi
1007             zj=c(3,nres+j)-zi
1008             dxj=dc_norm(1,nres+j)
1009             dyj=dc_norm(2,nres+j)
1010             dzj=dc_norm(3,nres+j)
1011 c            write (iout,*) i,j,xj,yj,zj
1012             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1013             rij=dsqrt(rrij)
1014 C Calculate angle-dependent terms of energy and contributions to their
1015 C derivatives.
1016             call sc_angular
1017             sigsq=1.0D0/sigsq
1018             sig=sig0ij*dsqrt(sigsq)
1019             rij_shift=1.0D0/rij-sig+sig0ij
1020 C I hate to put IF's in the loops, but here don't have another choice!!!!
1021             if (rij_shift.le.0.0D0) then
1022               evdw=1.0D20
1023               return
1024             endif
1025             sigder=-sig*sigsq
1026 c---------------------------------------------------------------
1027             rij_shift=1.0D0/rij_shift
1028             fac=rij_shift**expon
1029             e1=fac*fac*aa(itypi,itypj)
1030             e2=fac*bb(itypi,itypj)
1031             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1032             eps2der=evdwij*eps3rt
1033             eps3der=evdwij*eps2rt
1034             evdwij=evdwij*eps2rt*eps3rt
1035             evdw=evdw+evdwij
1036             ij=icant(itypi,itypj)
1037             aux=eps1*eps2rt**2*eps3rt**2
1038 c            eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1
1039 c     &        /dabs(eps(itypi,itypj))
1040 c            eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1041 c-----------------------
1042             eps0ij=eps(itypi,itypj)
1043             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*e1/ftune_eps(eps0ij)
1044             rr0ij=r0(itypi,itypj)
1045             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps0ij
1046 c            eneps_temp(2,ij)=eneps_temp(2,ij)+(rij_shift*rr0ij)**expon
1047 c-----------------------
1048 c            write (iout,*) "i",i," j",j," itypi",itypi," itypj",itypj,
1049 c     &         " ij",ij," eneps",aux*e1/dabs(eps(itypi,itypj)),
1050 c     &         aux*e2/eps(itypi,itypj)
1051             if (lprn) then
1052             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1053             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1054             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1055      &        restyp(itypi),i,restyp(itypj),j,
1056      &        epsi,sigm,chi1,chi2,chip1,chip2,
1057      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1058      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1059      &        evdwij
1060             endif
1061             if (calc_grad) then
1062 C Calculate gradient components.
1063             e1=e1*eps1*eps2rt**2*eps3rt**2
1064             fac=-expon*(e1+evdwij)*rij_shift
1065             sigder=fac*sigder
1066             fac=rij*fac
1067 C Calculate the radial part of the gradient
1068             gg(1)=xj*fac
1069             gg(2)=yj*fac
1070             gg(3)=zj*fac
1071 C Calculate angular part of the gradient.
1072             call sc_grad
1073             endif
1074           enddo      ! j
1075         enddo        ! iint
1076       enddo          ! i
1077       return
1078       end
1079 C-----------------------------------------------------------------------------
1080       subroutine egbv(evdw)
1081 C
1082 C This subroutine calculates the interaction energy of nonbonded side chains
1083 C assuming the Gay-Berne-Vorobjev potential of interaction.
1084 C
1085       implicit real*8 (a-h,o-z)
1086       include 'DIMENSIONS'
1087       include 'DIMENSIONS.ZSCOPT'
1088       include 'COMMON.GEO'
1089       include 'COMMON.VAR'
1090       include 'COMMON.LOCAL'
1091       include 'COMMON.CHAIN'
1092       include 'COMMON.DERIV'
1093       include 'COMMON.NAMES'
1094       include 'COMMON.INTERACT'
1095       include 'COMMON.WEIGHTDER'
1096       include 'COMMON.IOUNITS'
1097       include 'COMMON.CALC'
1098       common /srutu/ icall
1099       logical lprn
1100       integer icant
1101       external icant
1102       do i=1,nntyp
1103         do j=1,2
1104           eneps_temp(j,i)=0.0d0
1105         enddo
1106       enddo
1107       evdw=0.0D0
1108 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1109       evdw=0.0D0
1110       lprn=.false.
1111 c      if (icall.gt.0) lprn=.true.
1112       ind=0
1113       do i=iatsc_s,iatsc_e
1114         itypi=itype(i)
1115         itypi1=itype(i+1)
1116         xi=c(1,nres+i)
1117         yi=c(2,nres+i)
1118         zi=c(3,nres+i)
1119         dxi=dc_norm(1,nres+i)
1120         dyi=dc_norm(2,nres+i)
1121         dzi=dc_norm(3,nres+i)
1122         dsci_inv=vbld_inv(i+nres)
1123 C
1124 C Calculate SC interaction energy.
1125 C
1126         do iint=1,nint_gr(i)
1127           do j=istart(i,iint),iend(i,iint)
1128             ind=ind+1
1129             itypj=itype(j)
1130             dscj_inv=vbld_inv(j+nres)
1131             sig0ij=sigma(itypi,itypj)
1132             r0ij=r0(itypi,itypj)
1133             chi1=chi(itypi,itypj)
1134             chi2=chi(itypj,itypi)
1135             chi12=chi1*chi2
1136             chip1=chip(itypi)
1137             chip2=chip(itypj)
1138             chip12=chip1*chip2
1139             alf1=alp(itypi)
1140             alf2=alp(itypj)
1141             alf12=0.5D0*(alf1+alf2)
1142 C For diagnostics only!!!
1143 c           chi1=0.0D0
1144 c           chi2=0.0D0
1145 c           chi12=0.0D0
1146 c           chip1=0.0D0
1147 c           chip2=0.0D0
1148 c           chip12=0.0D0
1149 c           alf1=0.0D0
1150 c           alf2=0.0D0
1151 c           alf12=0.0D0
1152             xj=c(1,nres+j)-xi
1153             yj=c(2,nres+j)-yi
1154             zj=c(3,nres+j)-zi
1155             dxj=dc_norm(1,nres+j)
1156             dyj=dc_norm(2,nres+j)
1157             dzj=dc_norm(3,nres+j)
1158             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1159             rij=dsqrt(rrij)
1160 C Calculate angle-dependent terms of energy and contributions to their
1161 C derivatives.
1162             call sc_angular
1163             sigsq=1.0D0/sigsq
1164             sig=sig0ij*dsqrt(sigsq)
1165             rij_shift=1.0D0/rij-sig+r0ij
1166 C I hate to put IF's in the loops, but here don't have another choice!!!!
1167             if (rij_shift.le.0.0D0) then
1168               evdw=1.0D20
1169               return
1170             endif
1171             sigder=-sig*sigsq
1172 c---------------------------------------------------------------
1173             rij_shift=1.0D0/rij_shift
1174             fac=rij_shift**expon
1175             e1=fac*fac*aa(itypi,itypj)
1176             e2=fac*bb(itypi,itypj)
1177             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1178             eps2der=evdwij*eps3rt
1179             eps3der=evdwij*eps2rt
1180             fac_augm=rrij**expon
1181             e_augm=augm(itypi,itypj)*fac_augm
1182             evdwij=evdwij*eps2rt*eps3rt
1183             evdw=evdw+evdwij+e_augm
1184             ij=icant(itypi,itypj)
1185             aux=eps1*eps2rt**2*eps3rt**2
1186             eneps_temp(1,ij)=eneps_temp(1,ij)+aux*(e1+e_augm)
1187      &        /dabs(eps(itypi,itypj))
1188             eneps_temp(2,ij)=eneps_temp(2,ij)+aux*e2/eps(itypi,itypj)
1189 c            eneps_temp(ij)=eneps_temp(ij)
1190 c     &         +(evdwij+e_augm)/eps(itypi,itypj)
1191 c            if (lprn) then
1192 c            sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1193 c            epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1194 c            write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1195 c     &        restyp(itypi),i,restyp(itypj),j,
1196 c     &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1197 c     &        chi1,chi2,chip1,chip2,
1198 c     &        eps1,eps2rt**2,eps3rt**2,
1199 c     &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1200 c     &        evdwij+e_augm
1201 c            endif
1202             if (calc_grad) then
1203 C Calculate gradient components.
1204             e1=e1*eps1*eps2rt**2*eps3rt**2
1205             fac=-expon*(e1+evdwij)*rij_shift
1206             sigder=fac*sigder
1207             fac=rij*fac-2*expon*rrij*e_augm
1208 C Calculate the radial part of the gradient
1209             gg(1)=xj*fac
1210             gg(2)=yj*fac
1211             gg(3)=zj*fac
1212 C Calculate angular part of the gradient.
1213             call sc_grad
1214             endif
1215           enddo      ! j
1216         enddo        ! iint
1217       enddo          ! i
1218       return
1219       end
1220 C-----------------------------------------------------------------------------
1221       SUBROUTINE emomo(evdw,evdw_p,evdw_m)
1222 C
1223 C This subroutine calculates the interaction energy of nonbonded side chains
1224 C assuming the Gay-Berne potential of interaction.
1225 C
1226        IMPLICIT NONE
1227        INCLUDE 'DIMENSIONS'
1228        INCLUDE 'DIMENSIONS.ZSCOPT'
1229        INCLUDE 'COMMON.CALC'
1230        INCLUDE 'COMMON.CONTROL'
1231        INCLUDE 'COMMON.CHAIN'
1232        INCLUDE 'COMMON.DERIV'
1233        INCLUDE 'COMMON.EMP'
1234        INCLUDE 'COMMON.GEO'
1235        INCLUDE 'COMMON.INTERACT'
1236        INCLUDE 'COMMON.IOUNITS'
1237        INCLUDE 'COMMON.LOCAL'
1238        INCLUDE 'COMMON.NAMES'
1239        INCLUDE 'COMMON.VAR'
1240        INCLUDE 'COMMON.WEIGHTDER'
1241        logical lprn
1242        double precision scalar
1243        double precision ener(4)
1244        integer troll
1245        integer iint,ij
1246        integer icant
1247
1248        energy_dec=.false.
1249        IF (energy_dec) write (iout,'(a)')
1250      & ' AAi i  AAj  j  1/rij  Rtail   Rhead   evdwij   Fcav   Ecl
1251      & Egb   Epol   Fisocav   Elj   Equad   evdw'
1252        evdw   = 0.0D0
1253        evdw_p = 0.0D0
1254        evdw_m = 0.0D0
1255 c DIAGNOSTICS
1256 ccccc      energy_dec=.false.
1257 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1258 c      lprn   = .false.
1259 c     if (icall.eq.0) lprn=.false.
1260 c END DIAGNOSTICS
1261 c      ind = 0
1262        DO i = iatsc_s, iatsc_e
1263         itypi  = itype(i)
1264 c        itypi1 = itype(i+1)
1265         dxi    = dc_norm(1,nres+i)
1266         dyi    = dc_norm(2,nres+i)
1267         dzi    = dc_norm(3,nres+i)
1268 c        dsci_inv=dsc_inv(itypi)
1269         dsci_inv = vbld_inv(i+nres)
1270 c        DO k = 1, 3
1271 c         ctail(k,1) = c(k, i+nres)
1272 c     &              - dtail(1,itypi,itypj) * dc_norm(k, nres+i)
1273 c        END DO
1274         xi=c(1,nres+i)
1275         yi=c(2,nres+i)
1276         zi=c(3,nres+i)
1277 c!-------------------------------------------------------------------
1278 C Calculate SC interaction energy.
1279         DO iint = 1, nint_gr(i)
1280          DO j = istart(i,iint), iend(i,iint)
1281 c! initialize variables for electrostatic gradients
1282           CALL elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
1283 c            ind=ind+1
1284 c            dscj_inv = dsc_inv(itypj)
1285           dscj_inv = vbld_inv(j+nres)
1286 c! rij holds 1/(distance of Calpha atoms)
1287           rrij = 1.0D0 / ( xj*xj + yj*yj + zj*zj)
1288           rij  = dsqrt(rrij)
1289 c!-------------------------------------------------------------------
1290 C Calculate angle-dependent terms of energy and contributions to their
1291 C derivatives.
1292
1293 #ifdef CHECK_MOMO
1294 c!      DO troll = 10, 5000
1295 c!      om1    = 0.0d0
1296 c!      om2    = 0.0d0
1297 c!      om12   = 1.0d0
1298 c!      sqom1  = om1 * om1
1299 c!      sqom2  = om2 * om2
1300 c!      sqom12 = om12 * om12
1301 c!      rij    = 5.0d0 / troll
1302 c!      rrij   = rij * rij
1303 c!      Rtail  = troll / 5.0d0
1304 c!      Rhead  = troll / 5.0d0
1305 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1306 c!      Rtail = dsqrt((Rtail**2)
1307 c!     &      +((dabs(dtail(1,itypi,itypj)-dtail(2,itypi,itypj)))**2))
1308 c!      rij = 1.0d0/Rtail
1309 c!      rrij = rij * rij
1310 #endif
1311           CALL sc_angular
1312 c! this should be in elgrad_init but om's are calculated by sc_angular
1313 c! which in turn is used by older potentials
1314 c! which proves how tangled UNRES code is >.<
1315 c! om = omega, sqom = om^2
1316           sqom1  = om1 * om1
1317           sqom2  = om2 * om2
1318           sqom12 = om12 * om12
1319
1320 c! now we calculate EGB - Gey-Berne
1321 c! It will be summed up in evdwij and saved in evdw
1322           sigsq     = 1.0D0  / sigsq
1323           sig       = sig0ij * dsqrt(sigsq)
1324 c!          rij_shift = 1.0D0  / rij - sig + sig0ij
1325           rij_shift = Rtail - sig + sig0ij
1326           IF (rij_shift.le.0.0D0) THEN
1327            evdw = 1.0D20
1328            RETURN
1329           END IF
1330           sigder = -sig * sigsq
1331           rij_shift = 1.0D0 / rij_shift
1332           fac       = rij_shift**expon
1333           c1        = fac  * fac * aa(itypi,itypj)
1334 c!          c1        = 0.0d0
1335           c2        = fac  * bb(itypi,itypj)
1336 c!          c2        = 0.0d0
1337           evdwij    = eps1 * eps2rt * eps3rt * ( c1 + c2 )
1338           eps2der   = eps3rt * evdwij
1339           eps3der   = eps2rt * evdwij
1340 c!          evdwij    = 4.0d0 * eps2rt * eps3rt * evdwij
1341           evdwij    = eps2rt * eps3rt * evdwij
1342 c!      evdwij = 0.0d0
1343 c!      write (*,*) "Gey Berne = ", evdwij
1344 #ifdef TSCSC
1345           IF (bb(itypi,itypj).gt.0) THEN
1346            evdw_p = evdw_p + evdwij
1347           ELSE
1348            evdw_m = evdw_m + evdwij
1349           END IF
1350 #else
1351           evdw = evdw
1352      &         + evdwij
1353 #endif
1354 c!-------------------------------------------------------------------
1355 c! Calculate some components of GGB
1356           c1     = c1 * eps1 * eps2rt**2 * eps3rt**2
1357           fac    = -expon * (c1 + evdwij) * rij_shift
1358           sigder = fac * sigder
1359 c!          fac    = rij * fac
1360 c! Calculate distance derivative
1361 c!          gg(1) = xj * fac
1362 c!          gg(2) = yj * fac
1363 c!          gg(3) = zj * fac
1364           gg(1) = fac
1365           gg(2) = fac
1366           gg(3) = fac
1367 c!      write (*,*) "gg(1) = ", gg(1)
1368 c!      write (*,*) "gg(2) = ", gg(2)
1369 c!      write (*,*) "gg(3) = ", gg(3)
1370 c! The angular derivatives of GGB are brought together in sc_grad
1371 c!-------------------------------------------------------------------
1372 c! Fcav
1373 c!
1374 c! Catch gly-gly interactions to skip calculation of something that
1375 c! does not exist
1376
1377       IF (itypi.eq.10.and.itypj.eq.10) THEN
1378        Fcav = 0.0d0
1379        dFdR = 0.0d0
1380        dCAVdOM1  = 0.0d0
1381        dCAVdOM2  = 0.0d0
1382        dCAVdOM12 = 0.0d0
1383       ELSE
1384
1385 c! we are not 2 glycines, so we calculate Fcav (and maybe more)
1386        fac = chis1 * sqom1 + chis2 * sqom2
1387      &     - 2.0d0 * chis12 * om1 * om2 * om12
1388 c! we will use pom later in Gcav, so dont mess with it!
1389        pom = 1.0d0 - chis1 * chis2 * sqom12
1390
1391        Lambf = (1.0d0 - (fac / pom))
1392        Lambf = dsqrt(Lambf)
1393
1394
1395        sparrow = 1.0d0 / dsqrt(sig1**2.0d0 + sig2**2.0d0)
1396 c!       write (*,*) "sparrow = ", sparrow
1397        Chif = Rtail * sparrow
1398        ChiLambf = Chif * Lambf
1399        eagle = dsqrt(ChiLambf)
1400        bat = ChiLambf ** 11.0d0
1401
1402        top = b1 * ( eagle + b2 * ChiLambf - b3 )
1403        bot = 1.0d0 + b4 * (ChiLambf ** 12.0d0)
1404        botsq = bot * bot
1405
1406 c!      write (*,*) "sig1 = ",sig1
1407 c!      write (*,*) "sig2 = ",sig2
1408 c!      write (*,*) "Rtail = ",Rtail
1409 c!      write (*,*) "sparrow = ",sparrow
1410 c!      write (*,*) "Chis1 = ", chis1
1411 c!      write (*,*) "Chis2 = ", chis2
1412 c!      write (*,*) "Chis12 = ", chis12
1413 c!      write (*,*) "om1 = ", om1
1414 c!      write (*,*) "om2 = ", om2
1415 c!      write (*,*) "om12 = ", om12
1416 c!      write (*,*) "sqom1 = ", sqom1
1417 c!      write (*,*) "sqom2 = ", sqom2
1418 c!      write (*,*) "sqom12 = ", sqom12
1419 c!      write (*,*) "Lambf = ",Lambf
1420 c!      write (*,*) "b1 = ",b1
1421 c!      write (*,*) "b2 = ",b2
1422 c!      write (*,*) "b3 = ",b3
1423 c!      write (*,*) "b4 = ",b4
1424 c!      write (*,*) "top = ",top
1425 c!      write (*,*) "bot = ",bot
1426        Fcav = top / bot
1427 c!       Fcav = 0.0d0
1428 c!      write (*,*) "Fcav = ", Fcav
1429 c!-------------------------------------------------------------------
1430 c! derivative of Fcav is Gcav...
1431 c!---------------------------------------------------
1432
1433        dtop = b1 * ((Lambf / (2.0d0 * eagle)) + (b2 * Lambf))
1434        dbot = 12.0d0 * b4 * bat * Lambf
1435        dFdR = ((dtop * bot - top * dbot) / botsq) * sparrow
1436 c!       dFdR = 0.0d0
1437 c!      write (*,*) "dFcav/dR = ", dFdR
1438
1439        dtop = b1 * ((Chif / (2.0d0 * eagle)) + (b2 * Chif))
1440        dbot = 12.0d0 * b4 * bat * Chif
1441        eagle = Lambf * pom
1442        dFdOM1  = -(chis1 * om1 - chis12 * om2 * om12) / (eagle)
1443        dFdOM2  = -(chis2 * om2 - chis12 * om1 * om12) / (eagle)
1444        dFdOM12 = chis12 * (chis1 * om1 * om12 - om2)
1445      &         * (chis2 * om2 * om12 - om1) / (eagle * pom)
1446
1447        dFdL = ((dtop * bot - top * dbot) / botsq)
1448 c!       dFdL = 0.0d0
1449        dCAVdOM1  = dFdL * ( dFdOM1 )
1450        dCAVdOM2  = dFdL * ( dFdOM2 )
1451        dCAVdOM12 = dFdL * ( dFdOM12 )
1452 c!      write (*,*) "dFcav/dOM1 = ", dCAVdOM1
1453 c!      write (*,*) "dFcav/dOM2 = ", dCAVdOM2
1454 c!      write (*,*) "dFcav/dOM12 = ", dCAVdOM12
1455 c!      write (*,*) ""
1456 c!-------------------------------------------------------------------
1457 c! Finally, add the distance derivatives of GB and Fcav to gvdwc
1458 c! Pom is used here to project the gradient vector into
1459 c! cartesian coordinates and at the same time contains
1460 c! dXhb/dXsc derivative (for charged amino acids
1461 c! location of hydrophobic centre of interaction is not
1462 c! the same as geometric centre of side chain, this
1463 c! derivative takes that into account)
1464 c! derivatives of omega angles will be added in sc_grad
1465
1466        DO k= 1, 3
1467         ertail(k) = Rtail_distance(k)/Rtail
1468        END DO
1469        erdxi = scalar( ertail(1), dC_norm(1,i+nres) )
1470        erdxj = scalar( ertail(1), dC_norm(1,j+nres) )
1471        facd1 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1472        facd2 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1473        DO k = 1, 3
1474 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1475 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1476         pom = ertail(k)-facd1*(ertail(k)-erdxi*dC_norm(k,i+nres))
1477         gvdwx(k,i) = gvdwx(k,i)
1478      &             - (( dFdR + gg(k) ) * pom)
1479 c!     &             - ( dFdR * pom )
1480         pom = ertail(k)-facd2*(ertail(k)-erdxj*dC_norm(k,j+nres))
1481         gvdwx(k,j) = gvdwx(k,j)
1482      &             + (( dFdR + gg(k) ) * pom)
1483 c!     &             + ( dFdR * pom )
1484
1485         gvdwc(k,i) = gvdwc(k,i)
1486      &             - (( dFdR + gg(k) ) * ertail(k))
1487 c!     &             - ( dFdR * ertail(k))
1488
1489         gvdwc(k,j) = gvdwc(k,j)
1490      &             + (( dFdR + gg(k) ) * ertail(k))
1491 c!     &             + ( dFdR * ertail(k))
1492
1493         gg(k) = 0.0d0
1494 c!      write (*,*) "Gvdwc(",k,",",i,")=", gvdwc(k,i)
1495 c!      write (*,*) "Gvdwc(",k,",",j,")=", gvdwc(k,j)
1496       END DO
1497
1498 c!-------------------------------------------------------------------
1499 c! Compute head-head and head-tail energies for each state
1500
1501           isel = iabs(Qi) + iabs(Qj)
1502           IF (isel.eq.0) THEN
1503 c! No charges - do nothing
1504            eheadtail = 0.0d0
1505
1506           ELSE IF (isel.eq.4) THEN
1507 c! Calculate dipole-dipole interactions
1508            CALL edd(ecl)
1509            eheadtail = ECL
1510
1511           ELSE IF (isel.eq.1 .and. iabs(Qi).eq.1) THEN
1512 c! Charge-nonpolar interactions
1513            CALL eqn(epol)
1514            eheadtail = epol
1515
1516           ELSE IF (isel.eq.1 .and. iabs(Qj).eq.1) THEN
1517 c! Nonpolar-charge interactions
1518            CALL enq(epol)
1519            eheadtail = epol
1520
1521           ELSE IF (isel.eq.3 .and. icharge(itypj).eq.2) THEN
1522 c! Charge-dipole interactions
1523            CALL eqd(ecl, elj, epol)
1524            eheadtail = ECL + elj + epol
1525
1526           ELSE IF (isel.eq.3 .and. icharge(itypi).eq.2) THEN
1527 c! Dipole-charge interactions
1528            CALL edq(ecl, elj, epol)
1529            eheadtail = ECL + elj + epol
1530
1531           ELSE IF ((isel.eq.2.and.
1532      &          iabs(Qi).eq.1).and.
1533      &          nstate(itypi,itypj).eq.1) THEN
1534 c! Same charge-charge interaction ( +/+ or -/- )
1535            CALL eqq(Ecl,Egb,Epol,Fisocav,Elj)
1536            eheadtail = ECL + Egb + Epol + Fisocav + Elj
1537
1538           ELSE IF ((isel.eq.2.and.
1539      &          iabs(Qi).eq.1).and.
1540      &          nstate(itypi,itypj).ne.1) THEN
1541 c! Different charge-charge interaction ( +/- or -/+ )
1542            CALL energy_quad
1543      &     (istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1544           END IF
1545        END IF  ! this endif ends the "catch the gly-gly" at the beggining of Fcav
1546 c!      write (*,*) "evdw = ", evdw
1547 c!      write (*,*) "Fcav = ", Fcav
1548 c!      write (*,*) "eheadtail = ", eheadtail
1549        evdw = evdw
1550      &      + Fcav
1551      &      + eheadtail
1552        ij=icant(itypi,itypj)
1553        eneps_temp(1,ij)=eneps_temp(1,ij)+evdwij
1554        eneps_temp(2,ij)=eneps_temp(2,ij)+Fcav
1555        eneps_temp(3,ij)=eheadtail
1556        IF (energy_dec) write (iout,'(2(1x,a3,i3),3f6.2,9f16.7)')
1557      &  restyp(itype(i)),i,restyp(itype(j)),j,
1558      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1559      &  Equad,evdw
1560        IF (energy_dec) write (*,'(2(1x,a3,i3),3f6.2,9f16.7)')
1561      &  restyp(itype(i)),i,restyp(itype(j)),j,
1562      &  1.0d0/rij,Rtail,Rhead,evdwij,Fcav,Ecl,Egb,Epol,Fisocav,Elj,
1563      &  Equad,evdw
1564 #ifdef CHECK_MOMO
1565        evdw = 0.0d0
1566        END DO ! troll
1567 #endif
1568
1569 c!-------------------------------------------------------------------
1570 c! As all angular derivatives are done, now we sum them up,
1571 c! then transform and project into cartesian vectors and add to gvdwc
1572 c! We call sc_grad always, with the exception of +/- interaction.
1573 c! This is because energy_quad subroutine needs to handle
1574 c! this job in his own way.
1575 c! This IS probably not very efficient and SHOULD be optimised
1576 c! but it will require major restructurization of emomo
1577 c! so it will be left as it is for now
1578 c!       write (*,*) 'troll1, nstate =', nstate (itypi,itypj)
1579        IF (nstate(itypi,itypj).eq.1) THEN
1580 #ifdef TSCSC
1581         IF (bb(itypi,itypj).gt.0) THEN
1582          CALL sc_grad
1583         ELSE
1584          CALL sc_grad_T
1585         END IF
1586 #else
1587         CALL sc_grad
1588 #endif
1589        END IF
1590 c!-------------------------------------------------------------------
1591 c! NAPISY KONCOWE
1592          END DO   ! j
1593         END DO    ! iint
1594        END DO     ! i
1595 c      write (iout,*) "Number of loop steps in EGB:",ind
1596 c      energy_dec=.false.
1597        RETURN
1598       END SUBROUTINE emomo
1599 c! END OF MOMO
1600 C-----------------------------------------------------------------------------
1601       SUBROUTINE eqq(Ecl,Egb,Epol,Fisocav,Elj)
1602        IMPLICIT NONE
1603        INCLUDE 'DIMENSIONS'
1604        INCLUDE 'DIMENSIONS.ZSCOPT'
1605        INCLUDE 'COMMON.CALC'
1606        INCLUDE 'COMMON.CHAIN'
1607        INCLUDE 'COMMON.CONTROL'
1608        INCLUDE 'COMMON.DERIV'
1609        INCLUDE 'COMMON.EMP'
1610        INCLUDE 'COMMON.GEO'
1611        INCLUDE 'COMMON.INTERACT'
1612        INCLUDE 'COMMON.IOUNITS'
1613        INCLUDE 'COMMON.LOCAL'
1614        INCLUDE 'COMMON.NAMES'
1615        INCLUDE 'COMMON.VAR'
1616        double precision scalar, facd3, facd4, federmaus, adler
1617 c! Epol and Gpol analytical parameters
1618        alphapol1 = alphapol(itypi,itypj)
1619        alphapol2 = alphapol(itypj,itypi)
1620 c! Fisocav and Gisocav analytical parameters
1621        al1  = alphiso(1,itypi,itypj)
1622        al2  = alphiso(2,itypi,itypj)
1623        al3  = alphiso(3,itypi,itypj)
1624        al4  = alphiso(4,itypi,itypj)
1625        csig = (1.0d0
1626      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1627      &      + sigiso2(itypi,itypj)**2.0d0))
1628 c!
1629        pis  = sig0head(itypi,itypj)
1630        eps_head = epshead(itypi,itypj)
1631        Rhead_sq = Rhead * Rhead
1632 c! R1 - distance between head of ith side chain and tail of jth sidechain
1633 c! R2 - distance between head of jth side chain and tail of ith sidechain
1634        R1 = 0.0d0
1635        R2 = 0.0d0
1636        DO k = 1, 3
1637 c! Calculate head-to-tail distances needed by Epol
1638         R1=R1+(ctail(k,2)-chead(k,1))**2
1639         R2=R2+(chead(k,2)-ctail(k,1))**2
1640        END DO
1641 c! Pitagoras
1642        R1 = dsqrt(R1)
1643        R2 = dsqrt(R2)
1644
1645 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1646 c!     &        +dhead(1,1,itypi,itypj))**2))
1647 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1648 c!     &        +dhead(2,1,itypi,itypj))**2))
1649 c!-------------------------------------------------------------------
1650 c! Coulomb electrostatic interaction
1651        Ecl = (332.0d0 * Qij) / Rhead
1652 c! derivative of Ecl is Gcl...
1653        dGCLdR = (-332.0d0 * Qij ) / Rhead_sq
1654        dGCLdOM1 = 0.0d0
1655        dGCLdOM2 = 0.0d0
1656        dGCLdOM12 = 0.0d0
1657 c!-------------------------------------------------------------------
1658 c! Generalised Born Solvent Polarization
1659 c! Charged head polarizes the solvent
1660        ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1661        Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1662        Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1663 c! Derivative of Egb is Ggb...
1664        dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1665        dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1666      &        / ( 2.0d0 * Fgb )
1667        dGGBdR = dGGBdFGB * dFGBdR
1668 c!-------------------------------------------------------------------
1669 c! Fisocav - isotropic cavity creation term
1670 c! or "how much energy it costs to put charged head in water"
1671        pom = Rhead * csig
1672        top = al1 * (dsqrt(pom) + al2 * pom - al3)
1673        bot = (1.0d0 + al4 * pom**12.0d0)
1674        botsq = bot * bot
1675        FisoCav = top / bot
1676 c!      write (*,*) "Rhead = ",Rhead
1677 c!      write (*,*) "csig = ",csig
1678 c!      write (*,*) "pom = ",pom
1679 c!      write (*,*) "al1 = ",al1
1680 c!      write (*,*) "al2 = ",al2
1681 c!      write (*,*) "al3 = ",al3
1682 c!      write (*,*) "al4 = ",al4
1683 c!      write (*,*) "top = ",top
1684 c!      write (*,*) "bot = ",bot
1685 c! Derivative of Fisocav is GCV...
1686        dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
1687        dbot = 12.0d0 * al4 * pom ** 11.0d0
1688        dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
1689 c!-------------------------------------------------------------------
1690 c! Epol
1691 c! Polarization energy - charged heads polarize hydrophobic "neck"
1692        MomoFac1 = (1.0d0 - chi1 * sqom2)
1693        MomoFac2 = (1.0d0 - chi2 * sqom1)
1694        RR1  = ( R1 * R1 ) / MomoFac1
1695        RR2  = ( R2 * R2 ) / MomoFac2
1696        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
1697        ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
1698        fgb1 = sqrt( RR1 + a12sq * ee1 )
1699        fgb2 = sqrt( RR2 + a12sq * ee2 )
1700        epol = 332.0d0 * eps_inout_fac * (
1701      & (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
1702 c!       epol = 0.0d0
1703 c       write (*,*) "eps_inout_fac = ",eps_inout_fac
1704 c       write (*,*) "alphapol1 = ", alphapol1
1705 c       write (*,*) "alphapol2 = ", alphapol2
1706 c       write (*,*) "fgb1 = ", fgb1
1707 c       write (*,*) "fgb2 = ", fgb2
1708 c       write (*,*) "epol = ", epol
1709 c! derivative of Epol is Gpol...
1710        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
1711      &          / (fgb1 ** 5.0d0)
1712        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
1713      &          / (fgb2 ** 5.0d0)
1714        dFGBdR1 = ( (R1 / MomoFac1)
1715      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
1716      &        / ( 2.0d0 * fgb1 )
1717        dFGBdR2 = ( (R2 / MomoFac2)
1718      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
1719      &        / ( 2.0d0 * fgb2 )
1720        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
1721      &          * ( 2.0d0 - 0.5d0 * ee1) )
1722      &          / ( 2.0d0 * fgb1 )
1723        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
1724      &          * ( 2.0d0 - 0.5d0 * ee2) )
1725      &          / ( 2.0d0 * fgb2 )
1726        dPOLdR1 = dPOLdFGB1 * dFGBdR1
1727 c!       dPOLdR1 = 0.0d0
1728        dPOLdR2 = dPOLdFGB2 * dFGBdR2
1729 c!       dPOLdR2 = 0.0d0
1730        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
1731 c!       dPOLdOM1 = 0.0d0
1732        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
1733 c!       dPOLdOM2 = 0.0d0
1734 c!-------------------------------------------------------------------
1735 c! Elj
1736 c! Lennard-Jones 6-12 interaction between heads
1737        pom = (pis / Rhead)**6.0d0
1738        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
1739 c! derivative of Elj is Glj
1740        dGLJdR = 4.0d0 * eps_head
1741      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
1742      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
1743 c!-------------------------------------------------------------------
1744 c! Return the results
1745 c! These things do the dRdX derivatives, that is
1746 c! allow us to change what we see from function that changes with
1747 c! distance to function that changes with LOCATION (of the interaction
1748 c! site)
1749        DO k = 1, 3
1750         erhead(k) = Rhead_distance(k)/Rhead
1751         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
1752         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
1753        END DO
1754
1755        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
1756        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
1757        bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
1758        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
1759        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
1760        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
1761        facd1 = d1 * vbld_inv(i+nres)
1762        facd2 = d2 * vbld_inv(j+nres)
1763        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
1764        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
1765
1766 c! Now we add appropriate partial derivatives (one in each dimension)
1767        DO k = 1, 3
1768         hawk   = (erhead_tail(k,1) +
1769      & facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres)))
1770         condor = (erhead_tail(k,2) +
1771      & facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
1772
1773         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
1774         gvdwx(k,i) = gvdwx(k,i)
1775      &             - dGCLdR * pom
1776      &             - dGGBdR * pom
1777      &             - dGCVdR * pom
1778      &             - dPOLdR1 * hawk
1779      &             - dPOLdR2 * (erhead_tail(k,2)
1780      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
1781      &             - dGLJdR * pom
1782
1783         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
1784         gvdwx(k,j) = gvdwx(k,j)
1785      &             + dGCLdR * pom
1786      &             + dGGBdR * pom
1787      &             + dGCVdR * pom
1788      &             + dPOLdR1 * (erhead_tail(k,1)
1789      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
1790      &             + dPOLdR2 * condor
1791      &             + dGLJdR * pom
1792
1793         gvdwc(k,i) = gvdwc(k,i)
1794      &             - dGCLdR * erhead(k)
1795      &             - dGGBdR * erhead(k)
1796      &             - dGCVdR * erhead(k)
1797      &             - dPOLdR1 * erhead_tail(k,1)
1798      &             - dPOLdR2 * erhead_tail(k,2)
1799      &             - dGLJdR * erhead(k)
1800
1801         gvdwc(k,j) = gvdwc(k,j)
1802      &             + dGCLdR * erhead(k)
1803      &             + dGGBdR * erhead(k)
1804      &             + dGCVdR * erhead(k)
1805      &             + dPOLdR1 * erhead_tail(k,1)
1806      &             + dPOLdR2 * erhead_tail(k,2)
1807      &             + dGLJdR * erhead(k)
1808
1809        END DO
1810        RETURN
1811       END SUBROUTINE eqq
1812 c!-------------------------------------------------------------------
1813       SUBROUTINE energy_quad
1814      &(istate,eheadtail,Ecl,Egb,Epol,Fisocav,Elj,Equad)
1815        IMPLICIT NONE
1816        INCLUDE 'DIMENSIONS'
1817        INCLUDE 'DIMENSIONS.ZSCOPT'
1818        INCLUDE 'COMMON.CALC'
1819        INCLUDE 'COMMON.CHAIN'
1820        INCLUDE 'COMMON.CONTROL'
1821        INCLUDE 'COMMON.DERIV'
1822        INCLUDE 'COMMON.EMP'
1823        INCLUDE 'COMMON.GEO'
1824        INCLUDE 'COMMON.INTERACT'
1825        INCLUDE 'COMMON.IOUNITS'
1826        INCLUDE 'COMMON.LOCAL'
1827        INCLUDE 'COMMON.NAMES'
1828        INCLUDE 'COMMON.VAR'
1829        double precision scalar
1830        double precision ener(4)
1831        double precision dcosom1(3),dcosom2(3)
1832 c! used in Epol derivatives
1833        double precision facd3, facd4
1834        double precision federmaus, adler
1835 c! Epol and Gpol analytical parameters
1836        alphapol1 = alphapol(itypi,itypj)
1837        alphapol2 = alphapol(itypj,itypi)
1838 c! Fisocav and Gisocav analytical parameters
1839        al1  = alphiso(1,itypi,itypj)
1840        al2  = alphiso(2,itypi,itypj)
1841        al3  = alphiso(3,itypi,itypj)
1842        al4  = alphiso(4,itypi,itypj)
1843        csig = (1.0d0
1844      &      / dsqrt(sigiso1(itypi, itypj)**2.0d0
1845      &      + sigiso2(itypi,itypj)**2.0d0))
1846 c!
1847        w1   = wqdip(1,itypi,itypj)
1848        w2   = wqdip(2,itypi,itypj)
1849        pis  = sig0head(itypi,itypj)
1850        eps_head = epshead(itypi,itypj)
1851 c! First things first:
1852 c! We need to do sc_grad's job with GB and Fcav
1853        eom1  =
1854      &         eps2der * eps2rt_om1
1855      &       - 2.0D0 * alf1 * eps3der
1856      &       + sigder * sigsq_om1
1857      &       + dCAVdOM1
1858        eom2  =
1859      &         eps2der * eps2rt_om2
1860      &       + 2.0D0 * alf2 * eps3der
1861      &       + sigder * sigsq_om2
1862      &       + dCAVdOM2
1863        eom12 =
1864      &         evdwij  * eps1_om12
1865      &       + eps2der * eps2rt_om12
1866      &       - 2.0D0 * alf12 * eps3der
1867      &       + sigder *sigsq_om12
1868      &       + dCAVdOM12
1869 c! now some magical transformations to project gradient into
1870 c! three cartesian vectors
1871        DO k = 1, 3
1872         dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
1873         dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
1874         gg(k) = gg(k) + eom1 * dcosom1(k) + eom2 * dcosom2(k)
1875 c! this acts on hydrophobic center of interaction
1876         gvdwx(k,i)= gvdwx(k,i) - gg(k)
1877      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1878      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1879         gvdwx(k,j)= gvdwx(k,j) + gg(k)
1880      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1881      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1882 c! this acts on Calpha
1883         gvdwc(k,i)=gvdwc(k,i)-gg(k)
1884         gvdwc(k,j)=gvdwc(k,j)+gg(k)
1885        END DO
1886 c! sc_grad is done, now we will compute
1887        eheadtail = 0.0d0
1888        eom1 = 0.0d0
1889        eom2 = 0.0d0
1890        eom12 = 0.0d0
1891
1892 c! ENERGY DEBUG
1893 c!       ii = 1
1894 c!       jj = 1
1895 c!       d1 = dhead(1, 1, itypi, itypj)
1896 c!       d2 = dhead(2, 1, itypi, itypj)
1897 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1898 c!     &        +dhead(1,ii,itypi,itypj))**2))
1899 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1900 c!     &        +dhead(2,jj,itypi,itypj))**2))
1901 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1902 c! END OF ENERGY DEBUG
1903 c*************************************************************
1904        DO istate = 1, nstate(itypi,itypj)
1905 c*************************************************************
1906         IF (istate.ne.1) THEN
1907          IF (istate.lt.3) THEN
1908           ii = 1
1909          ELSE
1910           ii = 2
1911          END IF
1912         jj = istate/ii
1913         d1 = dhead(1,ii,itypi,itypj)
1914         d2 = dhead(2,jj,itypi,itypj)
1915         DO k = 1,3
1916          chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
1917          chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
1918          Rhead_distance(k) = chead(k,2) - chead(k,1)
1919         END DO
1920 c! pitagoras (root of sum of squares)
1921         Rhead = dsqrt(
1922      &          (Rhead_distance(1)*Rhead_distance(1))
1923      &        + (Rhead_distance(2)*Rhead_distance(2))
1924      &        + (Rhead_distance(3)*Rhead_distance(3)))
1925         END IF
1926         Rhead_sq = Rhead * Rhead
1927
1928 c! R1 - distance between head of ith side chain and tail of jth sidechain
1929 c! R2 - distance between head of jth side chain and tail of ith sidechain
1930         R1 = 0.0d0
1931         R2 = 0.0d0
1932         DO k = 1, 3
1933 c! Calculate head-to-tail distances
1934          R1=R1+(ctail(k,2)-chead(k,1))**2
1935          R2=R2+(chead(k,2)-ctail(k,1))**2
1936         END DO
1937 c! Pitagoras
1938         R1 = dsqrt(R1)
1939         R2 = dsqrt(R2)
1940
1941 c! ENERGY DEBUG
1942 c!      write (*,*) "istate = ", istate
1943 c!      write (*,*) "ii = ", ii
1944 c!      write (*,*) "jj = ", jj
1945 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
1946 c!     &        +dhead(1,ii,itypi,itypj))**2))
1947 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
1948 c!     &        +dhead(2,jj,itypi,itypj))**2))
1949 c!      Rhead = dsqrt((Rtail**2)+((dabs(d1-d2))**2))
1950 c!      Rhead_sq = Rhead * Rhead
1951 c!      write (*,*) "d1 = ",d1
1952 c!      write (*,*) "d2 = ",d2
1953 c!      write (*,*) "R1 = ",R1
1954 c!      write (*,*) "R2 = ",R2
1955 c!      write (*,*) "Rhead = ",Rhead
1956 c! END OF ENERGY DEBUG
1957
1958 c!-------------------------------------------------------------------
1959 c! Coulomb electrostatic interaction
1960         Ecl = (332.0d0 * Qij) / (Rhead * eps_in)
1961 c!        Ecl = 0.0d0
1962 c!        write (*,*) "Ecl = ", Ecl
1963 c! derivative of Ecl is Gcl...
1964         dGCLdR = (-332.0d0 * Qij ) / (Rhead_sq * eps_in)
1965 c!        dGCLdR = 0.0d0
1966         dGCLdOM1 = 0.0d0
1967         dGCLdOM2 = 0.0d0
1968         dGCLdOM12 = 0.0d0
1969 c!-------------------------------------------------------------------
1970 c! Generalised Born Solvent Polarization
1971         ee = dexp(-( Rhead_sq ) / (4.0d0 * a12sq))
1972         Fgb = sqrt( ( Rhead_sq ) + a12sq * ee)
1973         Egb = -(332.0d0 * Qij * eps_inout_fac) / Fgb
1974 c!        Egb = 0.0d0
1975 c!      write (*,*) "a1*a2 = ", a12sq
1976 c!      write (*,*) "Rhead = ", Rhead
1977 c!      write (*,*) "Rhead_sq = ", Rhead_sq
1978 c!      write (*,*) "ee = ", ee
1979 c!      write (*,*) "Fgb = ", Fgb
1980 c!      write (*,*) "fac = ", eps_inout_fac
1981 c!      write (*,*) "Qij = ", Qij
1982 c!      write (*,*) "Egb = ", Egb
1983 c! Derivative of Egb is Ggb...
1984 c! dFGBdR is used by Quad's later...
1985         dGGBdFGB = -(-332.0d0 * Qij * eps_inout_fac) / (Fgb * Fgb)
1986         dFGBdR = ( Rhead * ( 2.0d0 - (0.5d0 * ee) ) )
1987      &         / ( 2.0d0 * Fgb )
1988         dGGBdR = dGGBdFGB * dFGBdR
1989 c!        dGGBdR = 0.0d0
1990 c!-------------------------------------------------------------------
1991 c! Fisocav - isotropic cavity creation term
1992         pom = Rhead * csig
1993         top = al1 * (dsqrt(pom) + al2 * pom - al3)
1994         bot = (1.0d0 + al4 * pom**12.0d0)
1995         botsq = bot * bot
1996         FisoCav = top / bot
1997 c!        FisoCav = 0.0d0
1998 c!      write (*,*) "pom = ",pom
1999 c!      write (*,*) "al1 = ",al1
2000 c!      write (*,*) "al2 = ",al2
2001 c!      write (*,*) "al3 = ",al3
2002 c!      write (*,*) "al4 = ",al4
2003 c!      write (*,*) "top = ",top
2004 c!      write (*,*) "bot = ",bot
2005 c!      write (*,*) "Fisocav = ", Fisocav
2006
2007 c! Derivative of Fisocav is GCV...
2008         dtop = al1 * ((1.0d0 / (2.0d0 * dsqrt(pom))) + al2)
2009         dbot = 12.0d0 * al4 * pom ** 11.0d0
2010         dGCVdR = ((dtop * bot - top * dbot) / botsq) * csig
2011 c!        dGCVdR = 0.0d0
2012 c!-------------------------------------------------------------------
2013 c! Polarization energy
2014 c! Epol
2015         MomoFac1 = (1.0d0 - chi1 * sqom2)
2016         MomoFac2 = (1.0d0 - chi2 * sqom1)
2017         RR1  = ( R1 * R1 ) / MomoFac1
2018         RR2  = ( R2 * R2 ) / MomoFac2
2019         ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2020         ee2  = exp(-( RR2 / (4.0d0 * a12sq) ))
2021         fgb1 = sqrt( RR1 + a12sq * ee1 )
2022         fgb2 = sqrt( RR2 + a12sq * ee2 )
2023         epol = 332.0d0 * eps_inout_fac * (
2024      &  (( alphapol1 / fgb1 )**4.0d0)+((alphapol2/fgb2) ** 4.0d0 ))
2025 c!        epol = 0.0d0
2026 c! derivative of Epol is Gpol...
2027         dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2028      &            / (fgb1 ** 5.0d0)
2029         dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2030      &            / (fgb2 ** 5.0d0)
2031         dFGBdR1 = ( (R1 / MomoFac1)
2032      &          * ( 2.0d0 - (0.5d0 * ee1) ) )
2033      &          / ( 2.0d0 * fgb1 )
2034         dFGBdR2 = ( (R2 / MomoFac2)
2035      &          * ( 2.0d0 - (0.5d0 * ee2) ) )
2036      &          / ( 2.0d0 * fgb2 )
2037         dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2038      &           * ( 2.0d0 - 0.5d0 * ee1) )
2039      &           / ( 2.0d0 * fgb1 )
2040         dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2041      &           * ( 2.0d0 - 0.5d0 * ee2) )
2042      &           / ( 2.0d0 * fgb2 )
2043         dPOLdR1 = dPOLdFGB1 * dFGBdR1
2044 c!        dPOLdR1 = 0.0d0
2045         dPOLdR2 = dPOLdFGB2 * dFGBdR2
2046 c!        dPOLdR2 = 0.0d0
2047         dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2048 c!        dPOLdOM1 = 0.0d0
2049         dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2050 c!        dPOLdOM2 = 0.0d0
2051 c!-------------------------------------------------------------------
2052 c! Elj
2053         pom = (pis / Rhead)**6.0d0
2054         Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2055 c!        Elj = 0.0d0
2056 c! derivative of Elj is Glj
2057         dGLJdR = 4.0d0 * eps_head
2058      &      * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2059      &      +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2060 c!        dGLJdR = 0.0d0
2061 c!-------------------------------------------------------------------
2062 c! Equad
2063        IF (Wqd.ne.0.0d0) THEN
2064         Beta1 = 5.0d0 + 3.0d0 * (sqom12 - 1.0d0)
2065      &        - 37.5d0  * ( sqom1 + sqom2 )
2066      &        + 157.5d0 * ( sqom1 * sqom2 )
2067      &        - 45.0d0  * om1*om2*om12
2068         fac = -( Wqd / (2.0d0 * Fgb**5.0d0) )
2069         Equad = fac * Beta1
2070 c!        Equad = 0.0d0
2071 c! derivative of Equad...
2072         dQUADdR = ((2.5d0 * Wqd * Beta1) / (Fgb**6.0d0)) * dFGBdR
2073 c!        dQUADdR = 0.0d0
2074         dQUADdOM1 = fac
2075      &            * (-75.0d0*om1 + 315.0d0*om1*sqom2 - 45.0d0*om2*om12)
2076 c!        dQUADdOM1 = 0.0d0
2077         dQUADdOM2 = fac
2078      &            * (-75.0d0*om2 + 315.0d0*sqom1*om2 - 45.0d0*om1*om12)
2079 c!        dQUADdOM2 = 0.0d0
2080         dQUADdOM12 = fac
2081      &             * ( 6.0d0*om12 - 45.0d0*om1*om2 )
2082 c!        dQUADdOM12 = 0.0d0
2083         ELSE
2084          Beta1 = 0.0d0
2085          Equad = 0.0d0
2086         END IF
2087 c!-------------------------------------------------------------------
2088 c! Return the results
2089 c! Angular stuff
2090         eom1 = dPOLdOM1 + dQUADdOM1
2091         eom2 = dPOLdOM2 + dQUADdOM2
2092         eom12 = dQUADdOM12
2093 c! now some magical transformations to project gradient into
2094 c! three cartesian vectors
2095         DO k = 1, 3
2096          dcosom1(k) = rij * (dc_norm(k,nres+i) - om1 * erij(k))
2097          dcosom2(k) = rij * (dc_norm(k,nres+j) - om2 * erij(k))
2098          tuna(k) = eom1 * dcosom1(k) + eom2 * dcosom2(k)
2099         END DO
2100 c! Radial stuff
2101         DO k = 1, 3
2102          erhead(k) = Rhead_distance(k)/Rhead
2103          erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2104          erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2105         END DO
2106         erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2107         erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2108         bat   = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2109         federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2110         eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2111         adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2112         facd1 = d1 * vbld_inv(i+nres)
2113         facd2 = d2 * vbld_inv(j+nres)
2114         facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2115         facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2116 c! Throw the results into gheadtail which holds gradients
2117 c! for each micro-state
2118         DO k = 1, 3
2119          hawk   = erhead_tail(k,1) +
2120      &  facd1 * (erhead_tail(k,1) - bat   * dC_norm(k,i+nres))
2121          condor = erhead_tail(k,2) +
2122      &  facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres))
2123
2124          pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2125 c! this acts on hydrophobic center of interaction
2126          gheadtail(k,1,1) = gheadtail(k,1,1)
2127      &                    - dGCLdR * pom
2128      &                    - dGGBdR * pom
2129      &                    - dGCVdR * pom
2130      &                    - dPOLdR1 * hawk
2131      &                    - dPOLdR2 * (erhead_tail(k,2)
2132      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2133      &                    - dGLJdR * pom
2134      &                    - dQUADdR * pom
2135      &                    - tuna(k)
2136      &            + (eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2137      &            + eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2138
2139          pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2140 c! this acts on hydrophobic center of interaction
2141          gheadtail(k,2,1) = gheadtail(k,2,1)
2142      &                    + dGCLdR * pom
2143      &                    + dGGBdR * pom
2144      &                    + dGCVdR * pom
2145      &                    + dPOLdR1 * (erhead_tail(k,1)
2146      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2147      &                    + dPOLdR2 * condor
2148      &                    + dGLJdR * pom
2149      &                    + dQUADdR * pom
2150      &                    + tuna(k)
2151      &            + (eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2152      &            + eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2153
2154 c! this acts on Calpha
2155          gheadtail(k,3,1) = gheadtail(k,3,1)
2156      &                    - dGCLdR * erhead(k)
2157      &                    - dGGBdR * erhead(k)
2158      &                    - dGCVdR * erhead(k)
2159      &                    - dPOLdR1 * erhead_tail(k,1)
2160      &                    - dPOLdR2 * erhead_tail(k,2)
2161      &                    - dGLJdR * erhead(k)
2162      &                    - dQUADdR * erhead(k)
2163      &                    - tuna(k)
2164
2165 c! this acts on Calpha
2166          gheadtail(k,4,1) = gheadtail(k,4,1)
2167      &                    + dGCLdR * erhead(k)
2168      &                    + dGGBdR * erhead(k)
2169      &                    + dGCVdR * erhead(k)
2170      &                    + dPOLdR1 * erhead_tail(k,1)
2171      &                    + dPOLdR2 * erhead_tail(k,2)
2172      &                    + dGLJdR * erhead(k)
2173      &                    + dQUADdR * erhead(k)
2174      &                    + tuna(k)
2175         END DO
2176 c!      write(*,*) "ECL = ", Ecl
2177 c!      write(*,*) "Egb = ", Egb
2178 c!      write(*,*) "Epol = ", Epol
2179 c!      write(*,*) "Fisocav = ", Fisocav
2180 c!      write(*,*) "Elj = ", Elj
2181 c!      write(*,*) "Equad = ", Equad
2182 c!      write(*,*) "wstate = ", wstate(istate,itypi,itypj)
2183 c!      write(*,*) "eheadtail = ", eheadtail
2184 c!      write(*,*) "TROLL = ", dexp(-betaT * ener(istate))
2185 c!      write(*,*) "dGCLdR = ", dGCLdR
2186 c!      write(*,*) "dGGBdR = ", dGGBdR
2187 c!      write(*,*) "dGCVdR = ", dGCVdR
2188 c!      write(*,*) "dPOLdR1 = ", dPOLdR1
2189 c!      write(*,*) "dPOLdR2 = ", dPOLdR2
2190 c!      write(*,*) "dGLJdR = ", dGLJdR
2191 c!      write(*,*) "dQUADdR = ", dQUADdR
2192 c!      write(*,*) "tuna(",k,") = ", tuna(k)
2193         ener(istate) = ECL + Egb + Epol + Fisocav + Elj + Equad
2194         eheadtail = eheadtail
2195      &            + wstate(istate, itypi, itypj)
2196      &            * dexp(-betaT * ener(istate))
2197 c! foreach cartesian dimension
2198         DO k = 1, 3
2199 c! foreach of two gvdwx and gvdwc
2200          DO l = 1, 4
2201           gheadtail(k,l,2) = gheadtail(k,l,2)
2202      &                     + wstate( istate, itypi, itypj )
2203      &                     * dexp(-betaT * ener(istate))
2204      &                     * gheadtail(k,l,1)
2205           gheadtail(k,l,1) = 0.0d0
2206          END DO
2207         END DO
2208        END DO
2209 c! Here ended the gigantic DO istate = 1, 4, which starts
2210 c! at the beggining of the subroutine
2211
2212        DO k = 1, 3
2213         DO l = 1, 4
2214          gheadtail(k,l,2) = gheadtail(k,l,2) / eheadtail
2215         END DO
2216         gvdwx(k,i) = gvdwx(k,i) + gheadtail(k,1,2)
2217         gvdwx(k,j) = gvdwx(k,j) + gheadtail(k,2,2)
2218         gvdwc(k,i) = gvdwc(k,i) + gheadtail(k,3,2)
2219         gvdwc(k,j) = gvdwc(k,j) + gheadtail(k,4,2)
2220         DO l = 1, 4
2221          gheadtail(k,l,1) = 0.0d0
2222          gheadtail(k,l,2) = 0.0d0
2223         END DO
2224        END DO
2225        eheadtail = (-dlog(eheadtail)) / betaT
2226        dPOLdOM1 = 0.0d0
2227        dPOLdOM2 = 0.0d0
2228        dQUADdOM1 = 0.0d0
2229        dQUADdOM2 = 0.0d0
2230        dQUADdOM12 = 0.0d0
2231        RETURN
2232       END SUBROUTINE energy_quad
2233 c!-------------------------------------------------------------------
2234       SUBROUTINE eqn(Epol)
2235       IMPLICIT NONE
2236       INCLUDE 'DIMENSIONS'
2237       INCLUDE 'DIMENSIONS.ZSCOPT'
2238       INCLUDE 'COMMON.CALC'
2239       INCLUDE 'COMMON.CHAIN'
2240       INCLUDE 'COMMON.CONTROL'
2241       INCLUDE 'COMMON.DERIV'
2242       INCLUDE 'COMMON.EMP'
2243       INCLUDE 'COMMON.GEO'
2244       INCLUDE 'COMMON.INTERACT'
2245       INCLUDE 'COMMON.IOUNITS'
2246       INCLUDE 'COMMON.LOCAL'
2247       INCLUDE 'COMMON.NAMES'
2248       INCLUDE 'COMMON.VAR'
2249       double precision scalar, facd4, federmaus
2250       alphapol1 = alphapol(itypi,itypj)
2251 c! R1 - distance between head of ith side chain and tail of jth sidechain
2252        R1 = 0.0d0
2253        DO k = 1, 3
2254 c! Calculate head-to-tail distances
2255         R1=R1+(ctail(k,2)-chead(k,1))**2
2256        END DO
2257 c! Pitagoras
2258        R1 = dsqrt(R1)
2259
2260 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2261 c!     &        +dhead(1,1,itypi,itypj))**2))
2262 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2263 c!     &        +dhead(2,1,itypi,itypj))**2))
2264 c--------------------------------------------------------------------
2265 c Polarization energy
2266 c Epol
2267        MomoFac1 = (1.0d0 - chi1 * sqom2)
2268        RR1  = R1 * R1 / MomoFac1
2269        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2270        fgb1 = sqrt( RR1 + a12sq * ee1)
2271        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2272 c!       epol = 0.0d0
2273 c!------------------------------------------------------------------
2274 c! derivative of Epol is Gpol...
2275        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2276      &          / (fgb1 ** 5.0d0)
2277        dFGBdR1 = ( (R1 / MomoFac1)
2278      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2279      &        / ( 2.0d0 * fgb1 )
2280        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2281      &          * (2.0d0 - 0.5d0 * ee1) )
2282      &          / (2.0d0 * fgb1)
2283        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2284 c!       dPOLdR1 = 0.0d0
2285        dPOLdOM1 = 0.0d0
2286        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2287 c!       dPOLdOM2 = 0.0d0
2288 c!-------------------------------------------------------------------
2289 c! Return the results
2290 c! (see comments in Eqq)
2291        DO k = 1, 3
2292         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2293        END DO
2294        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2295        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2296        facd1 = d1 * vbld_inv(i+nres)
2297        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2298
2299        DO k = 1, 3
2300         hawk = (erhead_tail(k,1) +
2301      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2302
2303         gvdwx(k,i) = gvdwx(k,i)
2304      &             - dPOLdR1 * hawk
2305         gvdwx(k,j) = gvdwx(k,j)
2306      &             + dPOLdR1 * (erhead_tail(k,1)
2307      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2308
2309         gvdwc(k,i) = gvdwc(k,i)
2310      &             - dPOLdR1 * erhead_tail(k,1)
2311         gvdwc(k,j) = gvdwc(k,j)
2312      &             + dPOLdR1 * erhead_tail(k,1)
2313
2314        END DO
2315        RETURN
2316       END SUBROUTINE eqn
2317
2318
2319 c!-------------------------------------------------------------------
2320
2321
2322
2323       SUBROUTINE enq(Epol)
2324        IMPLICIT NONE
2325        INCLUDE 'DIMENSIONS'
2326        INCLUDE 'DIMENSIONS.ZSCOPT'
2327        INCLUDE 'COMMON.CALC'
2328        INCLUDE 'COMMON.CHAIN'
2329        INCLUDE 'COMMON.CONTROL'
2330        INCLUDE 'COMMON.DERIV'
2331        INCLUDE 'COMMON.EMP'
2332        INCLUDE 'COMMON.GEO'
2333        INCLUDE 'COMMON.INTERACT'
2334        INCLUDE 'COMMON.IOUNITS'
2335        INCLUDE 'COMMON.LOCAL'
2336        INCLUDE 'COMMON.NAMES'
2337        INCLUDE 'COMMON.VAR'
2338        double precision scalar, facd3, adler
2339        alphapol2 = alphapol(itypj,itypi)
2340 c! R2 - distance between head of jth side chain and tail of ith sidechain
2341        R2 = 0.0d0
2342        DO k = 1, 3
2343 c! Calculate head-to-tail distances
2344         R2=R2+(chead(k,2)-ctail(k,1))**2
2345        END DO
2346 c! Pitagoras
2347        R2 = dsqrt(R2)
2348
2349 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2350 c!     &        +dhead(1,1,itypi,itypj))**2))
2351 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2352 c!     &        +dhead(2,1,itypi,itypj))**2))
2353 c------------------------------------------------------------------------
2354 c Polarization energy
2355        MomoFac2 = (1.0d0 - chi2 * sqom1)
2356        RR2  = R2 * R2 / MomoFac2
2357        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2358        fgb2 = sqrt(RR2  + a12sq * ee2)
2359        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2360 c!       epol = 0.0d0
2361 c!-------------------------------------------------------------------
2362 c! derivative of Epol is Gpol...
2363        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2364      &          / (fgb2 ** 5.0d0)
2365        dFGBdR2 = ( (R2 / MomoFac2)
2366      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2367      &        / (2.0d0 * fgb2)
2368        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2369      &          * (2.0d0 - 0.5d0 * ee2) )
2370      &          / (2.0d0 * fgb2)
2371        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2372 c!       dPOLdR2 = 0.0d0
2373        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2374 c!       dPOLdOM1 = 0.0d0
2375        dPOLdOM2 = 0.0d0
2376 c!-------------------------------------------------------------------
2377 c! Return the results
2378 c! (See comments in Eqq)
2379        DO k = 1, 3
2380         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2381        END DO
2382        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2383        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2384        facd2 = d2 * vbld_inv(j+nres)
2385        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2386        DO k = 1, 3
2387         condor = (erhead_tail(k,2)
2388      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2389
2390         gvdwx(k,i) = gvdwx(k,i)
2391      &             - dPOLdR2 * (erhead_tail(k,2)
2392      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2393         gvdwx(k,j) = gvdwx(k,j)
2394      &             + dPOLdR2 * condor
2395
2396         gvdwc(k,i) = gvdwc(k,i)
2397      &             - dPOLdR2 * erhead_tail(k,2)
2398         gvdwc(k,j) = gvdwc(k,j)
2399      &             + dPOLdR2 * erhead_tail(k,2)
2400
2401        END DO
2402       RETURN
2403       END SUBROUTINE enq
2404
2405
2406 c!-------------------------------------------------------------------
2407
2408
2409       SUBROUTINE eqd(Ecl,Elj,Epol)
2410        IMPLICIT NONE
2411        INCLUDE 'DIMENSIONS'
2412        INCLUDE 'DIMENSIONS.ZSCOPT'
2413        INCLUDE 'COMMON.CALC'
2414        INCLUDE 'COMMON.CHAIN'
2415        INCLUDE 'COMMON.CONTROL'
2416        INCLUDE 'COMMON.DERIV'
2417        INCLUDE 'COMMON.EMP'
2418        INCLUDE 'COMMON.GEO'
2419        INCLUDE 'COMMON.INTERACT'
2420        INCLUDE 'COMMON.IOUNITS'
2421        INCLUDE 'COMMON.LOCAL'
2422        INCLUDE 'COMMON.NAMES'
2423        INCLUDE 'COMMON.VAR'
2424        double precision scalar, facd4, federmaus
2425        alphapol1 = alphapol(itypi,itypj)
2426        w1        = wqdip(1,itypi,itypj)
2427        w2        = wqdip(2,itypi,itypj)
2428        pis       = sig0head(itypi,itypj)
2429        eps_head   = epshead(itypi,itypj)
2430 c!-------------------------------------------------------------------
2431 c! R1 - distance between head of ith side chain and tail of jth sidechain
2432        R1 = 0.0d0
2433        DO k = 1, 3
2434 c! Calculate head-to-tail distances
2435         R1=R1+(ctail(k,2)-chead(k,1))**2
2436        END DO
2437 c! Pitagoras
2438        R1 = dsqrt(R1)
2439
2440 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2441 c!     &        +dhead(1,1,itypi,itypj))**2))
2442 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2443 c!     &        +dhead(2,1,itypi,itypj))**2))
2444
2445 c!-------------------------------------------------------------------
2446 c! ecl
2447        sparrow  = w1 * Qi * om1
2448        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2449        Ecl = sparrow / Rhead**2.0d0
2450      &     - hawk    / Rhead**4.0d0
2451 c!-------------------------------------------------------------------
2452 c! derivative of ecl is Gcl
2453 c! dF/dr part
2454        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2455      &           + 4.0d0 * hawk    / Rhead**5.0d0
2456 c! dF/dom1
2457        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2458 c! dF/dom2
2459        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2460 c--------------------------------------------------------------------
2461 c Polarization energy
2462 c Epol
2463        MomoFac1 = (1.0d0 - chi1 * sqom2)
2464        RR1  = R1 * R1 / MomoFac1
2465        ee1  = exp(-( RR1 / (4.0d0 * a12sq) ))
2466        fgb1 = sqrt( RR1 + a12sq * ee1)
2467        epol = 332.0d0 * eps_inout_fac * (( alphapol1 / fgb1 )**4.0d0)
2468 c!       epol = 0.0d0
2469 c!------------------------------------------------------------------
2470 c! derivative of Epol is Gpol...
2471        dPOLdFGB1 = -(1328.0d0 * eps_inout_fac * alphapol1 ** 4.0d0)
2472      &          / (fgb1 ** 5.0d0)
2473        dFGBdR1 = ( (R1 / MomoFac1)
2474      &        * ( 2.0d0 - (0.5d0 * ee1) ) )
2475      &        / ( 2.0d0 * fgb1 )
2476        dFGBdOM2 = (((R1 * R1 * chi1 * om2) / (MomoFac1 * MomoFac1))
2477      &          * (2.0d0 - 0.5d0 * ee1) )
2478      &          / (2.0d0 * fgb1)
2479        dPOLdR1 = dPOLdFGB1 * dFGBdR1
2480 c!       dPOLdR1 = 0.0d0
2481        dPOLdOM1 = 0.0d0
2482        dPOLdOM2 = dPOLdFGB1 * dFGBdOM2
2483 c!       dPOLdOM2 = 0.0d0
2484 c!-------------------------------------------------------------------
2485 c! Elj
2486        pom = (pis / Rhead)**6.0d0
2487        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2488 c! derivative of Elj is Glj
2489        dGLJdR = 4.0d0 * eps_head
2490      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2491      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2492 c!-------------------------------------------------------------------
2493 c! Return the results
2494        DO k = 1, 3
2495         erhead(k) = Rhead_distance(k)/Rhead
2496         erhead_tail(k,1) = ((ctail(k,2)-chead(k,1))/R1)
2497        END DO
2498
2499        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2500        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2501        bat = scalar( erhead_tail(1,1), dC_norm(1,i+nres) )
2502        federmaus = scalar(erhead_tail(1,1),dC_norm(1,j+nres))
2503        facd1 = d1 * vbld_inv(i+nres)
2504        facd2 = d2 * vbld_inv(j+nres)
2505        facd4 = dtail(2,itypi,itypj) * vbld_inv(j+nres)
2506
2507        DO k = 1, 3
2508         hawk = (erhead_tail(k,1) +
2509      & facd1 * (erhead_tail(k,1) - bat * dC_norm(k,i+nres)))
2510
2511         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2512         gvdwx(k,i) = gvdwx(k,i)
2513      &             - dGCLdR * pom
2514      &             - dPOLdR1 * hawk
2515      &             - dGLJdR * pom
2516
2517         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2518         gvdwx(k,j) = gvdwx(k,j)
2519      &             + dGCLdR * pom
2520      &             + dPOLdR1 * (erhead_tail(k,1)
2521      & -facd4 * (erhead_tail(k,1) - federmaus * dC_norm(k,j+nres)))
2522      &             + dGLJdR * pom
2523
2524
2525         gvdwc(k,i) = gvdwc(k,i)
2526      &             - dGCLdR * erhead(k)
2527      &             - dPOLdR1 * erhead_tail(k,1)
2528      &             - dGLJdR * erhead(k)
2529
2530         gvdwc(k,j) = gvdwc(k,j)
2531      &             + dGCLdR * erhead(k)
2532      &             + dPOLdR1 * erhead_tail(k,1)
2533      &             + dGLJdR * erhead(k)
2534
2535        END DO
2536        RETURN
2537       END SUBROUTINE eqd
2538
2539
2540 c!-------------------------------------------------------------------
2541
2542
2543       SUBROUTINE edq(Ecl,Elj,Epol)
2544        IMPLICIT NONE
2545        INCLUDE 'DIMENSIONS'
2546        INCLUDE 'DIMENSIONS.ZSCOPT'
2547        INCLUDE 'COMMON.CALC'
2548        INCLUDE 'COMMON.CHAIN'
2549        INCLUDE 'COMMON.CONTROL'
2550        INCLUDE 'COMMON.DERIV'
2551        INCLUDE 'COMMON.EMP'
2552        INCLUDE 'COMMON.GEO'
2553        INCLUDE 'COMMON.INTERACT'
2554        INCLUDE 'COMMON.IOUNITS'
2555        INCLUDE 'COMMON.LOCAL'
2556        INCLUDE 'COMMON.NAMES'
2557        INCLUDE 'COMMON.VAR'
2558        double precision scalar, facd3, adler
2559        alphapol2 = alphapol(itypj,itypi)
2560        w1        = wqdip(1,itypi,itypj)
2561        w2        = wqdip(2,itypi,itypj)
2562        pis       = sig0head(itypi,itypj)
2563        eps_head  = epshead(itypi,itypj)
2564 c!-------------------------------------------------------------------
2565 c! R2 - distance between head of jth side chain and tail of ith sidechain
2566        R2 = 0.0d0
2567        DO k = 1, 3
2568 c! Calculate head-to-tail distances
2569         R2=R2+(chead(k,2)-ctail(k,1))**2
2570        END DO
2571 c! Pitagoras
2572        R2 = dsqrt(R2)
2573
2574 c!      R1     = dsqrt((Rtail**2)+((dtail(1,itypi,itypj)
2575 c!     &        +dhead(1,1,itypi,itypj))**2))
2576 c!      R2     = dsqrt((Rtail**2)+((dtail(2,itypi,itypj)
2577 c!     &        +dhead(2,1,itypi,itypj))**2))
2578
2579
2580 c!-------------------------------------------------------------------
2581 c! ecl
2582        sparrow  = w1 * Qi * om1
2583        hawk     = w2 * Qi * Qi * (1.0d0 - sqom2)
2584        ECL = sparrow / Rhead**2.0d0
2585      &     - hawk    / Rhead**4.0d0
2586 c!-------------------------------------------------------------------
2587 c! derivative of ecl is Gcl
2588 c! dF/dr part
2589        dGCLdR  = - 2.0d0 * sparrow / Rhead**3.0d0
2590      &           + 4.0d0 * hawk    / Rhead**5.0d0
2591 c! dF/dom1
2592        dGCLdOM1 = (w1 * Qi) / (Rhead**2.0d0)
2593 c! dF/dom2
2594        dGCLdOM2 = (2.0d0 * w2 * Qi * Qi * om2) / (Rhead ** 4.0d0)
2595 c--------------------------------------------------------------------
2596 c Polarization energy
2597 c Epol
2598        MomoFac2 = (1.0d0 - chi2 * sqom1)
2599        RR2  = R2 * R2 / MomoFac2
2600        ee2  = exp(-(RR2 / (4.0d0 * a12sq)))
2601        fgb2 = sqrt(RR2  + a12sq * ee2)
2602        epol = 332.0d0 * eps_inout_fac * ((alphapol2/fgb2) ** 4.0d0 )
2603 c!       epol = 0.0d0
2604 c! derivative of Epol is Gpol...
2605        dPOLdFGB2 = -(1328.0d0 * eps_inout_fac * alphapol2 ** 4.0d0)
2606      &          / (fgb2 ** 5.0d0)
2607        dFGBdR2 = ( (R2 / MomoFac2)
2608      &        * ( 2.0d0 - (0.5d0 * ee2) ) )
2609      &        / (2.0d0 * fgb2)
2610        dFGBdOM1 = (((R2 * R2 * chi2 * om1) / (MomoFac2 * MomoFac2))
2611      &          * (2.0d0 - 0.5d0 * ee2) )
2612      &          / (2.0d0 * fgb2)
2613        dPOLdR2 = dPOLdFGB2 * dFGBdR2
2614 c!       dPOLdR2 = 0.0d0
2615        dPOLdOM1 = dPOLdFGB2 * dFGBdOM1
2616 c!       dPOLdOM1 = 0.0d0
2617        dPOLdOM2 = 0.0d0
2618 c!-------------------------------------------------------------------
2619 c! Elj
2620        pom = (pis / Rhead)**6.0d0
2621        Elj = 4.0d0 * eps_head * pom * (pom-1.0d0)
2622 c! derivative of Elj is Glj
2623        dGLJdR = 4.0d0 * eps_head
2624      &     * (((-12.0d0*pis**12.0d0)/(Rhead**13.0d0))
2625      &     +  ((  6.0d0*pis**6.0d0) /(Rhead**7.0d0)))
2626 c!-------------------------------------------------------------------
2627 c! Return the results
2628 c! (see comments in Eqq)
2629        DO k = 1, 3
2630         erhead(k) = Rhead_distance(k)/Rhead
2631         erhead_tail(k,2) = ((chead(k,2)-ctail(k,1))/R2)
2632        END DO
2633        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2634        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2635        eagle = scalar( erhead_tail(1,2), dC_norm(1,j+nres) )
2636        adler = scalar( erhead_tail(1,2), dC_norm(1,i+nres) )
2637        facd1 = d1 * vbld_inv(i+nres)
2638        facd2 = d2 * vbld_inv(j+nres)
2639        facd3 = dtail(1,itypi,itypj) * vbld_inv(i+nres)
2640
2641        DO k = 1, 3
2642         condor = (erhead_tail(k,2)
2643      & + facd2 * (erhead_tail(k,2) - eagle * dC_norm(k,j+nres)))
2644
2645         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2646         gvdwx(k,i) = gvdwx(k,i)
2647      &             - dGCLdR * pom
2648      &             - dPOLdR2 * (erhead_tail(k,2)
2649      & -facd3 * (erhead_tail(k,2) - adler * dC_norm(k,i+nres)))
2650      &             - dGLJdR * pom
2651
2652         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2653         gvdwx(k,j) = gvdwx(k,j)
2654      &             + dGCLdR * pom
2655      &             + dPOLdR2 * condor
2656      &             + dGLJdR * pom
2657
2658
2659         gvdwc(k,i) = gvdwc(k,i)
2660      &             - dGCLdR * erhead(k)
2661      &             - dPOLdR2 * erhead_tail(k,2)
2662      &             - dGLJdR * erhead(k)
2663
2664         gvdwc(k,j) = gvdwc(k,j)
2665      &             + dGCLdR * erhead(k)
2666      &             + dPOLdR2 * erhead_tail(k,2)
2667      &             + dGLJdR * erhead(k)
2668
2669        END DO
2670        RETURN
2671       END SUBROUTINE edq
2672
2673
2674 C--------------------------------------------------------------------
2675
2676
2677       SUBROUTINE edd(ECL)
2678        IMPLICIT NONE
2679        INCLUDE 'DIMENSIONS'
2680        INCLUDE 'DIMENSIONS.ZSCOPT'
2681        INCLUDE 'COMMON.CALC'
2682        INCLUDE 'COMMON.CHAIN'
2683        INCLUDE 'COMMON.CONTROL'
2684        INCLUDE 'COMMON.DERIV'
2685        INCLUDE 'COMMON.EMP'
2686        INCLUDE 'COMMON.GEO'
2687        INCLUDE 'COMMON.INTERACT'
2688        INCLUDE 'COMMON.IOUNITS'
2689        INCLUDE 'COMMON.LOCAL'
2690        INCLUDE 'COMMON.NAMES'
2691        INCLUDE 'COMMON.VAR'
2692        double precision scalar
2693 c!       csig = sigiso(itypi,itypj)
2694        w1 = wqdip(1,itypi,itypj)
2695        w2 = wqdip(2,itypi,itypj)
2696 c!-------------------------------------------------------------------
2697 c! ECL
2698        fac = (om12 - 3.0d0 * om1 * om2)
2699        c1 = (w1 / (Rhead**3.0d0)) * fac
2700        c2 = (w2 / Rhead ** 6.0d0)
2701      &    * (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2702        ECL = c1 - c2
2703 c!       write (*,*) "w1 = ", w1
2704 c!       write (*,*) "w2 = ", w2
2705 c!       write (*,*) "om1 = ", om1
2706 c!       write (*,*) "om2 = ", om2
2707 c!       write (*,*) "om12 = ", om12
2708 c!       write (*,*) "fac = ", fac
2709 c!       write (*,*) "c1 = ", c1
2710 c!       write (*,*) "c2 = ", c2
2711 c!       write (*,*) "Ecl = ", Ecl
2712 c!       write (*,*) "c2_1 = ", (w2 / Rhead ** 6.0d0)
2713 c!       write (*,*) "c2_2 = ",
2714 c!     & (4.0d0 + fac * fac -3.0d0 * (sqom1 + sqom2))
2715 c!-------------------------------------------------------------------
2716 c! dervative of ECL is GCL...
2717 c! dECL/dr
2718        c1 = (-3.0d0 * w1 * fac) / (Rhead ** 4.0d0)
2719        c2 = (-6.0d0 * w2) / (Rhead ** 7.0d0)
2720      &    * (4.0d0 + fac * fac - 3.0d0 * (sqom1 + sqom2))
2721        dGCLdR = c1 - c2
2722 c! dECL/dom1
2723        c1 = (-3.0d0 * w1 * om2 ) / (Rhead**3.0d0)
2724        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2725      &    * ( om2 * om12 - 3.0d0 * om1 * sqom2 + om1 )
2726        dGCLdOM1 = c1 - c2
2727 c! dECL/dom2
2728        c1 = (-3.0d0 * w1 * om1 ) / (Rhead**3.0d0)
2729        c2 = (-6.0d0 * w2) / (Rhead**6.0d0)
2730      &    * ( om1 * om12 - 3.0d0 * sqom1 * om2 + om2 )
2731        dGCLdOM2 = c1 - c2
2732 c! dECL/dom12
2733        c1 = w1 / (Rhead ** 3.0d0)
2734        c2 = ( 2.0d0 * w2 * fac ) / Rhead ** 6.0d0
2735        dGCLdOM12 = c1 - c2
2736 c!-------------------------------------------------------------------
2737 c! Return the results
2738 c! (see comments in Eqq)
2739        DO k= 1, 3
2740         erhead(k) = Rhead_distance(k)/Rhead
2741        END DO
2742        erdxi = scalar( erhead(1), dC_norm(1,i+nres) )
2743        erdxj = scalar( erhead(1), dC_norm(1,j+nres) )
2744        facd1 = d1 * vbld_inv(i+nres)
2745        facd2 = d2 * vbld_inv(j+nres)
2746        DO k = 1, 3
2747
2748         pom = erhead(k)+facd1*(erhead(k)-erdxi*dC_norm(k,i+nres))
2749         gvdwx(k,i) = gvdwx(k,i)
2750      &             - dGCLdR * pom
2751         pom = erhead(k)+facd2*(erhead(k)-erdxj*dC_norm(k,j+nres))
2752         gvdwx(k,j) = gvdwx(k,j)
2753      &             + dGCLdR * pom
2754
2755         gvdwc(k,i) = gvdwc(k,i)
2756      &             - dGCLdR * erhead(k)
2757         gvdwc(k,j) = gvdwc(k,j)
2758      &             + dGCLdR * erhead(k)
2759        END DO
2760        RETURN
2761       END SUBROUTINE edd
2762
2763
2764 c!-------------------------------------------------------------------
2765
2766
2767       SUBROUTINE elgrad_init(eheadtail,Egb,Ecl,Elj,Equad,Epol)
2768        IMPLICIT NONE
2769 c! maxres
2770        INCLUDE 'DIMENSIONS'
2771        INCLUDE 'DIMENSIONS.ZSCOPT'
2772 c! itypi, itypj, i, j, k, l, chead,
2773        INCLUDE 'COMMON.CALC'
2774 c! c, nres, dc_norm
2775        INCLUDE 'COMMON.CHAIN'
2776 c! gradc, gradx
2777        INCLUDE 'COMMON.DERIV'
2778 c! electrostatic gradients-specific variables
2779        INCLUDE 'COMMON.EMP'
2780 c! wquad, dhead, alphiso, alphasur, rborn, epsintab
2781        INCLUDE 'COMMON.INTERACT'
2782 c! t_bath, Rb
2783 c       INCLUDE 'COMMON.MD'
2784 c! io for debug, disable it in final builds
2785        INCLUDE 'COMMON.IOUNITS'
2786        double precision Rb /1.987D-3/
2787 c!-------------------------------------------------------------------
2788 c! Variable Init
2789
2790 c! what amino acid is the aminoacid j'th?
2791        itypj = itype(j)
2792 c! 1/(Gas Constant * Thermostate temperature) = BetaT
2793 c! ENABLE THIS LINE WHEN USING CHECKGRAD!!!
2794 c!       t_bath = 300
2795 c!       BetaT = 1.0d0 / (t_bath * Rb)
2796        BetaT = 1.0d0 / (298.0d0 * Rb)
2797 c! Gay-berne var's
2798        sig0ij = sigma( itypi,itypj )
2799        chi1   = chi( itypi, itypj )
2800        chi2   = chi( itypj, itypi )
2801        chi12  = chi1 * chi2
2802        chip1  = chipp( itypi, itypj )
2803        chip2  = chipp( itypj, itypi )
2804        chip12 = chip1 * chip2
2805 c! not used by momo potential, but needed by sc_angular which is shared
2806 c! by all energy_potential subroutines
2807        alf1   = 0.0d0
2808        alf2   = 0.0d0
2809        alf12  = 0.0d0
2810 c! location, location, location
2811        xj  = c( 1, nres+j ) - xi
2812        yj  = c( 2, nres+j ) - yi
2813        zj  = c( 3, nres+j ) - zi
2814        dxj = dc_norm( 1, nres+j )
2815        dyj = dc_norm( 2, nres+j )
2816        dzj = dc_norm( 3, nres+j )
2817 c! distance from center of chain(?) to polar/charged head
2818 c!       write (*,*) "istate = ", 1
2819 c!       write (*,*) "ii = ", 1
2820 c!       write (*,*) "jj = ", 1
2821        d1 = dhead(1, 1, itypi, itypj)
2822        d2 = dhead(2, 1, itypi, itypj)
2823 c! ai*aj from Fgb
2824        a12sq = rborn(itypi,itypj) * rborn(itypj,itypi)
2825 c!       a12sq = a12sq * a12sq
2826 c! charge of amino acid itypi is...
2827        Qi  = icharge(itypi)
2828        Qj  = icharge(itypj)
2829        Qij = Qi * Qj
2830 c! chis1,2,12
2831        chis1 = chis(itypi,itypj)
2832        chis2 = chis(itypj,itypi)
2833        chis12 = chis1 * chis2
2834        sig1 = sigmap1(itypi,itypj)
2835        sig2 = sigmap2(itypi,itypj)
2836 c!       write (*,*) "sig1 = ", sig1
2837 c!       write (*,*) "sig2 = ", sig2
2838 c! alpha factors from Fcav/Gcav
2839        b1 = alphasur(1,itypi,itypj)
2840        b2 = alphasur(2,itypi,itypj)
2841        b3 = alphasur(3,itypi,itypj)
2842        b4 = alphasur(4,itypi,itypj)
2843 c! used to determine whether we want to do quadrupole calculations
2844        wqd = wquad(itypi, itypj)
2845 c! used by Fgb
2846        eps_in = epsintab(itypi,itypj)
2847        eps_inout_fac = ( (1.0d0/eps_in) - (1.0d0/eps_out))
2848 c!       write (*,*) "eps_inout_fac = ", eps_inout_fac
2849 c!-------------------------------------------------------------------
2850 c! tail location and distance calculations
2851        Rtail = 0.0d0
2852        DO k = 1, 3
2853         ctail(k,1)=c(k,i+nres)-dtail(1,itypi,itypj)*dc_norm(k,nres+i)
2854         ctail(k,2)=c(k,j+nres)-dtail(2,itypi,itypj)*dc_norm(k,nres+j)
2855        END DO
2856 c! tail distances will be themselves usefull elswhere
2857 c1 (in Gcav, for example)
2858        Rtail_distance(1) = ctail( 1, 2 ) - ctail( 1,1 )
2859        Rtail_distance(2) = ctail( 2, 2 ) - ctail( 2,1 )
2860        Rtail_distance(3) = ctail( 3, 2 ) - ctail( 3,1 )
2861        Rtail = dsqrt(
2862      &     (Rtail_distance(1)*Rtail_distance(1))
2863      &   + (Rtail_distance(2)*Rtail_distance(2))
2864      &   + (Rtail_distance(3)*Rtail_distance(3)))
2865 c!-------------------------------------------------------------------
2866 c! Calculate location and distance between polar heads
2867 c! distance between heads
2868 c! for each one of our three dimensional space...
2869        DO k = 1,3
2870 c! location of polar head is computed by taking hydrophobic centre
2871 c! and moving by a d1 * dc_norm vector
2872 c! see unres publications for very informative images
2873         chead(k,1) = c(k, i+nres) + d1 * dc_norm(k, i+nres)
2874         chead(k,2) = c(k, j+nres) + d2 * dc_norm(k, j+nres)
2875 c! distance
2876 c!        Rsc_distance(k) = dabs(c(k, i+nres) - c(k, j+nres))
2877 c!        Rsc(k) = Rsc_distance(k) * Rsc_distance(k)
2878         Rhead_distance(k) = chead(k,2) - chead(k,1)
2879        END DO
2880 c! pitagoras (root of sum of squares)
2881        Rhead = dsqrt(
2882      &     (Rhead_distance(1)*Rhead_distance(1))
2883      &   + (Rhead_distance(2)*Rhead_distance(2))
2884      &   + (Rhead_distance(3)*Rhead_distance(3)))
2885 c!-------------------------------------------------------------------
2886 c! zero everything that should be zero'ed
2887        Egb = 0.0d0
2888        ECL = 0.0d0
2889        Elj = 0.0d0
2890        Equad = 0.0d0
2891        Epol = 0.0d0
2892        eheadtail = 0.0d0
2893        dGCLdOM1 = 0.0d0
2894        dGCLdOM2 = 0.0d0
2895        dGCLdOM12 = 0.0d0
2896        dPOLdOM1 = 0.0d0
2897        dPOLdOM2 = 0.0d0
2898        RETURN
2899       END SUBROUTINE elgrad_init
2900
2901
2902 C-----------------------------------------------------------------------------
2903       subroutine sc_angular
2904 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2905 C om12. Called by ebp, egb, and egbv.
2906       implicit none
2907       include 'COMMON.CALC'
2908       erij(1)=xj*rij
2909       erij(2)=yj*rij
2910       erij(3)=zj*rij
2911       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2912       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2913       om12=dxi*dxj+dyi*dyj+dzi*dzj
2914       chiom12=chi12*om12
2915 C Calculate eps1(om12) and its derivative in om12
2916       faceps1=1.0D0-om12*chiom12
2917       faceps1_inv=1.0D0/faceps1
2918       eps1=dsqrt(faceps1_inv)
2919 C Following variable is eps1*deps1/dom12
2920       eps1_om12=faceps1_inv*chiom12
2921 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2922 C and om12.
2923       om1om2=om1*om2
2924       chiom1=chi1*om1
2925       chiom2=chi2*om2
2926       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2927       sigsq=1.0D0-facsig*faceps1_inv
2928       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2929       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2930       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2931 C Calculate eps2 and its derivatives in om1, om2, and om12.
2932       chipom1=chip1*om1
2933       chipom2=chip2*om2
2934       chipom12=chip12*om12
2935       facp=1.0D0-om12*chipom12
2936       facp_inv=1.0D0/facp
2937       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2938 C Following variable is the square root of eps2
2939       eps2rt=1.0D0-facp1*facp_inv
2940 C Following three variables are the derivatives of the square root of eps
2941 C in om1, om2, and om12.
2942       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2943       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2944       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2945 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2946       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2947 C Calculate whole angle-dependent part of epsilon and contributions
2948 C to its derivatives
2949       return
2950       end
2951 C----------------------------------------------------------------------------
2952       subroutine sc_grad
2953       implicit real*8 (a-h,o-z)
2954       include 'DIMENSIONS'
2955       include 'DIMENSIONS.ZSCOPT'
2956       include 'COMMON.CHAIN'
2957       include 'COMMON.DERIV'
2958       include 'COMMON.CALC'
2959       double precision dcosom1(3),dcosom2(3)
2960       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2961       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2962       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2963      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2964       do k=1,3
2965         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2966         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2967       enddo
2968       do k=1,3
2969         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
2970       enddo
2971       do k=1,3
2972         gvdwx(k,i)=gvdwx(k,i)-gg(k)
2973      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2974      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2975         gvdwx(k,j)=gvdwx(k,j)+gg(k)
2976      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2977      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2978       enddo
2979 C
2980 C Calculate the components of the gradient in DC and X
2981 C
2982       do k=i,j-1
2983         do l=1,3
2984           gvdwc(l,k)=gvdwc(l,k)+gg(l)
2985         enddo
2986       enddo
2987       return
2988       end
2989 c------------------------------------------------------------------------------
2990       subroutine vec_and_deriv
2991       implicit real*8 (a-h,o-z)
2992       include 'DIMENSIONS'
2993       include 'DIMENSIONS.ZSCOPT'
2994       include 'COMMON.IOUNITS'
2995       include 'COMMON.GEO'
2996       include 'COMMON.VAR'
2997       include 'COMMON.LOCAL'
2998       include 'COMMON.CHAIN'
2999       include 'COMMON.VECTORS'
3000       include 'COMMON.DERIV'
3001       include 'COMMON.INTERACT'
3002       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
3003 C Compute the local reference systems. For reference system (i), the
3004 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
3005 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
3006       do i=1,nres-1
3007 c          if (i.eq.nres-1 .or. itel(i+1).eq.0) then
3008           if (i.eq.nres-1) then
3009 C Case of the last full residue
3010 C Compute the Z-axis
3011             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
3012             costh=dcos(pi-theta(nres))
3013             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3014             do k=1,3
3015               uz(k,i)=fac*uz(k,i)
3016             enddo
3017             if (calc_grad) then
3018 C Compute the derivatives of uz
3019             uzder(1,1,1)= 0.0d0
3020             uzder(2,1,1)=-dc_norm(3,i-1)
3021             uzder(3,1,1)= dc_norm(2,i-1)
3022             uzder(1,2,1)= dc_norm(3,i-1)
3023             uzder(2,2,1)= 0.0d0
3024             uzder(3,2,1)=-dc_norm(1,i-1)
3025             uzder(1,3,1)=-dc_norm(2,i-1)
3026             uzder(2,3,1)= dc_norm(1,i-1)
3027             uzder(3,3,1)= 0.0d0
3028             uzder(1,1,2)= 0.0d0
3029             uzder(2,1,2)= dc_norm(3,i)
3030             uzder(3,1,2)=-dc_norm(2,i)
3031             uzder(1,2,2)=-dc_norm(3,i)
3032             uzder(2,2,2)= 0.0d0
3033             uzder(3,2,2)= dc_norm(1,i)
3034             uzder(1,3,2)= dc_norm(2,i)
3035             uzder(2,3,2)=-dc_norm(1,i)
3036             uzder(3,3,2)= 0.0d0
3037             endif
3038 C Compute the Y-axis
3039             facy=fac
3040             do k=1,3
3041               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
3042             enddo
3043             if (calc_grad) then
3044 C Compute the derivatives of uy
3045             do j=1,3
3046               do k=1,3
3047                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
3048      &                        -dc_norm(k,i)*dc_norm(j,i-1)
3049                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3050               enddo
3051               uyder(j,j,1)=uyder(j,j,1)-costh
3052               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3053             enddo
3054             do j=1,2
3055               do k=1,3
3056                 do l=1,3
3057                   uygrad(l,k,j,i)=uyder(l,k,j)
3058                   uzgrad(l,k,j,i)=uzder(l,k,j)
3059                 enddo
3060               enddo
3061             enddo
3062             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3063             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3064             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3065             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3066             endif
3067           else
3068 C Other residues
3069 C Compute the Z-axis
3070             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
3071             costh=dcos(pi-theta(i+2))
3072             fac=1.0d0/dsqrt(1.0d0-costh*costh)
3073             do k=1,3
3074               uz(k,i)=fac*uz(k,i)
3075             enddo
3076             if (calc_grad) then
3077 C Compute the derivatives of uz
3078             uzder(1,1,1)= 0.0d0
3079             uzder(2,1,1)=-dc_norm(3,i+1)
3080             uzder(3,1,1)= dc_norm(2,i+1)
3081             uzder(1,2,1)= dc_norm(3,i+1)
3082             uzder(2,2,1)= 0.0d0
3083             uzder(3,2,1)=-dc_norm(1,i+1)
3084             uzder(1,3,1)=-dc_norm(2,i+1)
3085             uzder(2,3,1)= dc_norm(1,i+1)
3086             uzder(3,3,1)= 0.0d0
3087             uzder(1,1,2)= 0.0d0
3088             uzder(2,1,2)= dc_norm(3,i)
3089             uzder(3,1,2)=-dc_norm(2,i)
3090             uzder(1,2,2)=-dc_norm(3,i)
3091             uzder(2,2,2)= 0.0d0
3092             uzder(3,2,2)= dc_norm(1,i)
3093             uzder(1,3,2)= dc_norm(2,i)
3094             uzder(2,3,2)=-dc_norm(1,i)
3095             uzder(3,3,2)= 0.0d0
3096             endif
3097 C Compute the Y-axis
3098             facy=fac
3099             do k=1,3
3100               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
3101             enddo
3102             if (calc_grad) then
3103 C Compute the derivatives of uy
3104             do j=1,3
3105               do k=1,3
3106                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
3107      &                        -dc_norm(k,i)*dc_norm(j,i+1)
3108                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
3109               enddo
3110               uyder(j,j,1)=uyder(j,j,1)-costh
3111               uyder(j,j,2)=1.0d0+uyder(j,j,2)
3112             enddo
3113             do j=1,2
3114               do k=1,3
3115                 do l=1,3
3116                   uygrad(l,k,j,i)=uyder(l,k,j)
3117                   uzgrad(l,k,j,i)=uzder(l,k,j)
3118                 enddo
3119               enddo
3120             enddo
3121             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
3122             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
3123             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
3124             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
3125           endif
3126           endif
3127       enddo
3128       if (calc_grad) then
3129       do i=1,nres-1
3130         vbld_inv_temp(1)=vbld_inv(i+1)
3131         if (i.lt.nres-1) then
3132           vbld_inv_temp(2)=vbld_inv(i+2)
3133         else
3134           vbld_inv_temp(2)=vbld_inv(i)
3135         endif
3136         do j=1,2
3137           do k=1,3
3138             do l=1,3
3139               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
3140               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
3141             enddo
3142           enddo
3143         enddo
3144       enddo
3145       endif
3146       return
3147       end
3148 c------------------------------------------------------------------------------
3149       subroutine set_matrices
3150       implicit real*8 (a-h,o-z)
3151       include 'DIMENSIONS'
3152 #ifdef MPI
3153       include "mpif.h"
3154       integer IERR
3155       integer status(MPI_STATUS_SIZE)
3156 #endif
3157       include 'DIMENSIONS.ZSCOPT'
3158       include 'COMMON.IOUNITS'
3159       include 'COMMON.GEO'
3160       include 'COMMON.VAR'
3161       include 'COMMON.LOCAL'
3162       include 'COMMON.CHAIN'
3163       include 'COMMON.DERIV'
3164       include 'COMMON.INTERACT'
3165       include 'COMMON.CONTACTS'
3166       include 'COMMON.TORSION'
3167       include 'COMMON.VECTORS'
3168       include 'COMMON.FFIELD'
3169       double precision auxvec(2),auxmat(2,2)
3170 C
3171 C Compute the virtual-bond-torsional-angle dependent quantities needed
3172 C to calculate the el-loc multibody terms of various order.
3173 C
3174 c      write(iout,*) 'SET_MATRICES nphi=',nphi,nres
3175       do i=3,nres+1
3176         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3177           iti = itype2loc(itype(i-2))
3178         else
3179           iti=nloctyp
3180         endif
3181 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3182         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3183           iti1 = itype2loc(itype(i-1))
3184         else
3185           iti1=nloctyp
3186         endif
3187 #ifdef NEWCORR
3188         cost1=dcos(theta(i-1))
3189         sint1=dsin(theta(i-1))
3190         sint1sq=sint1*sint1
3191         sint1cub=sint1sq*sint1
3192         sint1cost1=2*sint1*cost1
3193 #ifdef DEBUG
3194         write (iout,*) "bnew1",i,iti
3195         write (iout,*) (bnew1(k,1,iti),k=1,3)
3196         write (iout,*) (bnew1(k,2,iti),k=1,3)
3197         write (iout,*) "bnew2",i,iti
3198         write (iout,*) (bnew2(k,1,iti),k=1,3)
3199         write (iout,*) (bnew2(k,2,iti),k=1,3)
3200 #endif
3201         do k=1,2
3202           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
3203           b1(k,i-2)=sint1*b1k
3204           gtb1(k,i-2)=cost1*b1k-sint1sq*
3205      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
3206           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
3207           b2(k,i-2)=sint1*b2k
3208           if (calc_grad) gtb2(k,i-2)=cost1*b2k-sint1sq*
3209      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
3210         enddo
3211         do k=1,2
3212           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
3213           cc(1,k,i-2)=sint1sq*aux
3214           if (calc_grad) gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
3215      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
3216           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
3217           dd(1,k,i-2)=sint1sq*aux
3218           if (calc_grad) gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
3219      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
3220         enddo
3221         cc(2,1,i-2)=cc(1,2,i-2)
3222         cc(2,2,i-2)=-cc(1,1,i-2)
3223         gtcc(2,1,i-2)=gtcc(1,2,i-2)
3224         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
3225         dd(2,1,i-2)=dd(1,2,i-2)
3226         dd(2,2,i-2)=-dd(1,1,i-2)
3227         gtdd(2,1,i-2)=gtdd(1,2,i-2)
3228         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
3229         do k=1,2
3230           do l=1,2
3231             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
3232             EE(l,k,i-2)=sint1sq*aux
3233             if (calc_grad)
3234      &        gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
3235           enddo
3236         enddo
3237         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
3238         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
3239         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
3240         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
3241         if (calc_grad) then
3242         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
3243         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
3244         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
3245         endif
3246 c        b1tilde(1,i-2)=b1(1,i-2)
3247 c        b1tilde(2,i-2)=-b1(2,i-2)
3248 c        b2tilde(1,i-2)=b2(1,i-2)
3249 c        b2tilde(2,i-2)=-b2(2,i-2)
3250 #ifdef DEBUG
3251         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
3252         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3253         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3254         write (iout,*) 'theta=', theta(i-1)
3255 #endif
3256 #else
3257         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3258           iti = itype2loc(itype(i-2))
3259         else
3260           iti=nloctyp
3261         endif
3262 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3263         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3264           iti1 = itype2loc(itype(i-1))
3265         else
3266           iti1=nloctyp
3267         endif
3268         b1(1,i-2)=b(3,iti)
3269         b1(2,i-2)=b(5,iti)
3270         b2(1,i-2)=b(2,iti)
3271         b2(2,i-2)=b(4,iti)
3272         do k=1,2
3273           do l=1,2
3274            CC(k,l,i-2)=ccold(k,l,iti)
3275            DD(k,l,i-2)=ddold(k,l,iti)
3276            EE(k,l,i-2)=eeold(k,l,iti)
3277           enddo
3278         enddo
3279 #endif
3280         b1tilde(1,i-2)= b1(1,i-2)
3281         b1tilde(2,i-2)=-b1(2,i-2)
3282         b2tilde(1,i-2)= b2(1,i-2)
3283         b2tilde(2,i-2)=-b2(2,i-2)
3284 c
3285         Ctilde(1,1,i-2)= CC(1,1,i-2)
3286         Ctilde(1,2,i-2)= CC(1,2,i-2)
3287         Ctilde(2,1,i-2)=-CC(2,1,i-2)
3288         Ctilde(2,2,i-2)=-CC(2,2,i-2)
3289 c
3290         Dtilde(1,1,i-2)= DD(1,1,i-2)
3291         Dtilde(1,2,i-2)= DD(1,2,i-2)
3292         Dtilde(2,1,i-2)=-DD(2,1,i-2)
3293         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3294 c        write(iout,*) "i",i," iti",iti
3295 c        write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3296 c        write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3297       enddo
3298       do i=3,nres+1
3299         if (i .lt. nres+1) then
3300           sin1=dsin(phi(i))
3301           cos1=dcos(phi(i))
3302           sintab(i-2)=sin1
3303           costab(i-2)=cos1
3304           obrot(1,i-2)=cos1
3305           obrot(2,i-2)=sin1
3306           sin2=dsin(2*phi(i))
3307           cos2=dcos(2*phi(i))
3308           sintab2(i-2)=sin2
3309           costab2(i-2)=cos2
3310           obrot2(1,i-2)=cos2
3311           obrot2(2,i-2)=sin2
3312           Ug(1,1,i-2)=-cos1
3313           Ug(1,2,i-2)=-sin1
3314           Ug(2,1,i-2)=-sin1
3315           Ug(2,2,i-2)= cos1
3316           Ug2(1,1,i-2)=-cos2
3317           Ug2(1,2,i-2)=-sin2
3318           Ug2(2,1,i-2)=-sin2
3319           Ug2(2,2,i-2)= cos2
3320         else
3321           costab(i-2)=1.0d0
3322           sintab(i-2)=0.0d0
3323           obrot(1,i-2)=1.0d0
3324           obrot(2,i-2)=0.0d0
3325           obrot2(1,i-2)=0.0d0
3326           obrot2(2,i-2)=0.0d0
3327           Ug(1,1,i-2)=1.0d0
3328           Ug(1,2,i-2)=0.0d0
3329           Ug(2,1,i-2)=0.0d0
3330           Ug(2,2,i-2)=1.0d0
3331           Ug2(1,1,i-2)=0.0d0
3332           Ug2(1,2,i-2)=0.0d0
3333           Ug2(2,1,i-2)=0.0d0
3334           Ug2(2,2,i-2)=0.0d0
3335         endif
3336         if (i .gt. 3 .and. i .lt. nres+1) then
3337           obrot_der(1,i-2)=-sin1
3338           obrot_der(2,i-2)= cos1
3339           Ugder(1,1,i-2)= sin1
3340           Ugder(1,2,i-2)=-cos1
3341           Ugder(2,1,i-2)=-cos1
3342           Ugder(2,2,i-2)=-sin1
3343           dwacos2=cos2+cos2
3344           dwasin2=sin2+sin2
3345           obrot2_der(1,i-2)=-dwasin2
3346           obrot2_der(2,i-2)= dwacos2
3347           Ug2der(1,1,i-2)= dwasin2
3348           Ug2der(1,2,i-2)=-dwacos2
3349           Ug2der(2,1,i-2)=-dwacos2
3350           Ug2der(2,2,i-2)=-dwasin2
3351         else
3352           obrot_der(1,i-2)=0.0d0
3353           obrot_der(2,i-2)=0.0d0
3354           Ugder(1,1,i-2)=0.0d0
3355           Ugder(1,2,i-2)=0.0d0
3356           Ugder(2,1,i-2)=0.0d0
3357           Ugder(2,2,i-2)=0.0d0
3358           obrot2_der(1,i-2)=0.0d0
3359           obrot2_der(2,i-2)=0.0d0
3360           Ug2der(1,1,i-2)=0.0d0
3361           Ug2der(1,2,i-2)=0.0d0
3362           Ug2der(2,1,i-2)=0.0d0
3363           Ug2der(2,2,i-2)=0.0d0
3364         endif
3365 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3366         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3367           iti = itype2loc(itype(i-2))
3368         else
3369           iti=nloctyp
3370         endif
3371 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3372         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3373           iti1 = itype2loc(itype(i-1))
3374         else
3375           iti1=nloctyp
3376         endif
3377 cd        write (iout,*) '*******i',i,' iti1',iti
3378 cd        write (iout,*) 'b1',b1(:,iti)
3379 cd        write (iout,*) 'b2',b2(:,iti)
3380 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3381 c        if (i .gt. iatel_s+2) then
3382         if (i .gt. nnt+2) then
3383           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3384 #ifdef NEWCORR
3385           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3386 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3387 #endif
3388 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3389 c     &    EE(1,2,iti),EE(2,2,i)
3390           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3391           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3392 c          write(iout,*) "Macierz EUG",
3393 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3394 c     &    eug(2,2,i-2)
3395           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3396      &    then
3397           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3398           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3399           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3400           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3401           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3402           endif
3403         else
3404           do k=1,2
3405             Ub2(k,i-2)=0.0d0
3406             Ctobr(k,i-2)=0.0d0
3407             Dtobr2(k,i-2)=0.0d0
3408             do l=1,2
3409               EUg(l,k,i-2)=0.0d0
3410               CUg(l,k,i-2)=0.0d0
3411               DUg(l,k,i-2)=0.0d0
3412               DtUg2(l,k,i-2)=0.0d0
3413             enddo
3414           enddo
3415         endif
3416         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3417         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3418         do k=1,2
3419           muder(k,i-2)=Ub2der(k,i-2)
3420         enddo
3421 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3422         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3423           if (itype(i-1).le.ntyp) then
3424             iti1 = itype2loc(itype(i-1))
3425           else
3426             iti1=nloctyp
3427           endif
3428         else
3429           iti1=nloctyp
3430         endif
3431         do k=1,2
3432           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3433         enddo
3434 #ifdef MUOUT
3435         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3436      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3437      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3438      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3439      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3440      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3441 #endif
3442 cd        write (iout,*) 'mu1',mu1(:,i-2)
3443 cd        write (iout,*) 'mu2',mu2(:,i-2)
3444         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3445      &  then
3446         if (calc_grad) then
3447         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3448         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3449         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3450         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3451         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3452         endif
3453 C Vectors and matrices dependent on a single virtual-bond dihedral.
3454         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3455         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3456         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3457         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3458         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3459         if (calc_grad) then
3460         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3461         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3462         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3463         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3464         endif
3465         endif
3466       enddo
3467 C Matrices dependent on two consecutive virtual-bond dihedrals.
3468 C The order of matrices is from left to right.
3469       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3470      &then
3471       do i=2,nres-1
3472         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3473         if (calc_grad) then
3474         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3475         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3476         endif
3477         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3478         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3479         if (calc_grad) then
3480         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3481         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3482         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3483         endif
3484       enddo
3485       endif
3486       return
3487       end
3488 C--------------------------------------------------------------------------
3489       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3490 C
3491 C This subroutine calculates the average interaction energy and its gradient
3492 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3493 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3494 C The potential depends both on the distance of peptide-group centers and on
3495 C the orientation of the CA-CA virtual bonds.
3496 C
3497       implicit real*8 (a-h,o-z)
3498 #ifdef MPI
3499       include 'mpif.h'
3500 #endif
3501       include 'DIMENSIONS'
3502       include 'DIMENSIONS.ZSCOPT'
3503       include 'COMMON.CONTROL'
3504       include 'COMMON.IOUNITS'
3505       include 'COMMON.GEO'
3506       include 'COMMON.VAR'
3507       include 'COMMON.LOCAL'
3508       include 'COMMON.CHAIN'
3509       include 'COMMON.DERIV'
3510       include 'COMMON.INTERACT'
3511       include 'COMMON.CONTACTS'
3512       include 'COMMON.TORSION'
3513       include 'COMMON.VECTORS'
3514       include 'COMMON.FFIELD'
3515       include 'COMMON.TIME1'
3516       include 'COMMON.SPLITELE'
3517       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3518      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3519       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3520      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3521       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3522      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3523      &    num_conti,j1,j2
3524 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3525 #ifdef MOMENT
3526       double precision scal_el /1.0d0/
3527 #else
3528       double precision scal_el /0.5d0/
3529 #endif
3530 C 12/13/98
3531 C 13-go grudnia roku pamietnego...
3532       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3533      &                   0.0d0,1.0d0,0.0d0,
3534      &                   0.0d0,0.0d0,1.0d0/
3535 cd      write(iout,*) 'In EELEC'
3536 cd      do i=1,nloctyp
3537 cd        write(iout,*) 'Type',i
3538 cd        write(iout,*) 'B1',B1(:,i)
3539 cd        write(iout,*) 'B2',B2(:,i)
3540 cd        write(iout,*) 'CC',CC(:,:,i)
3541 cd        write(iout,*) 'DD',DD(:,:,i)
3542 cd        write(iout,*) 'EE',EE(:,:,i)
3543 cd      enddo
3544 cd      call check_vecgrad
3545 cd      stop
3546       if (icheckgrad.eq.1) then
3547         do i=1,nres-1
3548           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3549           do k=1,3
3550             dc_norm(k,i)=dc(k,i)*fac
3551           enddo
3552 c          write (iout,*) 'i',i,' fac',fac
3553         enddo
3554       endif
3555       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3556      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3557      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3558 c        call vec_and_deriv
3559 #ifdef TIMING
3560         time01=MPI_Wtime()
3561 #endif
3562         call set_matrices
3563 #ifdef TIMING
3564         time_mat=time_mat+MPI_Wtime()-time01
3565 #endif
3566       endif
3567 cd      do i=1,nres-1
3568 cd        write (iout,*) 'i=',i
3569 cd        do k=1,3
3570 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3571 cd        enddo
3572 cd        do k=1,3
3573 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3574 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3575 cd        enddo
3576 cd      enddo
3577       t_eelecij=0.0d0
3578       ees=0.0D0
3579       evdw1=0.0D0
3580       eel_loc=0.0d0
3581       eello_turn3=0.0d0
3582       eello_turn4=0.0d0
3583       ind=0
3584       do i=1,nres
3585         num_cont_hb(i)=0
3586       enddo
3587 cd      print '(a)','Enter EELEC'
3588 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3589       do i=1,nres
3590         gel_loc_loc(i)=0.0d0
3591         gcorr_loc(i)=0.0d0
3592       enddo
3593 c
3594 c
3595 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3596 C
3597 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3598 C
3599 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3600       do i=iturn3_start,iturn3_end
3601 c        if (i.le.1) cycle
3602 C        write(iout,*) "tu jest i",i
3603         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3604 C changes suggested by Ana to avoid out of bounds
3605 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3606 c     & .or.((i+4).gt.nres)
3607 c     & .or.((i-1).le.0)
3608 C end of changes by Ana
3609 C dobra zmiana wycofana
3610      &  .or. itype(i+2).eq.ntyp1
3611      &  .or. itype(i+3).eq.ntyp1) cycle
3612 C Adam: Instructions below will switch off existing interactions
3613 c        if(i.gt.1)then
3614 c          if(itype(i-1).eq.ntyp1)cycle
3615 c        end if
3616 c        if(i.LT.nres-3)then
3617 c          if (itype(i+4).eq.ntyp1) cycle
3618 c        end if
3619         dxi=dc(1,i)
3620         dyi=dc(2,i)
3621         dzi=dc(3,i)
3622         dx_normi=dc_norm(1,i)
3623         dy_normi=dc_norm(2,i)
3624         dz_normi=dc_norm(3,i)
3625         xmedi=c(1,i)+0.5d0*dxi
3626         ymedi=c(2,i)+0.5d0*dyi
3627         zmedi=c(3,i)+0.5d0*dzi
3628           xmedi=mod(xmedi,boxxsize)
3629           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3630           ymedi=mod(ymedi,boxysize)
3631           if (ymedi.lt.0) ymedi=ymedi+boxysize
3632           zmedi=mod(zmedi,boxzsize)
3633           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3634         num_conti=0
3635         call eelecij(i,i+2,ees,evdw1,eel_loc)
3636         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3637         num_cont_hb(i)=num_conti
3638       enddo
3639       do i=iturn4_start,iturn4_end
3640         if (i.lt.1) cycle
3641         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3642 C changes suggested by Ana to avoid out of bounds
3643 c     & .or.((i+5).gt.nres)
3644 c     & .or.((i-1).le.0)
3645 C end of changes suggested by Ana
3646      &    .or. itype(i+3).eq.ntyp1
3647      &    .or. itype(i+4).eq.ntyp1
3648 c     &    .or. itype(i+5).eq.ntyp1
3649 c     &    .or. itype(i).eq.ntyp1
3650 c     &    .or. itype(i-1).eq.ntyp1
3651      &                             ) cycle
3652         dxi=dc(1,i)
3653         dyi=dc(2,i)
3654         dzi=dc(3,i)
3655         dx_normi=dc_norm(1,i)
3656         dy_normi=dc_norm(2,i)
3657         dz_normi=dc_norm(3,i)
3658         xmedi=c(1,i)+0.5d0*dxi
3659         ymedi=c(2,i)+0.5d0*dyi
3660         zmedi=c(3,i)+0.5d0*dzi
3661 C Return atom into box, boxxsize is size of box in x dimension
3662 c  194   continue
3663 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3664 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3665 C Condition for being inside the proper box
3666 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3667 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3668 c        go to 194
3669 c        endif
3670 c  195   continue
3671 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3672 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3673 C Condition for being inside the proper box
3674 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3675 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3676 c        go to 195
3677 c        endif
3678 c  196   continue
3679 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3680 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3681 C Condition for being inside the proper box
3682 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3683 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3684 c        go to 196
3685 c        endif
3686           xmedi=mod(xmedi,boxxsize)
3687           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3688           ymedi=mod(ymedi,boxysize)
3689           if (ymedi.lt.0) ymedi=ymedi+boxysize
3690           zmedi=mod(zmedi,boxzsize)
3691           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3692
3693         num_conti=num_cont_hb(i)
3694 c        write(iout,*) "JESTEM W PETLI"
3695         call eelecij(i,i+3,ees,evdw1,eel_loc)
3696         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3697      &   call eturn4(i,eello_turn4)
3698         num_cont_hb(i)=num_conti
3699       enddo   ! i
3700 C Loop over all neighbouring boxes
3701 C      do xshift=-1,1
3702 C      do yshift=-1,1
3703 C      do zshift=-1,1
3704 c
3705 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3706 c
3707 CTU KURWA
3708       do i=iatel_s,iatel_e
3709 C        do i=75,75
3710 c        if (i.le.1) cycle
3711         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3712 C changes suggested by Ana to avoid out of bounds
3713 c     & .or.((i+2).gt.nres)
3714 c     & .or.((i-1).le.0)
3715 C end of changes by Ana
3716 c     &  .or. itype(i+2).eq.ntyp1
3717 c     &  .or. itype(i-1).eq.ntyp1
3718      &                ) cycle
3719         dxi=dc(1,i)
3720         dyi=dc(2,i)
3721         dzi=dc(3,i)
3722         dx_normi=dc_norm(1,i)
3723         dy_normi=dc_norm(2,i)
3724         dz_normi=dc_norm(3,i)
3725         xmedi=c(1,i)+0.5d0*dxi
3726         ymedi=c(2,i)+0.5d0*dyi
3727         zmedi=c(3,i)+0.5d0*dzi
3728           xmedi=mod(xmedi,boxxsize)
3729           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3730           ymedi=mod(ymedi,boxysize)
3731           if (ymedi.lt.0) ymedi=ymedi+boxysize
3732           zmedi=mod(zmedi,boxzsize)
3733           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3734 C          xmedi=xmedi+xshift*boxxsize
3735 C          ymedi=ymedi+yshift*boxysize
3736 C          zmedi=zmedi+zshift*boxzsize
3737
3738 C Return tom into box, boxxsize is size of box in x dimension
3739 c  164   continue
3740 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3741 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3742 C Condition for being inside the proper box
3743 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3744 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3745 c        go to 164
3746 c        endif
3747 c  165   continue
3748 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3749 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3750 C Condition for being inside the proper box
3751 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3752 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3753 c        go to 165
3754 c        endif
3755 c  166   continue
3756 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3757 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3758 cC Condition for being inside the proper box
3759 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3760 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3761 c        go to 166
3762 c        endif
3763
3764 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3765         num_conti=num_cont_hb(i)
3766 C I TU KURWA
3767         do j=ielstart(i),ielend(i)
3768 C          do j=16,17
3769 C          write (iout,*) i,j
3770 C         if (j.le.1) cycle
3771           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3772 C changes suggested by Ana to avoid out of bounds
3773 c     & .or.((j+2).gt.nres)
3774 c     & .or.((j-1).le.0)
3775 C end of changes by Ana
3776 c     & .or.itype(j+2).eq.ntyp1
3777 c     & .or.itype(j-1).eq.ntyp1
3778      &) cycle
3779           call eelecij(i,j,ees,evdw1,eel_loc)
3780         enddo ! j
3781         num_cont_hb(i)=num_conti
3782       enddo   ! i
3783 C     enddo   ! zshift
3784 C      enddo   ! yshift
3785 C      enddo   ! xshift
3786
3787 c      write (iout,*) "Number of loop steps in EELEC:",ind
3788 cd      do i=1,nres
3789 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3790 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3791 cd      enddo
3792 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3793 ccc      eel_loc=eel_loc+eello_turn3
3794 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3795       return
3796       end
3797 C-------------------------------------------------------------------------------
3798       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3799       implicit real*8 (a-h,o-z)
3800       include 'DIMENSIONS'
3801       include 'DIMENSIONS.ZSCOPT'
3802 #ifdef MPI
3803       include "mpif.h"
3804 #endif
3805       include 'COMMON.CONTROL'
3806       include 'COMMON.IOUNITS'
3807       include 'COMMON.GEO'
3808       include 'COMMON.VAR'
3809       include 'COMMON.LOCAL'
3810       include 'COMMON.CHAIN'
3811       include 'COMMON.DERIV'
3812       include 'COMMON.INTERACT'
3813       include 'COMMON.CONTACTS'
3814       include 'COMMON.TORSION'
3815       include 'COMMON.VECTORS'
3816       include 'COMMON.FFIELD'
3817       include 'COMMON.TIME1'
3818       include 'COMMON.SPLITELE'
3819       include 'COMMON.SHIELD'
3820       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3821      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3822       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3823      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3824      &    gmuij2(4),gmuji2(4)
3825       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3826      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3827      &    num_conti,j1,j2
3828 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3829 #ifdef MOMENT
3830       double precision scal_el /1.0d0/
3831 #else
3832       double precision scal_el /0.5d0/
3833 #endif
3834 C 12/13/98
3835 C 13-go grudnia roku pamietnego...
3836       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3837      &                   0.0d0,1.0d0,0.0d0,
3838      &                   0.0d0,0.0d0,1.0d0/
3839        integer xshift,yshift,zshift
3840 c          time00=MPI_Wtime()
3841 cd      write (iout,*) "eelecij",i,j
3842 c          ind=ind+1
3843           iteli=itel(i)
3844           itelj=itel(j)
3845           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3846           aaa=app(iteli,itelj)
3847           bbb=bpp(iteli,itelj)
3848           ael6i=ael6(iteli,itelj)
3849           ael3i=ael3(iteli,itelj)
3850           dxj=dc(1,j)
3851           dyj=dc(2,j)
3852           dzj=dc(3,j)
3853           dx_normj=dc_norm(1,j)
3854           dy_normj=dc_norm(2,j)
3855           dz_normj=dc_norm(3,j)
3856 C          xj=c(1,j)+0.5D0*dxj-xmedi
3857 C          yj=c(2,j)+0.5D0*dyj-ymedi
3858 C          zj=c(3,j)+0.5D0*dzj-zmedi
3859           xj=c(1,j)+0.5D0*dxj
3860           yj=c(2,j)+0.5D0*dyj
3861           zj=c(3,j)+0.5D0*dzj
3862           xj=mod(xj,boxxsize)
3863           if (xj.lt.0) xj=xj+boxxsize
3864           yj=mod(yj,boxysize)
3865           if (yj.lt.0) yj=yj+boxysize
3866           zj=mod(zj,boxzsize)
3867           if (zj.lt.0) zj=zj+boxzsize
3868           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3869       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3870       xj_safe=xj
3871       yj_safe=yj
3872       zj_safe=zj
3873       isubchap=0
3874       do xshift=-1,1
3875       do yshift=-1,1
3876       do zshift=-1,1
3877           xj=xj_safe+xshift*boxxsize
3878           yj=yj_safe+yshift*boxysize
3879           zj=zj_safe+zshift*boxzsize
3880           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3881           if(dist_temp.lt.dist_init) then
3882             dist_init=dist_temp
3883             xj_temp=xj
3884             yj_temp=yj
3885             zj_temp=zj
3886             isubchap=1
3887           endif
3888        enddo
3889        enddo
3890        enddo
3891        if (isubchap.eq.1) then
3892           xj=xj_temp-xmedi
3893           yj=yj_temp-ymedi
3894           zj=zj_temp-zmedi
3895        else
3896           xj=xj_safe-xmedi
3897           yj=yj_safe-ymedi
3898           zj=zj_safe-zmedi
3899        endif
3900 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3901 c  174   continue
3902 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3903 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3904 C Condition for being inside the proper box
3905 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3906 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3907 c        go to 174
3908 c        endif
3909 c  175   continue
3910 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3911 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3912 C Condition for being inside the proper box
3913 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3914 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3915 c        go to 175
3916 c        endif
3917 c  176   continue
3918 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3919 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3920 C Condition for being inside the proper box
3921 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3922 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3923 c        go to 176
3924 c        endif
3925 C        endif !endPBC condintion
3926 C        xj=xj-xmedi
3927 C        yj=yj-ymedi
3928 C        zj=zj-zmedi
3929           rij=xj*xj+yj*yj+zj*zj
3930
3931             sss=sscale(sqrt(rij))
3932             sssgrad=sscagrad(sqrt(rij))
3933 c            write (iout,*) "ij",i,j," rij",sqrt(rij)," r_cut",r_cut,
3934 c     &       " rlamb",rlamb," sss",sss
3935 c            if (sss.gt.0.0d0) then
3936           rrmij=1.0D0/rij
3937           rij=dsqrt(rij)
3938           rmij=1.0D0/rij
3939           r3ij=rrmij*rmij
3940           r6ij=r3ij*r3ij
3941           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3942           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3943           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3944           fac=cosa-3.0D0*cosb*cosg
3945           ev1=aaa*r6ij*r6ij
3946 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3947           if (j.eq.i+2) ev1=scal_el*ev1
3948           ev2=bbb*r6ij
3949           fac3=ael6i*r6ij
3950           fac4=ael3i*r3ij
3951           evdwij=(ev1+ev2)
3952           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3953           el2=fac4*fac
3954 C MARYSIA
3955 C          eesij=(el1+el2)
3956 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3957           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3958           if (shield_mode.gt.0) then
3959 C          fac_shield(i)=0.4
3960 C          fac_shield(j)=0.6
3961           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3962           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3963           eesij=(el1+el2)
3964           ees=ees+eesij
3965           else
3966           fac_shield(i)=1.0
3967           fac_shield(j)=1.0
3968           eesij=(el1+el2)
3969           ees=ees+eesij
3970           endif
3971           evdw1=evdw1+evdwij*sss
3972 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3973 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3974 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3975 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3976
3977           if (energy_dec) then
3978               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
3979      &'evdw1',i,j,evdwij
3980      &,iteli,itelj,aaa,evdw1,sss
3981               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3982      &fac_shield(i),fac_shield(j)
3983           endif
3984
3985 C
3986 C Calculate contributions to the Cartesian gradient.
3987 C
3988 #ifdef SPLITELE
3989           facvdw=-6*rrmij*(ev1+evdwij)*sss
3990           facel=-3*rrmij*(el1+eesij)
3991           fac1=fac
3992           erij(1)=xj*rmij
3993           erij(2)=yj*rmij
3994           erij(3)=zj*rmij
3995
3996 *
3997 * Radial derivatives. First process both termini of the fragment (i,j)
3998 *
3999           if (calc_grad) then
4000           ggg(1)=facel*xj
4001           ggg(2)=facel*yj
4002           ggg(3)=facel*zj
4003           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4004      &  (shield_mode.gt.0)) then
4005 C          print *,i,j
4006           do ilist=1,ishield_list(i)
4007            iresshield=shield_list(ilist,i)
4008            do k=1,3
4009            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
4010      &      *2.0
4011            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4012      &              rlocshield
4013      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
4014             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4015 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4016 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4017 C             if (iresshield.gt.i) then
4018 C               do ishi=i+1,iresshield-1
4019 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4020 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4021 C
4022 C              enddo
4023 C             else
4024 C               do ishi=iresshield,i
4025 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4026 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
4027 C
4028 C               enddo
4029 C              endif
4030            enddo
4031           enddo
4032           do ilist=1,ishield_list(j)
4033            iresshield=shield_list(ilist,j)
4034            do k=1,3
4035            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
4036      &     *2.0
4037            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
4038      &              rlocshield
4039      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
4040            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4041
4042 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4043 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4044 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4045 C             if (iresshield.gt.j) then
4046 C               do ishi=j+1,iresshield-1
4047 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4048 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4049 C
4050 C               enddo
4051 C            else
4052 C               do ishi=iresshield,j
4053 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4054 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4055 C               enddo
4056 C              endif
4057            enddo
4058           enddo
4059
4060           do k=1,3
4061             gshieldc(k,i)=gshieldc(k,i)+
4062      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4063             gshieldc(k,j)=gshieldc(k,j)+
4064      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4065             gshieldc(k,i-1)=gshieldc(k,i-1)+
4066      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4067             gshieldc(k,j-1)=gshieldc(k,j-1)+
4068      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4069
4070            enddo
4071            endif
4072 c          do k=1,3
4073 c            ghalf=0.5D0*ggg(k)
4074 c            gelc(k,i)=gelc(k,i)+ghalf
4075 c            gelc(k,j)=gelc(k,j)+ghalf
4076 c          enddo
4077 c 9/28/08 AL Gradient compotents will be summed only at the end
4078 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4079           do k=1,3
4080             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4081 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4082             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4083 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4084 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4085 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4086 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4087 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4088           enddo
4089 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4090
4091 *
4092 * Loop over residues i+1 thru j-1.
4093 *
4094 cgrad          do k=i+1,j-1
4095 cgrad            do l=1,3
4096 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4097 cgrad            enddo
4098 cgrad          enddo
4099           if (sss.gt.0.0) then
4100           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4101           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4102           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4103           else
4104           ggg(1)=0.0
4105           ggg(2)=0.0
4106           ggg(3)=0.0
4107           endif
4108 c          do k=1,3
4109 c            ghalf=0.5D0*ggg(k)
4110 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4111 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4112 c          enddo
4113 c 9/28/08 AL Gradient compotents will be summed only at the end
4114           do k=1,3
4115             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4116             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4117           enddo
4118 *
4119 * Loop over residues i+1 thru j-1.
4120 *
4121 cgrad          do k=i+1,j-1
4122 cgrad            do l=1,3
4123 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4124 cgrad            enddo
4125 cgrad          enddo
4126           endif ! calc_grad
4127 #else
4128 C MARYSIA
4129           facvdw=(ev1+evdwij)*sss
4130           facel=(el1+eesij)
4131           fac1=fac
4132           fac=-3*rrmij*(facvdw+facvdw+facel)
4133           erij(1)=xj*rmij
4134           erij(2)=yj*rmij
4135           erij(3)=zj*rmij
4136 *
4137 * Radial derivatives. First process both termini of the fragment (i,j)
4138 *
4139           if (calc_grad) then
4140           ggg(1)=fac*xj
4141 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4142           ggg(2)=fac*yj
4143 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4144           ggg(3)=fac*zj
4145 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4146 c          do k=1,3
4147 c            ghalf=0.5D0*ggg(k)
4148 c            gelc(k,i)=gelc(k,i)+ghalf
4149 c            gelc(k,j)=gelc(k,j)+ghalf
4150 c          enddo
4151 c 9/28/08 AL Gradient compotents will be summed only at the end
4152           do k=1,3
4153             gelc_long(k,j)=gelc(k,j)+ggg(k)
4154             gelc_long(k,i)=gelc(k,i)-ggg(k)
4155           enddo
4156 *
4157 * Loop over residues i+1 thru j-1.
4158 *
4159 cgrad          do k=i+1,j-1
4160 cgrad            do l=1,3
4161 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4162 cgrad            enddo
4163 cgrad          enddo
4164 c 9/28/08 AL Gradient compotents will be summed only at the end
4165           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4166           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4167           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4168           do k=1,3
4169             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4170             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4171           enddo
4172           endif ! calc_grad
4173 #endif
4174 *
4175 * Angular part
4176 *
4177           if (calc_grad) then
4178           ecosa=2.0D0*fac3*fac1+fac4
4179           fac4=-3.0D0*fac4
4180           fac3=-6.0D0*fac3
4181           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4182           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4183           do k=1,3
4184             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4185             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4186           enddo
4187 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4188 cd   &          (dcosg(k),k=1,3)
4189           do k=1,3
4190             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4191      &      fac_shield(i)**2*fac_shield(j)**2
4192           enddo
4193 c          do k=1,3
4194 c            ghalf=0.5D0*ggg(k)
4195 c            gelc(k,i)=gelc(k,i)+ghalf
4196 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4197 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4198 c            gelc(k,j)=gelc(k,j)+ghalf
4199 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4200 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4201 c          enddo
4202 cgrad          do k=i+1,j-1
4203 cgrad            do l=1,3
4204 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4205 cgrad            enddo
4206 cgrad          enddo
4207 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4208           do k=1,3
4209             gelc(k,i)=gelc(k,i)
4210      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4211      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4212      &           *fac_shield(i)**2*fac_shield(j)**2
4213             gelc(k,j)=gelc(k,j)
4214      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4215      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4216      &           *fac_shield(i)**2*fac_shield(j)**2
4217             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4218             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4219           enddo
4220 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4221
4222 C MARYSIA
4223 c          endif !sscale
4224           endif ! calc_grad
4225           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4226      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4227      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4228 C
4229 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4230 C   energy of a peptide unit is assumed in the form of a second-order
4231 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4232 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4233 C   are computed for EVERY pair of non-contiguous peptide groups.
4234 C
4235
4236           if (j.lt.nres-1) then
4237             j1=j+1
4238             j2=j-1
4239           else
4240             j1=j-1
4241             j2=j-2
4242           endif
4243           kkk=0
4244           lll=0
4245           do k=1,2
4246             do l=1,2
4247               kkk=kkk+1
4248               muij(kkk)=mu(k,i)*mu(l,j)
4249 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4250 #ifdef NEWCORR
4251              if (calc_grad) then
4252              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4253 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4254              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4255              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4256 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4257              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4258              endif
4259 #endif
4260             enddo
4261           enddo
4262 #ifdef DEBUG
4263           write (iout,*) 'EELEC: i',i,' j',j
4264           write (iout,*) 'j',j,' j1',j1,' j2',j2
4265           write(iout,*) 'muij',muij
4266           write (iout,*) "uy",uy(:,i)
4267           write (iout,*) "uz",uz(:,j)
4268           write (iout,*) "erij",erij
4269 #endif
4270           ury=scalar(uy(1,i),erij)
4271           urz=scalar(uz(1,i),erij)
4272           vry=scalar(uy(1,j),erij)
4273           vrz=scalar(uz(1,j),erij)
4274           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4275           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4276           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4277           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4278           fac=dsqrt(-ael6i)*r3ij
4279           a22=a22*fac
4280           a23=a23*fac
4281           a32=a32*fac
4282           a33=a33*fac
4283 cd          write (iout,'(4i5,4f10.5)')
4284 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4285 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4286 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4287 cd     &      uy(:,j),uz(:,j)
4288 cd          write (iout,'(4f10.5)')
4289 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4290 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4291 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4292 cd           write (iout,'(9f10.5/)')
4293 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4294 C Derivatives of the elements of A in virtual-bond vectors
4295           if (calc_grad) then
4296           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4297           do k=1,3
4298             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4299             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4300             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4301             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4302             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4303             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4304             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4305             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4306             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4307             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4308             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4309             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4310           enddo
4311 C Compute radial contributions to the gradient
4312           facr=-3.0d0*rrmij
4313           a22der=a22*facr
4314           a23der=a23*facr
4315           a32der=a32*facr
4316           a33der=a33*facr
4317           agg(1,1)=a22der*xj
4318           agg(2,1)=a22der*yj
4319           agg(3,1)=a22der*zj
4320           agg(1,2)=a23der*xj
4321           agg(2,2)=a23der*yj
4322           agg(3,2)=a23der*zj
4323           agg(1,3)=a32der*xj
4324           agg(2,3)=a32der*yj
4325           agg(3,3)=a32der*zj
4326           agg(1,4)=a33der*xj
4327           agg(2,4)=a33der*yj
4328           agg(3,4)=a33der*zj
4329 C Add the contributions coming from er
4330           fac3=-3.0d0*fac
4331           do k=1,3
4332             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4333             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4334             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4335             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4336           enddo
4337           do k=1,3
4338 C Derivatives in DC(i)
4339 cgrad            ghalf1=0.5d0*agg(k,1)
4340 cgrad            ghalf2=0.5d0*agg(k,2)
4341 cgrad            ghalf3=0.5d0*agg(k,3)
4342 cgrad            ghalf4=0.5d0*agg(k,4)
4343             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4344      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4345             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4346      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4347             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4348      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4349             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4350      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4351 C Derivatives in DC(i+1)
4352             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4353      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4354             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4355      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4356             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4357      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4358             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4359      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4360 C Derivatives in DC(j)
4361             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4362      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4363             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4364      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4365             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4366      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4367             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4368      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4369 C Derivatives in DC(j+1) or DC(nres-1)
4370             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4371      &      -3.0d0*vryg(k,3)*ury)
4372             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4373      &      -3.0d0*vrzg(k,3)*ury)
4374             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4375      &      -3.0d0*vryg(k,3)*urz)
4376             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4377      &      -3.0d0*vrzg(k,3)*urz)
4378 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4379 cgrad              do l=1,4
4380 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4381 cgrad              enddo
4382 cgrad            endif
4383           enddo
4384           endif ! calc_grad
4385           acipa(1,1)=a22
4386           acipa(1,2)=a23
4387           acipa(2,1)=a32
4388           acipa(2,2)=a33
4389           a22=-a22
4390           a23=-a23
4391           if (calc_grad) then
4392           do l=1,2
4393             do k=1,3
4394               agg(k,l)=-agg(k,l)
4395               aggi(k,l)=-aggi(k,l)
4396               aggi1(k,l)=-aggi1(k,l)
4397               aggj(k,l)=-aggj(k,l)
4398               aggj1(k,l)=-aggj1(k,l)
4399             enddo
4400           enddo
4401           endif ! calc_grad
4402           if (j.lt.nres-1) then
4403             a22=-a22
4404             a32=-a32
4405             do l=1,3,2
4406               do k=1,3
4407                 agg(k,l)=-agg(k,l)
4408                 aggi(k,l)=-aggi(k,l)
4409                 aggi1(k,l)=-aggi1(k,l)
4410                 aggj(k,l)=-aggj(k,l)
4411                 aggj1(k,l)=-aggj1(k,l)
4412               enddo
4413             enddo
4414           else
4415             a22=-a22
4416             a23=-a23
4417             a32=-a32
4418             a33=-a33
4419             do l=1,4
4420               do k=1,3
4421                 agg(k,l)=-agg(k,l)
4422                 aggi(k,l)=-aggi(k,l)
4423                 aggi1(k,l)=-aggi1(k,l)
4424                 aggj(k,l)=-aggj(k,l)
4425                 aggj1(k,l)=-aggj1(k,l)
4426               enddo
4427             enddo
4428           endif
4429           ENDIF ! WCORR
4430           IF (wel_loc.gt.0.0d0) THEN
4431 C Contribution to the local-electrostatic energy coming from the i-j pair
4432           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4433      &     +a33*muij(4)
4434 #ifdef DEBUG
4435           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4436      &     " a33",a33
4437           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4438      &     " wel_loc",wel_loc
4439 #endif
4440           if (shield_mode.eq.0) then
4441            fac_shield(i)=1.0
4442            fac_shield(j)=1.0
4443 C          else
4444 C           fac_shield(i)=0.4
4445 C           fac_shield(j)=0.6
4446           endif
4447           eel_loc_ij=eel_loc_ij
4448      &    *fac_shield(i)*fac_shield(j)
4449           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4450      &            'eelloc',i,j,eel_loc_ij
4451 c           if (eel_loc_ij.ne.0)
4452 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4453 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4454
4455           eel_loc=eel_loc+eel_loc_ij
4456 C Now derivative over eel_loc
4457           if (calc_grad) then
4458           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4459      &  (shield_mode.gt.0)) then
4460 C          print *,i,j
4461
4462           do ilist=1,ishield_list(i)
4463            iresshield=shield_list(ilist,i)
4464            do k=1,3
4465            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4466      &                                          /fac_shield(i)
4467 C     &      *2.0
4468            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4469      &              rlocshield
4470      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4471             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4472      &      +rlocshield
4473            enddo
4474           enddo
4475           do ilist=1,ishield_list(j)
4476            iresshield=shield_list(ilist,j)
4477            do k=1,3
4478            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4479      &                                       /fac_shield(j)
4480 C     &     *2.0
4481            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4482      &              rlocshield
4483      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4484            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4485      &             +rlocshield
4486
4487            enddo
4488           enddo
4489
4490           do k=1,3
4491             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4492      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4493             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4494      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4495             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4496      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4497             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4498      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4499            enddo
4500            endif
4501
4502
4503 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4504 c     &                     ' eel_loc_ij',eel_loc_ij
4505 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4506 C Calculate patrial derivative for theta angle
4507 #ifdef NEWCORR
4508          geel_loc_ij=(a22*gmuij1(1)
4509      &     +a23*gmuij1(2)
4510      &     +a32*gmuij1(3)
4511      &     +a33*gmuij1(4))
4512      &    *fac_shield(i)*fac_shield(j)
4513 c         write(iout,*) "derivative over thatai"
4514 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4515 c     &   a33*gmuij1(4)
4516          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4517      &      geel_loc_ij*wel_loc
4518 c         write(iout,*) "derivative over thatai-1"
4519 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4520 c     &   a33*gmuij2(4)
4521          geel_loc_ij=
4522      &     a22*gmuij2(1)
4523      &     +a23*gmuij2(2)
4524      &     +a32*gmuij2(3)
4525      &     +a33*gmuij2(4)
4526          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4527      &      geel_loc_ij*wel_loc
4528      &    *fac_shield(i)*fac_shield(j)
4529
4530 c  Derivative over j residue
4531          geel_loc_ji=a22*gmuji1(1)
4532      &     +a23*gmuji1(2)
4533      &     +a32*gmuji1(3)
4534      &     +a33*gmuji1(4)
4535 c         write(iout,*) "derivative over thataj"
4536 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4537 c     &   a33*gmuji1(4)
4538
4539         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4540      &      geel_loc_ji*wel_loc
4541      &    *fac_shield(i)*fac_shield(j)
4542
4543          geel_loc_ji=
4544      &     +a22*gmuji2(1)
4545      &     +a23*gmuji2(2)
4546      &     +a32*gmuji2(3)
4547      &     +a33*gmuji2(4)
4548 c         write(iout,*) "derivative over thataj-1"
4549 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4550 c     &   a33*gmuji2(4)
4551          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4552      &      geel_loc_ji*wel_loc
4553      &    *fac_shield(i)*fac_shield(j)
4554 #endif
4555 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4556
4557 C Partial derivatives in virtual-bond dihedral angles gamma
4558           if (i.gt.1)
4559      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4560      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4561      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4562      &    *fac_shield(i)*fac_shield(j)
4563
4564           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4565      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4566      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4567      &    *fac_shield(i)*fac_shield(j)
4568 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4569           do l=1,3
4570             ggg(l)=(agg(l,1)*muij(1)+
4571      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4572      &    *fac_shield(i)*fac_shield(j)
4573             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4574             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4575 cgrad            ghalf=0.5d0*ggg(l)
4576 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4577 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4578           enddo
4579 cgrad          do k=i+1,j2
4580 cgrad            do l=1,3
4581 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4582 cgrad            enddo
4583 cgrad          enddo
4584 C Remaining derivatives of eello
4585           do l=1,3
4586             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4587      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4588      &    *fac_shield(i)*fac_shield(j)
4589
4590             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4591      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4592      &    *fac_shield(i)*fac_shield(j)
4593
4594             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4595      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4596      &    *fac_shield(i)*fac_shield(j)
4597
4598             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4599      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4600      &    *fac_shield(i)*fac_shield(j)
4601
4602           enddo
4603           endif ! calc_grad
4604           ENDIF
4605
4606
4607 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4608 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4609           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4610      &       .and. num_conti.le.maxconts) then
4611 c            write (iout,*) i,j," entered corr"
4612 C
4613 C Calculate the contact function. The ith column of the array JCONT will
4614 C contain the numbers of atoms that make contacts with the atom I (of numbers
4615 C greater than I). The arrays FACONT and GACONT will contain the values of
4616 C the contact function and its derivative.
4617 c           r0ij=1.02D0*rpp(iteli,itelj)
4618 c           r0ij=1.11D0*rpp(iteli,itelj)
4619             r0ij=2.20D0*rpp(iteli,itelj)
4620 c           r0ij=1.55D0*rpp(iteli,itelj)
4621             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4622             if (fcont.gt.0.0D0) then
4623               num_conti=num_conti+1
4624               if (num_conti.gt.maxconts) then
4625                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4626      &                         ' will skip next contacts for this conf.'
4627               else
4628                 jcont_hb(num_conti,i)=j
4629 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4630 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4631                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4632      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4633 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4634 C  terms.
4635                 d_cont(num_conti,i)=rij
4636 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4637 C     --- Electrostatic-interaction matrix ---
4638                 a_chuj(1,1,num_conti,i)=a22
4639                 a_chuj(1,2,num_conti,i)=a23
4640                 a_chuj(2,1,num_conti,i)=a32
4641                 a_chuj(2,2,num_conti,i)=a33
4642 C     --- Gradient of rij
4643                 if (calc_grad) then
4644                 do kkk=1,3
4645                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4646                 enddo
4647                 kkll=0
4648                 do k=1,2
4649                   do l=1,2
4650                     kkll=kkll+1
4651                     do m=1,3
4652                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4653                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4654                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4655                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4656                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4657                     enddo
4658                   enddo
4659                 enddo
4660                 endif ! calc_grad
4661                 ENDIF
4662                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4663 C Calculate contact energies
4664                 cosa4=4.0D0*cosa
4665                 wij=cosa-3.0D0*cosb*cosg
4666                 cosbg1=cosb+cosg
4667                 cosbg2=cosb-cosg
4668 c               fac3=dsqrt(-ael6i)/r0ij**3
4669                 fac3=dsqrt(-ael6i)*r3ij
4670 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4671                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4672                 if (ees0tmp.gt.0) then
4673                   ees0pij=dsqrt(ees0tmp)
4674                 else
4675                   ees0pij=0
4676                 endif
4677 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4678                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4679                 if (ees0tmp.gt.0) then
4680                   ees0mij=dsqrt(ees0tmp)
4681                 else
4682                   ees0mij=0
4683                 endif
4684 c               ees0mij=0.0D0
4685                 if (shield_mode.eq.0) then
4686                 fac_shield(i)=1.0d0
4687                 fac_shield(j)=1.0d0
4688                 else
4689                 ees0plist(num_conti,i)=j
4690 C                fac_shield(i)=0.4d0
4691 C                fac_shield(j)=0.6d0
4692                 endif
4693                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4694      &          *fac_shield(i)*fac_shield(j)
4695                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4696      &          *fac_shield(i)*fac_shield(j)
4697 C Diagnostics. Comment out or remove after debugging!
4698 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4699 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4700 c               ees0m(num_conti,i)=0.0D0
4701 C End diagnostics.
4702 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4703 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4704 C Angular derivatives of the contact function
4705
4706                 ees0pij1=fac3/ees0pij
4707                 ees0mij1=fac3/ees0mij
4708                 fac3p=-3.0D0*fac3*rrmij
4709                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4710                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4711 c               ees0mij1=0.0D0
4712                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4713                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4714                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4715                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4716                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4717                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4718                 ecosap=ecosa1+ecosa2
4719                 ecosbp=ecosb1+ecosb2
4720                 ecosgp=ecosg1+ecosg2
4721                 ecosam=ecosa1-ecosa2
4722                 ecosbm=ecosb1-ecosb2
4723                 ecosgm=ecosg1-ecosg2
4724 C Diagnostics
4725 c               ecosap=ecosa1
4726 c               ecosbp=ecosb1
4727 c               ecosgp=ecosg1
4728 c               ecosam=0.0D0
4729 c               ecosbm=0.0D0
4730 c               ecosgm=0.0D0
4731 C End diagnostics
4732                 facont_hb(num_conti,i)=fcont
4733
4734                 if (calc_grad) then
4735                 fprimcont=fprimcont/rij
4736 cd              facont_hb(num_conti,i)=1.0D0
4737 C Following line is for diagnostics.
4738 cd              fprimcont=0.0D0
4739                 do k=1,3
4740                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4741                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4742                 enddo
4743                 do k=1,3
4744                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4745                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4746                 enddo
4747                 gggp(1)=gggp(1)+ees0pijp*xj
4748                 gggp(2)=gggp(2)+ees0pijp*yj
4749                 gggp(3)=gggp(3)+ees0pijp*zj
4750                 gggm(1)=gggm(1)+ees0mijp*xj
4751                 gggm(2)=gggm(2)+ees0mijp*yj
4752                 gggm(3)=gggm(3)+ees0mijp*zj
4753 C Derivatives due to the contact function
4754                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4755                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4756                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4757                 do k=1,3
4758 c
4759 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4760 c          following the change of gradient-summation algorithm.
4761 c
4762 cgrad                  ghalfp=0.5D0*gggp(k)
4763 cgrad                  ghalfm=0.5D0*gggm(k)
4764                   gacontp_hb1(k,num_conti,i)=!ghalfp
4765      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4766      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4767      &          *fac_shield(i)*fac_shield(j)
4768
4769                   gacontp_hb2(k,num_conti,i)=!ghalfp
4770      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4771      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4772      &          *fac_shield(i)*fac_shield(j)
4773
4774                   gacontp_hb3(k,num_conti,i)=gggp(k)
4775      &          *fac_shield(i)*fac_shield(j)
4776
4777                   gacontm_hb1(k,num_conti,i)=!ghalfm
4778      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4779      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4780      &          *fac_shield(i)*fac_shield(j)
4781
4782                   gacontm_hb2(k,num_conti,i)=!ghalfm
4783      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4784      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4785      &          *fac_shield(i)*fac_shield(j)
4786
4787                   gacontm_hb3(k,num_conti,i)=gggm(k)
4788      &          *fac_shield(i)*fac_shield(j)
4789
4790                 enddo
4791 C Diagnostics. Comment out or remove after debugging!
4792 cdiag           do k=1,3
4793 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4794 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4795 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4796 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4797 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4798 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4799 cdiag           enddo
4800
4801                  endif ! calc_grad
4802
4803               ENDIF ! wcorr
4804               endif  ! num_conti.le.maxconts
4805             endif  ! fcont.gt.0
4806           endif    ! j.gt.i+1
4807           if (calc_grad) then
4808           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4809             do k=1,4
4810               do l=1,3
4811                 ghalf=0.5d0*agg(l,k)
4812                 aggi(l,k)=aggi(l,k)+ghalf
4813                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4814                 aggj(l,k)=aggj(l,k)+ghalf
4815               enddo
4816             enddo
4817             if (j.eq.nres-1 .and. i.lt.j-2) then
4818               do k=1,4
4819                 do l=1,3
4820                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4821                 enddo
4822               enddo
4823             endif
4824           endif
4825           endif ! calc_grad
4826 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4827       return
4828       end
4829 C-----------------------------------------------------------------------------
4830       subroutine eturn3(i,eello_turn3)
4831 C Third- and fourth-order contributions from turns
4832       implicit real*8 (a-h,o-z)
4833       include 'DIMENSIONS'
4834       include 'DIMENSIONS.ZSCOPT'
4835       include 'COMMON.IOUNITS'
4836       include 'COMMON.GEO'
4837       include 'COMMON.VAR'
4838       include 'COMMON.LOCAL'
4839       include 'COMMON.CHAIN'
4840       include 'COMMON.DERIV'
4841       include 'COMMON.INTERACT'
4842       include 'COMMON.CONTACTS'
4843       include 'COMMON.TORSION'
4844       include 'COMMON.VECTORS'
4845       include 'COMMON.FFIELD'
4846       include 'COMMON.CONTROL'
4847       include 'COMMON.SHIELD'
4848       dimension ggg(3)
4849       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4850      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4851      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4852      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4853      &  auxgmat2(2,2),auxgmatt2(2,2)
4854       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4855      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4856       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4857      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4858      &    num_conti,j1,j2
4859       j=i+2
4860 c      write (iout,*) "eturn3",i,j,j1,j2
4861       a_temp(1,1)=a22
4862       a_temp(1,2)=a23
4863       a_temp(2,1)=a32
4864       a_temp(2,2)=a33
4865 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4866 C
4867 C               Third-order contributions
4868 C
4869 C                 (i+2)o----(i+3)
4870 C                      | |
4871 C                      | |
4872 C                 (i+1)o----i
4873 C
4874 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4875 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4876         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4877 c auxalary matices for theta gradient
4878 c auxalary matrix for i+1 and constant i+2
4879         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4880 c auxalary matrix for i+2 and constant i+1
4881         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4882         call transpose2(auxmat(1,1),auxmat1(1,1))
4883         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4884         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4885         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4886         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4887         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4888         if (shield_mode.eq.0) then
4889         fac_shield(i)=1.0
4890         fac_shield(j)=1.0
4891 C        else
4892 C        fac_shield(i)=0.4
4893 C        fac_shield(j)=0.6
4894         endif
4895         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4896      &  *fac_shield(i)*fac_shield(j)
4897         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4898      &  *fac_shield(i)*fac_shield(j)
4899         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4900      &    eello_t3
4901         if (calc_grad) then
4902 C#ifdef NEWCORR
4903 C Derivatives in theta
4904         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4905      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4906      &   *fac_shield(i)*fac_shield(j)
4907         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4908      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4909      &   *fac_shield(i)*fac_shield(j)
4910 C#endif
4911
4912 C Derivatives in shield mode
4913           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4914      &  (shield_mode.gt.0)) then
4915 C          print *,i,j
4916
4917           do ilist=1,ishield_list(i)
4918            iresshield=shield_list(ilist,i)
4919            do k=1,3
4920            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4921 C     &      *2.0
4922            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4923      &              rlocshield
4924      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4925             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4926      &      +rlocshield
4927            enddo
4928           enddo
4929           do ilist=1,ishield_list(j)
4930            iresshield=shield_list(ilist,j)
4931            do k=1,3
4932            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4933 C     &     *2.0
4934            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4935      &              rlocshield
4936      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4937            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4938      &             +rlocshield
4939
4940            enddo
4941           enddo
4942
4943           do k=1,3
4944             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4945      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4946             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4947      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4948             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4949      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4950             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4951      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4952            enddo
4953            endif
4954
4955 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4956 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4957 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4958 cd     &    ' eello_turn3_num',4*eello_turn3_num
4959 C Derivatives in gamma(i)
4960         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4961         call transpose2(auxmat2(1,1),auxmat3(1,1))
4962         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4963         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4964      &   *fac_shield(i)*fac_shield(j)
4965 C Derivatives in gamma(i+1)
4966         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4967         call transpose2(auxmat2(1,1),auxmat3(1,1))
4968         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4969         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4970      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4971      &   *fac_shield(i)*fac_shield(j)
4972 C Cartesian derivatives
4973         do l=1,3
4974 c            ghalf1=0.5d0*agg(l,1)
4975 c            ghalf2=0.5d0*agg(l,2)
4976 c            ghalf3=0.5d0*agg(l,3)
4977 c            ghalf4=0.5d0*agg(l,4)
4978           a_temp(1,1)=aggi(l,1)!+ghalf1
4979           a_temp(1,2)=aggi(l,2)!+ghalf2
4980           a_temp(2,1)=aggi(l,3)!+ghalf3
4981           a_temp(2,2)=aggi(l,4)!+ghalf4
4982           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4983           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4984      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4985      &   *fac_shield(i)*fac_shield(j)
4986
4987           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4988           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4989           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4990           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4991           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4992           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4993      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4994      &   *fac_shield(i)*fac_shield(j)
4995           a_temp(1,1)=aggj(l,1)!+ghalf1
4996           a_temp(1,2)=aggj(l,2)!+ghalf2
4997           a_temp(2,1)=aggj(l,3)!+ghalf3
4998           a_temp(2,2)=aggj(l,4)!+ghalf4
4999           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5000           gcorr3_turn(l,j)=gcorr3_turn(l,j)
5001      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5002      &   *fac_shield(i)*fac_shield(j)
5003           a_temp(1,1)=aggj1(l,1)
5004           a_temp(1,2)=aggj1(l,2)
5005           a_temp(2,1)=aggj1(l,3)
5006           a_temp(2,2)=aggj1(l,4)
5007           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
5008           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
5009      &      +0.5d0*(pizda(1,1)+pizda(2,2))
5010      &   *fac_shield(i)*fac_shield(j)
5011         enddo
5012
5013         endif ! calc_grad
5014
5015       return
5016       end
5017 C-------------------------------------------------------------------------------
5018       subroutine eturn4(i,eello_turn4)
5019 C Third- and fourth-order contributions from turns
5020       implicit real*8 (a-h,o-z)
5021       include 'DIMENSIONS'
5022       include 'DIMENSIONS.ZSCOPT'
5023       include 'COMMON.IOUNITS'
5024       include 'COMMON.GEO'
5025       include 'COMMON.VAR'
5026       include 'COMMON.LOCAL'
5027       include 'COMMON.CHAIN'
5028       include 'COMMON.DERIV'
5029       include 'COMMON.INTERACT'
5030       include 'COMMON.CONTACTS'
5031       include 'COMMON.TORSION'
5032       include 'COMMON.VECTORS'
5033       include 'COMMON.FFIELD'
5034       include 'COMMON.CONTROL'
5035       include 'COMMON.SHIELD'
5036       dimension ggg(3)
5037       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
5038      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
5039      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
5040      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
5041      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
5042      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
5043      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
5044       double precision agg(3,4),aggi(3,4),aggi1(3,4),
5045      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
5046       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
5047      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
5048      &    num_conti,j1,j2
5049       j=i+3
5050 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5051 C
5052 C               Fourth-order contributions
5053 C
5054 C                 (i+3)o----(i+4)
5055 C                     /  |
5056 C               (i+2)o   |
5057 C                     \  |
5058 C                 (i+1)o----i
5059 C
5060 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5061 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5062 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5063 c        write(iout,*)"WCHODZE W PROGRAM"
5064         a_temp(1,1)=a22
5065         a_temp(1,2)=a23
5066         a_temp(2,1)=a32
5067         a_temp(2,2)=a33
5068         iti1=itype2loc(itype(i+1))
5069         iti2=itype2loc(itype(i+2))
5070         iti3=itype2loc(itype(i+3))
5071 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5072         call transpose2(EUg(1,1,i+1),e1t(1,1))
5073         call transpose2(Eug(1,1,i+2),e2t(1,1))
5074         call transpose2(Eug(1,1,i+3),e3t(1,1))
5075 C Ematrix derivative in theta
5076         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5077         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5078         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5079         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5080 c       eta1 in derivative theta
5081         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5082         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5083 c       auxgvec is derivative of Ub2 so i+3 theta
5084         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5085 c       auxalary matrix of E i+1
5086         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5087 c        s1=0.0
5088 c        gs1=0.0
5089         s1=scalar2(b1(1,i+2),auxvec(1))
5090 c derivative of theta i+2 with constant i+3
5091         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5092 c derivative of theta i+2 with constant i+2
5093         gs32=scalar2(b1(1,i+2),auxgvec(1))
5094 c derivative of E matix in theta of i+1
5095         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5096
5097         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5098 c       ea31 in derivative theta
5099         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5100         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5101 c auxilary matrix auxgvec of Ub2 with constant E matirx
5102         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5103 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5104         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5105
5106 c        s2=0.0
5107 c        gs2=0.0
5108         s2=scalar2(b1(1,i+1),auxvec(1))
5109 c derivative of theta i+1 with constant i+3
5110         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5111 c derivative of theta i+2 with constant i+1
5112         gs21=scalar2(b1(1,i+1),auxgvec(1))
5113 c derivative of theta i+3 with constant i+1
5114         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5115 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5116 c     &  gtb1(1,i+1)
5117         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5118 c two derivatives over diffetent matrices
5119 c gtae3e2 is derivative over i+3
5120         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5121 c ae3gte2 is derivative over i+2
5122         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5123         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5124 c three possible derivative over theta E matices
5125 c i+1
5126         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5127 c i+2
5128         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5129 c i+3
5130         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5131         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5132
5133         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5134         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5135         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5136         if (shield_mode.eq.0) then
5137         fac_shield(i)=1.0
5138         fac_shield(j)=1.0
5139 C        else
5140 C        fac_shield(i)=0.6
5141 C        fac_shield(j)=0.4
5142         endif
5143         eello_turn4=eello_turn4-(s1+s2+s3)
5144      &  *fac_shield(i)*fac_shield(j)
5145         eello_t4=-(s1+s2+s3)
5146      &  *fac_shield(i)*fac_shield(j)
5147 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5148         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5149      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5150 C Now derivative over shield:
5151           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5152      &  (shield_mode.gt.0)) then
5153 C          print *,i,j
5154
5155           do ilist=1,ishield_list(i)
5156            iresshield=shield_list(ilist,i)
5157            do k=1,3
5158            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5159 C     &      *2.0
5160            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5161      &              rlocshield
5162      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5163             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5164      &      +rlocshield
5165            enddo
5166           enddo
5167           do ilist=1,ishield_list(j)
5168            iresshield=shield_list(ilist,j)
5169            do k=1,3
5170            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5171 C     &     *2.0
5172            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5173      &              rlocshield
5174      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5175            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5176      &             +rlocshield
5177
5178            enddo
5179           enddo
5180
5181           do k=1,3
5182             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5183      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5184             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5185      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5186             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5187      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5188             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5189      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5190            enddo
5191            endif
5192 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5193 cd     &    ' eello_turn4_num',8*eello_turn4_num
5194 #ifdef NEWCORR
5195         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5196      &                  -(gs13+gsE13+gsEE1)*wturn4
5197      &  *fac_shield(i)*fac_shield(j)
5198         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5199      &                    -(gs23+gs21+gsEE2)*wturn4
5200      &  *fac_shield(i)*fac_shield(j)
5201
5202         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5203      &                    -(gs32+gsE31+gsEE3)*wturn4
5204      &  *fac_shield(i)*fac_shield(j)
5205
5206 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5207 c     &   gs2
5208 #endif
5209         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5210      &      'eturn4',i,j,-(s1+s2+s3)
5211 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5212 c     &    ' eello_turn4_num',8*eello_turn4_num
5213 C Derivatives in gamma(i)
5214         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5215         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5216         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5217         s1=scalar2(b1(1,i+2),auxvec(1))
5218         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5219         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5220         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5221      &  *fac_shield(i)*fac_shield(j)
5222 C Derivatives in gamma(i+1)
5223         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5224         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5225         s2=scalar2(b1(1,i+1),auxvec(1))
5226         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5227         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5228         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5229         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5230      &  *fac_shield(i)*fac_shield(j)
5231 C Derivatives in gamma(i+2)
5232         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5233         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5234         s1=scalar2(b1(1,i+2),auxvec(1))
5235         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5236         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5237         s2=scalar2(b1(1,i+1),auxvec(1))
5238         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5239         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5240         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5241         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5242      &  *fac_shield(i)*fac_shield(j)
5243         if (calc_grad) then
5244 C Cartesian derivatives
5245 C Derivatives of this turn contributions in DC(i+2)
5246         if (j.lt.nres-1) then
5247           do l=1,3
5248             a_temp(1,1)=agg(l,1)
5249             a_temp(1,2)=agg(l,2)
5250             a_temp(2,1)=agg(l,3)
5251             a_temp(2,2)=agg(l,4)
5252             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5253             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5254             s1=scalar2(b1(1,i+2),auxvec(1))
5255             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5256             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5257             s2=scalar2(b1(1,i+1),auxvec(1))
5258             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5259             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5260             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5261             ggg(l)=-(s1+s2+s3)
5262             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5263      &  *fac_shield(i)*fac_shield(j)
5264           enddo
5265         endif
5266 C Remaining derivatives of this turn contribution
5267         do l=1,3
5268           a_temp(1,1)=aggi(l,1)
5269           a_temp(1,2)=aggi(l,2)
5270           a_temp(2,1)=aggi(l,3)
5271           a_temp(2,2)=aggi(l,4)
5272           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5273           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5274           s1=scalar2(b1(1,i+2),auxvec(1))
5275           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5276           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5277           s2=scalar2(b1(1,i+1),auxvec(1))
5278           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5279           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5280           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5281           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5282      &  *fac_shield(i)*fac_shield(j)
5283           a_temp(1,1)=aggi1(l,1)
5284           a_temp(1,2)=aggi1(l,2)
5285           a_temp(2,1)=aggi1(l,3)
5286           a_temp(2,2)=aggi1(l,4)
5287           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5288           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5289           s1=scalar2(b1(1,i+2),auxvec(1))
5290           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5291           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5292           s2=scalar2(b1(1,i+1),auxvec(1))
5293           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5294           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5295           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5296           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5297      &  *fac_shield(i)*fac_shield(j)
5298           a_temp(1,1)=aggj(l,1)
5299           a_temp(1,2)=aggj(l,2)
5300           a_temp(2,1)=aggj(l,3)
5301           a_temp(2,2)=aggj(l,4)
5302           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5303           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5304           s1=scalar2(b1(1,i+2),auxvec(1))
5305           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5306           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5307           s2=scalar2(b1(1,i+1),auxvec(1))
5308           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5309           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5310           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5311           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5312      &  *fac_shield(i)*fac_shield(j)
5313           a_temp(1,1)=aggj1(l,1)
5314           a_temp(1,2)=aggj1(l,2)
5315           a_temp(2,1)=aggj1(l,3)
5316           a_temp(2,2)=aggj1(l,4)
5317           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5318           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5319           s1=scalar2(b1(1,i+2),auxvec(1))
5320           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5321           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5322           s2=scalar2(b1(1,i+1),auxvec(1))
5323           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5324           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5325           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5326 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5327           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5328      &  *fac_shield(i)*fac_shield(j)
5329         enddo
5330
5331         endif ! calc_grad
5332
5333       return
5334       end
5335 C-----------------------------------------------------------------------------
5336       subroutine vecpr(u,v,w)
5337       implicit real*8(a-h,o-z)
5338       dimension u(3),v(3),w(3)
5339       w(1)=u(2)*v(3)-u(3)*v(2)
5340       w(2)=-u(1)*v(3)+u(3)*v(1)
5341       w(3)=u(1)*v(2)-u(2)*v(1)
5342       return
5343       end
5344 C-----------------------------------------------------------------------------
5345       subroutine unormderiv(u,ugrad,unorm,ungrad)
5346 C This subroutine computes the derivatives of a normalized vector u, given
5347 C the derivatives computed without normalization conditions, ugrad. Returns
5348 C ungrad.
5349       implicit none
5350       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5351       double precision vec(3)
5352       double precision scalar
5353       integer i,j
5354 c      write (2,*) 'ugrad',ugrad
5355 c      write (2,*) 'u',u
5356       do i=1,3
5357         vec(i)=scalar(ugrad(1,i),u(1))
5358       enddo
5359 c      write (2,*) 'vec',vec
5360       do i=1,3
5361         do j=1,3
5362           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5363         enddo
5364       enddo
5365 c      write (2,*) 'ungrad',ungrad
5366       return
5367       end
5368 C-----------------------------------------------------------------------------
5369       subroutine escp(evdw2,evdw2_14)
5370 C
5371 C This subroutine calculates the excluded-volume interaction energy between
5372 C peptide-group centers and side chains and its gradient in virtual-bond and
5373 C side-chain vectors.
5374 C
5375       implicit real*8 (a-h,o-z)
5376       include 'DIMENSIONS'
5377       include 'DIMENSIONS.ZSCOPT'
5378       include 'COMMON.GEO'
5379       include 'COMMON.VAR'
5380       include 'COMMON.LOCAL'
5381       include 'COMMON.CHAIN'
5382       include 'COMMON.DERIV'
5383       include 'COMMON.INTERACT'
5384       include 'COMMON.FFIELD'
5385       include 'COMMON.IOUNITS'
5386       dimension ggg(3)
5387       evdw2=0.0D0
5388       evdw2_14=0.0d0
5389 cd    print '(a)','Enter ESCP'
5390 c      write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e,
5391 c     &  ' scal14',scal14
5392       do i=iatscp_s,iatscp_e
5393         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5394         iteli=itel(i)
5395 c        write (iout,*) "i",i," iteli",iteli," nscp_gr",nscp_gr(i),
5396 c     &   " iscp",(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
5397         if (iteli.eq.0) goto 1225
5398         xi=0.5D0*(c(1,i)+c(1,i+1))
5399         yi=0.5D0*(c(2,i)+c(2,i+1))
5400         zi=0.5D0*(c(3,i)+c(3,i+1))
5401 C Returning the ith atom to box
5402           xi=mod(xi,boxxsize)
5403           if (xi.lt.0) xi=xi+boxxsize
5404           yi=mod(yi,boxysize)
5405           if (yi.lt.0) yi=yi+boxysize
5406           zi=mod(zi,boxzsize)
5407           if (zi.lt.0) zi=zi+boxzsize
5408         do iint=1,nscp_gr(i)
5409
5410         do j=iscpstart(i,iint),iscpend(i,iint)
5411           itypj=iabs(itype(j))
5412           if (itypj.eq.ntyp1) cycle
5413 C Uncomment following three lines for SC-p interactions
5414 c         xj=c(1,nres+j)-xi
5415 c         yj=c(2,nres+j)-yi
5416 c         zj=c(3,nres+j)-zi
5417 C Uncomment following three lines for Ca-p interactions
5418           xj=c(1,j)
5419           yj=c(2,j)
5420           zj=c(3,j)
5421 C returning the jth atom to box
5422           xj=mod(xj,boxxsize)
5423           if (xj.lt.0) xj=xj+boxxsize
5424           yj=mod(yj,boxysize)
5425           if (yj.lt.0) yj=yj+boxysize
5426           zj=mod(zj,boxzsize)
5427           if (zj.lt.0) zj=zj+boxzsize
5428       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5429       xj_safe=xj
5430       yj_safe=yj
5431       zj_safe=zj
5432       subchap=0
5433 C Finding the closest jth atom
5434       do xshift=-1,1
5435       do yshift=-1,1
5436       do zshift=-1,1
5437           xj=xj_safe+xshift*boxxsize
5438           yj=yj_safe+yshift*boxysize
5439           zj=zj_safe+zshift*boxzsize
5440           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5441           if(dist_temp.lt.dist_init) then
5442             dist_init=dist_temp
5443             xj_temp=xj
5444             yj_temp=yj
5445             zj_temp=zj
5446             subchap=1
5447           endif
5448        enddo
5449        enddo
5450        enddo
5451        if (subchap.eq.1) then
5452           xj=xj_temp-xi
5453           yj=yj_temp-yi
5454           zj=zj_temp-zi
5455        else
5456           xj=xj_safe-xi
5457           yj=yj_safe-yi
5458           zj=zj_safe-zi
5459        endif
5460           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5461 C sss is scaling function for smoothing the cutoff gradient otherwise
5462 C the gradient would not be continuouse
5463           sss=sscale(1.0d0/(dsqrt(rrij)))
5464           if (sss.le.0.0d0) cycle
5465           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5466           fac=rrij**expon2
5467           e1=fac*fac*aad(itypj,iteli)
5468           e2=fac*bad(itypj,iteli)
5469           if (iabs(j-i) .le. 2) then
5470             e1=scal14*e1
5471             e2=scal14*e2
5472             evdw2_14=evdw2_14+(e1+e2)*sss
5473           endif
5474           evdwij=e1+e2
5475 c          write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5476 c     &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5477 c     &       bad(itypj,iteli)
5478           evdw2=evdw2+evdwij*sss
5479           if (calc_grad) then
5480 C
5481 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5482 C
5483           fac=-(evdwij+e1)*rrij*sss
5484           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5485           ggg(1)=xj*fac
5486           ggg(2)=yj*fac
5487           ggg(3)=zj*fac
5488           if (j.lt.i) then
5489 cd          write (iout,*) 'j<i'
5490 C Uncomment following three lines for SC-p interactions
5491 c           do k=1,3
5492 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5493 c           enddo
5494           else
5495 cd          write (iout,*) 'j>i'
5496             do k=1,3
5497               ggg(k)=-ggg(k)
5498 C Uncomment following line for SC-p interactions
5499 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5500             enddo
5501           endif
5502           do k=1,3
5503             gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5504           enddo
5505           kstart=min0(i+1,j)
5506           kend=max0(i-1,j-1)
5507 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5508 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5509           do k=kstart,kend
5510             do l=1,3
5511               gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5512             enddo
5513           enddo
5514           endif ! calc_grad
5515         enddo
5516         enddo ! iint
5517  1225   continue
5518       enddo ! i
5519       do i=1,nct
5520         do j=1,3
5521           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5522           gradx_scp(j,i)=expon*gradx_scp(j,i)
5523         enddo
5524       enddo
5525 C******************************************************************************
5526 C
5527 C                              N O T E !!!
5528 C
5529 C To save time the factor EXPON has been extracted from ALL components
5530 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5531 C use!
5532 C
5533 C******************************************************************************
5534       return
5535       end
5536 C--------------------------------------------------------------------------
5537       subroutine edis(ehpb)
5538 C
5539 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5540 C
5541       implicit real*8 (a-h,o-z)
5542       include 'DIMENSIONS'
5543       include 'DIMENSIONS.ZSCOPT'
5544       include 'COMMON.SBRIDGE'
5545       include 'COMMON.CHAIN'
5546       include 'COMMON.DERIV'
5547       include 'COMMON.VAR'
5548       include 'COMMON.INTERACT'
5549       include 'COMMON.CONTROL'
5550       include 'COMMON.IOUNITS'
5551       dimension ggg(3)
5552       ehpb=0.0D0
5553 cd    print *,'edis: nhpb=',nhpb,' fbr=',fbr
5554 cd    print *,'link_start=',link_start,' link_end=',link_end
5555 C      write(iout,*) link_end, "link_end"
5556       if (link_end.eq.0) return
5557       do i=link_start,link_end
5558 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5559 C CA-CA distance used in regularization of structure.
5560         ii=ihpb(i)
5561         jj=jhpb(i)
5562 C iii and jjj point to the residues for which the distance is assigned.
5563         if (ii.gt.nres) then
5564           iii=ii-nres
5565           jjj=jj-nres
5566         else
5567           iii=ii
5568           jjj=jj
5569         endif
5570 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5571 C    distance and angle dependent SS bond potential.
5572 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5573 C     & iabs(itype(jjj)).eq.1) then
5574 C       write(iout,*) constr_dist,"const"
5575        if (.not.dyn_ss .and. i.le.nss) then
5576          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5577      & iabs(itype(jjj)).eq.1) then
5578           call ssbond_ene(iii,jjj,eij)
5579           ehpb=ehpb+2*eij
5580            endif !ii.gt.neres
5581         else if (ii.gt.nres .and. jj.gt.nres) then
5582 c Restraints from contact prediction
5583           dd=dist(ii,jj)
5584           if (constr_dist.eq.11) then
5585 C            ehpb=ehpb+fordepth(i)**4.0d0
5586 C     &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5587             ehpb=ehpb+fordepth(i)**4.0d0
5588      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5589             fac=fordepth(i)**4.0d0
5590      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5591 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5592 C     &    ehpb,fordepth(i),dd
5593 C            write(iout,*) ehpb,"atu?"
5594 C            ehpb,"tu?"
5595 C            fac=fordepth(i)**4.0d0
5596 C     &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5597            else
5598           if (dhpb1(i).gt.0.0d0) then
5599             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5600             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5601 c            write (iout,*) "beta nmr",
5602 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5603           else
5604             dd=dist(ii,jj)
5605             rdis=dd-dhpb(i)
5606 C Get the force constant corresponding to this distance.
5607             waga=forcon(i)
5608 C Calculate the contribution to energy.
5609             ehpb=ehpb+waga*rdis*rdis
5610 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
5611 C
5612 C Evaluate gradient.
5613 C
5614             fac=waga*rdis/dd
5615           endif !end dhpb1(i).gt.0
5616           endif !end const_dist=11
5617           do j=1,3
5618             ggg(j)=fac*(c(j,jj)-c(j,ii))
5619           enddo
5620           do j=1,3
5621             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5622             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5623           enddo
5624           do k=1,3
5625             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5626             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5627           enddo
5628         else !ii.gt.nres
5629 C          write(iout,*) "before"
5630           dd=dist(ii,jj)
5631 C          write(iout,*) "after",dd
5632           if (constr_dist.eq.11) then
5633             ehpb=ehpb+fordepth(i)**4.0d0
5634      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5635             fac=fordepth(i)**4.0d0
5636      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5637 C            ehpb=ehpb+fordepth(i)**4*rlornmr1(dd,dhpb(i),dhpb1(i))
5638 C            fac=fordepth(i)**4*rlornmr1prim(dd,dhpb(i),dhpb1(i))/dd
5639 C            print *,ehpb,"tu?"
5640 C            write(iout,*) ehpb,"btu?",
5641 C     & dd,dhpb(i),dhpb1(i),fordepth(i),forcon(i)
5642 C          write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
5643 C     &    ehpb,fordepth(i),dd
5644            else
5645           if (dhpb1(i).gt.0.0d0) then
5646             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5647             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5648 c            write (iout,*) "alph nmr",
5649 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5650           else
5651             rdis=dd-dhpb(i)
5652 C Get the force constant corresponding to this distance.
5653             waga=forcon(i)
5654 C Calculate the contribution to energy.
5655             ehpb=ehpb+waga*rdis*rdis
5656 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
5657 C
5658 C Evaluate gradient.
5659 C
5660             fac=waga*rdis/dd
5661           endif
5662           endif
5663
5664         do j=1,3
5665           ggg(j)=fac*(c(j,jj)-c(j,ii))
5666         enddo
5667 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5668 C If this is a SC-SC distance, we need to calculate the contributions to the
5669 C Cartesian gradient in the SC vectors (ghpbx).
5670         if (iii.lt.ii) then
5671           do j=1,3
5672             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5673             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5674           enddo
5675         endif
5676         do j=iii,jjj-1
5677           do k=1,3
5678             ghpbc(k,j)=ghpbc(k,j)+ggg(k)
5679           enddo
5680         enddo
5681         endif
5682       enddo
5683       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
5684       return
5685       end
5686 C--------------------------------------------------------------------------
5687       subroutine ssbond_ene(i,j,eij)
5688 C
5689 C Calculate the distance and angle dependent SS-bond potential energy
5690 C using a free-energy function derived based on RHF/6-31G** ab initio
5691 C calculations of diethyl disulfide.
5692 C
5693 C A. Liwo and U. Kozlowska, 11/24/03
5694 C
5695       implicit real*8 (a-h,o-z)
5696       include 'DIMENSIONS'
5697       include 'DIMENSIONS.ZSCOPT'
5698       include 'COMMON.SBRIDGE'
5699       include 'COMMON.CHAIN'
5700       include 'COMMON.DERIV'
5701       include 'COMMON.LOCAL'
5702       include 'COMMON.INTERACT'
5703       include 'COMMON.VAR'
5704       include 'COMMON.IOUNITS'
5705       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5706       itypi=iabs(itype(i))
5707       xi=c(1,nres+i)
5708       yi=c(2,nres+i)
5709       zi=c(3,nres+i)
5710       dxi=dc_norm(1,nres+i)
5711       dyi=dc_norm(2,nres+i)
5712       dzi=dc_norm(3,nres+i)
5713       dsci_inv=dsc_inv(itypi)
5714       itypj=iabs(itype(j))
5715       dscj_inv=dsc_inv(itypj)
5716       xj=c(1,nres+j)-xi
5717       yj=c(2,nres+j)-yi
5718       zj=c(3,nres+j)-zi
5719       dxj=dc_norm(1,nres+j)
5720       dyj=dc_norm(2,nres+j)
5721       dzj=dc_norm(3,nres+j)
5722       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5723       rij=dsqrt(rrij)
5724       erij(1)=xj*rij
5725       erij(2)=yj*rij
5726       erij(3)=zj*rij
5727       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5728       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5729       om12=dxi*dxj+dyi*dyj+dzi*dzj
5730       do k=1,3
5731         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5732         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5733       enddo
5734       rij=1.0d0/rij
5735       deltad=rij-d0cm
5736       deltat1=1.0d0-om1
5737       deltat2=1.0d0+om2
5738       deltat12=om2-om1+2.0d0
5739       cosphi=om12-om1*om2
5740       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5741      &  +akct*deltad*deltat12
5742      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi
5743 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5744 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5745 c     &  " deltat12",deltat12," eij",eij
5746       ed=2*akcm*deltad+akct*deltat12
5747       pom1=akct*deltad
5748       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5749       eom1=-2*akth*deltat1-pom1-om2*pom2
5750       eom2= 2*akth*deltat2+pom1-om1*pom2
5751       eom12=pom2
5752       do k=1,3
5753         gg(k)=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5754       enddo
5755       do k=1,3
5756         ghpbx(k,i)=ghpbx(k,i)-gg(k)
5757      &            +(eom12*dc_norm(k,nres+j)+eom1*erij(k))*dsci_inv
5758         ghpbx(k,j)=ghpbx(k,j)+gg(k)
5759      &            +(eom12*dc_norm(k,nres+i)+eom2*erij(k))*dscj_inv
5760       enddo
5761 C
5762 C Calculate the components of the gradient in DC and X
5763 C
5764       do k=i,j-1
5765         do l=1,3
5766           ghpbc(l,k)=ghpbc(l,k)+gg(l)
5767         enddo
5768       enddo
5769       return
5770       end
5771 C--------------------------------------------------------------------------
5772       subroutine ebond(estr)
5773 c
5774 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5775 c
5776       implicit real*8 (a-h,o-z)
5777       include 'DIMENSIONS'
5778       include 'DIMENSIONS.ZSCOPT'
5779       include 'COMMON.LOCAL'
5780       include 'COMMON.GEO'
5781       include 'COMMON.INTERACT'
5782       include 'COMMON.DERIV'
5783       include 'COMMON.VAR'
5784       include 'COMMON.CHAIN'
5785       include 'COMMON.IOUNITS'
5786       include 'COMMON.NAMES'
5787       include 'COMMON.FFIELD'
5788       include 'COMMON.CONTROL'
5789       double precision u(3),ud(3)
5790       estr=0.0d0
5791       estr1=0.0d0
5792 c      write (iout,*) "distchainmax",distchainmax
5793       do i=nnt+1,nct
5794         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5795 C          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5796 C          do j=1,3
5797 C          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5798 C     &      *dc(j,i-1)/vbld(i)
5799 C          enddo
5800 C          if (energy_dec) write(iout,*)
5801 C     &       "estr1",i,vbld(i),distchainmax,
5802 C     &       gnmr1(vbld(i),-1.0d0,distchainmax)
5803 C        else
5804          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5805         diff = vbld(i)-vbldpDUM
5806 C         write(iout,*) i,diff
5807          else
5808           diff = vbld(i)-vbldp0
5809 c          write (iout,*) i,vbld(i),vbldp0,diff,AKP*diff*diff
5810          endif
5811           estr=estr+diff*diff
5812           do j=1,3
5813             gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
5814           enddo
5815 C        endif
5816 C        write (iout,'(a7,i5,4f7.3)')
5817 C     &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
5818       enddo
5819       estr=0.5d0*AKP*estr+estr1
5820 c
5821 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
5822 c
5823       do i=nnt,nct
5824         iti=iabs(itype(i))
5825         if (iti.ne.10 .and. iti.ne.ntyp1) then
5826           nbi=nbondterm(iti)
5827           if (nbi.eq.1) then
5828             diff=vbld(i+nres)-vbldsc0(1,iti)
5829 C            write (iout,*) i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
5830 C     &      AKSC(1,iti),AKSC(1,iti)*diff*diff
5831             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
5832             do j=1,3
5833               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
5834             enddo
5835           else
5836             do j=1,nbi
5837               diff=vbld(i+nres)-vbldsc0(j,iti)
5838               ud(j)=aksc(j,iti)*diff
5839               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
5840             enddo
5841             uprod=u(1)
5842             do j=2,nbi
5843               uprod=uprod*u(j)
5844             enddo
5845             usum=0.0d0
5846             usumsqder=0.0d0
5847             do j=1,nbi
5848               uprod1=1.0d0
5849               uprod2=1.0d0
5850               do k=1,nbi
5851                 if (k.ne.j) then
5852                   uprod1=uprod1*u(k)
5853                   uprod2=uprod2*u(k)*u(k)
5854                 endif
5855               enddo
5856               usum=usum+uprod1
5857               usumsqder=usumsqder+ud(j)*uprod2
5858             enddo
5859 c            write (iout,*) i,iti,vbld(i+nres),(vbldsc0(j,iti),
5860 c     &      AKSC(j,iti),abond0(j,iti),u(j),j=1,nbi)
5861             estr=estr+uprod/usum
5862             do j=1,3
5863              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
5864             enddo
5865           endif
5866         endif
5867       enddo
5868       return
5869       end
5870 #ifdef CRYST_THETA
5871 C--------------------------------------------------------------------------
5872       subroutine ebend(etheta,ethetacnstr)
5873 C
5874 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
5875 C angles gamma and its derivatives in consecutive thetas and gammas.
5876 C
5877       implicit real*8 (a-h,o-z)
5878       include 'DIMENSIONS'
5879       include 'DIMENSIONS.ZSCOPT'
5880       include 'COMMON.LOCAL'
5881       include 'COMMON.GEO'
5882       include 'COMMON.INTERACT'
5883       include 'COMMON.DERIV'
5884       include 'COMMON.VAR'
5885       include 'COMMON.CHAIN'
5886       include 'COMMON.IOUNITS'
5887       include 'COMMON.NAMES'
5888       include 'COMMON.FFIELD'
5889       include 'COMMON.TORCNSTR'
5890       common /calcthet/ term1,term2,termm,diffak,ratak,
5891      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
5892      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
5893       double precision y(2),z(2)
5894       delta=0.02d0*pi
5895 c      time11=dexp(-2*time)
5896 c      time12=1.0d0
5897       etheta=0.0D0
5898 c      write (iout,*) "nres",nres
5899 c     write (*,'(a,i2)') 'EBEND ICG=',icg
5900 c      write (iout,*) ithet_start,ithet_end
5901       do i=ithet_start,ithet_end
5902 C        if (itype(i-1).eq.ntyp1) cycle
5903         if (i.le.2) cycle
5904         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
5905      &  .or.itype(i).eq.ntyp1) cycle
5906 C Zero the energy function and its derivative at 0 or pi.
5907         call splinthet(theta(i),0.5d0*delta,ss,ssd)
5908         it=itype(i-1)
5909         ichir1=isign(1,itype(i-2))
5910         ichir2=isign(1,itype(i))
5911          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
5912          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
5913          if (itype(i-1).eq.10) then
5914           itype1=isign(10,itype(i-2))
5915           ichir11=isign(1,itype(i-2))
5916           ichir12=isign(1,itype(i-2))
5917           itype2=isign(10,itype(i))
5918           ichir21=isign(1,itype(i))
5919           ichir22=isign(1,itype(i))
5920          endif
5921          if (i.eq.3) then
5922           y(1)=0.0D0
5923           y(2)=0.0D0
5924           else
5925
5926         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
5927 #ifdef OSF
5928           phii=phi(i)
5929 c          icrc=0
5930 c          call proc_proc(phii,icrc)
5931           if (icrc.eq.1) phii=150.0
5932 #else
5933           phii=phi(i)
5934 #endif
5935           y(1)=dcos(phii)
5936           y(2)=dsin(phii)
5937         else
5938           y(1)=0.0D0
5939           y(2)=0.0D0
5940         endif
5941         endif
5942         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
5943 #ifdef OSF
5944           phii1=phi(i+1)
5945 c          icrc=0
5946 c          call proc_proc(phii1,icrc)
5947           if (icrc.eq.1) phii1=150.0
5948           phii1=pinorm(phii1)
5949           z(1)=cos(phii1)
5950 #else
5951           phii1=phi(i+1)
5952           z(1)=dcos(phii1)
5953 #endif
5954           z(2)=dsin(phii1)
5955         else
5956           z(1)=0.0D0
5957           z(2)=0.0D0
5958         endif
5959 C Calculate the "mean" value of theta from the part of the distribution
5960 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
5961 C In following comments this theta will be referred to as t_c.
5962         thet_pred_mean=0.0d0
5963         do k=1,2
5964             athetk=athet(k,it,ichir1,ichir2)
5965             bthetk=bthet(k,it,ichir1,ichir2)
5966           if (it.eq.10) then
5967              athetk=athet(k,itype1,ichir11,ichir12)
5968              bthetk=bthet(k,itype2,ichir21,ichir22)
5969           endif
5970           thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
5971         enddo
5972 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5973         dthett=thet_pred_mean*ssd
5974         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
5975 c        write (iout,*) "thet_pred_mean",thet_pred_mean
5976 C Derivatives of the "mean" values in gamma1 and gamma2.
5977         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
5978      &+athet(2,it,ichir1,ichir2)*y(1))*ss
5979          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
5980      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
5981          if (it.eq.10) then
5982       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
5983      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
5984         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
5985      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
5986          endif
5987         if (theta(i).gt.pi-delta) then
5988           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
5989      &         E_tc0)
5990           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
5991           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5992           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
5993      &        E_theta)
5994           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
5995      &        E_tc)
5996         else if (theta(i).lt.delta) then
5997           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
5998           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
5999           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6000      &        E_theta)
6001           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6002           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6003      &        E_tc)
6004         else
6005           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6006      &        E_theta,E_tc)
6007         endif
6008         etheta=etheta+ethetai
6009 c         write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6010 c     &      'ebend',i,ethetai,theta(i),itype(i)
6011 c        write (iout,'(2i3,3f8.3,f10.5)') i,it,rad2deg*theta(i),
6012 c     &    rad2deg*phii,rad2deg*phii1,ethetai
6013         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6014         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6015         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
6016 c 1215   continue
6017       enddo
6018       ethetacnstr=0.0d0
6019 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
6020       do i=1,ntheta_constr
6021         itheta=itheta_constr(i)
6022         thetiii=theta(itheta)
6023         difi=pinorm(thetiii-theta_constr0(i))
6024         if (difi.gt.theta_drange(i)) then
6025           difi=difi-theta_drange(i)
6026           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6027           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6028      &    +for_thet_constr(i)*difi**3
6029         else if (difi.lt.-drange(i)) then
6030           difi=difi+drange(i)
6031           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
6032           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
6033      &    +for_thet_constr(i)*difi**3
6034         else
6035           difi=0.0
6036         endif
6037 C       if (energy_dec) then
6038 C        write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
6039 C     &    i,itheta,rad2deg*thetiii,
6040 C     &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
6041 C     &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
6042 C     &    gloc(itheta+nphi-2,icg)
6043 C        endif
6044       enddo
6045 C Ufff.... We've done all this!!!
6046       return
6047       end
6048 C---------------------------------------------------------------------------
6049       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6050      &     E_tc)
6051       implicit real*8 (a-h,o-z)
6052       include 'DIMENSIONS'
6053       include 'COMMON.LOCAL'
6054       include 'COMMON.IOUNITS'
6055       common /calcthet/ term1,term2,termm,diffak,ratak,
6056      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6057      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6058 C Calculate the contributions to both Gaussian lobes.
6059 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6060 C The "polynomial part" of the "standard deviation" of this part of
6061 C the distribution.
6062         sig=polthet(3,it)
6063         do j=2,0,-1
6064           sig=sig*thet_pred_mean+polthet(j,it)
6065         enddo
6066 C Derivative of the "interior part" of the "standard deviation of the"
6067 C gamma-dependent Gaussian lobe in t_c.
6068         sigtc=3*polthet(3,it)
6069         do j=2,1,-1
6070           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6071         enddo
6072         sigtc=sig*sigtc
6073 C Set the parameters of both Gaussian lobes of the distribution.
6074 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6075         fac=sig*sig+sigc0(it)
6076         sigcsq=fac+fac
6077         sigc=1.0D0/sigcsq
6078 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6079         sigsqtc=-4.0D0*sigcsq*sigtc
6080 c       print *,i,sig,sigtc,sigsqtc
6081 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6082         sigtc=-sigtc/(fac*fac)
6083 C Following variable is sigma(t_c)**(-2)
6084         sigcsq=sigcsq*sigcsq
6085         sig0i=sig0(it)
6086         sig0inv=1.0D0/sig0i**2
6087         delthec=thetai-thet_pred_mean
6088         delthe0=thetai-theta0i
6089         term1=-0.5D0*sigcsq*delthec*delthec
6090         term2=-0.5D0*sig0inv*delthe0*delthe0
6091 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6092 C NaNs in taking the logarithm. We extract the largest exponent which is added
6093 C to the energy (this being the log of the distribution) at the end of energy
6094 C term evaluation for this virtual-bond angle.
6095         if (term1.gt.term2) then
6096           termm=term1
6097           term2=dexp(term2-termm)
6098           term1=1.0d0
6099         else
6100           termm=term2
6101           term1=dexp(term1-termm)
6102           term2=1.0d0
6103         endif
6104 C The ratio between the gamma-independent and gamma-dependent lobes of
6105 C the distribution is a Gaussian function of thet_pred_mean too.
6106         diffak=gthet(2,it)-thet_pred_mean
6107         ratak=diffak/gthet(3,it)**2
6108         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6109 C Let's differentiate it in thet_pred_mean NOW.
6110         aktc=ak*ratak
6111 C Now put together the distribution terms to make complete distribution.
6112         termexp=term1+ak*term2
6113         termpre=sigc+ak*sig0i
6114 C Contribution of the bending energy from this theta is just the -log of
6115 C the sum of the contributions from the two lobes and the pre-exponential
6116 C factor. Simple enough, isn't it?
6117         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6118 C NOW the derivatives!!!
6119 C 6/6/97 Take into account the deformation.
6120         E_theta=(delthec*sigcsq*term1
6121      &       +ak*delthe0*sig0inv*term2)/termexp
6122         E_tc=((sigtc+aktc*sig0i)/termpre
6123      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6124      &       aktc*term2)/termexp)
6125       return
6126       end
6127 c-----------------------------------------------------------------------------
6128       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6129       implicit real*8 (a-h,o-z)
6130       include 'DIMENSIONS'
6131       include 'COMMON.LOCAL'
6132       include 'COMMON.IOUNITS'
6133       common /calcthet/ term1,term2,termm,diffak,ratak,
6134      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6135      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6136       delthec=thetai-thet_pred_mean
6137       delthe0=thetai-theta0i
6138 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6139       t3 = thetai-thet_pred_mean
6140       t6 = t3**2
6141       t9 = term1
6142       t12 = t3*sigcsq
6143       t14 = t12+t6*sigsqtc
6144       t16 = 1.0d0
6145       t21 = thetai-theta0i
6146       t23 = t21**2
6147       t26 = term2
6148       t27 = t21*t26
6149       t32 = termexp
6150       t40 = t32**2
6151       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6152      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6153      & *(-t12*t9-ak*sig0inv*t27)
6154       return
6155       end
6156 #else
6157 C--------------------------------------------------------------------------
6158       subroutine ebend(etheta)
6159 C
6160 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6161 C angles gamma and its derivatives in consecutive thetas and gammas.
6162 C ab initio-derived potentials from
6163 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6164 C
6165       implicit real*8 (a-h,o-z)
6166       include 'DIMENSIONS'
6167       include 'DIMENSIONS.ZSCOPT'
6168       include 'COMMON.LOCAL'
6169       include 'COMMON.GEO'
6170       include 'COMMON.INTERACT'
6171       include 'COMMON.DERIV'
6172       include 'COMMON.VAR'
6173       include 'COMMON.CHAIN'
6174       include 'COMMON.IOUNITS'
6175       include 'COMMON.NAMES'
6176       include 'COMMON.FFIELD'
6177       include 'COMMON.CONTROL'
6178       include 'COMMON.TORCNSTR'
6179       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6180      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6181      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6182      & sinph1ph2(maxdouble,maxdouble)
6183       logical lprn /.false./, lprn1 /.false./
6184       etheta=0.0D0
6185 c      write (iout,*) "ithetyp",(ithetyp(i),i=1,ntyp1)
6186       do i=ithet_start,ithet_end
6187 C         if (i.eq.2) cycle
6188 C        if (itype(i-1).eq.ntyp1) cycle
6189         if (i.le.2) cycle
6190         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6191      &  .or.itype(i).eq.ntyp1) cycle
6192         if (iabs(itype(i+1)).eq.20) iblock=2
6193         if (iabs(itype(i+1)).ne.20) iblock=1
6194         dethetai=0.0d0
6195         dephii=0.0d0
6196         dephii1=0.0d0
6197         theti2=0.5d0*theta(i)
6198         ityp2=ithetyp((itype(i-1)))
6199         do k=1,nntheterm
6200           coskt(k)=dcos(k*theti2)
6201           sinkt(k)=dsin(k*theti2)
6202         enddo
6203         if (i.eq.3) then
6204           phii=0.0d0
6205           ityp1=nthetyp+1
6206           do k=1,nsingle
6207             cosph1(k)=0.0d0
6208             sinph1(k)=0.0d0
6209           enddo
6210         else
6211         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6212 #ifdef OSF
6213           phii=phi(i)
6214           if (phii.ne.phii) phii=150.0
6215 #else
6216           phii=phi(i)
6217 #endif
6218           ityp1=ithetyp((itype(i-2)))
6219           do k=1,nsingle
6220             cosph1(k)=dcos(k*phii)
6221             sinph1(k)=dsin(k*phii)
6222           enddo
6223         else
6224           phii=0.0d0
6225 c          ityp1=nthetyp+1
6226           do k=1,nsingle
6227             ityp1=ithetyp((itype(i-2)))
6228             cosph1(k)=0.0d0
6229             sinph1(k)=0.0d0
6230           enddo
6231         endif
6232         endif
6233         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6234 #ifdef OSF
6235           phii1=phi(i+1)
6236           if (phii1.ne.phii1) phii1=150.0
6237           phii1=pinorm(phii1)
6238 #else
6239           phii1=phi(i+1)
6240 #endif
6241           ityp3=ithetyp((itype(i)))
6242           do k=1,nsingle
6243             cosph2(k)=dcos(k*phii1)
6244             sinph2(k)=dsin(k*phii1)
6245           enddo
6246         else
6247           phii1=0.0d0
6248 c          ityp3=nthetyp+1
6249           ityp3=ithetyp((itype(i)))
6250           do k=1,nsingle
6251             cosph2(k)=0.0d0
6252             sinph2(k)=0.0d0
6253           enddo
6254         endif
6255 c        write (iout,*) "i",i," ityp1",itype(i-2),ityp1,
6256 c     &   " ityp2",itype(i-1),ityp2," ityp3",itype(i),ityp3
6257 c        call flush(iout)
6258         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6259         do k=1,ndouble
6260           do l=1,k-1
6261             ccl=cosph1(l)*cosph2(k-l)
6262             ssl=sinph1(l)*sinph2(k-l)
6263             scl=sinph1(l)*cosph2(k-l)
6264             csl=cosph1(l)*sinph2(k-l)
6265             cosph1ph2(l,k)=ccl-ssl
6266             cosph1ph2(k,l)=ccl+ssl
6267             sinph1ph2(l,k)=scl+csl
6268             sinph1ph2(k,l)=scl-csl
6269           enddo
6270         enddo
6271         if (lprn) then
6272         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6273      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6274         write (iout,*) "coskt and sinkt"
6275         do k=1,nntheterm
6276           write (iout,*) k,coskt(k),sinkt(k)
6277         enddo
6278         endif
6279         do k=1,ntheterm
6280           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6281           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6282      &      *coskt(k)
6283           if (lprn)
6284      &    write (iout,*) "k",k,"
6285      &      aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6286      &     " ethetai",ethetai
6287         enddo
6288         if (lprn) then
6289         write (iout,*) "cosph and sinph"
6290         do k=1,nsingle
6291           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6292         enddo
6293         write (iout,*) "cosph1ph2 and sinph2ph2"
6294         do k=2,ndouble
6295           do l=1,k-1
6296             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6297      &         sinph1ph2(l,k),sinph1ph2(k,l)
6298           enddo
6299         enddo
6300         write(iout,*) "ethetai",ethetai
6301         endif
6302         do m=1,ntheterm2
6303           do k=1,nsingle
6304             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6305      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6306      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6307      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6308             ethetai=ethetai+sinkt(m)*aux
6309             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6310             dephii=dephii+k*sinkt(m)*(
6311      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6312      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6313             dephii1=dephii1+k*sinkt(m)*(
6314      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6315      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6316             if (lprn)
6317      &      write (iout,*) "m",m," k",k," bbthet",
6318      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6319      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6320      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6321      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6322           enddo
6323         enddo
6324         if (lprn)
6325      &  write(iout,*) "ethetai",ethetai
6326         do m=1,ntheterm3
6327           do k=2,ndouble
6328             do l=1,k-1
6329               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6330      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6331      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6332      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6333               ethetai=ethetai+sinkt(m)*aux
6334               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6335               dephii=dephii+l*sinkt(m)*(
6336      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6337      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6338      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6339      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6340               dephii1=dephii1+(k-l)*sinkt(m)*(
6341      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6342      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6343      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6344      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6345               if (lprn) then
6346               write (iout,*) "m",m," k",k," l",l," ffthet",
6347      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6348      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6349      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6350      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6351      &            " ethetai",ethetai
6352               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6353      &            cosph1ph2(k,l)*sinkt(m),
6354      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6355               endif
6356             enddo
6357           enddo
6358         enddo
6359 10      continue
6360         if (lprn1) write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6361      &   i,theta(i)*rad2deg,phii*rad2deg,
6362      &   phii1*rad2deg,ethetai
6363         etheta=etheta+ethetai
6364         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6365         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6366 c        gloc(nphi+i-2,icg)=wang*dethetai
6367         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6368       enddo
6369       return
6370       end
6371 #endif
6372 #ifdef CRYST_SC
6373 c-----------------------------------------------------------------------------
6374       subroutine esc(escloc)
6375 C Calculate the local energy of a side chain and its derivatives in the
6376 C corresponding virtual-bond valence angles THETA and the spherical angles
6377 C ALPHA and OMEGA.
6378       implicit real*8 (a-h,o-z)
6379       include 'DIMENSIONS'
6380       include 'DIMENSIONS.ZSCOPT'
6381       include 'COMMON.GEO'
6382       include 'COMMON.LOCAL'
6383       include 'COMMON.VAR'
6384       include 'COMMON.INTERACT'
6385       include 'COMMON.DERIV'
6386       include 'COMMON.CHAIN'
6387       include 'COMMON.IOUNITS'
6388       include 'COMMON.NAMES'
6389       include 'COMMON.FFIELD'
6390       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6391      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6392       common /sccalc/ time11,time12,time112,theti,it,nlobit
6393       delta=0.02d0*pi
6394       escloc=0.0D0
6395 C      write (iout,*) 'ESC'
6396       do i=loc_start,loc_end
6397         it=itype(i)
6398         if (it.eq.ntyp1) cycle
6399         if (it.eq.10) goto 1
6400         nlobit=nlob(iabs(it))
6401 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6402 C        write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6403         theti=theta(i+1)-pipol
6404         x(1)=dtan(theti)
6405         x(2)=alph(i)
6406         x(3)=omeg(i)
6407 c        write (iout,*) "i",i," x",x(1),x(2),x(3)
6408
6409         if (x(2).gt.pi-delta) then
6410           xtemp(1)=x(1)
6411           xtemp(2)=pi-delta
6412           xtemp(3)=x(3)
6413           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6414           xtemp(2)=pi
6415           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6416           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6417      &        escloci,dersc(2))
6418           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6419      &        ddersc0(1),dersc(1))
6420           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6421      &        ddersc0(3),dersc(3))
6422           xtemp(2)=pi-delta
6423           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6424           xtemp(2)=pi
6425           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6426           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6427      &            dersc0(2),esclocbi,dersc02)
6428           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6429      &            dersc12,dersc01)
6430           call splinthet(x(2),0.5d0*delta,ss,ssd)
6431           dersc0(1)=dersc01
6432           dersc0(2)=dersc02
6433           dersc0(3)=0.0d0
6434           do k=1,3
6435             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6436           enddo
6437           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6438           write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6439      &             esclocbi,ss,ssd
6440           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6441 c         escloci=esclocbi
6442 c         write (iout,*) escloci
6443         else if (x(2).lt.delta) then
6444           xtemp(1)=x(1)
6445           xtemp(2)=delta
6446           xtemp(3)=x(3)
6447           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6448           xtemp(2)=0.0d0
6449           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6450           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6451      &        escloci,dersc(2))
6452           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6453      &        ddersc0(1),dersc(1))
6454           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6455      &        ddersc0(3),dersc(3))
6456           xtemp(2)=delta
6457           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6458           xtemp(2)=0.0d0
6459           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6460           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6461      &            dersc0(2),esclocbi,dersc02)
6462           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6463      &            dersc12,dersc01)
6464           dersc0(1)=dersc01
6465           dersc0(2)=dersc02
6466           dersc0(3)=0.0d0
6467           call splinthet(x(2),0.5d0*delta,ss,ssd)
6468           do k=1,3
6469             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6470           enddo
6471           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6472 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6473 c     &             esclocbi,ss,ssd
6474           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6475 C         write (iout,*) 'i=',i, escloci
6476         else
6477           call enesc(x,escloci,dersc,ddummy,.false.)
6478         endif
6479
6480         escloc=escloc+escloci
6481 C        write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6482             write (iout,'(a6,i5,0pf7.3)')
6483      &     'escloc',i,escloci
6484
6485         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6486      &   wscloc*dersc(1)
6487         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6488         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6489     1   continue
6490       enddo
6491       return
6492       end
6493 C---------------------------------------------------------------------------
6494       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6495       implicit real*8 (a-h,o-z)
6496       include 'DIMENSIONS'
6497       include 'COMMON.GEO'
6498       include 'COMMON.LOCAL'
6499       include 'COMMON.IOUNITS'
6500       common /sccalc/ time11,time12,time112,theti,it,nlobit
6501       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6502       double precision contr(maxlob,-1:1)
6503       logical mixed
6504 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6505         escloc_i=0.0D0
6506         do j=1,3
6507           dersc(j)=0.0D0
6508           if (mixed) ddersc(j)=0.0d0
6509         enddo
6510         x3=x(3)
6511
6512 C Because of periodicity of the dependence of the SC energy in omega we have
6513 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6514 C To avoid underflows, first compute & store the exponents.
6515
6516         do iii=-1,1
6517
6518           x(3)=x3+iii*dwapi
6519
6520           do j=1,nlobit
6521             do k=1,3
6522               z(k)=x(k)-censc(k,j,it)
6523             enddo
6524             do k=1,3
6525               Axk=0.0D0
6526               do l=1,3
6527                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6528               enddo
6529               Ax(k,j,iii)=Axk
6530             enddo
6531             expfac=0.0D0
6532             do k=1,3
6533               expfac=expfac+Ax(k,j,iii)*z(k)
6534             enddo
6535             contr(j,iii)=expfac
6536           enddo ! j
6537
6538         enddo ! iii
6539
6540         x(3)=x3
6541 C As in the case of ebend, we want to avoid underflows in exponentiation and
6542 C subsequent NaNs and INFs in energy calculation.
6543 C Find the largest exponent
6544         emin=contr(1,-1)
6545         do iii=-1,1
6546           do j=1,nlobit
6547             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6548           enddo
6549         enddo
6550         emin=0.5D0*emin
6551 cd      print *,'it=',it,' emin=',emin
6552
6553 C Compute the contribution to SC energy and derivatives
6554         do iii=-1,1
6555
6556           do j=1,nlobit
6557             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6558 cd          print *,'j=',j,' expfac=',expfac
6559             escloc_i=escloc_i+expfac
6560             do k=1,3
6561               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6562             enddo
6563             if (mixed) then
6564               do k=1,3,2
6565                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6566      &            +gaussc(k,2,j,it))*expfac
6567               enddo
6568             endif
6569           enddo
6570
6571         enddo ! iii
6572
6573         dersc(1)=dersc(1)/cos(theti)**2
6574         ddersc(1)=ddersc(1)/cos(theti)**2
6575         ddersc(3)=ddersc(3)
6576
6577         escloci=-(dlog(escloc_i)-emin)
6578         do j=1,3
6579           dersc(j)=dersc(j)/escloc_i
6580         enddo
6581         if (mixed) then
6582           do j=1,3,2
6583             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6584           enddo
6585         endif
6586       return
6587       end
6588 C------------------------------------------------------------------------------
6589       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6590       implicit real*8 (a-h,o-z)
6591       include 'DIMENSIONS'
6592       include 'COMMON.GEO'
6593       include 'COMMON.LOCAL'
6594       include 'COMMON.IOUNITS'
6595       common /sccalc/ time11,time12,time112,theti,it,nlobit
6596       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6597       double precision contr(maxlob)
6598       logical mixed
6599
6600       escloc_i=0.0D0
6601
6602       do j=1,3
6603         dersc(j)=0.0D0
6604       enddo
6605
6606       do j=1,nlobit
6607         do k=1,2
6608           z(k)=x(k)-censc(k,j,it)
6609         enddo
6610         z(3)=dwapi
6611         do k=1,3
6612           Axk=0.0D0
6613           do l=1,3
6614             Axk=Axk+gaussc(l,k,j,it)*z(l)
6615           enddo
6616           Ax(k,j)=Axk
6617         enddo
6618         expfac=0.0D0
6619         do k=1,3
6620           expfac=expfac+Ax(k,j)*z(k)
6621         enddo
6622         contr(j)=expfac
6623       enddo ! j
6624
6625 C As in the case of ebend, we want to avoid underflows in exponentiation and
6626 C subsequent NaNs and INFs in energy calculation.
6627 C Find the largest exponent
6628       emin=contr(1)
6629       do j=1,nlobit
6630         if (emin.gt.contr(j)) emin=contr(j)
6631       enddo
6632       emin=0.5D0*emin
6633
6634 C Compute the contribution to SC energy and derivatives
6635
6636       dersc12=0.0d0
6637       do j=1,nlobit
6638         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6639         escloc_i=escloc_i+expfac
6640         do k=1,2
6641           dersc(k)=dersc(k)+Ax(k,j)*expfac
6642         enddo
6643         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6644      &            +gaussc(1,2,j,it))*expfac
6645         dersc(3)=0.0d0
6646       enddo
6647
6648       dersc(1)=dersc(1)/cos(theti)**2
6649       dersc12=dersc12/cos(theti)**2
6650       escloci=-(dlog(escloc_i)-emin)
6651       do j=1,2
6652         dersc(j)=dersc(j)/escloc_i
6653       enddo
6654       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6655       return
6656       end
6657 #else
6658 c----------------------------------------------------------------------------------
6659       subroutine esc(escloc)
6660 C Calculate the local energy of a side chain and its derivatives in the
6661 C corresponding virtual-bond valence angles THETA and the spherical angles
6662 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6663 C added by Urszula Kozlowska. 07/11/2007
6664 C
6665       implicit real*8 (a-h,o-z)
6666       include 'DIMENSIONS'
6667       include 'DIMENSIONS.ZSCOPT'
6668       include 'COMMON.GEO'
6669       include 'COMMON.LOCAL'
6670       include 'COMMON.VAR'
6671       include 'COMMON.SCROT'
6672       include 'COMMON.INTERACT'
6673       include 'COMMON.DERIV'
6674       include 'COMMON.CHAIN'
6675       include 'COMMON.IOUNITS'
6676       include 'COMMON.NAMES'
6677       include 'COMMON.FFIELD'
6678       include 'COMMON.CONTROL'
6679       include 'COMMON.VECTORS'
6680       double precision x_prime(3),y_prime(3),z_prime(3)
6681      &    , sumene,dsc_i,dp2_i,x(65),
6682      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6683      &    de_dxx,de_dyy,de_dzz,de_dt
6684       double precision s1_t,s1_6_t,s2_t,s2_6_t
6685       double precision
6686      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6687      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6688      & dt_dCi(3),dt_dCi1(3)
6689       common /sccalc/ time11,time12,time112,theti,it,nlobit
6690       delta=0.02d0*pi
6691       escloc=0.0D0
6692       do i=loc_start,loc_end
6693         if (itype(i).eq.ntyp1) cycle
6694         costtab(i+1) =dcos(theta(i+1))
6695         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6696         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6697         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6698         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6699         cosfac=dsqrt(cosfac2)
6700         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6701         sinfac=dsqrt(sinfac2)
6702         it=iabs(itype(i))
6703         if (it.eq.10) goto 1
6704 c
6705 C  Compute the axes of tghe local cartesian coordinates system; store in
6706 c   x_prime, y_prime and z_prime
6707 c
6708         do j=1,3
6709           x_prime(j) = 0.00
6710           y_prime(j) = 0.00
6711           z_prime(j) = 0.00
6712         enddo
6713 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6714 C     &   dc_norm(3,i+nres)
6715         do j = 1,3
6716           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6717           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6718         enddo
6719         do j = 1,3
6720           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6721         enddo
6722 c       write (2,*) "i",i
6723 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6724 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6725 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6726 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6727 c      & " xy",scalar(x_prime(1),y_prime(1)),
6728 c      & " xz",scalar(x_prime(1),z_prime(1)),
6729 c      & " yy",scalar(y_prime(1),y_prime(1)),
6730 c      & " yz",scalar(y_prime(1),z_prime(1)),
6731 c      & " zz",scalar(z_prime(1),z_prime(1))
6732 c
6733 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6734 C to local coordinate system. Store in xx, yy, zz.
6735 c
6736         xx=0.0d0
6737         yy=0.0d0
6738         zz=0.0d0
6739         do j = 1,3
6740           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6741           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6742           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6743         enddo
6744
6745         xxtab(i)=xx
6746         yytab(i)=yy
6747         zztab(i)=zz
6748 C
6749 C Compute the energy of the ith side cbain
6750 C
6751 c        write (2,*) "xx",xx," yy",yy," zz",zz
6752         it=iabs(itype(i))
6753         do j = 1,65
6754           x(j) = sc_parmin(j,it)
6755         enddo
6756 #ifdef CHECK_COORD
6757 Cc diagnostics - remove later
6758         xx1 = dcos(alph(2))
6759         yy1 = dsin(alph(2))*dcos(omeg(2))
6760         zz1 = -dsign(1.0d0,itype(i))*dsin(alph(2))*dsin(omeg(2))
6761         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6762      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6763      &    xx1,yy1,zz1
6764 C,"  --- ", xx_w,yy_w,zz_w
6765 c end diagnostics
6766 #endif
6767         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6768      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6769      &   + x(10)*yy*zz
6770         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6771      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6772      & + x(20)*yy*zz
6773         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6774      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6775      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6776      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6777      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6778      &  +x(40)*xx*yy*zz
6779         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6780      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6781      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6782      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6783      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6784      &  +x(60)*xx*yy*zz
6785         dsc_i   = 0.743d0+x(61)
6786         dp2_i   = 1.9d0+x(62)
6787         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6788      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6789         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6790      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6791         s1=(1+x(63))/(0.1d0 + dscp1)
6792         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6793         s2=(1+x(65))/(0.1d0 + dscp2)
6794         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6795         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6796      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6797 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6798 c     &   sumene4,
6799 c     &   dscp1,dscp2,sumene
6800 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6801         escloc = escloc + sumene
6802 c        write (2,*) "escloc",escloc
6803 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i),
6804 c     &  zz,xx,yy
6805         if (.not. calc_grad) goto 1
6806 #ifdef DEBUG
6807 C
6808 C This section to check the numerical derivatives of the energy of ith side
6809 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6810 C #define DEBUG in the code to turn it on.
6811 C
6812         write (2,*) "sumene               =",sumene
6813         aincr=1.0d-7
6814         xxsave=xx
6815         xx=xx+aincr
6816         write (2,*) xx,yy,zz
6817         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6818         de_dxx_num=(sumenep-sumene)/aincr
6819         xx=xxsave
6820         write (2,*) "xx+ sumene from enesc=",sumenep
6821         yysave=yy
6822         yy=yy+aincr
6823         write (2,*) xx,yy,zz
6824         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6825         de_dyy_num=(sumenep-sumene)/aincr
6826         yy=yysave
6827         write (2,*) "yy+ sumene from enesc=",sumenep
6828         zzsave=zz
6829         zz=zz+aincr
6830         write (2,*) xx,yy,zz
6831         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6832         de_dzz_num=(sumenep-sumene)/aincr
6833         zz=zzsave
6834         write (2,*) "zz+ sumene from enesc=",sumenep
6835         costsave=cost2tab(i+1)
6836         sintsave=sint2tab(i+1)
6837         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6838         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6839         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6840         de_dt_num=(sumenep-sumene)/aincr
6841         write (2,*) " t+ sumene from enesc=",sumenep
6842         cost2tab(i+1)=costsave
6843         sint2tab(i+1)=sintsave
6844 C End of diagnostics section.
6845 #endif
6846 C
6847 C Compute the gradient of esc
6848 C
6849         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6850         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6851         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
6852         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
6853         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
6854         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
6855         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
6856         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
6857         pom1=(sumene3*sint2tab(i+1)+sumene1)
6858      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
6859         pom2=(sumene4*cost2tab(i+1)+sumene2)
6860      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
6861         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
6862         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
6863      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
6864      &  +x(40)*yy*zz
6865         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
6866         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
6867      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
6868      &  +x(60)*yy*zz
6869         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
6870      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
6871      &        +(pom1+pom2)*pom_dx
6872 #ifdef DEBUG
6873         write(2,*), "de_dxx = ", de_dxx,de_dxx_num
6874 #endif
6875 C
6876         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
6877         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
6878      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
6879      &  +x(40)*xx*zz
6880         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
6881         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
6882      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
6883      &  +x(59)*zz**2 +x(60)*xx*zz
6884         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
6885      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
6886      &        +(pom1-pom2)*pom_dy
6887 #ifdef DEBUG
6888         write(2,*), "de_dyy = ", de_dyy,de_dyy_num
6889 #endif
6890 C
6891         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
6892      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
6893      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
6894      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
6895      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
6896      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
6897      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
6898      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
6899 #ifdef DEBUG
6900         write(2,*), "de_dzz = ", de_dzz,de_dzz_num
6901 #endif
6902 C
6903         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
6904      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
6905      &  +pom1*pom_dt1+pom2*pom_dt2
6906 #ifdef DEBUG
6907         write(2,*), "de_dt = ", de_dt,de_dt_num
6908 #endif
6909 c
6910 C
6911        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
6912        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
6913        cosfac2xx=cosfac2*xx
6914        sinfac2yy=sinfac2*yy
6915        do k = 1,3
6916          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
6917      &      vbld_inv(i+1)
6918          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
6919      &      vbld_inv(i)
6920          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
6921          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
6922 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
6923 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
6924 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
6925 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
6926          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
6927          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
6928          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
6929          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
6930          dZZ_Ci1(k)=0.0d0
6931          dZZ_Ci(k)=0.0d0
6932          do j=1,3
6933            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
6934      & *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6935            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
6936      &  *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
6937          enddo
6938
6939          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
6940          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
6941          dZZ_XYZ(k)=vbld_inv(i+nres)*(z_prime(k)-zz*dC_norm(k,i+nres))
6942 c
6943          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
6944          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
6945        enddo
6946
6947        do k=1,3
6948          dXX_Ctab(k,i)=dXX_Ci(k)
6949          dXX_C1tab(k,i)=dXX_Ci1(k)
6950          dYY_Ctab(k,i)=dYY_Ci(k)
6951          dYY_C1tab(k,i)=dYY_Ci1(k)
6952          dZZ_Ctab(k,i)=dZZ_Ci(k)
6953          dZZ_C1tab(k,i)=dZZ_Ci1(k)
6954          dXX_XYZtab(k,i)=dXX_XYZ(k)
6955          dYY_XYZtab(k,i)=dYY_XYZ(k)
6956          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
6957        enddo
6958
6959        do k = 1,3
6960 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
6961 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
6962 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
6963 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
6964 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
6965 c     &    dt_dci(k)
6966 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
6967 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
6968          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
6969      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
6970          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
6971      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
6972          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
6973      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
6974        enddo
6975 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
6976 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
6977
6978 C to check gradient call subroutine check_grad
6979
6980     1 continue
6981       enddo
6982       return
6983       end
6984 #endif
6985 c------------------------------------------------------------------------------
6986       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
6987 C
6988 C This procedure calculates two-body contact function g(rij) and its derivative:
6989 C
6990 C           eps0ij                                     !       x < -1
6991 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
6992 C            0                                         !       x > 1
6993 C
6994 C where x=(rij-r0ij)/delta
6995 C
6996 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
6997 C
6998       implicit none
6999       double precision rij,r0ij,eps0ij,fcont,fprimcont
7000       double precision x,x2,x4,delta
7001 c     delta=0.02D0*r0ij
7002 c      delta=0.2D0*r0ij
7003       x=(rij-r0ij)/delta
7004       if (x.lt.-1.0D0) then
7005         fcont=eps0ij
7006         fprimcont=0.0D0
7007       else if (x.le.1.0D0) then
7008         x2=x*x
7009         x4=x2*x2
7010         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7011         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7012       else
7013         fcont=0.0D0
7014         fprimcont=0.0D0
7015       endif
7016       return
7017       end
7018 c------------------------------------------------------------------------------
7019       subroutine splinthet(theti,delta,ss,ssder)
7020       implicit real*8 (a-h,o-z)
7021       include 'DIMENSIONS'
7022       include 'DIMENSIONS.ZSCOPT'
7023       include 'COMMON.VAR'
7024       include 'COMMON.GEO'
7025       thetup=pi-delta
7026       thetlow=delta
7027       if (theti.gt.pipol) then
7028         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7029       else
7030         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7031         ssder=-ssder
7032       endif
7033       return
7034       end
7035 c------------------------------------------------------------------------------
7036       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7037       implicit none
7038       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7039       double precision ksi,ksi2,ksi3,a1,a2,a3
7040       a1=fprim0*delta/(f1-f0)
7041       a2=3.0d0-2.0d0*a1
7042       a3=a1-2.0d0
7043       ksi=(x-x0)/delta
7044       ksi2=ksi*ksi
7045       ksi3=ksi2*ksi
7046       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7047       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7048       return
7049       end
7050 c------------------------------------------------------------------------------
7051       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7052       implicit none
7053       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7054       double precision ksi,ksi2,ksi3,a1,a2,a3
7055       ksi=(x-x0)/delta
7056       ksi2=ksi*ksi
7057       ksi3=ksi2*ksi
7058       a1=fprim0x*delta
7059       a2=3*(f1x-f0x)-2*fprim0x*delta
7060       a3=fprim0x*delta-2*(f1x-f0x)
7061       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7062       return
7063       end
7064 C-----------------------------------------------------------------------------
7065 #ifdef CRYST_TOR
7066 C-----------------------------------------------------------------------------
7067       subroutine etor(etors)
7068       implicit real*8 (a-h,o-z)
7069       include 'DIMENSIONS'
7070       include 'DIMENSIONS.ZSCOPT'
7071       include 'COMMON.VAR'
7072       include 'COMMON.GEO'
7073       include 'COMMON.LOCAL'
7074       include 'COMMON.TORSION'
7075       include 'COMMON.INTERACT'
7076       include 'COMMON.DERIV'
7077       include 'COMMON.CHAIN'
7078       include 'COMMON.NAMES'
7079       include 'COMMON.IOUNITS'
7080       include 'COMMON.FFIELD'
7081       include 'COMMON.TORCNSTR'
7082       logical lprn
7083 C Set lprn=.true. for debugging
7084       lprn=.false.
7085 c      lprn=.true.
7086       etors=0.0D0
7087       do i=iphi_start,iphi_end
7088         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
7089      &      .or. itype(i).eq.ntyp1) cycle
7090         itori=itortyp(itype(i-2))
7091         itori1=itortyp(itype(i-1))
7092         phii=phi(i)
7093         gloci=0.0D0
7094 C Proline-Proline pair is a special case...
7095         if (itori.eq.3 .and. itori1.eq.3) then
7096           if (phii.gt.-dwapi3) then
7097             cosphi=dcos(3*phii)
7098             fac=1.0D0/(1.0D0-cosphi)
7099             etorsi=v1(1,3,3)*fac
7100             etorsi=etorsi+etorsi
7101             etors=etors+etorsi-v1(1,3,3)
7102             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7103           endif
7104           do j=1,3
7105             v1ij=v1(j+1,itori,itori1)
7106             v2ij=v2(j+1,itori,itori1)
7107             cosphi=dcos(j*phii)
7108             sinphi=dsin(j*phii)
7109             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7110             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7111           enddo
7112         else
7113           do j=1,nterm_old
7114             v1ij=v1(j,itori,itori1)
7115             v2ij=v2(j,itori,itori1)
7116             cosphi=dcos(j*phii)
7117             sinphi=dsin(j*phii)
7118             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7119             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7120           enddo
7121         endif
7122         if (lprn)
7123      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7124      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7125      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7126         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7127 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7128       enddo
7129       return
7130       end
7131 c------------------------------------------------------------------------------
7132 #else
7133       subroutine etor(etors)
7134       implicit real*8 (a-h,o-z)
7135       include 'DIMENSIONS'
7136       include 'DIMENSIONS.ZSCOPT'
7137       include 'COMMON.VAR'
7138       include 'COMMON.GEO'
7139       include 'COMMON.LOCAL'
7140       include 'COMMON.TORSION'
7141       include 'COMMON.INTERACT'
7142       include 'COMMON.DERIV'
7143       include 'COMMON.CHAIN'
7144       include 'COMMON.NAMES'
7145       include 'COMMON.IOUNITS'
7146       include 'COMMON.FFIELD'
7147       include 'COMMON.TORCNSTR'
7148       include 'COMMON.WEIGHTS'
7149       include 'COMMON.WEIGHTDER'
7150       logical lprn
7151 C Set lprn=.true. for debugging
7152       lprn=.false.
7153 c      lprn=.true.
7154       etors=0.0D0
7155       do iblock=1,2
7156       do i=-ntyp+1,ntyp-1
7157         do j=-ntyp+1,ntyp-1
7158           do k=0,3
7159             do l=0,2*maxterm
7160               etor_temp(l,k,j,i,iblock)=0.0d0
7161             enddo
7162           enddo
7163         enddo
7164       enddo
7165       enddo
7166       do i=iphi_start,iphi_end
7167         if (i.le.2) cycle
7168         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7169      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7170         if (itel(i-2).eq.0 .or. itel(i-1).eq.0) goto 1215
7171         if (iabs(itype(i)).eq.20) then
7172           iblock=2
7173         else
7174           iblock=1
7175         endif
7176         itori=itortyp(itype(i-2))
7177         itori1=itortyp(itype(i-1))
7178         weitori=weitor(0,itori,itori1,iblock)
7179         phii=phi(i)
7180         gloci=0.0D0
7181         etori=0.0d0
7182 C Regular cosine and sine terms
7183         do j=1,nterm(itori,itori1,iblock)
7184           v1ij=v1(j,itori,itori1,iblock)
7185           v2ij=v2(j,itori,itori1,iblock)
7186           cosphi=dcos(j*phii)
7187           sinphi=dsin(j*phii)
7188           etori=etori+v1ij*cosphi+v2ij*sinphi
7189           etor_temp(j,0,itori,itori1,iblock)=
7190      &      etor_temp(j,0,itori,itori1,iblock)+cosphi*ww(13)
7191           etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)=
7192      &    etor_temp(nterm(itori,itori1,iblock)+j,0,itori,itori1,iblock)+
7193      &      sinphi*ww(13)
7194           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7195         enddo
7196 C Lorentz terms
7197 C                         v1
7198 C  E = SUM ----------------------------------- - v1
7199 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7200 C
7201         cosphi=dcos(0.5d0*phii)
7202         sinphi=dsin(0.5d0*phii)
7203         do j=1,nlor(itori,itori1,iblock)
7204           vl1ij=vlor1(j,itori,itori1)
7205           vl2ij=vlor2(j,itori,itori1)
7206           vl3ij=vlor3(j,itori,itori1)
7207           pom=vl2ij*cosphi+vl3ij*sinphi
7208           pom1=1.0d0/(pom*pom+1.0d0)
7209           etori=etori+vl1ij*pom1
7210           pom=-pom*pom1*pom1
7211           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7212         enddo
7213 C Subtract the constant term
7214         etors=etors+(etori-v0(itori,itori1,iblock))*weitori
7215         etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)+
7216      &    (etori-v0(itori,itori1,iblock))*ww(13)
7217
7218         if (lprn) then
7219         write (iout,'(2(a3,2x,i3,2x),2i3,8f8.3/26x,6f8.3/)')
7220      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7221      &  weitori,v0(itori,itori1,iblock)*weitori,
7222      &  (v1(j,itori,itori1,iblock)*weitori,
7223      &  j=1,6),(v2(j,itori,itori1,iblock)*weitori,j=1,6)
7224         write (iout,*) "typ",itori,iloctyp(itori),itori1,
7225      &    iloctyp(itori1)," etor_temp",
7226      &    etor_temp(0,0,itori,itori1,1)
7227         call flush(iout)
7228         endif
7229         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7230 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7231  1215   continue
7232       enddo
7233       return
7234       end
7235 c----------------------------------------------------------------------------
7236       subroutine etor_d(etors_d)
7237 C 6/23/01 Compute double torsional energy
7238       implicit real*8 (a-h,o-z)
7239       include 'DIMENSIONS'
7240       include 'DIMENSIONS.ZSCOPT'
7241       include 'COMMON.VAR'
7242       include 'COMMON.GEO'
7243       include 'COMMON.LOCAL'
7244       include 'COMMON.TORSION'
7245       include 'COMMON.INTERACT'
7246       include 'COMMON.DERIV'
7247       include 'COMMON.CHAIN'
7248       include 'COMMON.NAMES'
7249       include 'COMMON.IOUNITS'
7250       include 'COMMON.FFIELD'
7251       include 'COMMON.TORCNSTR'
7252       logical lprn
7253 C Set lprn=.true. for debugging
7254       lprn=.false.
7255 c     lprn=.true.
7256       etors_d=0.0D0
7257       do i=iphi_start,iphi_end-1
7258         if (i.le.3) cycle
7259 C        if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7260 C     &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
7261          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7262      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7263      &  (itype(i+1).eq.ntyp1)) cycle
7264         if (itel(i-2).eq.0 .or. itel(i-1).eq.0 .or. itel(i).eq.0)
7265      &     goto 1215
7266         itori=itortyp(itype(i-2))
7267         itori1=itortyp(itype(i-1))
7268         itori2=itortyp(itype(i))
7269         phii=phi(i)
7270         phii1=phi(i+1)
7271         gloci1=0.0D0
7272         gloci2=0.0D0
7273         iblock=1
7274         if (iabs(itype(i+1)).eq.20) iblock=2
7275 C Regular cosine and sine terms
7276         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7277           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7278           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7279           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7280           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7281           cosphi1=dcos(j*phii)
7282           sinphi1=dsin(j*phii)
7283           cosphi2=dcos(j*phii1)
7284           sinphi2=dsin(j*phii1)
7285           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7286      &     v2cij*cosphi2+v2sij*sinphi2
7287           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7288           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7289         enddo
7290         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7291           do l=1,k-1
7292             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7293             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7294             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7295             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7296             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7297             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7298             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7299             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7300             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7301      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7302             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7303      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7304             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7305      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7306           enddo
7307         enddo
7308         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7309         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7310  1215   continue
7311       enddo
7312       return
7313       end
7314 #endif
7315 c---------------------------------------------------------------------------
7316 C The rigorous attempt to derive energy function
7317       subroutine etor_kcc(etors)
7318       implicit real*8 (a-h,o-z)
7319       include 'DIMENSIONS'
7320       include 'DIMENSIONS.ZSCOPT'
7321       include 'COMMON.VAR'
7322       include 'COMMON.GEO'
7323       include 'COMMON.LOCAL'
7324       include 'COMMON.TORSION'
7325       include 'COMMON.INTERACT'
7326       include 'COMMON.DERIV'
7327       include 'COMMON.CHAIN'
7328       include 'COMMON.NAMES'
7329       include 'COMMON.IOUNITS'
7330       include 'COMMON.FFIELD'
7331       include 'COMMON.TORCNSTR'
7332       include 'COMMON.CONTROL'
7333       include 'COMMON.WEIGHTS'
7334       include 'COMMON.WEIGHTDER'
7335       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7336       logical lprn
7337 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7338 C Set lprn=.true. for debugging
7339       lprn=energy_dec
7340 c      lprn=.true.
7341       if (lprn) write (iout,*)"ETOR_KCC"
7342       do iblock=1,2
7343       do i=-ntyp+1,ntyp-1
7344         do j=-ntyp+1,ntyp-1
7345           do k=0,3
7346             do l=0,2*maxterm
7347               etor_temp(l,k,j,i,iblock)=0.0d0
7348             enddo
7349           enddo
7350         enddo
7351       enddo
7352       enddo
7353       do i=-ntyp+1,ntyp-1
7354         do j=-ntyp+1,ntyp-1
7355           do k=0,2*maxtor_kcc
7356             do l=1,maxval_kcc
7357               do ll=1,maxval_kcc
7358                 etor_temp_kcc(ll,l,k,j,i)=0.0d0
7359               enddo
7360             enddo
7361           enddo
7362         enddo
7363       enddo
7364       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7365       etors=0.0D0
7366       do i=iphi_start,iphi_end
7367 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7368 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7369 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7370 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7371         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7372      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7373         itori=itortyp(itype(i-2))
7374         itori1=itortyp(itype(i-1))
7375         weitori=weitor(0,itori,itori1,1)
7376         if (lprn) write (iout,*) i-2,i-2,itori,itori1,"weitor",weitori
7377         phii=phi(i)
7378         glocig=0.0D0
7379         glocit1=0.0d0
7380         glocit2=0.0d0
7381 C to avoid multiple devision by 2
7382 c        theti22=0.5d0*theta(i)
7383 C theta 12 is the theta_1 /2
7384 C theta 22 is theta_2 /2
7385 c        theti12=0.5d0*theta(i-1)
7386 C and appropriate sinus function
7387         sinthet1=dsin(theta(i-1))
7388         sinthet2=dsin(theta(i))
7389         costhet1=dcos(theta(i-1))
7390         costhet2=dcos(theta(i))
7391 C to speed up lets store its mutliplication
7392         sint1t2=sinthet2*sinthet1
7393         sint1t2n=1.0d0
7394 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7395 C +d_n*sin(n*gamma)) *
7396 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7397 C we have two sum 1) Non-Chebyshev which is with n and gamma
7398         nval=nterm_kcc_Tb(itori,itori1)
7399         c1(0)=0.0d0
7400         c2(0)=0.0d0
7401         c1(1)=1.0d0
7402         c2(1)=1.0d0
7403         do j=2,nval
7404           c1(j)=c1(j-1)*costhet1
7405           c2(j)=c2(j-1)*costhet2
7406         enddo
7407         etori=0.0d0
7408         do j=1,nterm_kcc(itori,itori1)
7409           cosphi=dcos(j*phii)
7410           sinphi=dsin(j*phii)
7411           sint1t2n1=sint1t2n
7412           sint1t2n=sint1t2n*sint1t2
7413           sumvalc=0.0d0
7414           gradvalct1=0.0d0
7415           gradvalct2=0.0d0
7416           do k=1,nval
7417             do l=1,nval
7418               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7419               etor_temp_kcc(l,k,j,itori,itori1)=
7420      &           etor_temp_kcc(l,k,j,itori,itori1)+
7421      &           c1(k)*c2(l)*sint1t2n*cosphi*ww(13)
7422               gradvalct1=gradvalct1+
7423      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7424               gradvalct2=gradvalct2+
7425      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7426             enddo
7427           enddo
7428           gradvalct1=-gradvalct1*sinthet1
7429           gradvalct2=-gradvalct2*sinthet2
7430           sumvals=0.0d0
7431           gradvalst1=0.0d0
7432           gradvalst2=0.0d0
7433           do k=1,nval
7434             do l=1,nval
7435               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7436               etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)=
7437      &        etor_temp_kcc(l,k,j+nterm_kcc(itori,itori1),itori,itori1)+
7438      &           c1(k)*c2(l)*sint1t2n*sinphi*ww(13)
7439               gradvalst1=gradvalst1+
7440      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7441               gradvalst2=gradvalst2+
7442      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7443             enddo
7444           enddo
7445           gradvalst1=-gradvalst1*sinthet1
7446           gradvalst2=-gradvalst2*sinthet2
7447           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7448           etor_temp(0,0,itori,itori1,1)=etor_temp(0,0,itori,itori1,1)
7449      &     +sint1t2n*(sumvalc*cosphi+sumvals*sinphi)*ww(13)
7450 C glocig is the gradient local i site in gamma
7451           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7452 C now gradient over theta_1
7453           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7454      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7455           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7456      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7457         enddo ! j
7458         etors=etors+etori*weitori
7459 C derivative over gamma
7460         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7461 C derivative over theta1
7462         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7463 C now derivative over theta2
7464         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7465         if (lprn)
7466      &    write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7467      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7468       enddo
7469       return
7470       end
7471 c---------------------------------------------------------------------------------------------
7472       subroutine etor_constr(edihcnstr)
7473       implicit real*8 (a-h,o-z)
7474       include 'DIMENSIONS'
7475       include 'DIMENSIONS.ZSCOPT'
7476       include 'COMMON.VAR'
7477       include 'COMMON.GEO'
7478       include 'COMMON.LOCAL'
7479       include 'COMMON.TORSION'
7480       include 'COMMON.INTERACT'
7481       include 'COMMON.DERIV'
7482       include 'COMMON.CHAIN'
7483       include 'COMMON.NAMES'
7484       include 'COMMON.IOUNITS'
7485       include 'COMMON.FFIELD'
7486       include 'COMMON.TORCNSTR'
7487       include 'COMMON.CONTROL'
7488 ! 6/20/98 - dihedral angle constraints
7489       edihcnstr=0.0d0
7490 c      do i=1,ndih_constr
7491 c      write (iout,*) "idihconstr_start",idihconstr_start,
7492 c     &  " idihconstr_end",idihconstr_end
7493       do i=idihconstr_start,idihconstr_end
7494         itori=idih_constr(i)
7495         phii=phi(itori)
7496         difi=pinorm(phii-phi0(i))
7497         if (difi.gt.drange(i)) then
7498           difi=difi-drange(i)
7499           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7500           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7501         else if (difi.lt.-drange(i)) then
7502           difi=difi+drange(i)
7503           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7504           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7505         else
7506           difi=0.0
7507         endif
7508       enddo
7509       return
7510       end
7511 c----------------------------------------------------------------------------
7512 C The rigorous attempt to derive energy function
7513       subroutine ebend_kcc(etheta)
7514
7515       implicit real*8 (a-h,o-z)
7516       include 'DIMENSIONS'
7517       include 'DIMENSIONS.ZSCOPT'
7518       include 'COMMON.VAR'
7519       include 'COMMON.GEO'
7520       include 'COMMON.LOCAL'
7521       include 'COMMON.TORSION'
7522       include 'COMMON.INTERACT'
7523       include 'COMMON.DERIV'
7524       include 'COMMON.CHAIN'
7525       include 'COMMON.NAMES'
7526       include 'COMMON.IOUNITS'
7527       include 'COMMON.FFIELD'
7528       include 'COMMON.TORCNSTR'
7529       include 'COMMON.CONTROL'
7530       include 'COMMON.WEIGHTDER'
7531       logical lprn
7532       double precision thybt1(maxang_kcc)
7533 C Set lprn=.true. for debugging
7534       lprn=energy_dec
7535 c     lprn=.true.
7536 C      print *,"wchodze kcc"
7537       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7538       do i=0,ntyp
7539         do j=1,maxang_kcc
7540           ebend_temp_kcc(j,i)=0.0d0
7541         enddo
7542       enddo
7543       etheta=0.0D0
7544       do i=ithet_start,ithet_end
7545 c        print *,i,itype(i-1),itype(i),itype(i-2)
7546         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7547      &  .or.itype(i).eq.ntyp1) cycle
7548         iti=iabs(itortyp(itype(i-1)))
7549         sinthet=dsin(theta(i))
7550         costhet=dcos(theta(i))
7551         do j=1,nbend_kcc_Tb(iti)
7552           thybt1(j)=v1bend_chyb(j,iti)
7553           ebend_temp_kcc(j,iti)=ebend_temp_kcc(j,iti)+dcos(j*theta(i))
7554         enddo
7555         sumth1thyb=v1bend_chyb(0,iti)+
7556      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7557         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7558      &    sumth1thyb
7559         ihelp=nbend_kcc_Tb(iti)-1
7560         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7561         etheta=etheta+sumth1thyb
7562 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7563         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7564       enddo
7565       return
7566       end
7567 c-------------------------------------------------------------------------------------
7568       subroutine etheta_constr(ethetacnstr)
7569
7570       implicit real*8 (a-h,o-z)
7571       include 'DIMENSIONS'
7572       include 'DIMENSIONS.ZSCOPT'
7573       include 'COMMON.VAR'
7574       include 'COMMON.GEO'
7575       include 'COMMON.LOCAL'
7576       include 'COMMON.TORSION'
7577       include 'COMMON.INTERACT'
7578       include 'COMMON.DERIV'
7579       include 'COMMON.CHAIN'
7580       include 'COMMON.NAMES'
7581       include 'COMMON.IOUNITS'
7582       include 'COMMON.FFIELD'
7583       include 'COMMON.TORCNSTR'
7584       include 'COMMON.CONTROL'
7585       ethetacnstr=0.0d0
7586 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7587       do i=ithetaconstr_start,ithetaconstr_end
7588         itheta=itheta_constr(i)
7589         thetiii=theta(itheta)
7590         difi=pinorm(thetiii-theta_constr0(i))
7591         if (difi.gt.theta_drange(i)) then
7592           difi=difi-theta_drange(i)
7593           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7594           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7595      &    +for_thet_constr(i)*difi**3
7596         else if (difi.lt.-drange(i)) then
7597           difi=difi+drange(i)
7598           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7599           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7600      &    +for_thet_constr(i)*difi**3
7601         else
7602           difi=0.0
7603         endif
7604        if (energy_dec) then
7605         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7606      &    i,itheta,rad2deg*thetiii,
7607      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7608      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7609      &    gloc(itheta+nphi-2,icg)
7610         endif
7611       enddo
7612       return
7613       end
7614 c------------------------------------------------------------------------------
7615       subroutine eback_sc_corr(esccor)
7616 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7617 c        conformational states; temporarily implemented as differences
7618 c        between UNRES torsional potentials (dependent on three types of
7619 c        residues) and the torsional potentials dependent on all 20 types
7620 c        of residues computed from AM1 energy surfaces of terminally-blocked
7621 c        amino-acid residues.
7622       implicit real*8 (a-h,o-z)
7623       include 'DIMENSIONS'
7624       include 'DIMENSIONS.ZSCOPT'
7625       include 'COMMON.VAR'
7626       include 'COMMON.GEO'
7627       include 'COMMON.LOCAL'
7628       include 'COMMON.TORSION'
7629       include 'COMMON.SCCOR'
7630       include 'COMMON.INTERACT'
7631       include 'COMMON.DERIV'
7632       include 'COMMON.CHAIN'
7633       include 'COMMON.NAMES'
7634       include 'COMMON.IOUNITS'
7635       include 'COMMON.FFIELD'
7636       include 'COMMON.CONTROL'
7637       logical lprn
7638 C Set lprn=.true. for debugging
7639       lprn=.false.
7640 c      lprn=.true.
7641 c      write (iout,*) "EBACK_SC_COR",iphi_start,iphi_end,nterm_sccor
7642       esccor=0.0D0
7643       do i=itau_start,itau_end
7644         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7645         esccor_ii=0.0D0
7646         isccori=isccortyp(itype(i-2))
7647         isccori1=isccortyp(itype(i-1))
7648         phii=phi(i)
7649         do intertyp=1,3 !intertyp
7650 cc Added 09 May 2012 (Adasko)
7651 cc  Intertyp means interaction type of backbone mainchain correlation:
7652 c   1 = SC...Ca...Ca...Ca
7653 c   2 = Ca...Ca...Ca...SC
7654 c   3 = SC...Ca...Ca...SCi
7655         gloci=0.0D0
7656         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7657      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7658      &      (itype(i-1).eq.ntyp1)))
7659      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7660      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7661      &     .or.(itype(i).eq.ntyp1)))
7662      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7663      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7664      &      (itype(i-3).eq.ntyp1)))) cycle
7665         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7666         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7667      & cycle
7668        do j=1,nterm_sccor(isccori,isccori1)
7669           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7670           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7671           cosphi=dcos(j*tauangle(intertyp,i))
7672           sinphi=dsin(j*tauangle(intertyp,i))
7673            esccor=esccor+v1ij*cosphi+v2ij*sinphi
7674            gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7675          enddo
7676 C      write (iout,*)"EBACK_SC_COR",esccor,i
7677 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp,
7678 c     & nterm_sccor(isccori,isccori1),isccori,isccori1
7679 c        gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7680         if (lprn)
7681      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7682      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7683      &  (v1sccor(j,1,itori,itori1),j=1,6)
7684      &  ,(v2sccor(j,1,itori,itori1),j=1,6)
7685 c        gsccor_loc(i-3)=gloci
7686        enddo !intertyp
7687       enddo
7688       return
7689       end
7690 c------------------------------------------------------------------------------
7691       subroutine multibody(ecorr)
7692 C This subroutine calculates multi-body contributions to energy following
7693 C the idea of Skolnick et al. If side chains I and J make a contact and
7694 C at the same time side chains I+1 and J+1 make a contact, an extra
7695 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7696       implicit real*8 (a-h,o-z)
7697       include 'DIMENSIONS'
7698       include 'DIMENSIONS.ZSCOPT'
7699       include 'COMMON.IOUNITS'
7700       include 'COMMON.DERIV'
7701       include 'COMMON.INTERACT'
7702       include 'COMMON.CONTACTS'
7703       double precision gx(3),gx1(3)
7704       logical lprn
7705
7706 C Set lprn=.true. for debugging
7707       lprn=.false.
7708
7709       if (lprn) then
7710         write (iout,'(a)') 'Contact function values:'
7711         do i=nnt,nct-2
7712           write (iout,'(i2,20(1x,i2,f10.5))')
7713      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7714         enddo
7715       endif
7716       ecorr=0.0D0
7717       do i=nnt,nct
7718         do j=1,3
7719           gradcorr(j,i)=0.0D0
7720           gradxorr(j,i)=0.0D0
7721         enddo
7722       enddo
7723       do i=nnt,nct-2
7724
7725         DO ISHIFT = 3,4
7726
7727         i1=i+ishift
7728         num_conti=num_cont(i)
7729         num_conti1=num_cont(i1)
7730         do jj=1,num_conti
7731           j=jcont(jj,i)
7732           do kk=1,num_conti1
7733             j1=jcont(kk,i1)
7734             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7735 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7736 cd   &                   ' ishift=',ishift
7737 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7738 C The system gains extra energy.
7739               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7740             endif   ! j1==j+-ishift
7741           enddo     ! kk
7742         enddo       ! jj
7743
7744         ENDDO ! ISHIFT
7745
7746       enddo         ! i
7747       return
7748       end
7749 c------------------------------------------------------------------------------
7750       double precision function esccorr(i,j,k,l,jj,kk)
7751       implicit real*8 (a-h,o-z)
7752       include 'DIMENSIONS'
7753       include 'DIMENSIONS.ZSCOPT'
7754       include 'COMMON.IOUNITS'
7755       include 'COMMON.DERIV'
7756       include 'COMMON.INTERACT'
7757       include 'COMMON.CONTACTS'
7758       double precision gx(3),gx1(3)
7759       logical lprn
7760       lprn=.false.
7761       eij=facont(jj,i)
7762       ekl=facont(kk,k)
7763 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7764 C Calculate the multi-body contribution to energy.
7765 C Calculate multi-body contributions to the gradient.
7766 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7767 cd   & k,l,(gacont(m,kk,k),m=1,3)
7768       do m=1,3
7769         gx(m) =ekl*gacont(m,jj,i)
7770         gx1(m)=eij*gacont(m,kk,k)
7771         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7772         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7773         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7774         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7775       enddo
7776       do m=i,j-1
7777         do ll=1,3
7778           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7779         enddo
7780       enddo
7781       do m=k,l-1
7782         do ll=1,3
7783           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7784         enddo
7785       enddo
7786       esccorr=-eij*ekl
7787       return
7788       end
7789 c------------------------------------------------------------------------------
7790       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7791 C This subroutine calculates multi-body contributions to hydrogen-bonding
7792       implicit real*8 (a-h,o-z)
7793       include 'DIMENSIONS'
7794       include 'DIMENSIONS.ZSCOPT'
7795       include 'COMMON.IOUNITS'
7796       include 'COMMON.FFIELD'
7797       include 'COMMON.DERIV'
7798       include 'COMMON.INTERACT'
7799       include 'COMMON.CONTACTS'
7800       double precision gx(3),gx1(3)
7801       logical lprn,ldone
7802
7803 C Set lprn=.true. for debugging
7804       lprn=.false.
7805       if (lprn) then
7806         write (iout,'(a)') 'Contact function values:'
7807         do i=nnt,nct-2
7808           write (iout,'(2i3,50(1x,i2,f5.2))')
7809      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
7810      &    j=1,num_cont_hb(i))
7811         enddo
7812       endif
7813       ecorr=0.0D0
7814 C Remove the loop below after debugging !!!
7815       do i=nnt,nct
7816         do j=1,3
7817           gradcorr(j,i)=0.0D0
7818           gradxorr(j,i)=0.0D0
7819         enddo
7820       enddo
7821 C Calculate the local-electrostatic correlation terms
7822       do i=iatel_s,iatel_e+1
7823         i1=i+1
7824         num_conti=num_cont_hb(i)
7825         num_conti1=num_cont_hb(i+1)
7826         do jj=1,num_conti
7827           j=jcont_hb(jj,i)
7828           do kk=1,num_conti1
7829             j1=jcont_hb(kk,i1)
7830 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7831 c     &         ' jj=',jj,' kk=',kk
7832             if (j1.eq.j+1 .or. j1.eq.j-1) then
7833 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7834 C The system gains extra energy.
7835               ecorr=ecorr+ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
7836               n_corr=n_corr+1
7837             else if (j1.eq.j) then
7838 C Contacts I-J and I-(J+1) occur simultaneously.
7839 C The system loses extra energy.
7840 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
7841             endif
7842           enddo ! kk
7843           do kk=1,num_conti
7844             j1=jcont_hb(kk,i)
7845 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7846 c    &         ' jj=',jj,' kk=',kk
7847             if (j1.eq.j+1) then
7848 C Contacts I-J and (I+1)-J occur simultaneously.
7849 C The system loses extra energy.
7850 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
7851             endif ! j1==j+1
7852           enddo ! kk
7853         enddo ! jj
7854       enddo ! i
7855       return
7856       end
7857 c------------------------------------------------------------------------------
7858       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
7859      &  n_corr1)
7860 C This subroutine calculates multi-body contributions to hydrogen-bonding
7861       implicit real*8 (a-h,o-z)
7862       include 'DIMENSIONS'
7863       include 'DIMENSIONS.ZSCOPT'
7864       include 'COMMON.IOUNITS'
7865 #ifdef MPI
7866       include "mpif.h"
7867 #endif
7868       include 'COMMON.FFIELD'
7869       include 'COMMON.DERIV'
7870       include 'COMMON.LOCAL'
7871       include 'COMMON.INTERACT'
7872       include 'COMMON.CONTACTS'
7873       include 'COMMON.CHAIN'
7874       include 'COMMON.CONTROL'
7875       include 'COMMON.SHIELD'
7876       double precision gx(3),gx1(3)
7877       integer num_cont_hb_old(maxres)
7878       logical lprn,ldone
7879       double precision eello4,eello5,eelo6,eello_turn6
7880       external eello4,eello5,eello6,eello_turn6
7881 C Set lprn=.true. for debugging
7882       lprn=.false.
7883       eturn6=0.0d0
7884       if (lprn) then
7885         write (iout,'(a)') 'Contact function values:'
7886         do i=nnt,nct-2
7887           write (iout,'(2i3,50(1x,i2,5f6.3))')
7888      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
7889      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
7890         enddo
7891       endif
7892       ecorr=0.0D0
7893       ecorr5=0.0d0
7894       ecorr6=0.0d0
7895 C Remove the loop below after debugging !!!
7896       do i=nnt,nct
7897         do j=1,3
7898           gradcorr(j,i)=0.0D0
7899           gradxorr(j,i)=0.0D0
7900         enddo
7901       enddo
7902 C Calculate the dipole-dipole interaction energies
7903       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
7904       do i=iatel_s,iatel_e+1
7905         num_conti=num_cont_hb(i)
7906         do jj=1,num_conti
7907           j=jcont_hb(jj,i)
7908 #ifdef MOMENT
7909           call dipole(i,j,jj)
7910 #endif
7911         enddo
7912       enddo
7913       endif
7914 C Calculate the local-electrostatic correlation terms
7915 c                write (iout,*) "gradcorr5 in eello5 before loop"
7916 c                do iii=1,nres
7917 c                  write (iout,'(i5,3f10.5)')
7918 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7919 c                enddo
7920       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
7921 c        write (iout,*) "corr loop i",i
7922         i1=i+1
7923         num_conti=num_cont_hb(i)
7924         num_conti1=num_cont_hb(i+1)
7925         do jj=1,num_conti
7926           j=jcont_hb(jj,i)
7927           jp=iabs(j)
7928           do kk=1,num_conti1
7929             j1=jcont_hb(kk,i1)
7930             jp1=iabs(j1)
7931 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7932 c     &         ' jj=',jj,' kk=',kk
7933 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
7934             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
7935      &          .or. j.lt.0 .and. j1.gt.0) .and.
7936      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
7937 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
7938 C The system gains extra energy.
7939               n_corr=n_corr+1
7940               sqd1=dsqrt(d_cont(jj,i))
7941               sqd2=dsqrt(d_cont(kk,i1))
7942               sred_geom = sqd1*sqd2
7943               IF (sred_geom.lt.cutoff_corr) THEN
7944                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
7945      &            ekont,fprimcont)
7946 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
7947 cd     &         ' jj=',jj,' kk=',kk
7948                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
7949                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
7950                 do l=1,3
7951                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
7952                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
7953                 enddo
7954                 n_corr1=n_corr1+1
7955 cd               write (iout,*) 'sred_geom=',sred_geom,
7956 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
7957 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
7958 cd               write (iout,*) "g_contij",g_contij
7959 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
7960 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
7961                 call calc_eello(i,jp,i+1,jp1,jj,kk)
7962                 if (wcorr4.gt.0.0d0)
7963      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
7964 CC     &            *fac_shield(i)**2*fac_shield(j)**2
7965                   if (energy_dec.and.wcorr4.gt.0.0d0)
7966      1                 write (iout,'(a6,4i5,0pf7.3)')
7967      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
7968 c                write (iout,*) "gradcorr5 before eello5"
7969 c                do iii=1,nres
7970 c                  write (iout,'(i5,3f10.5)')
7971 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7972 c                enddo
7973                 if (wcorr5.gt.0.0d0)
7974      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
7975 c                write (iout,*) "gradcorr5 after eello5"
7976 c                do iii=1,nres
7977 c                  write (iout,'(i5,3f10.5)')
7978 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
7979 c                enddo
7980                   if (energy_dec.and.wcorr5.gt.0.0d0)
7981      1                 write (iout,'(a6,4i5,0pf7.3)')
7982      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
7983 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
7984 cd                write(2,*)'ijkl',i,jp,i+1,jp1
7985                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
7986      &               .or. wturn6.eq.0.0d0))then
7987 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
7988                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
7989                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
7990      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
7991 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
7992 cd     &            'ecorr6=',ecorr6
7993 cd                write (iout,'(4e15.5)') sred_geom,
7994 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
7995 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
7996 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
7997                 else if (wturn6.gt.0.0d0
7998      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
7999 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8000                   eturn6=eturn6+eello_turn6(i,jj,kk)
8001                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8002      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8003 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8004                 endif
8005               ENDIF
8006 1111          continue
8007             endif
8008           enddo ! kk
8009         enddo ! jj
8010       enddo ! i
8011       do i=1,nres
8012         num_cont_hb(i)=num_cont_hb_old(i)
8013       enddo
8014 c                write (iout,*) "gradcorr5 in eello5"
8015 c                do iii=1,nres
8016 c                  write (iout,'(i5,3f10.5)')
8017 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8018 c                enddo
8019       return
8020       end
8021 c------------------------------------------------------------------------------
8022       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8023       implicit real*8 (a-h,o-z)
8024       include 'DIMENSIONS'
8025       include 'DIMENSIONS.ZSCOPT'
8026       include 'COMMON.IOUNITS'
8027       include 'COMMON.DERIV'
8028       include 'COMMON.INTERACT'
8029       include 'COMMON.CONTACTS'
8030       include 'COMMON.SHIELD'
8031       include 'COMMON.CONTROL'
8032       double precision gx(3),gx1(3)
8033       logical lprn
8034       lprn=.false.
8035 C      print *,"wchodze",fac_shield(i),shield_mode
8036       eij=facont_hb(jj,i)
8037       ekl=facont_hb(kk,k)
8038       ees0pij=ees0p(jj,i)
8039       ees0pkl=ees0p(kk,k)
8040       ees0mij=ees0m(jj,i)
8041       ees0mkl=ees0m(kk,k)
8042       ekont=eij*ekl
8043       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8044 C*
8045 C     & fac_shield(i)**2*fac_shield(j)**2
8046 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8047 C Following 4 lines for diagnostics.
8048 cd    ees0pkl=0.0D0
8049 cd    ees0pij=1.0D0
8050 cd    ees0mkl=0.0D0
8051 cd    ees0mij=1.0D0
8052 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8053 c     & 'Contacts ',i,j,
8054 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8055 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8056 c     & 'gradcorr_long'
8057 C Calculate the multi-body contribution to energy.
8058 C      ecorr=ecorr+ekont*ees
8059 C Calculate multi-body contributions to the gradient.
8060       coeffpees0pij=coeffp*ees0pij
8061       coeffmees0mij=coeffm*ees0mij
8062       coeffpees0pkl=coeffp*ees0pkl
8063       coeffmees0mkl=coeffm*ees0mkl
8064       do ll=1,3
8065 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8066         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8067      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8068      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8069         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8070      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8071      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8072 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8073         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8074      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8075      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8076         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8077      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8078      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8079         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8080      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8081      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8082         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8083         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8084         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8085      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8086      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8087         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8088         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8089 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8090       enddo
8091 c      write (iout,*)
8092 cgrad      do m=i+1,j-1
8093 cgrad        do ll=1,3
8094 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8095 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8096 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8097 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8098 cgrad        enddo
8099 cgrad      enddo
8100 cgrad      do m=k+1,l-1
8101 cgrad        do ll=1,3
8102 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8103 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8104 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8105 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8106 cgrad        enddo
8107 cgrad      enddo
8108 c      write (iout,*) "ehbcorr",ekont*ees
8109 C      print *,ekont,ees,i,k
8110       ehbcorr=ekont*ees
8111 C now gradient over shielding
8112 C      return
8113       if (shield_mode.gt.0) then
8114        j=ees0plist(jj,i)
8115        l=ees0plist(kk,k)
8116 C        print *,i,j,fac_shield(i),fac_shield(j),
8117 C     &fac_shield(k),fac_shield(l)
8118         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8119      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8120           do ilist=1,ishield_list(i)
8121            iresshield=shield_list(ilist,i)
8122            do m=1,3
8123            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8124 C     &      *2.0
8125            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8126      &              rlocshield
8127      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8128             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8129      &+rlocshield
8130            enddo
8131           enddo
8132           do ilist=1,ishield_list(j)
8133            iresshield=shield_list(ilist,j)
8134            do m=1,3
8135            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8136 C     &     *2.0
8137            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8138      &              rlocshield
8139      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8140            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8141      &     +rlocshield
8142            enddo
8143           enddo
8144
8145           do ilist=1,ishield_list(k)
8146            iresshield=shield_list(ilist,k)
8147            do m=1,3
8148            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8149 C     &     *2.0
8150            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8151      &              rlocshield
8152      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8153            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8154      &     +rlocshield
8155            enddo
8156           enddo
8157           do ilist=1,ishield_list(l)
8158            iresshield=shield_list(ilist,l)
8159            do m=1,3
8160            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8161 C     &     *2.0
8162            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8163      &              rlocshield
8164      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8165            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8166      &     +rlocshield
8167            enddo
8168           enddo
8169 C          print *,gshieldx(m,iresshield)
8170           do m=1,3
8171             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8172      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8173             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8174      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8175             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8176      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8177             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8178      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8179
8180             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8181      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8182             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8183      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8184             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8185      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8186             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8187      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8188
8189            enddo
8190       endif
8191       endif
8192       return
8193       end
8194 #ifdef MOMENT
8195 C---------------------------------------------------------------------------
8196       subroutine dipole(i,j,jj)
8197       implicit real*8 (a-h,o-z)
8198       include 'DIMENSIONS'
8199       include 'DIMENSIONS.ZSCOPT'
8200       include 'COMMON.IOUNITS'
8201       include 'COMMON.CHAIN'
8202       include 'COMMON.FFIELD'
8203       include 'COMMON.DERIV'
8204       include 'COMMON.INTERACT'
8205       include 'COMMON.CONTACTS'
8206       include 'COMMON.TORSION'
8207       include 'COMMON.VAR'
8208       include 'COMMON.GEO'
8209       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8210      &  auxmat(2,2)
8211       iti1 = itortyp(itype(i+1))
8212       if (j.lt.nres-1) then
8213         itj1 = itype2loc(itype(j+1))
8214       else
8215         itj1=nloctyp
8216       endif
8217       do iii=1,2
8218         dipi(iii,1)=Ub2(iii,i)
8219         dipderi(iii)=Ub2der(iii,i)
8220         dipi(iii,2)=b1(iii,i+1)
8221         dipj(iii,1)=Ub2(iii,j)
8222         dipderj(iii)=Ub2der(iii,j)
8223         dipj(iii,2)=b1(iii,j+1)
8224       enddo
8225       kkk=0
8226       do iii=1,2
8227         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8228         do jjj=1,2
8229           kkk=kkk+1
8230           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8231         enddo
8232       enddo
8233       do kkk=1,5
8234         do lll=1,3
8235           mmm=0
8236           do iii=1,2
8237             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8238      &        auxvec(1))
8239             do jjj=1,2
8240               mmm=mmm+1
8241               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8242             enddo
8243           enddo
8244         enddo
8245       enddo
8246       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8247       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8248       do iii=1,2
8249         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8250       enddo
8251       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8252       do iii=1,2
8253         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
8254       enddo
8255       return
8256       end
8257 #endif
8258 C---------------------------------------------------------------------------
8259       subroutine calc_eello(i,j,k,l,jj,kk)
8260 C
8261 C This subroutine computes matrices and vectors needed to calculate
8262 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
8263 C
8264       implicit real*8 (a-h,o-z)
8265       include 'DIMENSIONS'
8266       include 'DIMENSIONS.ZSCOPT'
8267       include 'COMMON.IOUNITS'
8268       include 'COMMON.CHAIN'
8269       include 'COMMON.DERIV'
8270       include 'COMMON.INTERACT'
8271       include 'COMMON.CONTACTS'
8272       include 'COMMON.TORSION'
8273       include 'COMMON.VAR'
8274       include 'COMMON.GEO'
8275       include 'COMMON.FFIELD'
8276       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
8277      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
8278       logical lprn
8279       common /kutas/ lprn
8280 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
8281 cd     & ' jj=',jj,' kk=',kk
8282 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
8283 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
8284 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
8285       do iii=1,2
8286         do jjj=1,2
8287           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
8288           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
8289         enddo
8290       enddo
8291       call transpose2(aa1(1,1),aa1t(1,1))
8292       call transpose2(aa2(1,1),aa2t(1,1))
8293       do kkk=1,5
8294         do lll=1,3
8295           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
8296      &      aa1tder(1,1,lll,kkk))
8297           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
8298      &      aa2tder(1,1,lll,kkk))
8299         enddo
8300       enddo
8301       if (l.eq.j+1) then
8302 C parallel orientation of the two CA-CA-CA frames.
8303         if (i.gt.1) then
8304           iti=itype2loc(itype(i))
8305         else
8306           iti=nloctyp
8307         endif
8308         itk1=itype2loc(itype(k+1))
8309         itj=itype2loc(itype(j))
8310         if (l.lt.nres-1) then
8311           itl1=itype2loc(itype(l+1))
8312         else
8313           itl1=nloctyp
8314         endif
8315 C A1 kernel(j+1) A2T
8316 cd        do iii=1,2
8317 cd          write (iout,'(3f10.5,5x,3f10.5)')
8318 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
8319 cd        enddo
8320         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8321      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
8322      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8323 C Following matrices are needed only for 6-th order cumulants
8324         IF (wcorr6.gt.0.0d0) THEN
8325         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8326      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
8327      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8328         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8329      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
8330      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8331      &   ADtEAderx(1,1,1,1,1,1))
8332         lprn=.false.
8333         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8334      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
8335      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8336      &   ADtEA1derx(1,1,1,1,1,1))
8337         ENDIF
8338 C End 6-th order cumulants
8339 cd        lprn=.false.
8340 cd        if (lprn) then
8341 cd        write (2,*) 'In calc_eello6'
8342 cd        do iii=1,2
8343 cd          write (2,*) 'iii=',iii
8344 cd          do kkk=1,5
8345 cd            write (2,*) 'kkk=',kkk
8346 cd            do jjj=1,2
8347 cd              write (2,'(3(2f10.5),5x)')
8348 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8349 cd            enddo
8350 cd          enddo
8351 cd        enddo
8352 cd        endif
8353         call transpose2(EUgder(1,1,k),auxmat(1,1))
8354         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8355         call transpose2(EUg(1,1,k),auxmat(1,1))
8356         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8357         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8358         do iii=1,2
8359           do kkk=1,5
8360             do lll=1,3
8361               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8362      &          EAEAderx(1,1,lll,kkk,iii,1))
8363             enddo
8364           enddo
8365         enddo
8366 C A1T kernel(i+1) A2
8367         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8368      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
8369      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8370 C Following matrices are needed only for 6-th order cumulants
8371         IF (wcorr6.gt.0.0d0) THEN
8372         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8373      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
8374      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8375         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8376      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
8377      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8378      &   ADtEAderx(1,1,1,1,1,2))
8379         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
8380      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
8381      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8382      &   ADtEA1derx(1,1,1,1,1,2))
8383         ENDIF
8384 C End 6-th order cumulants
8385         call transpose2(EUgder(1,1,l),auxmat(1,1))
8386         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
8387         call transpose2(EUg(1,1,l),auxmat(1,1))
8388         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8389         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8390         do iii=1,2
8391           do kkk=1,5
8392             do lll=1,3
8393               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8394      &          EAEAderx(1,1,lll,kkk,iii,2))
8395             enddo
8396           enddo
8397         enddo
8398 C AEAb1 and AEAb2
8399 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8400 C They are needed only when the fifth- or the sixth-order cumulants are
8401 C indluded.
8402         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
8403         call transpose2(AEA(1,1,1),auxmat(1,1))
8404         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8405         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8406         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8407         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8408         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8409         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8410         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8411         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8412         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8413         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8414         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8415         call transpose2(AEA(1,1,2),auxmat(1,1))
8416         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
8417         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
8418         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
8419         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8420         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
8421         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
8422         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
8423         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
8424         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
8425         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
8426         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
8427 C Calculate the Cartesian derivatives of the vectors.
8428         do iii=1,2
8429           do kkk=1,5
8430             do lll=1,3
8431               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8432               call matvec2(auxmat(1,1),b1(1,i),
8433      &          AEAb1derx(1,lll,kkk,iii,1,1))
8434               call matvec2(auxmat(1,1),Ub2(1,i),
8435      &          AEAb2derx(1,lll,kkk,iii,1,1))
8436               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8437      &          AEAb1derx(1,lll,kkk,iii,2,1))
8438               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8439      &          AEAb2derx(1,lll,kkk,iii,2,1))
8440               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8441               call matvec2(auxmat(1,1),b1(1,j),
8442      &          AEAb1derx(1,lll,kkk,iii,1,2))
8443               call matvec2(auxmat(1,1),Ub2(1,j),
8444      &          AEAb2derx(1,lll,kkk,iii,1,2))
8445               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
8446      &          AEAb1derx(1,lll,kkk,iii,2,2))
8447               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
8448      &          AEAb2derx(1,lll,kkk,iii,2,2))
8449             enddo
8450           enddo
8451         enddo
8452         ENDIF
8453 C End vectors
8454       else
8455 C Antiparallel orientation of the two CA-CA-CA frames.
8456         if (i.gt.1) then
8457           iti=itype2loc(itype(i))
8458         else
8459           iti=nloctyp
8460         endif
8461         itk1=itype2loc(itype(k+1))
8462         itl=itype2loc(itype(l))
8463         itj=itype2loc(itype(j))
8464         if (j.lt.nres-1) then
8465           itj1=itype2loc(itype(j+1))
8466         else
8467           itj1=nloctyp
8468         endif
8469 C A2 kernel(j-1)T A1T
8470         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8471      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
8472      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
8473 C Following matrices are needed only for 6-th order cumulants
8474         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8475      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8476         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8477      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
8478      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
8479         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8480      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
8481      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
8482      &   ADtEAderx(1,1,1,1,1,1))
8483         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
8484      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
8485      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
8486      &   ADtEA1derx(1,1,1,1,1,1))
8487         ENDIF
8488 C End 6-th order cumulants
8489         call transpose2(EUgder(1,1,k),auxmat(1,1))
8490         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
8491         call transpose2(EUg(1,1,k),auxmat(1,1))
8492         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
8493         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
8494         do iii=1,2
8495           do kkk=1,5
8496             do lll=1,3
8497               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8498      &          EAEAderx(1,1,lll,kkk,iii,1))
8499             enddo
8500           enddo
8501         enddo
8502 C A2T kernel(i+1)T A1
8503         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8504      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
8505      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
8506 C Following matrices are needed only for 6-th order cumulants
8507         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
8508      &     j.eq.i+4 .and. l.eq.i+3)) THEN
8509         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8510      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
8511      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
8512         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8513      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
8514      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
8515      &   ADtEAderx(1,1,1,1,1,2))
8516         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
8517      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
8518      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
8519      &   ADtEA1derx(1,1,1,1,1,2))
8520         ENDIF
8521 C End 6-th order cumulants
8522         call transpose2(EUgder(1,1,j),auxmat(1,1))
8523         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
8524         call transpose2(EUg(1,1,j),auxmat(1,1))
8525         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
8526         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
8527         do iii=1,2
8528           do kkk=1,5
8529             do lll=1,3
8530               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8531      &          EAEAderx(1,1,lll,kkk,iii,2))
8532             enddo
8533           enddo
8534         enddo
8535 C AEAb1 and AEAb2
8536 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
8537 C They are needed only when the fifth- or the sixth-order cumulants are
8538 C indluded.
8539         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
8540      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
8541         call transpose2(AEA(1,1,1),auxmat(1,1))
8542         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
8543         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
8544         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
8545         call transpose2(AEAderg(1,1,1),auxmat(1,1))
8546         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
8547         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
8548         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
8549         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
8550         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
8551         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
8552         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
8553         call transpose2(AEA(1,1,2),auxmat(1,1))
8554         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
8555         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
8556         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
8557         call transpose2(AEAderg(1,1,2),auxmat(1,1))
8558         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
8559         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
8560         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
8561         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
8562         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
8563         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
8564         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
8565 C Calculate the Cartesian derivatives of the vectors.
8566         do iii=1,2
8567           do kkk=1,5
8568             do lll=1,3
8569               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
8570               call matvec2(auxmat(1,1),b1(1,i),
8571      &          AEAb1derx(1,lll,kkk,iii,1,1))
8572               call matvec2(auxmat(1,1),Ub2(1,i),
8573      &          AEAb2derx(1,lll,kkk,iii,1,1))
8574               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
8575      &          AEAb1derx(1,lll,kkk,iii,2,1))
8576               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
8577      &          AEAb2derx(1,lll,kkk,iii,2,1))
8578               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
8579               call matvec2(auxmat(1,1),b1(1,l),
8580      &          AEAb1derx(1,lll,kkk,iii,1,2))
8581               call matvec2(auxmat(1,1),Ub2(1,l),
8582      &          AEAb2derx(1,lll,kkk,iii,1,2))
8583               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
8584      &          AEAb1derx(1,lll,kkk,iii,2,2))
8585               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
8586      &          AEAb2derx(1,lll,kkk,iii,2,2))
8587             enddo
8588           enddo
8589         enddo
8590         ENDIF
8591 C End vectors
8592       endif
8593       return
8594       end
8595 C---------------------------------------------------------------------------
8596       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
8597      &  KK,KKderg,AKA,AKAderg,AKAderx)
8598       implicit none
8599       integer nderg
8600       logical transp
8601       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
8602      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
8603      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
8604       integer iii,kkk,lll
8605       integer jjj,mmm
8606       logical lprn
8607       common /kutas/ lprn
8608       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
8609       do iii=1,nderg
8610         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
8611      &    AKAderg(1,1,iii))
8612       enddo
8613 cd      if (lprn) write (2,*) 'In kernel'
8614       do kkk=1,5
8615 cd        if (lprn) write (2,*) 'kkk=',kkk
8616         do lll=1,3
8617           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
8618      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
8619 cd          if (lprn) then
8620 cd            write (2,*) 'lll=',lll
8621 cd            write (2,*) 'iii=1'
8622 cd            do jjj=1,2
8623 cd              write (2,'(3(2f10.5),5x)')
8624 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
8625 cd            enddo
8626 cd          endif
8627           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
8628      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
8629 cd          if (lprn) then
8630 cd            write (2,*) 'lll=',lll
8631 cd            write (2,*) 'iii=2'
8632 cd            do jjj=1,2
8633 cd              write (2,'(3(2f10.5),5x)')
8634 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
8635 cd            enddo
8636 cd          endif
8637         enddo
8638       enddo
8639       return
8640       end
8641 C---------------------------------------------------------------------------
8642       double precision function eello4(i,j,k,l,jj,kk)
8643       implicit real*8 (a-h,o-z)
8644       include 'DIMENSIONS'
8645       include 'DIMENSIONS.ZSCOPT'
8646       include 'COMMON.IOUNITS'
8647       include 'COMMON.CHAIN'
8648       include 'COMMON.DERIV'
8649       include 'COMMON.INTERACT'
8650       include 'COMMON.CONTACTS'
8651       include 'COMMON.TORSION'
8652       include 'COMMON.VAR'
8653       include 'COMMON.GEO'
8654       double precision pizda(2,2),ggg1(3),ggg2(3)
8655 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
8656 cd        eello4=0.0d0
8657 cd        return
8658 cd      endif
8659 cd      print *,'eello4:',i,j,k,l,jj,kk
8660 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
8661 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
8662 cold      eij=facont_hb(jj,i)
8663 cold      ekl=facont_hb(kk,k)
8664 cold      ekont=eij*ekl
8665       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
8666       if (calc_grad) then
8667 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
8668       gcorr_loc(k-1)=gcorr_loc(k-1)
8669      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
8670       if (l.eq.j+1) then
8671         gcorr_loc(l-1)=gcorr_loc(l-1)
8672      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8673       else
8674         gcorr_loc(j-1)=gcorr_loc(j-1)
8675      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
8676       endif
8677       do iii=1,2
8678         do kkk=1,5
8679           do lll=1,3
8680             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
8681      &                        -EAEAderx(2,2,lll,kkk,iii,1)
8682 cd            derx(lll,kkk,iii)=0.0d0
8683           enddo
8684         enddo
8685       enddo
8686 cd      gcorr_loc(l-1)=0.0d0
8687 cd      gcorr_loc(j-1)=0.0d0
8688 cd      gcorr_loc(k-1)=0.0d0
8689 cd      eel4=1.0d0
8690 cd      write (iout,*)'Contacts have occurred for peptide groups',
8691 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
8692 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
8693       if (j.lt.nres-1) then
8694         j1=j+1
8695         j2=j-1
8696       else
8697         j1=j-1
8698         j2=j-2
8699       endif
8700       if (l.lt.nres-1) then
8701         l1=l+1
8702         l2=l-1
8703       else
8704         l1=l-1
8705         l2=l-2
8706       endif
8707       do ll=1,3
8708 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
8709 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
8710         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
8711         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
8712 cgrad        ghalf=0.5d0*ggg1(ll)
8713         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
8714         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
8715         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
8716         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
8717         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
8718         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
8719 cgrad        ghalf=0.5d0*ggg2(ll)
8720         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
8721         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
8722         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
8723         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
8724         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
8725         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
8726       enddo
8727 cgrad      do m=i+1,j-1
8728 cgrad        do ll=1,3
8729 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
8730 cgrad        enddo
8731 cgrad      enddo
8732 cgrad      do m=k+1,l-1
8733 cgrad        do ll=1,3
8734 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
8735 cgrad        enddo
8736 cgrad      enddo
8737 cgrad      do m=i+2,j2
8738 cgrad        do ll=1,3
8739 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
8740 cgrad        enddo
8741 cgrad      enddo
8742 cgrad      do m=k+2,l2
8743 cgrad        do ll=1,3
8744 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
8745 cgrad        enddo
8746 cgrad      enddo
8747 cd      do iii=1,nres-3
8748 cd        write (2,*) iii,gcorr_loc(iii)
8749 cd      enddo
8750       endif ! calc_grad
8751       eello4=ekont*eel4
8752 cd      write (2,*) 'ekont',ekont
8753 cd      write (iout,*) 'eello4',ekont*eel4
8754       return
8755       end
8756 C---------------------------------------------------------------------------
8757       double precision function eello5(i,j,k,l,jj,kk)
8758       implicit real*8 (a-h,o-z)
8759       include 'DIMENSIONS'
8760       include 'DIMENSIONS.ZSCOPT'
8761       include 'COMMON.IOUNITS'
8762       include 'COMMON.CHAIN'
8763       include 'COMMON.DERIV'
8764       include 'COMMON.INTERACT'
8765       include 'COMMON.CONTACTS'
8766       include 'COMMON.TORSION'
8767       include 'COMMON.VAR'
8768       include 'COMMON.GEO'
8769       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
8770       double precision ggg1(3),ggg2(3)
8771 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8772 C                                                                              C
8773 C                            Parallel chains                                   C
8774 C                                                                              C
8775 C          o             o                   o             o                   C
8776 C         /l\           / \             \   / \           / \   /              C
8777 C        /   \         /   \             \ /   \         /   \ /               C
8778 C       j| o |l1       | o |              o| o |         | o |o                C
8779 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8780 C      \i/   \         /   \ /             /   \         /   \                 C
8781 C       o    k1             o                                                  C
8782 C         (I)          (II)                (III)          (IV)                 C
8783 C                                                                              C
8784 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8785 C                                                                              C
8786 C                            Antiparallel chains                               C
8787 C                                                                              C
8788 C          o             o                   o             o                   C
8789 C         /j\           / \             \   / \           / \   /              C
8790 C        /   \         /   \             \ /   \         /   \ /               C
8791 C      j1| o |l        | o |              o| o |         | o |o                C
8792 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
8793 C      \i/   \         /   \ /             /   \         /   \                 C
8794 C       o     k1            o                                                  C
8795 C         (I)          (II)                (III)          (IV)                 C
8796 C                                                                              C
8797 C      eello5_1        eello5_2            eello5_3       eello5_4             C
8798 C                                                                              C
8799 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
8800 C                                                                              C
8801 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8802 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
8803 cd        eello5=0.0d0
8804 cd        return
8805 cd      endif
8806 cd      write (iout,*)
8807 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
8808 cd     &   ' and',k,l
8809       itk=itype2loc(itype(k))
8810       itl=itype2loc(itype(l))
8811       itj=itype2loc(itype(j))
8812       eello5_1=0.0d0
8813       eello5_2=0.0d0
8814       eello5_3=0.0d0
8815       eello5_4=0.0d0
8816 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
8817 cd     &   eel5_3_num,eel5_4_num)
8818       do iii=1,2
8819         do kkk=1,5
8820           do lll=1,3
8821             derx(lll,kkk,iii)=0.0d0
8822           enddo
8823         enddo
8824       enddo
8825 cd      eij=facont_hb(jj,i)
8826 cd      ekl=facont_hb(kk,k)
8827 cd      ekont=eij*ekl
8828 cd      write (iout,*)'Contacts have occurred for peptide groups',
8829 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
8830 cd      goto 1111
8831 C Contribution from the graph I.
8832 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
8833 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
8834       call transpose2(EUg(1,1,k),auxmat(1,1))
8835       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
8836       vv(1)=pizda(1,1)-pizda(2,2)
8837       vv(2)=pizda(1,2)+pizda(2,1)
8838       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
8839      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8840       if (calc_grad) then
8841 C Explicit gradient in virtual-dihedral angles.
8842       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
8843      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
8844      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
8845       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8846       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
8847       vv(1)=pizda(1,1)-pizda(2,2)
8848       vv(2)=pizda(1,2)+pizda(2,1)
8849       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8850      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
8851      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8852       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
8853       vv(1)=pizda(1,1)-pizda(2,2)
8854       vv(2)=pizda(1,2)+pizda(2,1)
8855       if (l.eq.j+1) then
8856         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
8857      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8858      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8859       else
8860         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
8861      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
8862      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
8863       endif
8864 C Cartesian gradient
8865       do iii=1,2
8866         do kkk=1,5
8867           do lll=1,3
8868             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
8869      &        pizda(1,1))
8870             vv(1)=pizda(1,1)-pizda(2,2)
8871             vv(2)=pizda(1,2)+pizda(2,1)
8872             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8873      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
8874      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
8875           enddo
8876         enddo
8877       enddo
8878       endif ! calc_grad
8879 c      goto 1112
8880 c1111  continue
8881 C Contribution from graph II
8882       call transpose2(EE(1,1,k),auxmat(1,1))
8883       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
8884       vv(1)=pizda(1,1)+pizda(2,2)
8885       vv(2)=pizda(2,1)-pizda(1,2)
8886       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
8887      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
8888       if (calc_grad) then
8889 C Explicit gradient in virtual-dihedral angles.
8890       g_corr5_loc(k-1)=g_corr5_loc(k-1)
8891      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
8892       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
8893       vv(1)=pizda(1,1)+pizda(2,2)
8894       vv(2)=pizda(2,1)-pizda(1,2)
8895       if (l.eq.j+1) then
8896         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8897      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8898      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8899       else
8900         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8901      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
8902      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
8903       endif
8904 C Cartesian gradient
8905       do iii=1,2
8906         do kkk=1,5
8907           do lll=1,3
8908             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
8909      &        pizda(1,1))
8910             vv(1)=pizda(1,1)+pizda(2,2)
8911             vv(2)=pizda(2,1)-pizda(1,2)
8912             derx(lll,kkk,iii)=derx(lll,kkk,iii)
8913      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
8914      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
8915           enddo
8916         enddo
8917       enddo
8918       endif ! calc_grad
8919 cd      goto 1112
8920 cd1111  continue
8921       if (l.eq.j+1) then
8922 cd        goto 1110
8923 C Parallel orientation
8924 C Contribution from graph III
8925         call transpose2(EUg(1,1,l),auxmat(1,1))
8926         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
8927         vv(1)=pizda(1,1)-pizda(2,2)
8928         vv(2)=pizda(1,2)+pizda(2,1)
8929         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
8930      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8931         if (calc_grad) then
8932 C Explicit gradient in virtual-dihedral angles.
8933         g_corr5_loc(j-1)=g_corr5_loc(j-1)
8934      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
8935      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
8936         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
8937         vv(1)=pizda(1,1)-pizda(2,2)
8938         vv(2)=pizda(1,2)+pizda(2,1)
8939         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8940      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
8941      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8942         call transpose2(EUgder(1,1,l),auxmat1(1,1))
8943         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
8944         vv(1)=pizda(1,1)-pizda(2,2)
8945         vv(2)=pizda(1,2)+pizda(2,1)
8946         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8947      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
8948      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
8949 C Cartesian gradient
8950         do iii=1,2
8951           do kkk=1,5
8952             do lll=1,3
8953               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
8954      &          pizda(1,1))
8955               vv(1)=pizda(1,1)-pizda(2,2)
8956               vv(2)=pizda(1,2)+pizda(2,1)
8957               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8958      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
8959      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
8960             enddo
8961           enddo
8962         enddo
8963 cd        goto 1112
8964 C Contribution from graph IV
8965 cd1110    continue
8966         call transpose2(EE(1,1,l),auxmat(1,1))
8967         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
8968         vv(1)=pizda(1,1)+pizda(2,2)
8969         vv(2)=pizda(2,1)-pizda(1,2)
8970         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
8971      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
8972 C Explicit gradient in virtual-dihedral angles.
8973         g_corr5_loc(l-1)=g_corr5_loc(l-1)
8974      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
8975         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
8976         vv(1)=pizda(1,1)+pizda(2,2)
8977         vv(2)=pizda(2,1)-pizda(1,2)
8978         g_corr5_loc(k-1)=g_corr5_loc(k-1)
8979      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
8980      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
8981 C Cartesian gradient
8982         do iii=1,2
8983           do kkk=1,5
8984             do lll=1,3
8985               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
8986      &          pizda(1,1))
8987               vv(1)=pizda(1,1)+pizda(2,2)
8988               vv(2)=pizda(2,1)-pizda(1,2)
8989               derx(lll,kkk,iii)=derx(lll,kkk,iii)
8990      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
8991      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
8992             enddo
8993           enddo
8994         enddo
8995         endif ! calc_grad
8996       else
8997 C Antiparallel orientation
8998 C Contribution from graph III
8999 c        goto 1110
9000         call transpose2(EUg(1,1,j),auxmat(1,1))
9001         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9002         vv(1)=pizda(1,1)-pizda(2,2)
9003         vv(2)=pizda(1,2)+pizda(2,1)
9004         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9005      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9006         if (calc_grad) then
9007 C Explicit gradient in virtual-dihedral angles.
9008         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9009      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9010      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9011         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9012         vv(1)=pizda(1,1)-pizda(2,2)
9013         vv(2)=pizda(1,2)+pizda(2,1)
9014         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9015      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9016      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9017         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9018         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9019         vv(1)=pizda(1,1)-pizda(2,2)
9020         vv(2)=pizda(1,2)+pizda(2,1)
9021         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9022      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9023      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9024 C Cartesian gradient
9025         do iii=1,2
9026           do kkk=1,5
9027             do lll=1,3
9028               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9029      &          pizda(1,1))
9030               vv(1)=pizda(1,1)-pizda(2,2)
9031               vv(2)=pizda(1,2)+pizda(2,1)
9032               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9033      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9034      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9035             enddo
9036           enddo
9037         enddo
9038         endif ! calc_grad
9039 cd        goto 1112
9040 C Contribution from graph IV
9041 1110    continue
9042         call transpose2(EE(1,1,j),auxmat(1,1))
9043         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9044         vv(1)=pizda(1,1)+pizda(2,2)
9045         vv(2)=pizda(2,1)-pizda(1,2)
9046         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9047      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9048         if (calc_grad) then
9049 C Explicit gradient in virtual-dihedral angles.
9050         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9051      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9052         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9053         vv(1)=pizda(1,1)+pizda(2,2)
9054         vv(2)=pizda(2,1)-pizda(1,2)
9055         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9056      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9057      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9058 C Cartesian gradient
9059         do iii=1,2
9060           do kkk=1,5
9061             do lll=1,3
9062               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9063      &          pizda(1,1))
9064               vv(1)=pizda(1,1)+pizda(2,2)
9065               vv(2)=pizda(2,1)-pizda(1,2)
9066               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9067      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9068      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9069             enddo
9070           enddo
9071         enddo
9072         endif ! calc_grad
9073       endif
9074 1112  continue
9075       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9076 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9077 cd        write (2,*) 'ijkl',i,j,k,l
9078 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9079 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9080 cd      endif
9081 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9082 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9083 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9084 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9085       if (calc_grad) then
9086       if (j.lt.nres-1) then
9087         j1=j+1
9088         j2=j-1
9089       else
9090         j1=j-1
9091         j2=j-2
9092       endif
9093       if (l.lt.nres-1) then
9094         l1=l+1
9095         l2=l-1
9096       else
9097         l1=l-1
9098         l2=l-2
9099       endif
9100 cd      eij=1.0d0
9101 cd      ekl=1.0d0
9102 cd      ekont=1.0d0
9103 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9104 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9105 C        summed up outside the subrouine as for the other subroutines
9106 C        handling long-range interactions. The old code is commented out
9107 C        with "cgrad" to keep track of changes.
9108       do ll=1,3
9109 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9110 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9111         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9112         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9113 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9114 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9115 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9116 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9117 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9118 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9119 c     &   gradcorr5ij,
9120 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9121 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9122 cgrad        ghalf=0.5d0*ggg1(ll)
9123 cd        ghalf=0.0d0
9124         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9125         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9126         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9127         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9128         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9129         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9130 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9131 cgrad        ghalf=0.5d0*ggg2(ll)
9132 cd        ghalf=0.0d0
9133         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9134         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9135         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9136         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9137         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9138         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9139       enddo
9140       endif ! calc_grad
9141 cd      goto 1112
9142 cgrad      do m=i+1,j-1
9143 cgrad        do ll=1,3
9144 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9145 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9146 cgrad        enddo
9147 cgrad      enddo
9148 cgrad      do m=k+1,l-1
9149 cgrad        do ll=1,3
9150 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9151 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9152 cgrad        enddo
9153 cgrad      enddo
9154 c1112  continue
9155 cgrad      do m=i+2,j2
9156 cgrad        do ll=1,3
9157 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9158 cgrad        enddo
9159 cgrad      enddo
9160 cgrad      do m=k+2,l2
9161 cgrad        do ll=1,3
9162 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9163 cgrad        enddo
9164 cgrad      enddo
9165 cd      do iii=1,nres-3
9166 cd        write (2,*) iii,g_corr5_loc(iii)
9167 cd      enddo
9168       eello5=ekont*eel5
9169 cd      write (2,*) 'ekont',ekont
9170 cd      write (iout,*) 'eello5',ekont*eel5
9171       return
9172       end
9173 c--------------------------------------------------------------------------
9174       double precision function eello6(i,j,k,l,jj,kk)
9175       implicit real*8 (a-h,o-z)
9176       include 'DIMENSIONS'
9177       include 'DIMENSIONS.ZSCOPT'
9178       include 'COMMON.IOUNITS'
9179       include 'COMMON.CHAIN'
9180       include 'COMMON.DERIV'
9181       include 'COMMON.INTERACT'
9182       include 'COMMON.CONTACTS'
9183       include 'COMMON.TORSION'
9184       include 'COMMON.VAR'
9185       include 'COMMON.GEO'
9186       include 'COMMON.FFIELD'
9187       double precision ggg1(3),ggg2(3)
9188 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9189 cd        eello6=0.0d0
9190 cd        return
9191 cd      endif
9192 cd      write (iout,*)
9193 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9194 cd     &   ' and',k,l
9195       eello6_1=0.0d0
9196       eello6_2=0.0d0
9197       eello6_3=0.0d0
9198       eello6_4=0.0d0
9199       eello6_5=0.0d0
9200       eello6_6=0.0d0
9201 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9202 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9203       do iii=1,2
9204         do kkk=1,5
9205           do lll=1,3
9206             derx(lll,kkk,iii)=0.0d0
9207           enddo
9208         enddo
9209       enddo
9210 cd      eij=facont_hb(jj,i)
9211 cd      ekl=facont_hb(kk,k)
9212 cd      ekont=eij*ekl
9213 cd      eij=1.0d0
9214 cd      ekl=1.0d0
9215 cd      ekont=1.0d0
9216       if (l.eq.j+1) then
9217         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9218         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9219         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9220         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9221         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9222         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9223       else
9224         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9225         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9226         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9227         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9228         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9229           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9230         else
9231           eello6_5=0.0d0
9232         endif
9233         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9234       endif
9235 C If turn contributions are considered, they will be handled separately.
9236       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9237 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9238 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9239 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9240 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9241 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9242 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9243 cd      goto 1112
9244       if (calc_grad) then
9245       if (j.lt.nres-1) then
9246         j1=j+1
9247         j2=j-1
9248       else
9249         j1=j-1
9250         j2=j-2
9251       endif
9252       if (l.lt.nres-1) then
9253         l1=l+1
9254         l2=l-1
9255       else
9256         l1=l-1
9257         l2=l-2
9258       endif
9259       do ll=1,3
9260 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
9261 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
9262 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
9263 cgrad        ghalf=0.5d0*ggg1(ll)
9264 cd        ghalf=0.0d0
9265         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
9266         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
9267         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
9268         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
9269         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
9270         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
9271         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
9272         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
9273 cgrad        ghalf=0.5d0*ggg2(ll)
9274 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
9275 cd        ghalf=0.0d0
9276         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
9277         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
9278         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
9279         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
9280         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
9281         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
9282       enddo
9283       endif ! calc_grad
9284 cd      goto 1112
9285 cgrad      do m=i+1,j-1
9286 cgrad        do ll=1,3
9287 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
9288 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
9289 cgrad        enddo
9290 cgrad      enddo
9291 cgrad      do m=k+1,l-1
9292 cgrad        do ll=1,3
9293 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
9294 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
9295 cgrad        enddo
9296 cgrad      enddo
9297 cgrad1112  continue
9298 cgrad      do m=i+2,j2
9299 cgrad        do ll=1,3
9300 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
9301 cgrad        enddo
9302 cgrad      enddo
9303 cgrad      do m=k+2,l2
9304 cgrad        do ll=1,3
9305 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
9306 cgrad        enddo
9307 cgrad      enddo
9308 cd      do iii=1,nres-3
9309 cd        write (2,*) iii,g_corr6_loc(iii)
9310 cd      enddo
9311       eello6=ekont*eel6
9312 cd      write (2,*) 'ekont',ekont
9313 cd      write (iout,*) 'eello6',ekont*eel6
9314       return
9315       end
9316 c--------------------------------------------------------------------------
9317       double precision function eello6_graph1(i,j,k,l,imat,swap)
9318       implicit real*8 (a-h,o-z)
9319       include 'DIMENSIONS'
9320       include 'DIMENSIONS.ZSCOPT'
9321       include 'COMMON.IOUNITS'
9322       include 'COMMON.CHAIN'
9323       include 'COMMON.DERIV'
9324       include 'COMMON.INTERACT'
9325       include 'COMMON.CONTACTS'
9326       include 'COMMON.TORSION'
9327       include 'COMMON.VAR'
9328       include 'COMMON.GEO'
9329       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
9330       logical swap
9331       logical lprn
9332       common /kutas/ lprn
9333 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9334 C                                                                              C
9335 C      Parallel       Antiparallel                                             C
9336 C                                                                              C
9337 C          o             o                                                     C
9338 C         /l\           /j\                                                    C
9339 C        /   \         /   \                                                   C
9340 C       /| o |         | o |\                                                  C
9341 C     \ j|/k\|  /   \  |/k\|l /                                                C
9342 C      \ /   \ /     \ /   \ /                                                 C
9343 C       o     o       o     o                                                  C
9344 C       i             i                                                        C
9345 C                                                                              C
9346 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9347       itk=itype2loc(itype(k))
9348       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
9349       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
9350       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
9351       call transpose2(EUgC(1,1,k),auxmat(1,1))
9352       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9353       vv1(1)=pizda1(1,1)-pizda1(2,2)
9354       vv1(2)=pizda1(1,2)+pizda1(2,1)
9355       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9356       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
9357       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
9358       s5=scalar2(vv(1),Dtobr2(1,i))
9359 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
9360       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
9361       if (calc_grad) then
9362       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
9363      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
9364      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
9365      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
9366      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
9367      & +scalar2(vv(1),Dtobr2der(1,i)))
9368       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
9369       vv1(1)=pizda1(1,1)-pizda1(2,2)
9370       vv1(2)=pizda1(1,2)+pizda1(2,1)
9371       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
9372       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
9373       if (l.eq.j+1) then
9374         g_corr6_loc(l-1)=g_corr6_loc(l-1)
9375      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9376      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9377      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9378      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9379       else
9380         g_corr6_loc(j-1)=g_corr6_loc(j-1)
9381      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
9382      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
9383      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
9384      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
9385       endif
9386       call transpose2(EUgCder(1,1,k),auxmat(1,1))
9387       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
9388       vv1(1)=pizda1(1,1)-pizda1(2,2)
9389       vv1(2)=pizda1(1,2)+pizda1(2,1)
9390       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
9391      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
9392      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
9393      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
9394       do iii=1,2
9395         if (swap) then
9396           ind=3-iii
9397         else
9398           ind=iii
9399         endif
9400         do kkk=1,5
9401           do lll=1,3
9402             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
9403             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
9404             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
9405             call transpose2(EUgC(1,1,k),auxmat(1,1))
9406             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9407      &        pizda1(1,1))
9408             vv1(1)=pizda1(1,1)-pizda1(2,2)
9409             vv1(2)=pizda1(1,2)+pizda1(2,1)
9410             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
9411             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
9412      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
9413             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
9414      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
9415             s5=scalar2(vv(1),Dtobr2(1,i))
9416             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
9417           enddo
9418         enddo
9419       enddo
9420       endif ! calc_grad
9421       return
9422       end
9423 c----------------------------------------------------------------------------
9424       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
9425       implicit real*8 (a-h,o-z)
9426       include 'DIMENSIONS'
9427       include 'DIMENSIONS.ZSCOPT'
9428       include 'COMMON.IOUNITS'
9429       include 'COMMON.CHAIN'
9430       include 'COMMON.DERIV'
9431       include 'COMMON.INTERACT'
9432       include 'COMMON.CONTACTS'
9433       include 'COMMON.TORSION'
9434       include 'COMMON.VAR'
9435       include 'COMMON.GEO'
9436       logical swap
9437       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9438      & auxvec1(2),auxvec2(2),auxmat1(2,2)
9439       logical lprn
9440       common /kutas/ lprn
9441 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9442 C                                                                              C
9443 C      Parallel       Antiparallel                                             C
9444 C                                                                              C
9445 C          o             o                                                     C
9446 C     \   /l\           /j\   /                                                C
9447 C      \ /   \         /   \ /                                                 C
9448 C       o| o |         | o |o                                                  C
9449 C     \ j|/k\|      \  |/k\|l                                                  C
9450 C      \ /   \       \ /   \                                                   C
9451 C       o             o                                                        C
9452 C       i             i                                                        C
9453 C                                                                              C
9454 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9455 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
9456 C AL 7/4/01 s1 would occur in the sixth-order moment,
9457 C           but not in a cluster cumulant
9458 #ifdef MOMENT
9459       s1=dip(1,jj,i)*dip(1,kk,k)
9460 #endif
9461       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
9462       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9463       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
9464       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
9465       call transpose2(EUg(1,1,k),auxmat(1,1))
9466       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
9467       vv(1)=pizda(1,1)-pizda(2,2)
9468       vv(2)=pizda(1,2)+pizda(2,1)
9469       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9470 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9471 #ifdef MOMENT
9472       eello6_graph2=-(s1+s2+s3+s4)
9473 #else
9474       eello6_graph2=-(s2+s3+s4)
9475 #endif
9476 c      eello6_graph2=-s3
9477 C Derivatives in gamma(i-1)
9478       if (calc_grad) then
9479       if (i.gt.1) then
9480 #ifdef MOMENT
9481         s1=dipderg(1,jj,i)*dip(1,kk,k)
9482 #endif
9483         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9484         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
9485         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9486         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9487 #ifdef MOMENT
9488         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9489 #else
9490         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9491 #endif
9492 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
9493       endif
9494 C Derivatives in gamma(k-1)
9495 #ifdef MOMENT
9496       s1=dip(1,jj,i)*dipderg(1,kk,k)
9497 #endif
9498       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
9499       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9500       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
9501       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9502       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9503       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
9504       vv(1)=pizda(1,1)-pizda(2,2)
9505       vv(2)=pizda(1,2)+pizda(2,1)
9506       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9507 #ifdef MOMENT
9508       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9509 #else
9510       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9511 #endif
9512 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
9513 C Derivatives in gamma(j-1) or gamma(l-1)
9514       if (j.gt.1) then
9515 #ifdef MOMENT
9516         s1=dipderg(3,jj,i)*dip(1,kk,k)
9517 #endif
9518         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
9519         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9520         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
9521         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
9522         vv(1)=pizda(1,1)-pizda(2,2)
9523         vv(2)=pizda(1,2)+pizda(2,1)
9524         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9525 #ifdef MOMENT
9526         if (swap) then
9527           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9528         else
9529           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9530         endif
9531 #endif
9532         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
9533 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
9534       endif
9535 C Derivatives in gamma(l-1) or gamma(j-1)
9536       if (l.gt.1) then
9537 #ifdef MOMENT
9538         s1=dip(1,jj,i)*dipderg(3,kk,k)
9539 #endif
9540         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
9541         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
9542         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
9543         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
9544         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
9545         vv(1)=pizda(1,1)-pizda(2,2)
9546         vv(2)=pizda(1,2)+pizda(2,1)
9547         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9548 #ifdef MOMENT
9549         if (swap) then
9550           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
9551         else
9552           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
9553         endif
9554 #endif
9555         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
9556 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
9557       endif
9558 C Cartesian derivatives.
9559       if (lprn) then
9560         write (2,*) 'In eello6_graph2'
9561         do iii=1,2
9562           write (2,*) 'iii=',iii
9563           do kkk=1,5
9564             write (2,*) 'kkk=',kkk
9565             do jjj=1,2
9566               write (2,'(3(2f10.5),5x)')
9567      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9568             enddo
9569           enddo
9570         enddo
9571       endif
9572       do iii=1,2
9573         do kkk=1,5
9574           do lll=1,3
9575 #ifdef MOMENT
9576             if (iii.eq.1) then
9577               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
9578             else
9579               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
9580             endif
9581 #endif
9582             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
9583      &        auxvec(1))
9584             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
9585             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
9586      &        auxvec(1))
9587             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
9588             call transpose2(EUg(1,1,k),auxmat(1,1))
9589             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
9590      &        pizda(1,1))
9591             vv(1)=pizda(1,1)-pizda(2,2)
9592             vv(2)=pizda(1,2)+pizda(2,1)
9593             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
9594 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
9595 #ifdef MOMENT
9596             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9597 #else
9598             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9599 #endif
9600             if (swap) then
9601               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9602             else
9603               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9604             endif
9605           enddo
9606         enddo
9607       enddo
9608       endif ! calc_grad
9609       return
9610       end
9611 c----------------------------------------------------------------------------
9612       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
9613       implicit real*8 (a-h,o-z)
9614       include 'DIMENSIONS'
9615       include 'DIMENSIONS.ZSCOPT'
9616       include 'COMMON.IOUNITS'
9617       include 'COMMON.CHAIN'
9618       include 'COMMON.DERIV'
9619       include 'COMMON.INTERACT'
9620       include 'COMMON.CONTACTS'
9621       include 'COMMON.TORSION'
9622       include 'COMMON.VAR'
9623       include 'COMMON.GEO'
9624       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
9625       logical swap
9626 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9627 C                                                                              C
9628 C      Parallel       Antiparallel                                             C
9629 C                                                                              C
9630 C          o             o                                                     C
9631 C         /l\   /   \   /j\                                                    C
9632 C        /   \ /     \ /   \                                                   C
9633 C       /| o |o       o| o |\                                                  C
9634 C       j|/k\|  /      |/k\|l /                                                C
9635 C        /   \ /       /   \ /                                                 C
9636 C       /     o       /     o                                                  C
9637 C       i             i                                                        C
9638 C                                                                              C
9639 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9640 C
9641 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9642 C           energy moment and not to the cluster cumulant.
9643       iti=itortyp(itype(i))
9644       if (j.lt.nres-1) then
9645         itj1=itype2loc(itype(j+1))
9646       else
9647         itj1=nloctyp
9648       endif
9649       itk=itype2loc(itype(k))
9650       itk1=itype2loc(itype(k+1))
9651       if (l.lt.nres-1) then
9652         itl1=itype2loc(itype(l+1))
9653       else
9654         itl1=nloctyp
9655       endif
9656 #ifdef MOMENT
9657       s1=dip(4,jj,i)*dip(4,kk,k)
9658 #endif
9659       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
9660       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9661       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
9662       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9663       call transpose2(EE(1,1,k),auxmat(1,1))
9664       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
9665       vv(1)=pizda(1,1)+pizda(2,2)
9666       vv(2)=pizda(2,1)-pizda(1,2)
9667       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9668 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
9669 cd     & "sum",-(s2+s3+s4)
9670 #ifdef MOMENT
9671       eello6_graph3=-(s1+s2+s3+s4)
9672 #else
9673       eello6_graph3=-(s2+s3+s4)
9674 #endif
9675 c      eello6_graph3=-s4
9676 C Derivatives in gamma(k-1)
9677       if (calc_grad) then
9678       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
9679       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9680       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
9681       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
9682 C Derivatives in gamma(l-1)
9683       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
9684       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9685       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
9686       vv(1)=pizda(1,1)+pizda(2,2)
9687       vv(2)=pizda(2,1)-pizda(1,2)
9688       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9689       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9690 C Cartesian derivatives.
9691       do iii=1,2
9692         do kkk=1,5
9693           do lll=1,3
9694 #ifdef MOMENT
9695             if (iii.eq.1) then
9696               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
9697             else
9698               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
9699             endif
9700 #endif
9701             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9702      &        auxvec(1))
9703             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
9704             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9705      &        auxvec(1))
9706             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
9707             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
9708      &        pizda(1,1))
9709             vv(1)=pizda(1,1)+pizda(2,2)
9710             vv(2)=pizda(2,1)-pizda(1,2)
9711             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
9712 #ifdef MOMENT
9713             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9714 #else
9715             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9716 #endif
9717             if (swap) then
9718               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9719             else
9720               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9721             endif
9722 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
9723           enddo
9724         enddo
9725       enddo
9726       endif ! calc_grad
9727       return
9728       end
9729 c----------------------------------------------------------------------------
9730       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
9731       implicit real*8 (a-h,o-z)
9732       include 'DIMENSIONS'
9733       include 'DIMENSIONS.ZSCOPT'
9734       include 'COMMON.IOUNITS'
9735       include 'COMMON.CHAIN'
9736       include 'COMMON.DERIV'
9737       include 'COMMON.INTERACT'
9738       include 'COMMON.CONTACTS'
9739       include 'COMMON.TORSION'
9740       include 'COMMON.VAR'
9741       include 'COMMON.GEO'
9742       include 'COMMON.FFIELD'
9743       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
9744      & auxvec1(2),auxmat1(2,2)
9745       logical swap
9746 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9747 C                                                                              C
9748 C      Parallel       Antiparallel                                             C
9749 C                                                                              C
9750 C          o             o                                                     C
9751 C         /l\   /   \   /j\                                                    C
9752 C        /   \ /     \ /   \                                                   C
9753 C       /| o |o       o| o |\                                                  C
9754 C     \ j|/k\|      \  |/k\|l                                                  C
9755 C      \ /   \       \ /   \                                                   C
9756 C       o     \       o     \                                                  C
9757 C       i             i                                                        C
9758 C                                                                              C
9759 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9760 C
9761 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
9762 C           energy moment and not to the cluster cumulant.
9763 cd      write (2,*) 'eello_graph4: wturn6',wturn6
9764       iti=itype2loc(itype(i))
9765       itj=itype2loc(itype(j))
9766       if (j.lt.nres-1) then
9767         itj1=itype2loc(itype(j+1))
9768       else
9769         itj1=nloctyp
9770       endif
9771       itk=itype2loc(itype(k))
9772       if (k.lt.nres-1) then
9773         itk1=itype2loc(itype(k+1))
9774       else
9775         itk1=nloctyp
9776       endif
9777       itl=itype2loc(itype(l))
9778       if (l.lt.nres-1) then
9779         itl1=itype2loc(itype(l+1))
9780       else
9781         itl1=nloctyp
9782       endif
9783 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
9784 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
9785 cd     & ' itl',itl,' itl1',itl1
9786 #ifdef MOMENT
9787       if (imat.eq.1) then
9788         s1=dip(3,jj,i)*dip(3,kk,k)
9789       else
9790         s1=dip(2,jj,j)*dip(2,kk,l)
9791       endif
9792 #endif
9793       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
9794       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9795       if (j.eq.l+1) then
9796         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
9797         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9798       else
9799         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
9800         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9801       endif
9802       call transpose2(EUg(1,1,k),auxmat(1,1))
9803       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
9804       vv(1)=pizda(1,1)-pizda(2,2)
9805       vv(2)=pizda(2,1)+pizda(1,2)
9806       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9807 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
9808 #ifdef MOMENT
9809       eello6_graph4=-(s1+s2+s3+s4)
9810 #else
9811       eello6_graph4=-(s2+s3+s4)
9812 #endif
9813 C Derivatives in gamma(i-1)
9814       if (calc_grad) then
9815       if (i.gt.1) then
9816 #ifdef MOMENT
9817         if (imat.eq.1) then
9818           s1=dipderg(2,jj,i)*dip(3,kk,k)
9819         else
9820           s1=dipderg(4,jj,j)*dip(2,kk,l)
9821         endif
9822 #endif
9823         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
9824         if (j.eq.l+1) then
9825           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
9826           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9827         else
9828           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
9829           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9830         endif
9831         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
9832         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9833 cd          write (2,*) 'turn6 derivatives'
9834 #ifdef MOMENT
9835           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
9836 #else
9837           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
9838 #endif
9839         else
9840 #ifdef MOMENT
9841           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
9842 #else
9843           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
9844 #endif
9845         endif
9846       endif
9847 C Derivatives in gamma(k-1)
9848 #ifdef MOMENT
9849       if (imat.eq.1) then
9850         s1=dip(3,jj,i)*dipderg(2,kk,k)
9851       else
9852         s1=dip(2,jj,j)*dipderg(4,kk,l)
9853       endif
9854 #endif
9855       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
9856       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
9857       if (j.eq.l+1) then
9858         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
9859         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
9860       else
9861         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
9862         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
9863       endif
9864       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9865       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
9866       vv(1)=pizda(1,1)-pizda(2,2)
9867       vv(2)=pizda(2,1)+pizda(1,2)
9868       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9869       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9870 #ifdef MOMENT
9871         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
9872 #else
9873         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
9874 #endif
9875       else
9876 #ifdef MOMENT
9877         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
9878 #else
9879         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
9880 #endif
9881       endif
9882 C Derivatives in gamma(j-1) or gamma(l-1)
9883       if (l.eq.j+1 .and. l.gt.1) then
9884         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9885         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9886         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9887         vv(1)=pizda(1,1)-pizda(2,2)
9888         vv(2)=pizda(2,1)+pizda(1,2)
9889         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9890         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
9891       else if (j.gt.1) then
9892         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
9893         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9894         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
9895         vv(1)=pizda(1,1)-pizda(2,2)
9896         vv(2)=pizda(2,1)+pizda(1,2)
9897         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9898         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9899           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
9900         else
9901           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
9902         endif
9903       endif
9904 C Cartesian derivatives.
9905       do iii=1,2
9906         do kkk=1,5
9907           do lll=1,3
9908 #ifdef MOMENT
9909             if (iii.eq.1) then
9910               if (imat.eq.1) then
9911                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
9912               else
9913                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
9914               endif
9915             else
9916               if (imat.eq.1) then
9917                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
9918               else
9919                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
9920               endif
9921             endif
9922 #endif
9923             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
9924      &        auxvec(1))
9925             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
9926             if (j.eq.l+1) then
9927               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9928      &          b1(1,j+1),auxvec(1))
9929               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
9930             else
9931               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
9932      &          b1(1,l+1),auxvec(1))
9933               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
9934             endif
9935             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
9936      &        pizda(1,1))
9937             vv(1)=pizda(1,1)-pizda(2,2)
9938             vv(2)=pizda(2,1)+pizda(1,2)
9939             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
9940             if (swap) then
9941               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
9942 #ifdef MOMENT
9943                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9944      &             -(s1+s2+s4)
9945 #else
9946                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
9947      &             -(s2+s4)
9948 #endif
9949                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
9950               else
9951 #ifdef MOMENT
9952                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
9953 #else
9954                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
9955 #endif
9956                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9957               endif
9958             else
9959 #ifdef MOMENT
9960               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
9961 #else
9962               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
9963 #endif
9964               if (l.eq.j+1) then
9965                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
9966               else
9967                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
9968               endif
9969             endif
9970           enddo
9971         enddo
9972       enddo
9973       endif ! calc_grad
9974       return
9975       end
9976 c----------------------------------------------------------------------------
9977       double precision function eello_turn6(i,jj,kk)
9978       implicit real*8 (a-h,o-z)
9979       include 'DIMENSIONS'
9980       include 'DIMENSIONS.ZSCOPT'
9981       include 'COMMON.IOUNITS'
9982       include 'COMMON.CHAIN'
9983       include 'COMMON.DERIV'
9984       include 'COMMON.INTERACT'
9985       include 'COMMON.CONTACTS'
9986       include 'COMMON.TORSION'
9987       include 'COMMON.VAR'
9988       include 'COMMON.GEO'
9989       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
9990      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
9991      &  ggg1(3),ggg2(3)
9992       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
9993      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
9994 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
9995 C           the respective energy moment and not to the cluster cumulant.
9996       s1=0.0d0
9997       s8=0.0d0
9998       s13=0.0d0
9999 c
10000       eello_turn6=0.0d0
10001       j=i+4
10002       k=i+1
10003       l=i+3
10004       iti=itype2loc(itype(i))
10005       itk=itype2loc(itype(k))
10006       itk1=itype2loc(itype(k+1))
10007       itl=itype2loc(itype(l))
10008       itj=itype2loc(itype(j))
10009 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10010 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10011 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10012 cd        eello6=0.0d0
10013 cd        return
10014 cd      endif
10015 cd      write (iout,*)
10016 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10017 cd     &   ' and',k,l
10018 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10019       do iii=1,2
10020         do kkk=1,5
10021           do lll=1,3
10022             derx_turn(lll,kkk,iii)=0.0d0
10023           enddo
10024         enddo
10025       enddo
10026 cd      eij=1.0d0
10027 cd      ekl=1.0d0
10028 cd      ekont=1.0d0
10029       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10030 cd      eello6_5=0.0d0
10031 cd      write (2,*) 'eello6_5',eello6_5
10032 #ifdef MOMENT
10033       call transpose2(AEA(1,1,1),auxmat(1,1))
10034       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10035       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10036       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10037 #endif
10038       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10039       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10040       s2 = scalar2(b1(1,k),vtemp1(1))
10041 #ifdef MOMENT
10042       call transpose2(AEA(1,1,2),atemp(1,1))
10043       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10044       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10045       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10046 #endif
10047       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10048       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10049       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10050 #ifdef MOMENT
10051       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10052       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10053       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10054       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10055       ss13 = scalar2(b1(1,k),vtemp4(1))
10056       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10057 #endif
10058 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10059 c      s1=0.0d0
10060 c      s2=0.0d0
10061 c      s8=0.0d0
10062 c      s12=0.0d0
10063 c      s13=0.0d0
10064       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10065 C Derivatives in gamma(i+2)
10066       if (calc_grad) then
10067       s1d =0.0d0
10068       s8d =0.0d0
10069 #ifdef MOMENT
10070       call transpose2(AEA(1,1,1),auxmatd(1,1))
10071       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10072       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10073       call transpose2(AEAderg(1,1,2),atempd(1,1))
10074       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10075       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10076 #endif
10077       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10078       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10079       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10080 c      s1d=0.0d0
10081 c      s2d=0.0d0
10082 c      s8d=0.0d0
10083 c      s12d=0.0d0
10084 c      s13d=0.0d0
10085       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10086 C Derivatives in gamma(i+3)
10087 #ifdef MOMENT
10088       call transpose2(AEA(1,1,1),auxmatd(1,1))
10089       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10090       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10091       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10092 #endif
10093       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10094       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10095       s2d = scalar2(b1(1,k),vtemp1d(1))
10096 #ifdef MOMENT
10097       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10098       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10099 #endif
10100       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10101 #ifdef MOMENT
10102       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10103       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10104       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10105 #endif
10106 c      s1d=0.0d0
10107 c      s2d=0.0d0
10108 c      s8d=0.0d0
10109 c      s12d=0.0d0
10110 c      s13d=0.0d0
10111 #ifdef MOMENT
10112       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10113      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10114 #else
10115       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10116      &               -0.5d0*ekont*(s2d+s12d)
10117 #endif
10118 C Derivatives in gamma(i+4)
10119       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10120       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10121       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10122 #ifdef MOMENT
10123       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10124       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10125       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10126 #endif
10127 c      s1d=0.0d0
10128 c      s2d=0.0d0
10129 c      s8d=0.0d0
10130 C      s12d=0.0d0
10131 c      s13d=0.0d0
10132 #ifdef MOMENT
10133       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10134 #else
10135       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10136 #endif
10137 C Derivatives in gamma(i+5)
10138 #ifdef MOMENT
10139       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10140       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10141       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10142 #endif
10143       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10144       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10145       s2d = scalar2(b1(1,k),vtemp1d(1))
10146 #ifdef MOMENT
10147       call transpose2(AEA(1,1,2),atempd(1,1))
10148       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10149       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10150 #endif
10151       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10152       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10153 #ifdef MOMENT
10154       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10155       ss13d = scalar2(b1(1,k),vtemp4d(1))
10156       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10157 #endif
10158 c      s1d=0.0d0
10159 c      s2d=0.0d0
10160 c      s8d=0.0d0
10161 c      s12d=0.0d0
10162 c      s13d=0.0d0
10163 #ifdef MOMENT
10164       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10165      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10166 #else
10167       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10168      &               -0.5d0*ekont*(s2d+s12d)
10169 #endif
10170 C Cartesian derivatives
10171       do iii=1,2
10172         do kkk=1,5
10173           do lll=1,3
10174 #ifdef MOMENT
10175             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10176             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10177             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10178 #endif
10179             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10180             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10181      &          vtemp1d(1))
10182             s2d = scalar2(b1(1,k),vtemp1d(1))
10183 #ifdef MOMENT
10184             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10185             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10186             s8d = -(atempd(1,1)+atempd(2,2))*
10187      &           scalar2(cc(1,1,l),vtemp2(1))
10188 #endif
10189             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10190      &           auxmatd(1,1))
10191             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10192             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10193 c      s1d=0.0d0
10194 c      s2d=0.0d0
10195 c      s8d=0.0d0
10196 c      s12d=0.0d0
10197 c      s13d=0.0d0
10198 #ifdef MOMENT
10199             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10200      &        - 0.5d0*(s1d+s2d)
10201 #else
10202             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10203      &        - 0.5d0*s2d
10204 #endif
10205 #ifdef MOMENT
10206             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10207      &        - 0.5d0*(s8d+s12d)
10208 #else
10209             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10210      &        - 0.5d0*s12d
10211 #endif
10212           enddo
10213         enddo
10214       enddo
10215 #ifdef MOMENT
10216       do kkk=1,5
10217         do lll=1,3
10218           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10219      &      achuj_tempd(1,1))
10220           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10221           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10222           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10223           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10224           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10225      &      vtemp4d(1))
10226           ss13d = scalar2(b1(1,k),vtemp4d(1))
10227           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10228           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10229         enddo
10230       enddo
10231 #endif
10232 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10233 cd     &  16*eel_turn6_num
10234 cd      goto 1112
10235       if (j.lt.nres-1) then
10236         j1=j+1
10237         j2=j-1
10238       else
10239         j1=j-1
10240         j2=j-2
10241       endif
10242       if (l.lt.nres-1) then
10243         l1=l+1
10244         l2=l-1
10245       else
10246         l1=l-1
10247         l2=l-2
10248       endif
10249       do ll=1,3
10250 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10251 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10252 cgrad        ghalf=0.5d0*ggg1(ll)
10253 cd        ghalf=0.0d0
10254         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10255         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10256         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10257      &    +ekont*derx_turn(ll,2,1)
10258         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10259         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10260      &    +ekont*derx_turn(ll,4,1)
10261         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10262         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10263         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10264 cgrad        ghalf=0.5d0*ggg2(ll)
10265 cd        ghalf=0.0d0
10266         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10267      &    +ekont*derx_turn(ll,2,2)
10268         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10269         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10270      &    +ekont*derx_turn(ll,4,2)
10271         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
10272         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
10273         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
10274       enddo
10275 cd      goto 1112
10276 cgrad      do m=i+1,j-1
10277 cgrad        do ll=1,3
10278 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
10279 cgrad        enddo
10280 cgrad      enddo
10281 cgrad      do m=k+1,l-1
10282 cgrad        do ll=1,3
10283 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
10284 cgrad        enddo
10285 cgrad      enddo
10286 cgrad1112  continue
10287 cgrad      do m=i+2,j2
10288 cgrad        do ll=1,3
10289 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
10290 cgrad        enddo
10291 cgrad      enddo
10292 cgrad      do m=k+2,l2
10293 cgrad        do ll=1,3
10294 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
10295 cgrad        enddo
10296 cgrad      enddo
10297 cd      do iii=1,nres-3
10298 cd        write (2,*) iii,g_corr6_loc(iii)
10299 cd      enddo
10300       endif ! calc_grad
10301       eello_turn6=ekont*eel_turn6
10302 cd      write (2,*) 'ekont',ekont
10303 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
10304       return
10305       end
10306
10307 crc-------------------------------------------------
10308 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10309       subroutine Eliptransfer(eliptran)
10310       implicit real*8 (a-h,o-z)
10311       include 'DIMENSIONS'
10312       include 'DIMENSIONS.ZSCOPT'
10313       include 'COMMON.GEO'
10314       include 'COMMON.VAR'
10315       include 'COMMON.LOCAL'
10316       include 'COMMON.CHAIN'
10317       include 'COMMON.DERIV'
10318       include 'COMMON.INTERACT'
10319       include 'COMMON.IOUNITS'
10320       include 'COMMON.CALC'
10321       include 'COMMON.CONTROL'
10322       include 'COMMON.SPLITELE'
10323       include 'COMMON.SBRIDGE'
10324 C this is done by Adasko
10325 C      print *,"wchodze"
10326 C structure of box:
10327 C      water
10328 C--bordliptop-- buffore starts
10329 C--bufliptop--- here true lipid starts
10330 C      lipid
10331 C--buflipbot--- lipid ends buffore starts
10332 C--bordlipbot--buffore ends
10333       eliptran=0.0
10334       do i=1,nres
10335 C       do i=1,1
10336         if (itype(i).eq.ntyp1) cycle
10337
10338         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
10339         if (positi.le.0) positi=positi+boxzsize
10340 C        print *,i
10341 C first for peptide groups
10342 c for each residue check if it is in lipid or lipid water border area
10343        if ((positi.gt.bordlipbot)
10344      &.and.(positi.lt.bordliptop)) then
10345 C the energy transfer exist
10346         if (positi.lt.buflipbot) then
10347 C what fraction I am in
10348          fracinbuf=1.0d0-
10349      &        ((positi-bordlipbot)/lipbufthick)
10350 C lipbufthick is thickenes of lipid buffore
10351          sslip=sscalelip(fracinbuf)
10352          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10353          eliptran=eliptran+sslip*pepliptran
10354          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10355          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10356 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10357         elseif (positi.gt.bufliptop) then
10358          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
10359          sslip=sscalelip(fracinbuf)
10360          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10361          eliptran=eliptran+sslip*pepliptran
10362          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
10363          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
10364 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
10365 C          print *, "doing sscalefor top part"
10366 C         print *,i,sslip,fracinbuf,ssgradlip
10367         else
10368          eliptran=eliptran+pepliptran
10369 C         print *,"I am in true lipid"
10370         endif
10371 C       else
10372 C       eliptran=elpitran+0.0 ! I am in water
10373        endif
10374        enddo
10375 C       print *, "nic nie bylo w lipidzie?"
10376 C now multiply all by the peptide group transfer factor
10377 C       eliptran=eliptran*pepliptran
10378 C now the same for side chains
10379 CV       do i=1,1
10380        do i=1,nres
10381         if (itype(i).eq.ntyp1) cycle
10382         positi=(mod(c(3,i+nres),boxzsize))
10383         if (positi.le.0) positi=positi+boxzsize
10384 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
10385 c for each residue check if it is in lipid or lipid water border area
10386 C       respos=mod(c(3,i+nres),boxzsize)
10387 C       print *,positi,bordlipbot,buflipbot
10388        if ((positi.gt.bordlipbot)
10389      & .and.(positi.lt.bordliptop)) then
10390 C the energy transfer exist
10391         if (positi.lt.buflipbot) then
10392          fracinbuf=1.0d0-
10393      &     ((positi-bordlipbot)/lipbufthick)
10394 C lipbufthick is thickenes of lipid buffore
10395          sslip=sscalelip(fracinbuf)
10396          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
10397          eliptran=eliptran+sslip*liptranene(itype(i))
10398          gliptranx(3,i)=gliptranx(3,i)
10399      &+ssgradlip*liptranene(itype(i))
10400          gliptranc(3,i-1)= gliptranc(3,i-1)
10401      &+ssgradlip*liptranene(itype(i))
10402 C         print *,"doing sccale for lower part"
10403         elseif (positi.gt.bufliptop) then
10404          fracinbuf=1.0d0-
10405      &((bordliptop-positi)/lipbufthick)
10406          sslip=sscalelip(fracinbuf)
10407          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
10408          eliptran=eliptran+sslip*liptranene(itype(i))
10409          gliptranx(3,i)=gliptranx(3,i)
10410      &+ssgradlip*liptranene(itype(i))
10411          gliptranc(3,i-1)= gliptranc(3,i-1)
10412      &+ssgradlip*liptranene(itype(i))
10413 C          print *, "doing sscalefor top part",sslip,fracinbuf
10414         else
10415          eliptran=eliptran+liptranene(itype(i))
10416 C         print *,"I am in true lipid"
10417         endif
10418         endif ! if in lipid or buffor
10419 C       else
10420 C       eliptran=elpitran+0.0 ! I am in water
10421        enddo
10422        return
10423        end
10424
10425
10426 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10427
10428       SUBROUTINE MATVEC2(A1,V1,V2)
10429       implicit real*8 (a-h,o-z)
10430       include 'DIMENSIONS'
10431       DIMENSION A1(2,2),V1(2),V2(2)
10432 c      DO 1 I=1,2
10433 c        VI=0.0
10434 c        DO 3 K=1,2
10435 c    3     VI=VI+A1(I,K)*V1(K)
10436 c        Vaux(I)=VI
10437 c    1 CONTINUE
10438
10439       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
10440       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
10441
10442       v2(1)=vaux1
10443       v2(2)=vaux2
10444       END
10445 C---------------------------------------
10446       SUBROUTINE MATMAT2(A1,A2,A3)
10447       implicit real*8 (a-h,o-z)
10448       include 'DIMENSIONS'
10449       DIMENSION A1(2,2),A2(2,2),A3(2,2)
10450 c      DIMENSION AI3(2,2)
10451 c        DO  J=1,2
10452 c          A3IJ=0.0
10453 c          DO K=1,2
10454 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
10455 c          enddo
10456 c          A3(I,J)=A3IJ
10457 c       enddo
10458 c      enddo
10459
10460       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
10461       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
10462       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
10463       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
10464
10465       A3(1,1)=AI3_11
10466       A3(2,1)=AI3_21
10467       A3(1,2)=AI3_12
10468       A3(2,2)=AI3_22
10469       END
10470
10471 c-------------------------------------------------------------------------
10472       double precision function scalar2(u,v)
10473       implicit none
10474       double precision u(2),v(2)
10475       double precision sc
10476       integer i
10477       scalar2=u(1)*v(1)+u(2)*v(2)
10478       return
10479       end
10480
10481 C-----------------------------------------------------------------------------
10482
10483       subroutine transpose2(a,at)
10484       implicit none
10485       double precision a(2,2),at(2,2)
10486       at(1,1)=a(1,1)
10487       at(1,2)=a(2,1)
10488       at(2,1)=a(1,2)
10489       at(2,2)=a(2,2)
10490       return
10491       end
10492 c--------------------------------------------------------------------------
10493       subroutine transpose(n,a,at)
10494       implicit none
10495       integer n,i,j
10496       double precision a(n,n),at(n,n)
10497       do i=1,n
10498         do j=1,n
10499           at(j,i)=a(i,j)
10500         enddo
10501       enddo
10502       return
10503       end
10504 C---------------------------------------------------------------------------
10505       subroutine prodmat3(a1,a2,kk,transp,prod)
10506       implicit none
10507       integer i,j
10508       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
10509       logical transp
10510 crc      double precision auxmat(2,2),prod_(2,2)
10511
10512       if (transp) then
10513 crc        call transpose2(kk(1,1),auxmat(1,1))
10514 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
10515 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10516
10517            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
10518      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
10519            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
10520      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
10521            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
10522      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
10523            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
10524      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
10525
10526       else
10527 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
10528 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
10529
10530            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
10531      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
10532            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
10533      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
10534            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
10535      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
10536            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
10537      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
10538
10539       endif
10540 c      call transpose2(a2(1,1),a2t(1,1))
10541
10542 crc      print *,transp
10543 crc      print *,((prod_(i,j),i=1,2),j=1,2)
10544 crc      print *,((prod(i,j),i=1,2),j=1,2)
10545
10546       return
10547       end
10548 C-----------------------------------------------------------------------------
10549       double precision function scalar(u,v)
10550       implicit none
10551       double precision u(3),v(3)
10552       double precision sc
10553       integer i
10554       sc=0.0d0
10555       do i=1,3
10556         sc=sc+u(i)*v(i)
10557       enddo
10558       scalar=sc
10559       return
10560       end
10561 C-----------------------------------------------------------------------
10562       double precision function sscale(r)
10563       double precision r,gamm
10564       include "COMMON.SPLITELE"
10565       if(r.lt.r_cut-rlamb) then
10566         sscale=1.0d0
10567       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10568         gamm=(r-(r_cut-rlamb))/rlamb
10569         sscale=1.0d0+gamm*gamm*(2*gamm-3.0d0)
10570       else
10571         sscale=0d0
10572       endif
10573       return
10574       end
10575 C-----------------------------------------------------------------------
10576 C-----------------------------------------------------------------------
10577       double precision function sscagrad(r)
10578       double precision r,gamm
10579       include "COMMON.SPLITELE"
10580       if(r.lt.r_cut-rlamb) then
10581         sscagrad=0.0d0
10582       else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10583         gamm=(r-(r_cut-rlamb))/rlamb
10584         sscagrad=gamm*(6*gamm-6.0d0)/rlamb
10585       else
10586         sscagrad=0.0d0
10587       endif
10588       return
10589       end
10590 C-----------------------------------------------------------------------
10591 C-----------------------------------------------------------------------
10592       double precision function sscalelip(r)
10593       double precision r,gamm
10594       include "COMMON.SPLITELE"
10595 C      if(r.lt.r_cut-rlamb) then
10596 C        sscale=1.0d0
10597 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10598 C        gamm=(r-(r_cut-rlamb))/rlamb
10599         sscalelip=1.0d0+r*r*(2*r-3.0d0)
10600 C      else
10601 C        sscale=0d0
10602 C      endif
10603       return
10604       end
10605 C-----------------------------------------------------------------------
10606       double precision function sscagradlip(r)
10607       double precision r,gamm
10608       include "COMMON.SPLITELE"
10609 C     if(r.lt.r_cut-rlamb) then
10610 C        sscagrad=0.0d0
10611 C      else if(r.le.r_cut.and.r.ge.r_cut-rlamb) then
10612 C        gamm=(r-(r_cut-rlamb))/rlamb
10613         sscagradlip=r*(6*r-6.0d0)
10614 C      else
10615 C        sscagrad=0.0d0
10616 C      endif
10617       return
10618       end
10619
10620 C-----------------------------------------------------------------------
10621        subroutine set_shield_fac
10622       implicit real*8 (a-h,o-z)
10623       include 'DIMENSIONS'
10624       include 'DIMENSIONS.ZSCOPT'
10625       include 'COMMON.CHAIN'
10626       include 'COMMON.DERIV'
10627       include 'COMMON.IOUNITS'
10628       include 'COMMON.SHIELD'
10629       include 'COMMON.INTERACT'
10630 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10631       double precision div77_81/0.974996043d0/,
10632      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10633
10634 C the vector between center of side_chain and peptide group
10635        double precision pep_side(3),long,side_calf(3),
10636      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10637      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10638 C the line belowe needs to be changed for FGPROC>1
10639       do i=1,nres-1
10640       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10641       ishield_list(i)=0
10642 Cif there two consequtive dummy atoms there is no peptide group between them
10643 C the line below has to be changed for FGPROC>1
10644       VolumeTotal=0.0
10645       do k=1,nres
10646        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10647        dist_pep_side=0.0
10648        dist_side_calf=0.0
10649        do j=1,3
10650 C first lets set vector conecting the ithe side-chain with kth side-chain
10651       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10652 C      pep_side(j)=2.0d0
10653 C and vector conecting the side-chain with its proper calfa
10654       side_calf(j)=c(j,k+nres)-c(j,k)
10655 C      side_calf(j)=2.0d0
10656       pept_group(j)=c(j,i)-c(j,i+1)
10657 C lets have their lenght
10658       dist_pep_side=pep_side(j)**2+dist_pep_side
10659       dist_side_calf=dist_side_calf+side_calf(j)**2
10660       dist_pept_group=dist_pept_group+pept_group(j)**2
10661       enddo
10662        dist_pep_side=dsqrt(dist_pep_side)
10663        dist_pept_group=dsqrt(dist_pept_group)
10664        dist_side_calf=dsqrt(dist_side_calf)
10665       do j=1,3
10666         pep_side_norm(j)=pep_side(j)/dist_pep_side
10667         side_calf_norm(j)=dist_side_calf
10668       enddo
10669 C now sscale fraction
10670        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10671 C       print *,buff_shield,"buff"
10672 C now sscale
10673         if (sh_frac_dist.le.0.0) cycle
10674 C If we reach here it means that this side chain reaches the shielding sphere
10675 C Lets add him to the list for gradient
10676         ishield_list(i)=ishield_list(i)+1
10677 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10678 C this list is essential otherwise problem would be O3
10679         shield_list(ishield_list(i),i)=k
10680 C Lets have the sscale value
10681         if (sh_frac_dist.gt.1.0) then
10682          scale_fac_dist=1.0d0
10683          do j=1,3
10684          sh_frac_dist_grad(j)=0.0d0
10685          enddo
10686         else
10687          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10688      &                   *(2.0*sh_frac_dist-3.0d0)
10689          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
10690      &                  /dist_pep_side/buff_shield*0.5
10691 C remember for the final gradient multiply sh_frac_dist_grad(j)
10692 C for side_chain by factor -2 !
10693          do j=1,3
10694          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10695 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10696 C     &                    sh_frac_dist_grad(j)
10697          enddo
10698         endif
10699 C        if ((i.eq.3).and.(k.eq.2)) then
10700 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
10701 C     & ,"TU"
10702 C        endif
10703
10704 C this is what is now we have the distance scaling now volume...
10705       short=short_r_sidechain(itype(k))
10706       long=long_r_sidechain(itype(k))
10707       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
10708 C now costhet_grad
10709 C       costhet=0.0d0
10710        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
10711 C       costhet_fac=0.0d0
10712        do j=1,3
10713          costhet_grad(j)=costhet_fac*pep_side(j)
10714        enddo
10715 C remember for the final gradient multiply costhet_grad(j)
10716 C for side_chain by factor -2 !
10717 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10718 C pep_side0pept_group is vector multiplication
10719       pep_side0pept_group=0.0
10720       do j=1,3
10721       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10722       enddo
10723       cosalfa=(pep_side0pept_group/
10724      & (dist_pep_side*dist_side_calf))
10725       fac_alfa_sin=1.0-cosalfa**2
10726       fac_alfa_sin=dsqrt(fac_alfa_sin)
10727       rkprim=fac_alfa_sin*(long-short)+short
10728 C now costhet_grad
10729        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
10730        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
10731
10732        do j=1,3
10733          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10734      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10735      &*(long-short)/fac_alfa_sin*cosalfa/
10736      &((dist_pep_side*dist_side_calf))*
10737      &((side_calf(j))-cosalfa*
10738      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10739
10740         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
10741      &*(long-short)/fac_alfa_sin*cosalfa
10742      &/((dist_pep_side*dist_side_calf))*
10743      &(pep_side(j)-
10744      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10745        enddo
10746
10747       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
10748      &                    /VSolvSphere_div
10749      &                    *wshield
10750 C now the gradient...
10751 C grad_shield is gradient of Calfa for peptide groups
10752 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
10753 C     &               costhet,cosphi
10754 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
10755 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
10756       do j=1,3
10757       grad_shield(j,i)=grad_shield(j,i)
10758 C gradient po skalowaniu
10759      &                +(sh_frac_dist_grad(j)
10760 C  gradient po costhet
10761      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
10762      &-scale_fac_dist*(cosphi_grad_long(j))
10763      &/(1.0-cosphi) )*div77_81
10764      &*VofOverlap
10765 C grad_shield_side is Cbeta sidechain gradient
10766       grad_shield_side(j,ishield_list(i),i)=
10767      &        (sh_frac_dist_grad(j)*(-2.0d0)
10768      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
10769      &       +scale_fac_dist*(cosphi_grad_long(j))
10770      &        *2.0d0/(1.0-cosphi))
10771      &        *div77_81*VofOverlap
10772
10773        grad_shield_loc(j,ishield_list(i),i)=
10774      &   scale_fac_dist*cosphi_grad_loc(j)
10775      &        *2.0d0/(1.0-cosphi)
10776      &        *div77_81*VofOverlap
10777       enddo
10778       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10779       enddo
10780       fac_shield(i)=VolumeTotal*div77_81+div4_81
10781 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10782       enddo
10783       return
10784       end
10785 C--------------------------------------------------------------------------
10786 C first for shielding is setting of function of side-chains
10787        subroutine set_shield_fac2
10788       implicit real*8 (a-h,o-z)
10789       include 'DIMENSIONS'
10790       include 'DIMENSIONS.ZSCOPT'
10791       include 'COMMON.CHAIN'
10792       include 'COMMON.DERIV'
10793       include 'COMMON.IOUNITS'
10794       include 'COMMON.SHIELD'
10795       include 'COMMON.INTERACT'
10796 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
10797       double precision div77_81/0.974996043d0/,
10798      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
10799
10800 C the vector between center of side_chain and peptide group
10801        double precision pep_side(3),long,side_calf(3),
10802      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
10803      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
10804 C the line belowe needs to be changed for FGPROC>1
10805       do i=1,nres-1
10806       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
10807       ishield_list(i)=0
10808 Cif there two consequtive dummy atoms there is no peptide group between them
10809 C the line below has to be changed for FGPROC>1
10810       VolumeTotal=0.0
10811       do k=1,nres
10812        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
10813        dist_pep_side=0.0
10814        dist_side_calf=0.0
10815        do j=1,3
10816 C first lets set vector conecting the ithe side-chain with kth side-chain
10817       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
10818 C      pep_side(j)=2.0d0
10819 C and vector conecting the side-chain with its proper calfa
10820       side_calf(j)=c(j,k+nres)-c(j,k)
10821 C      side_calf(j)=2.0d0
10822       pept_group(j)=c(j,i)-c(j,i+1)
10823 C lets have their lenght
10824       dist_pep_side=pep_side(j)**2+dist_pep_side
10825       dist_side_calf=dist_side_calf+side_calf(j)**2
10826       dist_pept_group=dist_pept_group+pept_group(j)**2
10827       enddo
10828        dist_pep_side=dsqrt(dist_pep_side)
10829        dist_pept_group=dsqrt(dist_pept_group)
10830        dist_side_calf=dsqrt(dist_side_calf)
10831       do j=1,3
10832         pep_side_norm(j)=pep_side(j)/dist_pep_side
10833         side_calf_norm(j)=dist_side_calf
10834       enddo
10835 C now sscale fraction
10836        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
10837 C       print *,buff_shield,"buff"
10838 C now sscale
10839         if (sh_frac_dist.le.0.0) cycle
10840 C If we reach here it means that this side chain reaches the shielding sphere
10841 C Lets add him to the list for gradient
10842         ishield_list(i)=ishield_list(i)+1
10843 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
10844 C this list is essential otherwise problem would be O3
10845         shield_list(ishield_list(i),i)=k
10846 C Lets have the sscale value
10847         if (sh_frac_dist.gt.1.0) then
10848          scale_fac_dist=1.0d0
10849          do j=1,3
10850          sh_frac_dist_grad(j)=0.0d0
10851          enddo
10852         else
10853          scale_fac_dist=-sh_frac_dist*sh_frac_dist
10854      &                   *(2.0d0*sh_frac_dist-3.0d0)
10855          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
10856      &                  /dist_pep_side/buff_shield*0.5d0
10857 C remember for the final gradient multiply sh_frac_dist_grad(j)
10858 C for side_chain by factor -2 !
10859          do j=1,3
10860          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
10861 C         sh_frac_dist_grad(j)=0.0d0
10862 C         scale_fac_dist=1.0d0
10863 C         print *,"jestem",scale_fac_dist,fac_help_scale,
10864 C     &                    sh_frac_dist_grad(j)
10865          enddo
10866         endif
10867 C this is what is now we have the distance scaling now volume...
10868       short=short_r_sidechain(itype(k))
10869       long=long_r_sidechain(itype(k))
10870       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
10871       sinthet=short/dist_pep_side*costhet
10872 C now costhet_grad
10873 C       costhet=0.6d0
10874 C       sinthet=0.8
10875        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
10876 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
10877 C     &             -short/dist_pep_side**2/costhet)
10878 C       costhet_fac=0.0d0
10879        do j=1,3
10880          costhet_grad(j)=costhet_fac*pep_side(j)
10881        enddo
10882 C remember for the final gradient multiply costhet_grad(j)
10883 C for side_chain by factor -2 !
10884 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
10885 C pep_side0pept_group is vector multiplication
10886       pep_side0pept_group=0.0d0
10887       do j=1,3
10888       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
10889       enddo
10890       cosalfa=(pep_side0pept_group/
10891      & (dist_pep_side*dist_side_calf))
10892       fac_alfa_sin=1.0d0-cosalfa**2
10893       fac_alfa_sin=dsqrt(fac_alfa_sin)
10894       rkprim=fac_alfa_sin*(long-short)+short
10895 C      rkprim=short
10896
10897 C now costhet_grad
10898        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
10899 C       cosphi=0.6
10900        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
10901        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
10902      &      dist_pep_side**2)
10903 C       sinphi=0.8
10904        do j=1,3
10905          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
10906      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10907      &*(long-short)/fac_alfa_sin*cosalfa/
10908      &((dist_pep_side*dist_side_calf))*
10909      &((side_calf(j))-cosalfa*
10910      &((pep_side(j)/dist_pep_side)*dist_side_calf))
10911 C       cosphi_grad_long(j)=0.0d0
10912         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
10913      &*(long-short)/fac_alfa_sin*cosalfa
10914      &/((dist_pep_side*dist_side_calf))*
10915      &(pep_side(j)-
10916      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
10917 C       cosphi_grad_loc(j)=0.0d0
10918        enddo
10919 C      print *,sinphi,sinthet
10920       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
10921      &                    /VSolvSphere_div
10922 C     &                    *wshield
10923 C now the gradient...
10924       do j=1,3
10925       grad_shield(j,i)=grad_shield(j,i)
10926 C gradient po skalowaniu
10927      &                +(sh_frac_dist_grad(j)*VofOverlap
10928 C  gradient po costhet
10929      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
10930      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10931      &       sinphi/sinthet*costhet*costhet_grad(j)
10932      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10933      & )*wshield
10934 C grad_shield_side is Cbeta sidechain gradient
10935       grad_shield_side(j,ishield_list(i),i)=
10936      &        (sh_frac_dist_grad(j)*(-2.0d0)
10937      &        *VofOverlap
10938      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10939      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
10940      &       sinphi/sinthet*costhet*costhet_grad(j)
10941      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
10942      &       )*wshield
10943
10944        grad_shield_loc(j,ishield_list(i),i)=
10945      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
10946      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
10947      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
10948      &        ))
10949      &        *wshield
10950       enddo
10951       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
10952       enddo
10953       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
10954 C      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
10955 C      write(2,*) "TU",rpp(1,1),short,long,buff_shield
10956       enddo
10957       return
10958       end
10959 C--------------------------------------------------------------------------
10960       double precision function tschebyshev(m,n,x,y)
10961       implicit none
10962       include "DIMENSIONS"
10963       integer i,m,n
10964       double precision x(n),y,yy(0:maxvar),aux
10965 c Tschebyshev polynomial. Note that the first term is omitted
10966 c m=0: the constant term is included
10967 c m=1: the constant term is not included
10968       yy(0)=1.0d0
10969       yy(1)=y
10970       do i=2,n
10971         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
10972       enddo
10973       aux=0.0d0
10974       do i=m,n
10975         aux=aux+x(i)*yy(i)
10976       enddo
10977       tschebyshev=aux
10978       return
10979       end
10980 C--------------------------------------------------------------------------
10981       double precision function gradtschebyshev(m,n,x,y)
10982       implicit none
10983       include "DIMENSIONS"
10984       integer i,m,n
10985       double precision x(n+1),y,yy(0:maxvar),aux
10986 c Tschebyshev polynomial. Note that the first term is omitted
10987 c m=0: the constant term is included
10988 c m=1: the constant term is not included
10989       yy(0)=1.0d0
10990       yy(1)=2.0d0*y
10991       do i=2,n
10992         yy(i)=2*y*yy(i-1)-yy(i-2)
10993       enddo
10994       aux=0.0d0
10995       do i=m,n
10996         aux=aux+x(i+1)*yy(i)*(i+1)
10997 C        print *, x(i+1),yy(i),i
10998       enddo
10999       gradtschebyshev=aux
11000       return
11001       end
11002