source/unres/src_MD-M-SAXS/energy_p_new_barrier.F.safe

   1       subroutine etotal(energia)
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4 #ifndef ISNAN
   5       external proc_proc
   6 #ifdef WINPGI
   7 cMS$ATTRIBUTES C ::  proc_proc
   8 #endif
   9 #endif
  10 #ifdef MPI
  11       include "mpif.h"
  12       double precision weights_(n_ene)
  13 #endif
  14       include 'COMMON.SETUP'
  15       include 'COMMON.IOUNITS'
  16       double precision energia(0:n_ene)
  17       include 'COMMON.LOCAL'
  18       include 'COMMON.FFIELD'
  19       include 'COMMON.DERIV'
  20       include 'COMMON.INTERACT'
  21       include 'COMMON.SBRIDGE'
  22       include 'COMMON.CHAIN'
  23       include 'COMMON.VAR'
  24       include 'COMMON.MD'
  25       include 'COMMON.CONTROL'
  26       include 'COMMON.TIME1'
  27       include 'COMMON.SPLITELE'
  28       include 'COMMON.TORCNSTR'
  29 #ifdef MPI
  30 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  31 c     & " nfgtasks",nfgtasks
  32       if (nfgtasks.gt.1) then
  33         time00=MPI_Wtime()
  34 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  35         if (fg_rank.eq.0) then
  36           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  37 c          print *,"Processor",myrank," BROADCAST iorder"
  38 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  39 C FG slaves as WEIGHTS array.
  40           weights_(1)=wsc
  41           weights_(2)=wscp
  42           weights_(3)=welec
  43           weights_(4)=wcorr
  44           weights_(5)=wcorr5
  45           weights_(6)=wcorr6
  46           weights_(7)=wel_loc
  47           weights_(8)=wturn3
  48           weights_(9)=wturn4
  49           weights_(10)=wturn6
  50           weights_(11)=wang
  51           weights_(12)=wscloc
  52           weights_(13)=wtor
  53           weights_(14)=wtor_d
  54           weights_(15)=wstrain
  55           weights_(16)=wvdwpp
  56           weights_(17)=wbond
  57           weights_(18)=scal14
  58           weights_(21)=wsccor
  59           weights_(22)=wtube
  60           weights_(26)=wsaxs
  61 C FG Master broadcasts the WEIGHTS_ array
  62           call MPI_Bcast(weights_(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64         else
  65 C FG slaves receive the WEIGHTS array
  66           call MPI_Bcast(weights(1),n_ene,
  67      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  68           wsc=weights(1)
  69           wscp=weights(2)
  70           welec=weights(3)
  71           wcorr=weights(4)
  72           wcorr5=weights(5)
  73           wcorr6=weights(6)
  74           wel_loc=weights(7)
  75           wturn3=weights(8)
  76           wturn4=weights(9)
  77           wturn6=weights(10)
  78           wang=weights(11)
  79           wscloc=weights(12)
  80           wtor=weights(13)
  81           wtor_d=weights(14)
  82           wstrain=weights(15)
  83           wvdwpp=weights(16)
  84           wbond=weights(17)
  85           scal14=weights(18)
  86           wsccor=weights(21)
  87           wtube=weights(22)
  88           wsaxs=weights(26)
  89         endif
  90         time_Bcast=time_Bcast+MPI_Wtime()-time00
  91         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  92 c        call chainbuild_cart
  93       endif
  94 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  95 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  96 #else
  97 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  98 c        call int_from_cart1(.false.)
  99 c      endif
 100 #endif
 101 #ifdef TIMING
 102       time00=MPI_Wtime()
 103 #endif
 104 C
 105 C Compute the side-chain and electrostatic interaction energy
 106 C
 107 C      print *,ipot
 108       goto (101,102,103,104,105,106) ipot
 109 C Lennard-Jones potential.
 110   101 call elj(evdw)
 111 cd    print '(a)','Exit ELJ'
 112       goto 107
 113 C Lennard-Jones-Kihara potential (shifted).
 114   102 call eljk(evdw)
 115       goto 107
 116 C Berne-Pechukas potential (dilated LJ, angular dependence).
 117   103 call ebp(evdw)
 118       goto 107
 119 C Gay-Berne potential (shifted LJ, angular dependence).
 120   104 call egb(evdw)
 121 C      print *,"bylem w egb"
 122       goto 107
 123 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 124   105 call egbv(evdw)
 125       goto 107
 126 C Soft-sphere potential
 127   106 call e_softsphere(evdw)
 128 C
 129 C Calculate electrostatic (H-bonding) energy of the main chain.
 130 C
 131   107 continue
 132 cmc
 133 cmc Sep-06: egb takes care of dynamic ss bonds too
 134 cmc
 135 c      if (dyn_ss) call dyn_set_nss
 136
 137 c      print *,"Processor",myrank," computed USCSC"
 138 #ifdef TIMING
 139       time01=MPI_Wtime()
 140 #endif
 141       call vec_and_deriv
 142 #ifdef TIMING
 143       time_vec=time_vec+MPI_Wtime()-time01
 144 #endif
 145 C Introduction of shielding effect first for each peptide group
 146 C the shielding factor is set this factor is describing how each
 147 C peptide group is shielded by side-chains
 148 C the matrix - shield_fac(i) the i index describe the ith between i and i+1
 149 C      write (iout,*) "shield_mode",shield_mode
 150       if (shield_mode.eq.1) then
 151        call set_shield_fac
 152       else if  (shield_mode.eq.2) then
 153        call set_shield_fac2
 154       endif
 155 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 156       if (ipot.lt.6) then
 157 #ifdef SPLITELE
 158          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 159      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 160      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 161      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 162 #else
 163          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 164      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 165      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 166      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 167 #endif
 168             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 169          else
 170             ees=0.0d0
 171             evdw1=0.0d0
 172             eel_loc=0.0d0
 173             eello_turn3=0.0d0
 174             eello_turn4=0.0d0
 175          endif
 176       else
 177         write (iout,*) "Soft-spheer ELEC potential"
 178 c        call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 179 c     &   eello_turn4)
 180       endif
 181 c#ifdef TIMING
 182 c      time_enecalc=time_enecalc+MPI_Wtime()-time00
 183 c#endif
 184 c      print *,"Processor",myrank," computed UELEC"
 185 C
 186 C Calculate excluded-volume interaction energy between peptide groups
 187 C and side chains.
 188 C
 189       if (ipot.lt.6) then
 190        if(wscp.gt.0d0) then
 191         call escp(evdw2,evdw2_14)
 192        else
 193         evdw2=0
 194         evdw2_14=0
 195        endif
 196       else
 197 c        write (iout,*) "Soft-sphere SCP potential"
 198         call escp_soft_sphere(evdw2,evdw2_14)
 199       endif
 200 c
 201 c Calculate the bond-stretching energy
 202 c
 203       call ebond(estr)
 204 C
 205 C Calculate the disulfide-bridge and other energy and the contributions
 206 C from other distance constraints.
 207 cd      write (iout,*) 'Calling EHPB'
 208       call edis(ehpb)
 209 cd    print *,'EHPB exitted succesfully.'
 210 C
 211 C Calculate the virtual-bond-angle energy.
 212 C
 213       if (wang.gt.0d0) then
 214        if (tor_mode.eq.0) then
 215          call ebend(ebe)
 216        else
 217 C ebend kcc is Kubo cumulant clustered rigorous attemp to derive the
 218 C energy function
 219          call ebend_kcc(ebe)
 220        endif
 221       else
 222         ebe=0.0d0
 223       endif
 224       ethetacnstr=0.0d0
 225       if (with_theta_constr) call etheta_constr(ethetacnstr)
 226 c      print *,"Processor",myrank," computed UB"
 227 C
 228 C Calculate the SC local energy.
 229 C
 230 C      print *,"TU DOCHODZE?"
 231       call esc(escloc)
 232 c      print *,"Processor",myrank," computed USC"
 233 C
 234 C Calculate the virtual-bond torsional energy.
 235 C
 236 cd    print *,'nterm=',nterm
 237 C      print *,"tor",tor_mode
 238       if (wtor.gt.0.0d0) then
 239          if (tor_mode.eq.0) then
 240            call etor(etors)
 241          else
 242 C etor kcc is Kubo cumulant clustered rigorous attemp to derive the
 243 C energy function
 244            call etor_kcc(etors)
 245          endif
 246       else
 247         etors=0.0d0
 248       endif
 249       edihcnstr=0.0d0
 250       if (ndih_constr.gt.0) call etor_constr(edihcnstr)
 251 c      print *,"Processor",myrank," computed Utor"
 252 C
 253 C 6/23/01 Calculate double-torsional energy
 254 C
 255       if ((wtor_d.gt.0.0d0).and.(tor_mode.eq.0)) then
 256         call etor_d(etors_d)
 257       else
 258         etors_d=0
 259       endif
 260 c      print *,"Processor",myrank," computed Utord"
 261 C
 262 C 21/5/07 Calculate local sicdechain correlation energy
 263 C
 264       if (wsccor.gt.0.0d0) then
 265         call eback_sc_corr(esccor)
 266       else
 267         esccor=0.0d0
 268       endif
 269 C      print *,"PRZED MULIt"
 270 c      print *,"Processor",myrank," computed Usccorr"
 271 C
 272 C 12/1/95 Multi-body terms
 273 C
 274       n_corr=0
 275       n_corr1=0
 276       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 277      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 278          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 279 c         write(2,*)'MULTIBODY_EELLO n_corr=',n_corr,' n_corr1=',n_corr1,
 280 c     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 281 c        call flush(iout)
 282       else
 283          ecorr=0.0d0
 284          ecorr5=0.0d0
 285          ecorr6=0.0d0
 286          eturn6=0.0d0
 287       endif
 288       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 289 c         write (iout,*) "Before MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,
 290 c     &     n_corr,n_corr1
 291 c         call flush(iout)
 292          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 293 c         write (iout,*) "MULTIBODY_HB ecorr",ecorr,ecorr5,ecorr6,n_corr,
 294 c     &     n_corr1
 295 c         call flush(iout)
 296       endif
 297 c      print *,"Processor",myrank," computed Ucorr"
 298 c      write (iout,*) "nsaxs",nsaxs," saxs_mode",saxs_mode
 299       if (nsaxs.gt.0 .and. saxs_mode.eq.0) then
 300         call e_saxs(Esaxs_constr)
 301 c        write (iout,*) "From Esaxs: Esaxs_constr",Esaxs_constr
 302       else if (nsaxs.gt.0 .and. saxs_mode.gt.0) then
 303         call e_saxsC(Esaxs_constr)
 304 c        write (iout,*) "From EsaxsC: Esaxs_constr",Esaxs_constr
 305       else
 306         Esaxs_constr = 0.0d0
 307       endif
 308 C
 309 C If performing constraint dynamics, call the constraint energy
 310 C  after the equilibration time
 311 c      if(usampl.and.totT.gt.eq_time) then
 312 c      write (iout,*) "usampl",usampl
 313       if(usampl) then
 314          call EconstrQ
 315          if (loc_qlike) then
 316            call Econstr_back_qlike
 317          else
 318            call Econstr_back
 319          endif
 320       else
 321          Uconst=0.0d0
 322          Uconst_back=0.0d0
 323       endif
 324 C 01/27/2015 added by adasko
 325 C the energy component below is energy transfer into lipid environment
 326 C based on partition function
 327 C      print *,"przed lipidami"
 328       if (wliptran.gt.0) then
 329         call Eliptransfer(eliptran)
 330       endif
 331 C      print *,"za lipidami"
 332       if (AFMlog.gt.0) then
 333         call AFMforce(Eafmforce)
 334       else if (selfguide.gt.0) then
 335         call AFMvel(Eafmforce)
 336       endif
 337       if (TUBElog.eq.1) then
 338 C      print *,"just before call"
 339         call calctube(Etube)
 340        elseif (TUBElog.eq.2) then
 341         call calctube2(Etube)
 342        else
 343        Etube=0.0d0
 344        endif
 345
 346 #ifdef TIMING
 347       time_enecalc=time_enecalc+MPI_Wtime()-time00
 348 #endif
 349 c      print *,"Processor",myrank," computed Uconstr"
 350 #ifdef TIMING
 351       time00=MPI_Wtime()
 352 #endif
 353 c
 354 C Sum the energies
 355 C
 356       energia(1)=evdw
 357 #ifdef SCP14
 358       energia(2)=evdw2-evdw2_14
 359       energia(18)=evdw2_14
 360 #else
 361       energia(2)=evdw2
 362       energia(18)=0.0d0
 363 #endif
 364 #ifdef SPLITELE
 365       energia(3)=ees
 366       energia(16)=evdw1
 367 #else
 368       energia(3)=ees+evdw1
 369       energia(16)=0.0d0
 370 #endif
 371       energia(4)=ecorr
 372       energia(5)=ecorr5
 373       energia(6)=ecorr6
 374       energia(7)=eel_loc
 375       energia(8)=eello_turn3
 376       energia(9)=eello_turn4
 377       energia(10)=eturn6
 378       energia(11)=ebe
 379       energia(12)=escloc
 380       energia(13)=etors
 381       energia(14)=etors_d
 382       energia(15)=ehpb
 383       energia(19)=edihcnstr
 384       energia(17)=estr
 385       energia(20)=Uconst+Uconst_back
 386       energia(21)=esccor
 387       energia(22)=eliptran
 388       energia(23)=Eafmforce
 389       energia(24)=ethetacnstr
 390       energia(25)=Etube
 391       energia(26)=Esaxs_constr
 392 c      write (iout,*) "esaxs_constr",energia(26)
 393 c    Here are the energies showed per procesor if the are more processors
 394 c    per molecule then we sum it up in sum_energy subroutine
 395 c      print *," Processor",myrank," calls SUM_ENERGY"
 396       call sum_energy(energia,.true.)
 397 c      write (iout,*) "After sum_energy: esaxs_constr",energia(26)
 398       if (dyn_ss) call dyn_set_nss
 399 c      print *," Processor",myrank," left SUM_ENERGY"
 400 #ifdef TIMING
 401       time_sumene=time_sumene+MPI_Wtime()-time00
 402 #endif
 403       return
 404       end
 405 c-------------------------------------------------------------------------------
 406       subroutine sum_energy(energia,reduce)
 407       implicit real*8 (a-h,o-z)
 408       include 'DIMENSIONS'
 409 #ifndef ISNAN
 410       external proc_proc
 411 #ifdef WINPGI
 412 cMS$ATTRIBUTES C ::  proc_proc
 413 #endif
 414 #endif
 415 #ifdef MPI
 416       include "mpif.h"
 417 #endif
 418       include 'COMMON.SETUP'
 419       include 'COMMON.IOUNITS'
 420       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 421       include 'COMMON.FFIELD'
 422       include 'COMMON.DERIV'
 423       include 'COMMON.INTERACT'
 424       include 'COMMON.SBRIDGE'
 425       include 'COMMON.CHAIN'
 426       include 'COMMON.VAR'
 427       include 'COMMON.CONTROL'
 428       include 'COMMON.TIME1'
 429       logical reduce
 430 #ifdef MPI
 431       if (nfgtasks.gt.1 .and. reduce) then
 432 #ifdef DEBUG
 433         write (iout,*) "energies before REDUCE"
 434         call enerprint(energia)
 435         call flush(iout)
 436 #endif
 437         do i=0,n_ene
 438           enebuff(i)=energia(i)
 439         enddo
 440         time00=MPI_Wtime()
 441         call MPI_Barrier(FG_COMM,IERR)
 442         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 443         time00=MPI_Wtime()
 444         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 445      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 446 #ifdef DEBUG
 447         write (iout,*) "energies after REDUCE"
 448         call enerprint(energia)
 449         call flush(iout)
 450 #endif
 451         time_Reduce=time_Reduce+MPI_Wtime()-time00
 452       endif
 453       if (fg_rank.eq.0) then
 454 #endif
 455       evdw=energia(1)
 456 #ifdef SCP14
 457       evdw2=energia(2)+energia(18)
 458       evdw2_14=energia(18)
 459 #else
 460       evdw2=energia(2)
 461 #endif
 462 #ifdef SPLITELE
 463       ees=energia(3)
 464       evdw1=energia(16)
 465 #else
 466       ees=energia(3)
 467       evdw1=0.0d0
 468 #endif
 469       ecorr=energia(4)
 470       ecorr5=energia(5)
 471       ecorr6=energia(6)
 472       eel_loc=energia(7)
 473       eello_turn3=energia(8)
 474       eello_turn4=energia(9)
 475       eturn6=energia(10)
 476       ebe=energia(11)
 477       escloc=energia(12)
 478       etors=energia(13)
 479       etors_d=energia(14)
 480       ehpb=energia(15)
 481       edihcnstr=energia(19)
 482       estr=energia(17)
 483       Uconst=energia(20)
 484       esccor=energia(21)
 485       eliptran=energia(22)
 486       Eafmforce=energia(23)
 487       ethetacnstr=energia(24)
 488       Etube=energia(25)
 489       esaxs_constr=energia(26)
 490 #ifdef SPLITELE
 491       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 492      & +wang*ebe+wtor*etors+wscloc*escloc
 493      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 494      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 495      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 496      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran+Eafmforce
 497      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr
 498 #else
 499       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 500      & +wang*ebe+wtor*etors+wscloc*escloc
 501      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 502      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 503      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 504      & +wbond*estr+wumb*Uconst+wsccor*esccor+wliptran*eliptran
 505      & +Eafmforce
 506      & +ethetacnstr+wtube*Etube+wsaxs*esaxs_constr
 507 #endif
 508       energia(0)=etot
 509 c detecting NaNQ
 510 #ifdef ISNAN
 511 #ifdef AIX
 512       if (isnan(etot).ne.0) energia(0)=1.0d+99
 513 #else
 514       if (isnan(etot)) energia(0)=1.0d+99
 515 #endif
 516 #else
 517       i=0
 518 #ifdef WINPGI
 519       idumm=proc_proc(etot,i)
 520 #else
 521       call proc_proc(etot,i)
 522 #endif
 523       if(i.eq.1)energia(0)=1.0d+99
 524 #endif
 525 #ifdef MPI
 526       endif
 527 #endif
 528       return
 529       end
 530 c-------------------------------------------------------------------------------
 531       subroutine sum_gradient
 532       implicit real*8 (a-h,o-z)
 533       include 'DIMENSIONS'
 534 #ifndef ISNAN
 535       external proc_proc
 536 #ifdef WINPGI
 537 cMS$ATTRIBUTES C ::  proc_proc
 538 #endif
 539 #endif
 540 #ifdef MPI
 541       include 'mpif.h'
 542 #endif
 543       double precision gradbufc(3,-1:maxres),gradbufx(3,-1:maxres),
 544      & glocbuf(4*maxres),gradbufc_sum(3,-1:maxres)
 545      & ,gloc_scbuf(3,-1:maxres)
 546       include 'COMMON.SETUP'
 547       include 'COMMON.IOUNITS'
 548       include 'COMMON.FFIELD'
 549       include 'COMMON.DERIV'
 550       include 'COMMON.INTERACT'
 551       include 'COMMON.SBRIDGE'
 552       include 'COMMON.CHAIN'
 553       include 'COMMON.VAR'
 554       include 'COMMON.CONTROL'
 555       include 'COMMON.TIME1'
 556       include 'COMMON.MAXGRAD'
 557       include 'COMMON.SCCOR'
 558 #ifdef TIMING
 559       time01=MPI_Wtime()
 560 #endif
 561 #ifdef DEBUG
 562       write (iout,*) "sum_gradient gvdwc, gvdwx"
 563       do i=1,nres
 564         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 565      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 566       enddo
 567       call flush(iout)
 568 #endif
 569 #ifdef DEBUG
 570       write (iout,*) "sum_gradient gsaxsc, gsaxsx"
 571       do i=0,nres
 572         write (iout,'(i3,3e15.5,5x,3e15.5)')
 573      &   i,(gsaxsc(j,i),j=1,3),(gsaxsx(j,i),j=1,3)
 574       enddo
 575       call flush(iout)
 576 #endif
 577 #ifdef MPI
 578 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 579         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 580      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 581 #endif
 582 C
 583 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 584 C            in virtual-bond-vector coordinates
 585 C
 586 #ifdef DEBUG
 587 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 588 c      do i=1,nres-1
 589 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 590 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 591 c      enddo
 592 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 593 c      do i=1,nres-1
 594 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 595 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 596 c      enddo
 597       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 598       do i=1,nres
 599         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 600      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 601      &   g_corr5_loc(i)
 602       enddo
 603       call flush(iout)
 604 #endif
 605 #ifdef DEBUG
 606       write (iout,*) "gsaxsc"
 607       do i=1,nres
 608         write (iout,'(i3,3f10.5)') i,(wsaxs*gsaxsc(j,i),j=1,3)
 609       enddo
 610       call flush(iout)
 611 #endif
 612 #ifdef SPLITELE
 613       do i=0,nct
 614         do j=1,3
 615           gradbufc(j,i)=wsc*gvdwc(j,i)+
 616      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 617      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 618      &                wel_loc*gel_loc_long(j,i)+
 619      &                wcorr*gradcorr_long(j,i)+
 620      &                wcorr5*gradcorr5_long(j,i)+
 621      &                wcorr6*gradcorr6_long(j,i)+
 622      &                wturn6*gcorr6_turn_long(j,i)+
 623      &                wstrain*ghpbc(j,i)
 624      &                +wliptran*gliptranc(j,i)
 625      &                +gradafm(j,i)
 626      &                 +welec*gshieldc(j,i)
 627      &                 +wcorr*gshieldc_ec(j,i)
 628      &                 +wturn3*gshieldc_t3(j,i)
 629      &                 +wturn4*gshieldc_t4(j,i)
 630      &                 +wel_loc*gshieldc_ll(j,i)
 631      &                +wtube*gg_tube(j,i)
 632      &                +wsaxs*gsaxsc(j,i)
 633
 634
 635
 636         enddo
 637       enddo
 638 #else
 639       do i=0,nct
 640         do j=1,3
 641           gradbufc(j,i)=wsc*gvdwc(j,i)+
 642      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 643      &                welec*gelc_long(j,i)+
 644      &                wbond*gradb(j,i)+
 645      &                wel_loc*gel_loc_long(j,i)+
 646      &                wcorr*gradcorr_long(j,i)+
 647      &                wcorr5*gradcorr5_long(j,i)+
 648      &                wcorr6*gradcorr6_long(j,i)+
 649      &                wturn6*gcorr6_turn_long(j,i)+
 650      &                wstrain*ghpbc(j,i)
 651      &                +wliptran*gliptranc(j,i)
 652      &                +gradafm(j,i)
 653      &                 +welec*gshieldc(j,i)
 654      &                 +wcorr*gshieldc_ec(j,i)
 655      &                 +wturn4*gshieldc_t4(j,i)
 656      &                 +wel_loc*gshieldc_ll(j,i)
 657      &                +wtube*gg_tube(j,i)
 658      &                +wsaxs*gsaxsc(j,i)
 659
 660
 661
 662         enddo
 663       enddo
 664 #endif
 665 #ifdef DEBUG
 666       write (iout,*) "gradc from gradbufc"
 667       do i=1,nres
 668         write (iout,'(i3,3f10.5)') i,(gradc(j,i,icg),j=1,3)
 669       enddo
 670       call flush(iout)
 671 #endif
 672 #ifdef MPI
 673       if (nfgtasks.gt.1) then
 674       time00=MPI_Wtime()
 675 #ifdef DEBUG
 676       write (iout,*) "gradbufc before allreduce"
 677       do i=1,nres
 678         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 679       enddo
 680       call flush(iout)
 681 #endif
 682       do i=0,nres
 683         do j=1,3
 684           gradbufc_sum(j,i)=gradbufc(j,i)
 685         enddo
 686       enddo
 687 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 688 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 689 c      time_reduce=time_reduce+MPI_Wtime()-time00
 690 #ifdef DEBUG
 691 c      write (iout,*) "gradbufc_sum after allreduce"
 692 c      do i=1,nres
 693 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 694 c      enddo
 695 c      call flush(iout)
 696 #endif
 697 #ifdef TIMING
 698 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 699 #endif
 700       do i=nnt,nres
 701         do k=1,3
 702           gradbufc(k,i)=0.0d0
 703         enddo
 704       enddo
 705 #ifdef DEBUG
 706       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 707       write (iout,*) (i," jgrad_start",jgrad_start(i),
 708      &                  " jgrad_end  ",jgrad_end(i),
 709      &                  i=igrad_start,igrad_end)
 710 #endif
 711 c
 712 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 713 c do not parallelize this part.
 714 c
 715 c      do i=igrad_start,igrad_end
 716 c        do j=jgrad_start(i),jgrad_end(i)
 717 c          do k=1,3
 718 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 719 c          enddo
 720 c        enddo
 721 c      enddo
 722       do j=1,3
 723         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 724       enddo
 725       do i=nres-2,-1,-1
 726         do j=1,3
 727           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 728         enddo
 729       enddo
 730 #ifdef DEBUG
 731       write (iout,*) "gradbufc after summing"
 732       do i=1,nres
 733         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 734       enddo
 735       call flush(iout)
 736 #endif
 737       else
 738 #endif
 739 #ifdef DEBUG
 740       write (iout,*) "gradbufc"
 741       do i=1,nres
 742         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 743       enddo
 744       call flush(iout)
 745 #endif
 746       do i=-1,nres
 747         do j=1,3
 748           gradbufc_sum(j,i)=gradbufc(j,i)
 749           gradbufc(j,i)=0.0d0
 750         enddo
 751       enddo
 752       do j=1,3
 753         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 754       enddo
 755       do i=nres-2,-1,-1
 756         do j=1,3
 757           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 758         enddo
 759       enddo
 760 c      do i=nnt,nres-1
 761 c        do k=1,3
 762 c          gradbufc(k,i)=0.0d0
 763 c        enddo
 764 c        do j=i+1,nres
 765 c          do k=1,3
 766 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 767 c          enddo
 768 c        enddo
 769 c      enddo
 770 #ifdef DEBUG
 771       write (iout,*) "gradbufc after summing"
 772       do i=1,nres
 773         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 774       enddo
 775       call flush(iout)
 776 #endif
 777 #ifdef MPI
 778       endif
 779 #endif
 780       do k=1,3
 781         gradbufc(k,nres)=0.0d0
 782       enddo
 783       do i=-1,nct
 784         do j=1,3
 785 #ifdef SPLITELE
 786 C          print *,gradbufc(1,13)
 787 C          print *,welec*gelc(1,13)
 788 C          print *,wel_loc*gel_loc(1,13)
 789 C          print *,0.5d0*(wscp*gvdwc_scpp(1,13))
 790 C          print *,welec*gelc_long(1,13)+wvdwpp*gvdwpp(1,13)
 791 C          print *,wel_loc*gel_loc_long(1,13)
 792 C          print *,gradafm(1,13),"AFM"
 793           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 794      &                wel_loc*gel_loc(j,i)+
 795      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 796      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 797      &                wel_loc*gel_loc_long(j,i)+
 798      &                wcorr*gradcorr_long(j,i)+
 799      &                wcorr5*gradcorr5_long(j,i)+
 800      &                wcorr6*gradcorr6_long(j,i)+
 801      &                wturn6*gcorr6_turn_long(j,i))+
 802      &                wbond*gradb(j,i)+
 803      &                wcorr*gradcorr(j,i)+
 804      &                wturn3*gcorr3_turn(j,i)+
 805      &                wturn4*gcorr4_turn(j,i)+
 806      &                wcorr5*gradcorr5(j,i)+
 807      &                wcorr6*gradcorr6(j,i)+
 808      &                wturn6*gcorr6_turn(j,i)+
 809      &                wsccor*gsccorc(j,i)
 810      &               +wscloc*gscloc(j,i)
 811      &               +wliptran*gliptranc(j,i)
 812      &                +gradafm(j,i)
 813      &                 +welec*gshieldc(j,i)
 814      &                 +welec*gshieldc_loc(j,i)
 815      &                 +wcorr*gshieldc_ec(j,i)
 816      &                 +wcorr*gshieldc_loc_ec(j,i)
 817      &                 +wturn3*gshieldc_t3(j,i)
 818      &                 +wturn3*gshieldc_loc_t3(j,i)
 819      &                 +wturn4*gshieldc_t4(j,i)
 820      &                 +wturn4*gshieldc_loc_t4(j,i)
 821      &                 +wel_loc*gshieldc_ll(j,i)
 822      &                 +wel_loc*gshieldc_loc_ll(j,i)
 823      &                +wtube*gg_tube(j,i)
 824
 825 #else
 826           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 827      &                wel_loc*gel_loc(j,i)+
 828      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 829      &                welec*gelc_long(j,i)+
 830      &                wel_loc*gel_loc_long(j,i)+
 831      &                wcorr*gcorr_long(j,i)+
 832      &                wcorr5*gradcorr5_long(j,i)+
 833      &                wcorr6*gradcorr6_long(j,i)+
 834      &                wturn6*gcorr6_turn_long(j,i))+
 835      &                wbond*gradb(j,i)+
 836      &                wcorr*gradcorr(j,i)+
 837      &                wturn3*gcorr3_turn(j,i)+
 838      &                wturn4*gcorr4_turn(j,i)+
 839      &                wcorr5*gradcorr5(j,i)+
 840      &                wcorr6*gradcorr6(j,i)+
 841      &                wturn6*gcorr6_turn(j,i)+
 842      &                wsccor*gsccorc(j,i)
 843      &               +wscloc*gscloc(j,i)
 844      &               +wliptran*gliptranc(j,i)
 845      &                +gradafm(j,i)
 846      &                 +welec*gshieldc(j,i)
 847      &                 +welec*gshieldc_loc(j,i)
 848      &                 +wcorr*gshieldc_ec(j,i)
 849      &                 +wcorr*gshieldc_loc_ec(j,i)
 850      &                 +wturn3*gshieldc_t3(j,i)
 851      &                 +wturn3*gshieldc_loc_t3(j,i)
 852      &                 +wturn4*gshieldc_t4(j,i)
 853      &                 +wturn4*gshieldc_loc_t4(j,i)
 854      &                 +wel_loc*gshieldc_ll(j,i)
 855      &                 +wel_loc*gshieldc_loc_ll(j,i)
 856      &                +wtube*gg_tube(j,i)
 857
 858
 859 #endif
 860           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 861      &                  wbond*gradbx(j,i)+
 862      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 863      &                  wsccor*gsccorx(j,i)
 864      &                 +wscloc*gsclocx(j,i)
 865      &                 +wliptran*gliptranx(j,i)
 866      &                 +welec*gshieldx(j,i)
 867      &                 +wcorr*gshieldx_ec(j,i)
 868      &                 +wturn3*gshieldx_t3(j,i)
 869      &                 +wturn4*gshieldx_t4(j,i)
 870      &                 +wel_loc*gshieldx_ll(j,i)
 871      &                 +wtube*gg_tube_sc(j,i)
 872      &                 +wsaxs*gsaxsx(j,i)
 873
 874
 875
 876         enddo
 877       enddo
 878 #ifdef DEBUG
 879       write (iout,*) "gradc gradx gloc after adding"
 880       do i=1,nres
 881         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 882      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 883       enddo
 884 #endif
 885 #ifdef DEBUG
 886       write (iout,*) "gloc before adding corr"
 887       do i=1,4*nres
 888         write (iout,*) i,gloc(i,icg)
 889       enddo
 890 #endif
 891       do i=1,nres-3
 892         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 893      &   +wcorr5*g_corr5_loc(i)
 894      &   +wcorr6*g_corr6_loc(i)
 895      &   +wturn4*gel_loc_turn4(i)
 896      &   +wturn3*gel_loc_turn3(i)
 897      &   +wturn6*gel_loc_turn6(i)
 898      &   +wel_loc*gel_loc_loc(i)
 899       enddo
 900 #ifdef DEBUG
 901       write (iout,*) "gloc after adding corr"
 902       do i=1,4*nres
 903         write (iout,*) i,gloc(i,icg)
 904       enddo
 905 #endif
 906 #ifdef MPI
 907       if (nfgtasks.gt.1) then
 908         do j=1,3
 909           do i=1,nres
 910             gradbufc(j,i)=gradc(j,i,icg)
 911             gradbufx(j,i)=gradx(j,i,icg)
 912           enddo
 913         enddo
 914         do i=1,4*nres
 915           glocbuf(i)=gloc(i,icg)
 916         enddo
 917 c#define DEBUG
 918 #ifdef DEBUG
 919       write (iout,*) "gloc_sc before reduce"
 920       do i=1,nres
 921        do j=1,1
 922         write (iout,*) i,j,gloc_sc(j,i,icg)
 923        enddo
 924       enddo
 925 #endif
 926 c#undef DEBUG
 927         do i=1,nres
 928          do j=1,3
 929           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 930          enddo
 931         enddo
 932         time00=MPI_Wtime()
 933         call MPI_Barrier(FG_COMM,IERR)
 934         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 935         time00=MPI_Wtime()
 936         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 937      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 938         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 939      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 940         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 941      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 942         time_reduce=time_reduce+MPI_Wtime()-time00
 943         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 944      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 945         time_reduce=time_reduce+MPI_Wtime()-time00
 946 #ifdef DEBUG
 947       write (iout,*) "gradc after reduce"
 948       do i=1,nres
 949        do j=1,3
 950         write (iout,*) i,j,gradc(j,i,icg)
 951        enddo
 952       enddo
 953 #endif
 954 #ifdef DEBUG
 955       write (iout,*) "gloc_sc after reduce"
 956       do i=1,nres
 957        do j=1,1
 958         write (iout,*) i,j,gloc_sc(j,i,icg)
 959        enddo
 960       enddo
 961 #endif
 962 #ifdef DEBUG
 963       write (iout,*) "gloc after reduce"
 964       do i=1,4*nres
 965         write (iout,*) i,gloc(i,icg)
 966       enddo
 967 #endif
 968       endif
 969 #endif
 970       if (gnorm_check) then
 971 c
 972 c Compute the maximum elements of the gradient
 973 c
 974       gvdwc_max=0.0d0
 975       gvdwc_scp_max=0.0d0
 976       gelc_max=0.0d0
 977       gvdwpp_max=0.0d0
 978       gradb_max=0.0d0
 979       ghpbc_max=0.0d0
 980       gradcorr_max=0.0d0
 981       gel_loc_max=0.0d0
 982       gcorr3_turn_max=0.0d0
 983       gcorr4_turn_max=0.0d0
 984       gradcorr5_max=0.0d0
 985       gradcorr6_max=0.0d0
 986       gcorr6_turn_max=0.0d0
 987       gsccorc_max=0.0d0
 988       gscloc_max=0.0d0
 989       gvdwx_max=0.0d0
 990       gradx_scp_max=0.0d0
 991       ghpbx_max=0.0d0
 992       gradxorr_max=0.0d0
 993       gsccorx_max=0.0d0
 994       gsclocx_max=0.0d0
 995       do i=1,nct
 996         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 997         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 998         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 999         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
1000      &   gvdwc_scp_max=gvdwc_scp_norm
1001         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
1002         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
1003         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
1004         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
1005         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
1006         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
1007         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
1008         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
1009         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
1010         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
1011         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
1012         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
1013         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
1014      &    gcorr3_turn(1,i)))
1015         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
1016      &    gcorr3_turn_max=gcorr3_turn_norm
1017         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
1018      &    gcorr4_turn(1,i)))
1019         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
1020      &    gcorr4_turn_max=gcorr4_turn_norm
1021         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
1022         if (gradcorr5_norm.gt.gradcorr5_max)
1023      &    gradcorr5_max=gradcorr5_norm
1024         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
1025         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
1026         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
1027      &    gcorr6_turn(1,i)))
1028         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
1029      &    gcorr6_turn_max=gcorr6_turn_norm
1030         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
1031         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
1032         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
1033         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
1034         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
1035         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
1036         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
1037         if (gradx_scp_norm.gt.gradx_scp_max)
1038      &    gradx_scp_max=gradx_scp_norm
1039         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
1040         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
1041         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
1042         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
1043         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
1044         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
1045         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
1046         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
1047       enddo
1048       if (gradout) then
1049 #if (defined AIX || defined CRAY)
1050         open(istat,file=statname,position="append")
1051 #else
1052         open(istat,file=statname,access="append")
1053 #endif
1054         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
1055      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
1056      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
1057      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
1058      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
1059      &     gsccorx_max,gsclocx_max
1060         close(istat)
1061         if (gvdwc_max.gt.1.0d4) then
1062           write (iout,*) "gvdwc gvdwx gradb gradbx"
1063           do i=nnt,nct
1064             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
1065      &        gradb(j,i),gradbx(j,i),j=1,3)
1066           enddo
1067           call pdbout(0.0d0,'cipiszcze',iout)
1068           call flush(iout)
1069         endif
1070       endif
1071       endif
1072 #ifdef DEBUG
1073       write (iout,*) "gradc gradx gloc"
1074       do i=1,nres
1075         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
1076      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
1077       enddo
1078 #endif
1079 #ifdef TIMING
1080       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
1081 #endif
1082       return
1083       end
1084 c-------------------------------------------------------------------------------
1085       subroutine rescale_weights(t_bath)
1086       implicit real*8 (a-h,o-z)
1087       include 'DIMENSIONS'
1088       include 'COMMON.IOUNITS'
1089       include 'COMMON.FFIELD'
1090       include 'COMMON.SBRIDGE'
1091       include 'COMMON.CONTROL'
1092       double precision kfac /2.4d0/
1093       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
1094 c      facT=temp0/t_bath
1095 c      facT=2*temp0/(t_bath+temp0)
1096       if (rescale_mode.eq.0) then
1097         facT=1.0d0
1098         facT2=1.0d0
1099         facT3=1.0d0
1100         facT4=1.0d0
1101         facT5=1.0d0
1102       else if (rescale_mode.eq.1) then
1103         facT=kfac/(kfac-1.0d0+t_bath/temp0)
1104         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
1105         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
1106         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
1107         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
1108       else if (rescale_mode.eq.2) then
1109         x=t_bath/temp0
1110         x2=x*x
1111         x3=x2*x
1112         x4=x3*x
1113         x5=x4*x
1114         facT=licznik/dlog(dexp(x)+dexp(-x))
1115         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
1116         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
1117         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
1118         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
1119       else
1120         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
1121         write (*,*) "Wrong RESCALE_MODE",rescale_mode
1122 #ifdef MPI
1123        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
1124 #endif
1125        stop 555
1126       endif
1127       if (shield_mode.gt.0) then
1128        wscp=weights(2)*fact
1129        wsc=weights(1)*fact
1130        wvdwpp=weights(16)*fact
1131       endif
1132       welec=weights(3)*fact
1133       wcorr=weights(4)*fact3
1134       wcorr5=weights(5)*fact4
1135       wcorr6=weights(6)*fact5
1136       wel_loc=weights(7)*fact2
1137       wturn3=weights(8)*fact2
1138       wturn4=weights(9)*fact3
1139       wturn6=weights(10)*fact5
1140       wtor=weights(13)*fact
1141       wtor_d=weights(14)*fact2
1142       wsccor=weights(21)*fact
1143       if (scale_umb) wumb=t_bath/temp0
1144 c      write (iout,*) "scale_umb",scale_umb
1145 c      write (iout,*) "t_bath",t_bath," temp0",temp0," wumb",wumb
1146
1147       return
1148       end
1149 C------------------------------------------------------------------------
1150       subroutine enerprint(energia)
1151       implicit real*8 (a-h,o-z)
1152       include 'DIMENSIONS'
1153       include 'COMMON.IOUNITS'
1154       include 'COMMON.FFIELD'
1155       include 'COMMON.SBRIDGE'
1156       include 'COMMON.MD'
1157       double precision energia(0:n_ene)
1158       etot=energia(0)
1159       evdw=energia(1)
1160       evdw2=energia(2)
1161 #ifdef SCP14
1162       evdw2=energia(2)+energia(18)
1163 #else
1164       evdw2=energia(2)
1165 #endif
1166       ees=energia(3)
1167 #ifdef SPLITELE
1168       evdw1=energia(16)
1169 #endif
1170       ecorr=energia(4)
1171       ecorr5=energia(5)
1172       ecorr6=energia(6)
1173       eel_loc=energia(7)
1174       eello_turn3=energia(8)
1175       eello_turn4=energia(9)
1176       eello_turn6=energia(10)
1177       ebe=energia(11)
1178       escloc=energia(12)
1179       etors=energia(13)
1180       etors_d=energia(14)
1181       ehpb=energia(15)
1182       edihcnstr=energia(19)
1183       estr=energia(17)
1184       Uconst=energia(20)
1185       esccor=energia(21)
1186       eliptran=energia(22)
1187       Eafmforce=energia(23)
1188       ethetacnstr=energia(24)
1189       etube=energia(25)
1190       esaxs=energia(26)
1191 #ifdef SPLITELE
1192       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
1193      &  estr,wbond,ebe,wang,
1194      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1195      &  ecorr,wcorr,
1196      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1197      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,edihcnstr,
1198      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1199      &  etube,wtube,esaxs,wsaxs,
1200      &  etot
1201    10 format (/'Virtual-chain energies:'//
1202      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1203      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1204      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1205      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
1206      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1207      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1208      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1209      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1210      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1211      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1212      & ' (SS bridges & dist. cnstr.)'/
1213      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1214      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1215      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1216      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1217      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1218      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1219      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1220      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1221      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1222      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1223      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1224      & 'UCONST=',1pE16.6,' WEIGHT=',1pD16.6' (umbrella restraints)'/
1225      & 'ELT=   ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
1226      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1227      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (tube confinment)'/
1228      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
1229      & 'ETOT=  ',1pE16.6,' (total)')
1230
1231 #else
1232       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1233      &  estr,wbond,ebe,wang,
1234      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1235      &  ecorr,wcorr,
1236      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1237      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1238      &  ethetacnstr,ebr*nss,Uconst,wumb,eliptran,wliptran,Eafmforc,
1239      &  etube,wtube,esaxs,wsaxs,
1240      &  etot
1241    10 format (/'Virtual-chain energies:'//
1242      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1243      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1244      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1245      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1246      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1247      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1248      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1249      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1250      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1251      & ' (SS bridges & dist. restr.)'/
1252      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1253      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1254      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1255      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1256      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1257      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1258      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1259      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1260      & 'EDIHC= ',1pE16.6,' (virtual-bond dihedral angle restraints)'/
1261      & 'ETHETC=',1pE16.6,' (virtual-bond angle restraints)'/
1262      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1263      & 'UCONST=',1pE16.6,' WEIGHT=',1pD16.6' (umbrella restraints)'/
1264      & 'ELT=   ',1pE16.6,' WEIGHT=',1pD16.6,' (Lipid transfer)'/
1265      & 'EAFM=  ',1pE16.6,' (atomic-force microscopy)'/
1266      & 'ETUBE= ',1pE16.6,' WEIGHT=',1pD16.6,' (tube confinment)'/
1267      & 'E_SAXS=',1pE16.6,' WEIGHT=',1pD16.6,' (SAXS restraints)'/
1268      & 'ETOT=  ',1pE16.6,' (total)')
1269 #endif
1270       return
1271       end
1272 C-----------------------------------------------------------------------
1273       subroutine elj(evdw)
1274 C
1275 C This subroutine calculates the interaction energy of nonbonded side chains
1276 C assuming the LJ potential of interaction.
1277 C
1278       implicit real*8 (a-h,o-z)
1279       include 'DIMENSIONS'
1280       parameter (accur=1.0d-10)
1281       include 'COMMON.GEO'
1282       include 'COMMON.VAR'
1283       include 'COMMON.LOCAL'
1284       include 'COMMON.CHAIN'
1285       include 'COMMON.DERIV'
1286       include 'COMMON.INTERACT'
1287       include 'COMMON.TORSION'
1288       include 'COMMON.SBRIDGE'
1289       include 'COMMON.NAMES'
1290       include 'COMMON.IOUNITS'
1291       include 'COMMON.CONTACTS'
1292       dimension gg(3)
1293 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1294       evdw=0.0D0
1295       do i=iatsc_s,iatsc_e
1296         itypi=iabs(itype(i))
1297         if (itypi.eq.ntyp1) cycle
1298         itypi1=iabs(itype(i+1))
1299         xi=c(1,nres+i)
1300         yi=c(2,nres+i)
1301         zi=c(3,nres+i)
1302 C Change 12/1/95
1303         num_conti=0
1304 C
1305 C Calculate SC interaction energy.
1306 C
1307         do iint=1,nint_gr(i)
1308 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1309 cd   &                  'iend=',iend(i,iint)
1310           do j=istart(i,iint),iend(i,iint)
1311             itypj=iabs(itype(j))
1312             if (itypj.eq.ntyp1) cycle
1313             xj=c(1,nres+j)-xi
1314             yj=c(2,nres+j)-yi
1315             zj=c(3,nres+j)-zi
1316 C Change 12/1/95 to calculate four-body interactions
1317             rij=xj*xj+yj*yj+zj*zj
1318             rrij=1.0D0/rij
1319 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1320             eps0ij=eps(itypi,itypj)
1321             fac=rrij**expon2
1322 C have you changed here?
1323             e1=fac*fac*aa
1324             e2=fac*bb
1325             evdwij=e1+e2
1326 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1327 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1328 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1329 cd   &        restyp(itypi),i,restyp(itypj),j,a(itypi,itypj),
1330 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1331 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1332             evdw=evdw+evdwij
1333 C
1334 C Calculate the components of the gradient in DC and X
1335 C
1336             fac=-rrij*(e1+evdwij)
1337             gg(1)=xj*fac
1338             gg(2)=yj*fac
1339             gg(3)=zj*fac
1340             do k=1,3
1341               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1342               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1343               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1344               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1345             enddo
1346 cgrad            do k=i,j-1
1347 cgrad              do l=1,3
1348 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1349 cgrad              enddo
1350 cgrad            enddo
1351 C
1352 C 12/1/95, revised on 5/20/97
1353 C
1354 C Calculate the contact function. The ith column of the array JCONT will
1355 C contain the numbers of atoms that make contacts with the atom I (of numbers
1356 C greater than I). The arrays FACONT and GACONT will contain the values of
1357 C the contact function and its derivative.
1358 C
1359 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1360 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1361 C Uncomment next line, if the correlation interactions are contact function only
1362             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1363               rij=dsqrt(rij)
1364               sigij=sigma(itypi,itypj)
1365               r0ij=rs0(itypi,itypj)
1366 C
1367 C Check whether the SC's are not too far to make a contact.
1368 C
1369               rcut=1.5d0*r0ij
1370               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1371 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1372 C
1373               if (fcont.gt.0.0D0) then
1374 C If the SC-SC distance if close to sigma, apply spline.
1375 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1376 cAdam &             fcont1,fprimcont1)
1377 cAdam           fcont1=1.0d0-fcont1
1378 cAdam           if (fcont1.gt.0.0d0) then
1379 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1380 cAdam             fcont=fcont*fcont1
1381 cAdam           endif
1382 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1383 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1384 cga             do k=1,3
1385 cga               gg(k)=gg(k)*eps0ij
1386 cga             enddo
1387 cga             eps0ij=-evdwij*eps0ij
1388 C Uncomment for AL's type of SC correlation interactions.
1389 cadam           eps0ij=-evdwij
1390                 num_conti=num_conti+1
1391                 jcont(num_conti,i)=j
1392                 facont(num_conti,i)=fcont*eps0ij
1393                 fprimcont=eps0ij*fprimcont/rij
1394                 fcont=expon*fcont
1395 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1396 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1397 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1398 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1399                 gacont(1,num_conti,i)=-fprimcont*xj
1400                 gacont(2,num_conti,i)=-fprimcont*yj
1401                 gacont(3,num_conti,i)=-fprimcont*zj
1402 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1403 cd              write (iout,'(2i3,3f10.5)')
1404 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1405               endif
1406             endif
1407           enddo      ! j
1408         enddo        ! iint
1409 C Change 12/1/95
1410         num_cont(i)=num_conti
1411       enddo          ! i
1412       do i=1,nct
1413         do j=1,3
1414           gvdwc(j,i)=expon*gvdwc(j,i)
1415           gvdwx(j,i)=expon*gvdwx(j,i)
1416         enddo
1417       enddo
1418 C******************************************************************************
1419 C
1420 C                              N O T E !!!
1421 C
1422 C To save time, the factor of EXPON has been extracted from ALL components
1423 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1424 C use!
1425 C
1426 C******************************************************************************
1427       return
1428       end
1429 C-----------------------------------------------------------------------------
1430       subroutine eljk(evdw)
1431 C
1432 C This subroutine calculates the interaction energy of nonbonded side chains
1433 C assuming the LJK potential of interaction.
1434 C
1435       implicit real*8 (a-h,o-z)
1436       include 'DIMENSIONS'
1437       include 'COMMON.GEO'
1438       include 'COMMON.VAR'
1439       include 'COMMON.LOCAL'
1440       include 'COMMON.CHAIN'
1441       include 'COMMON.DERIV'
1442       include 'COMMON.INTERACT'
1443       include 'COMMON.IOUNITS'
1444       include 'COMMON.NAMES'
1445       dimension gg(3)
1446       logical scheck
1447 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1448       evdw=0.0D0
1449       do i=iatsc_s,iatsc_e
1450         itypi=iabs(itype(i))
1451         if (itypi.eq.ntyp1) cycle
1452         itypi1=iabs(itype(i+1))
1453         xi=c(1,nres+i)
1454         yi=c(2,nres+i)
1455         zi=c(3,nres+i)
1456 C
1457 C Calculate SC interaction energy.
1458 C
1459         do iint=1,nint_gr(i)
1460           do j=istart(i,iint),iend(i,iint)
1461             itypj=iabs(itype(j))
1462             if (itypj.eq.ntyp1) cycle
1463             xj=c(1,nres+j)-xi
1464             yj=c(2,nres+j)-yi
1465             zj=c(3,nres+j)-zi
1466             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1467             fac_augm=rrij**expon
1468             e_augm=augm(itypi,itypj)*fac_augm
1469             r_inv_ij=dsqrt(rrij)
1470             rij=1.0D0/r_inv_ij
1471             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1472             fac=r_shift_inv**expon
1473 C have you changed here?
1474             e1=fac*fac*aa
1475             e2=fac*bb
1476             evdwij=e_augm+e1+e2
1477 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1478 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1479 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1480 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1481 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1482 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1483 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1484             evdw=evdw+evdwij
1485 C
1486 C Calculate the components of the gradient in DC and X
1487 C
1488             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1489             gg(1)=xj*fac
1490             gg(2)=yj*fac
1491             gg(3)=zj*fac
1492             do k=1,3
1493               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1494               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1495               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1496               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1497             enddo
1498 cgrad            do k=i,j-1
1499 cgrad              do l=1,3
1500 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1501 cgrad              enddo
1502 cgrad            enddo
1503           enddo      ! j
1504         enddo        ! iint
1505       enddo          ! i
1506       do i=1,nct
1507         do j=1,3
1508           gvdwc(j,i)=expon*gvdwc(j,i)
1509           gvdwx(j,i)=expon*gvdwx(j,i)
1510         enddo
1511       enddo
1512       return
1513       end
1514 C-----------------------------------------------------------------------------
1515       subroutine ebp(evdw)
1516 C
1517 C This subroutine calculates the interaction energy of nonbonded side chains
1518 C assuming the Berne-Pechukas potential of interaction.
1519 C
1520       implicit real*8 (a-h,o-z)
1521       include 'DIMENSIONS'
1522       include 'COMMON.GEO'
1523       include 'COMMON.VAR'
1524       include 'COMMON.LOCAL'
1525       include 'COMMON.CHAIN'
1526       include 'COMMON.DERIV'
1527       include 'COMMON.NAMES'
1528       include 'COMMON.INTERACT'
1529       include 'COMMON.IOUNITS'
1530       include 'COMMON.CALC'
1531       common /srutu/ icall
1532 c     double precision rrsave(maxdim)
1533       logical lprn
1534       evdw=0.0D0
1535 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1536       evdw=0.0D0
1537 c     if (icall.eq.0) then
1538 c       lprn=.true.
1539 c     else
1540         lprn=.false.
1541 c     endif
1542       ind=0
1543       do i=iatsc_s,iatsc_e
1544         itypi=iabs(itype(i))
1545         if (itypi.eq.ntyp1) cycle
1546         itypi1=iabs(itype(i+1))
1547         xi=c(1,nres+i)
1548         yi=c(2,nres+i)
1549         zi=c(3,nres+i)
1550         dxi=dc_norm(1,nres+i)
1551         dyi=dc_norm(2,nres+i)
1552         dzi=dc_norm(3,nres+i)
1553 c        dsci_inv=dsc_inv(itypi)
1554         dsci_inv=vbld_inv(i+nres)
1555 C
1556 C Calculate SC interaction energy.
1557 C
1558         do iint=1,nint_gr(i)
1559           do j=istart(i,iint),iend(i,iint)
1560             ind=ind+1
1561             itypj=iabs(itype(j))
1562             if (itypj.eq.ntyp1) cycle
1563 c            dscj_inv=dsc_inv(itypj)
1564             dscj_inv=vbld_inv(j+nres)
1565             chi1=chi(itypi,itypj)
1566             chi2=chi(itypj,itypi)
1567             chi12=chi1*chi2
1568             chip1=chip(itypi)
1569             chip2=chip(itypj)
1570             chip12=chip1*chip2
1571             alf1=alp(itypi)
1572             alf2=alp(itypj)
1573             alf12=0.5D0*(alf1+alf2)
1574 C For diagnostics only!!!
1575 c           chi1=0.0D0
1576 c           chi2=0.0D0
1577 c           chi12=0.0D0
1578 c           chip1=0.0D0
1579 c           chip2=0.0D0
1580 c           chip12=0.0D0
1581 c           alf1=0.0D0
1582 c           alf2=0.0D0
1583 c           alf12=0.0D0
1584             xj=c(1,nres+j)-xi
1585             yj=c(2,nres+j)-yi
1586             zj=c(3,nres+j)-zi
1587             dxj=dc_norm(1,nres+j)
1588             dyj=dc_norm(2,nres+j)
1589             dzj=dc_norm(3,nres+j)
1590             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1591 cd          if (icall.eq.0) then
1592 cd            rrsave(ind)=rrij
1593 cd          else
1594 cd            rrij=rrsave(ind)
1595 cd          endif
1596             rij=dsqrt(rrij)
1597 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1598             call sc_angular
1599 C Calculate whole angle-dependent part of epsilon and contributions
1600 C to its derivatives
1601 C have you changed here?
1602             fac=(rrij*sigsq)**expon2
1603             e1=fac*fac*aa
1604             e2=fac*bb
1605             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1606             eps2der=evdwij*eps3rt
1607             eps3der=evdwij*eps2rt
1608             evdwij=evdwij*eps2rt*eps3rt
1609             evdw=evdw+evdwij
1610             if (lprn) then
1611             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1612             epsi=bb**2/aa
1613 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1614 cd     &        restyp(itypi),i,restyp(itypj),j,
1615 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1616 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1617 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1618 cd     &        evdwij
1619             endif
1620 C Calculate gradient components.
1621             e1=e1*eps1*eps2rt**2*eps3rt**2
1622             fac=-expon*(e1+evdwij)
1623             sigder=fac/sigsq
1624             fac=rrij*fac
1625 C Calculate radial part of the gradient
1626             gg(1)=xj*fac
1627             gg(2)=yj*fac
1628             gg(3)=zj*fac
1629 C Calculate the angular part of the gradient and sum add the contributions
1630 C to the appropriate components of the Cartesian gradient.
1631             call sc_grad
1632           enddo      ! j
1633         enddo        ! iint
1634       enddo          ! i
1635 c     stop
1636       return
1637       end
1638 C-----------------------------------------------------------------------------
1639       subroutine egb(evdw)
1640 C
1641 C This subroutine calculates the interaction energy of nonbonded side chains
1642 C assuming the Gay-Berne potential of interaction.
1643 C
1644       implicit real*8 (a-h,o-z)
1645       include 'DIMENSIONS'
1646       include 'COMMON.GEO'
1647       include 'COMMON.VAR'
1648       include 'COMMON.LOCAL'
1649       include 'COMMON.CHAIN'
1650       include 'COMMON.DERIV'
1651       include 'COMMON.NAMES'
1652       include 'COMMON.INTERACT'
1653       include 'COMMON.IOUNITS'
1654       include 'COMMON.CALC'
1655       include 'COMMON.CONTROL'
1656       include 'COMMON.SPLITELE'
1657       include 'COMMON.SBRIDGE'
1658       logical lprn
1659       integer xshift,yshift,zshift
1660
1661       evdw=0.0D0
1662 ccccc      energy_dec=.false.
1663 C      print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1664       evdw=0.0D0
1665       lprn=.false.
1666 c     if (icall.eq.0) lprn=.false.
1667       ind=0
1668 C the loop over all 27 posible neigbours (for xshift=0,yshift=0,zshift=0
1669 C we have the original box)
1670 C      do xshift=-1,1
1671 C      do yshift=-1,1
1672 C      do zshift=-1,1
1673       do i=iatsc_s,iatsc_e
1674         itypi=iabs(itype(i))
1675         if (itypi.eq.ntyp1) cycle
1676         itypi1=iabs(itype(i+1))
1677         xi=c(1,nres+i)
1678         yi=c(2,nres+i)
1679         zi=c(3,nres+i)
1680 C Return atom into box, boxxsize is size of box in x dimension
1681 c  134   continue
1682 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
1683 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
1684 C Condition for being inside the proper box
1685 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
1686 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
1687 c        go to 134
1688 c        endif
1689 c  135   continue
1690 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
1691 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
1692 C Condition for being inside the proper box
1693 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
1694 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
1695 c        go to 135
1696 c        endif
1697 c  136   continue
1698 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
1699 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
1700 C Condition for being inside the proper box
1701 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
1702 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
1703 c        go to 136
1704 c        endif
1705           xi=mod(xi,boxxsize)
1706           if (xi.lt.0) xi=xi+boxxsize
1707           yi=mod(yi,boxysize)
1708           if (yi.lt.0) yi=yi+boxysize
1709           zi=mod(zi,boxzsize)
1710           if (zi.lt.0) zi=zi+boxzsize
1711 C define scaling factor for lipids
1712
1713 C        if (positi.le.0) positi=positi+boxzsize
1714 C        print *,i
1715 C first for peptide groups
1716 c for each residue check if it is in lipid or lipid water border area
1717        if ((zi.gt.bordlipbot)
1718      &.and.(zi.lt.bordliptop)) then
1719 C the energy transfer exist
1720         if (zi.lt.buflipbot) then
1721 C what fraction I am in
1722          fracinbuf=1.0d0-
1723      &        ((zi-bordlipbot)/lipbufthick)
1724 C lipbufthick is thickenes of lipid buffore
1725          sslipi=sscalelip(fracinbuf)
1726          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
1727         elseif (zi.gt.bufliptop) then
1728          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
1729          sslipi=sscalelip(fracinbuf)
1730          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
1731         else
1732          sslipi=1.0d0
1733          ssgradlipi=0.0
1734         endif
1735        else
1736          sslipi=0.0d0
1737          ssgradlipi=0.0
1738        endif
1739
1740 C          xi=xi+xshift*boxxsize
1741 C          yi=yi+yshift*boxysize
1742 C          zi=zi+zshift*boxzsize
1743
1744         dxi=dc_norm(1,nres+i)
1745         dyi=dc_norm(2,nres+i)
1746         dzi=dc_norm(3,nres+i)
1747 c        dsci_inv=dsc_inv(itypi)
1748         dsci_inv=vbld_inv(i+nres)
1749 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1750 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1751 C
1752 C Calculate SC interaction energy.
1753 C
1754         do iint=1,nint_gr(i)
1755           do j=istart(i,iint),iend(i,iint)
1756             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1757
1758 c              write(iout,*) "PRZED ZWYKLE", evdwij
1759               call dyn_ssbond_ene(i,j,evdwij)
1760 c              write(iout,*) "PO ZWYKLE", evdwij
1761
1762               evdw=evdw+evdwij
1763               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1764      &                        'evdw',i,j,evdwij,' ss'
1765 C triple bond artifac removal
1766              do k=j+1,iend(i,iint)
1767 C search over all next residues
1768               if (dyn_ss_mask(k)) then
1769 C check if they are cysteins
1770 C              write(iout,*) 'k=',k
1771
1772 c              write(iout,*) "PRZED TRI", evdwij
1773                evdwij_przed_tri=evdwij
1774               call triple_ssbond_ene(i,j,k,evdwij)
1775 c               if(evdwij_przed_tri.ne.evdwij) then
1776 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1777 c               endif
1778
1779 c              write(iout,*) "PO TRI", evdwij
1780 C call the energy function that removes the artifical triple disulfide
1781 C bond the soubroutine is located in ssMD.F
1782               evdw=evdw+evdwij
1783               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1784      &                        'evdw',i,j,evdwij,'tss'
1785               endif!dyn_ss_mask(k)
1786              enddo! k
1787             ELSE
1788             ind=ind+1
1789             itypj=iabs(itype(j))
1790             if (itypj.eq.ntyp1) cycle
1791 c            dscj_inv=dsc_inv(itypj)
1792             dscj_inv=vbld_inv(j+nres)
1793 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1794 c     &       1.0d0/vbld(j+nres)
1795 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1796             sig0ij=sigma(itypi,itypj)
1797             chi1=chi(itypi,itypj)
1798             chi2=chi(itypj,itypi)
1799             chi12=chi1*chi2
1800             chip1=chip(itypi)
1801             chip2=chip(itypj)
1802             chip12=chip1*chip2
1803             alf1=alp(itypi)
1804             alf2=alp(itypj)
1805             alf12=0.5D0*(alf1+alf2)
1806 C For diagnostics only!!!
1807 c           chi1=0.0D0
1808 c           chi2=0.0D0
1809 c           chi12=0.0D0
1810 c           chip1=0.0D0
1811 c           chip2=0.0D0
1812 c           chip12=0.0D0
1813 c           alf1=0.0D0
1814 c           alf2=0.0D0
1815 c           alf12=0.0D0
1816             xj=c(1,nres+j)
1817             yj=c(2,nres+j)
1818             zj=c(3,nres+j)
1819 C Return atom J into box the original box
1820 c  137   continue
1821 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
1822 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
1823 C Condition for being inside the proper box
1824 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
1825 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
1826 c        go to 137
1827 c        endif
1828 c  138   continue
1829 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
1830 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
1831 C Condition for being inside the proper box
1832 c        if ((yj.gt.((0.5d0)*boxysize)).or.
1833 c     &       (yj.lt.((-0.5d0)*boxysize))) then
1834 c        go to 138
1835 c        endif
1836 c  139   continue
1837 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
1838 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
1839 C Condition for being inside the proper box
1840 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
1841 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
1842 c        go to 139
1843 c        endif
1844           xj=mod(xj,boxxsize)
1845           if (xj.lt.0) xj=xj+boxxsize
1846           yj=mod(yj,boxysize)
1847           if (yj.lt.0) yj=yj+boxysize
1848           zj=mod(zj,boxzsize)
1849           if (zj.lt.0) zj=zj+boxzsize
1850        if ((zj.gt.bordlipbot)
1851      &.and.(zj.lt.bordliptop)) then
1852 C the energy transfer exist
1853         if (zj.lt.buflipbot) then
1854 C what fraction I am in
1855          fracinbuf=1.0d0-
1856      &        ((zj-bordlipbot)/lipbufthick)
1857 C lipbufthick is thickenes of lipid buffore
1858          sslipj=sscalelip(fracinbuf)
1859          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
1860         elseif (zj.gt.bufliptop) then
1861          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
1862          sslipj=sscalelip(fracinbuf)
1863          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
1864         else
1865          sslipj=1.0d0
1866          ssgradlipj=0.0
1867         endif
1868        else
1869          sslipj=0.0d0
1870          ssgradlipj=0.0
1871        endif
1872       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1873      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1874       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
1875      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
1876 C      write(iout,*) "tu,", i,j,aa_lip(itypi,itypj),bb_lip(itypi,itypj)
1877 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'(2e10.5)')
1878 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
1879 C      if (ssgradlipj.gt.0.0d0) print *,"??WTF??"
1880 C      print *,sslipi,sslipj,bordlipbot,zi,zj
1881       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1882       xj_safe=xj
1883       yj_safe=yj
1884       zj_safe=zj
1885       subchap=0
1886       do xshift=-1,1
1887       do yshift=-1,1
1888       do zshift=-1,1
1889           xj=xj_safe+xshift*boxxsize
1890           yj=yj_safe+yshift*boxysize
1891           zj=zj_safe+zshift*boxzsize
1892           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
1893           if(dist_temp.lt.dist_init) then
1894             dist_init=dist_temp
1895             xj_temp=xj
1896             yj_temp=yj
1897             zj_temp=zj
1898             subchap=1
1899           endif
1900        enddo
1901        enddo
1902        enddo
1903        if (subchap.eq.1) then
1904           xj=xj_temp-xi
1905           yj=yj_temp-yi
1906           zj=zj_temp-zi
1907        else
1908           xj=xj_safe-xi
1909           yj=yj_safe-yi
1910           zj=zj_safe-zi
1911        endif
1912             dxj=dc_norm(1,nres+j)
1913             dyj=dc_norm(2,nres+j)
1914             dzj=dc_norm(3,nres+j)
1915 C            xj=xj-xi
1916 C            yj=yj-yi
1917 C            zj=zj-zi
1918 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1919 c            write (iout,*) "j",j," dc_norm",
1920 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1921             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1922             rij=dsqrt(rrij)
1923             sss=sscale((1.0d0/rij)/sigma(itypi,itypj))
1924             sssgrad=sscagrad((1.0d0/rij)/sigma(itypi,itypj))
1925
1926 c            write (iout,'(a7,4f8.3)')
1927 c    &      "ssscale",sss,((1.0d0/rij)/sigma(itypi,itypj)),r_cut,rlamb
1928             if (sss.gt.0.0d0) then
1929 C Calculate angle-dependent terms of energy and contributions to their
1930 C derivatives.
1931             call sc_angular
1932             sigsq=1.0D0/sigsq
1933             sig=sig0ij*dsqrt(sigsq)
1934             rij_shift=1.0D0/rij-sig+sig0ij
1935 c for diagnostics; uncomment
1936 c            rij_shift=1.2*sig0ij
1937 C I hate to put IF's in the loops, but here don't have another choice!!!!
1938             if (rij_shift.le.0.0D0) then
1939               evdw=1.0D20
1940 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1941 cd     &        restyp(itypi),i,restyp(itypj),j,
1942 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1943               return
1944             endif
1945             sigder=-sig*sigsq
1946 c---------------------------------------------------------------
1947             rij_shift=1.0D0/rij_shift
1948             fac=rij_shift**expon
1949 C here to start with
1950 C            if (c(i,3).gt.
1951             faclip=fac
1952             e1=fac*fac*aa
1953             e2=fac*bb
1954             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1955             eps2der=evdwij*eps3rt
1956             eps3der=evdwij*eps2rt
1957 C       write(63,'(2i3,2e10.3,2f10.5)') i,j,aa,bb, evdwij,
1958 C     &((sslipi+sslipj)/2.0d0+
1959 C     &(2.0d0-sslipi-sslipj)/2.0d0)
1960 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1961 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1962             evdwij=evdwij*eps2rt*eps3rt
1963             evdw=evdw+evdwij*sss
1964             if (lprn) then
1965             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
1966             epsi=bb**2/aa
1967             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1968      &        restyp(itypi),i,restyp(itypj),j,
1969      &        epsi,sigm,chi1,chi2,chip1,chip2,
1970      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1971      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1972      &        evdwij
1973             endif
1974
1975             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1976      &                        'evdw',i,j,evdwij
1977
1978 C Calculate gradient components.
1979             e1=e1*eps1*eps2rt**2*eps3rt**2
1980             fac=-expon*(e1+evdwij)*rij_shift
1981             sigder=fac*sigder
1982             fac=rij*fac
1983 c            print '(2i4,6f8.4)',i,j,sss,sssgrad*
1984 c     &      evdwij,fac,sigma(itypi,itypj),expon
1985             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
1986 c            fac=0.0d0
1987 C Calculate the radial part of the gradient
1988             gg_lipi(3)=eps1*(eps2rt*eps2rt)
1989      &*(eps3rt*eps3rt)*sss/2.0d0*(faclip*faclip*
1990      & (aa_lip(itypi,itypj)-aa_aq(itypi,itypj))
1991      &+faclip*(bb_lip(itypi,itypj)-bb_aq(itypi,itypj)))
1992             gg_lipj(3)=ssgradlipj*gg_lipi(3)
1993             gg_lipi(3)=gg_lipi(3)*ssgradlipi
1994 C            gg_lipi(3)=0.0d0
1995 C            gg_lipj(3)=0.0d0
1996             gg(1)=xj*fac
1997             gg(2)=yj*fac
1998             gg(3)=zj*fac
1999 C Calculate angular part of the gradient.
2000             call sc_grad
2001             endif
2002             ENDIF    ! dyn_ss
2003           enddo      ! j
2004         enddo        ! iint
2005       enddo          ! i
2006 C      enddo          ! zshift
2007 C      enddo          ! yshift
2008 C      enddo          ! xshift
2009 c      write (iout,*) "Number of loop steps in EGB:",ind
2010 cccc      energy_dec=.false.
2011       return
2012       end
2013 C-----------------------------------------------------------------------------
2014       subroutine egbv(evdw)
2015 C
2016 C This subroutine calculates the interaction energy of nonbonded side chains
2017 C assuming the Gay-Berne-Vorobjev potential of interaction.
2018 C
2019       implicit real*8 (a-h,o-z)
2020       include 'DIMENSIONS'
2021       include 'COMMON.GEO'
2022       include 'COMMON.VAR'
2023       include 'COMMON.LOCAL'
2024       include 'COMMON.CHAIN'
2025       include 'COMMON.DERIV'
2026       include 'COMMON.NAMES'
2027       include 'COMMON.INTERACT'
2028       include 'COMMON.IOUNITS'
2029       include 'COMMON.CALC'
2030       integer xshift,yshift,zshift
2031       common /srutu/ icall
2032       logical lprn
2033       evdw=0.0D0
2034 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
2035       evdw=0.0D0
2036       lprn=.false.
2037 c     if (icall.eq.0) lprn=.true.
2038       ind=0
2039       do i=iatsc_s,iatsc_e
2040         itypi=iabs(itype(i))
2041         if (itypi.eq.ntyp1) cycle
2042         itypi1=iabs(itype(i+1))
2043         xi=c(1,nres+i)
2044         yi=c(2,nres+i)
2045         zi=c(3,nres+i)
2046           xi=mod(xi,boxxsize)
2047           if (xi.lt.0) xi=xi+boxxsize
2048           yi=mod(yi,boxysize)
2049           if (yi.lt.0) yi=yi+boxysize
2050           zi=mod(zi,boxzsize)
2051           if (zi.lt.0) zi=zi+boxzsize
2052 C define scaling factor for lipids
2053
2054 C        if (positi.le.0) positi=positi+boxzsize
2055 C        print *,i
2056 C first for peptide groups
2057 c for each residue check if it is in lipid or lipid water border area
2058        if ((zi.gt.bordlipbot)
2059      &.and.(zi.lt.bordliptop)) then
2060 C the energy transfer exist
2061         if (zi.lt.buflipbot) then
2062 C what fraction I am in
2063          fracinbuf=1.0d0-
2064      &        ((zi-bordlipbot)/lipbufthick)
2065 C lipbufthick is thickenes of lipid buffore
2066          sslipi=sscalelip(fracinbuf)
2067          ssgradlipi=-sscagradlip(fracinbuf)/lipbufthick
2068         elseif (zi.gt.bufliptop) then
2069          fracinbuf=1.0d0-((bordliptop-zi)/lipbufthick)
2070          sslipi=sscalelip(fracinbuf)
2071          ssgradlipi=sscagradlip(fracinbuf)/lipbufthick
2072         else
2073          sslipi=1.0d0
2074          ssgradlipi=0.0
2075         endif
2076        else
2077          sslipi=0.0d0
2078          ssgradlipi=0.0
2079        endif
2080
2081         dxi=dc_norm(1,nres+i)
2082         dyi=dc_norm(2,nres+i)
2083         dzi=dc_norm(3,nres+i)
2084 c        dsci_inv=dsc_inv(itypi)
2085         dsci_inv=vbld_inv(i+nres)
2086 C
2087 C Calculate SC interaction energy.
2088 C
2089         do iint=1,nint_gr(i)
2090           do j=istart(i,iint),iend(i,iint)
2091             ind=ind+1
2092             itypj=iabs(itype(j))
2093             if (itypj.eq.ntyp1) cycle
2094 c            dscj_inv=dsc_inv(itypj)
2095             dscj_inv=vbld_inv(j+nres)
2096             sig0ij=sigma(itypi,itypj)
2097             r0ij=r0(itypi,itypj)
2098             chi1=chi(itypi,itypj)
2099             chi2=chi(itypj,itypi)
2100             chi12=chi1*chi2
2101             chip1=chip(itypi)
2102             chip2=chip(itypj)
2103             chip12=chip1*chip2
2104             alf1=alp(itypi)
2105             alf2=alp(itypj)
2106             alf12=0.5D0*(alf1+alf2)
2107 C For diagnostics only!!!
2108 c           chi1=0.0D0
2109 c           chi2=0.0D0
2110 c           chi12=0.0D0
2111 c           chip1=0.0D0
2112 c           chip2=0.0D0
2113 c           chip12=0.0D0
2114 c           alf1=0.0D0
2115 c           alf2=0.0D0
2116 c           alf12=0.0D0
2117 C            xj=c(1,nres+j)-xi
2118 C            yj=c(2,nres+j)-yi
2119 C            zj=c(3,nres+j)-zi
2120           xj=mod(xj,boxxsize)
2121           if (xj.lt.0) xj=xj+boxxsize
2122           yj=mod(yj,boxysize)
2123           if (yj.lt.0) yj=yj+boxysize
2124           zj=mod(zj,boxzsize)
2125           if (zj.lt.0) zj=zj+boxzsize
2126        if ((zj.gt.bordlipbot)
2127      &.and.(zj.lt.bordliptop)) then
2128 C the energy transfer exist
2129         if (zj.lt.buflipbot) then
2130 C what fraction I am in
2131          fracinbuf=1.0d0-
2132      &        ((zj-bordlipbot)/lipbufthick)
2133 C lipbufthick is thickenes of lipid buffore
2134          sslipj=sscalelip(fracinbuf)
2135          ssgradlipj=-sscagradlip(fracinbuf)/lipbufthick
2136         elseif (zj.gt.bufliptop) then
2137          fracinbuf=1.0d0-((bordliptop-zj)/lipbufthick)
2138          sslipj=sscalelip(fracinbuf)
2139          ssgradlipj=sscagradlip(fracinbuf)/lipbufthick
2140         else
2141          sslipj=1.0d0
2142          ssgradlipj=0.0
2143         endif
2144        else
2145          sslipj=0.0d0
2146          ssgradlipj=0.0
2147        endif
2148       aa=aa_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2149      &  +aa_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2150       bb=bb_lip(itypi,itypj)*(sslipi+sslipj)/2.0d0
2151      &  +bb_aq(itypi,itypj)*(2.0d0-sslipi-sslipj)/2.0d0
2152 C      if (aa.ne.aa_aq(itypi,itypj)) write(63,'2e10.5')
2153 C     &(aa-aa_aq(itypi,itypj)),(bb-bb_aq(itypi,itypj))
2154 C      write(iout,*) "tu,", i,j,aa,bb,aa_lip(itypi,itypj),sslipi,sslipj
2155       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2156       xj_safe=xj
2157       yj_safe=yj
2158       zj_safe=zj
2159       subchap=0
2160       do xshift=-1,1
2161       do yshift=-1,1
2162       do zshift=-1,1
2163           xj=xj_safe+xshift*boxxsize
2164           yj=yj_safe+yshift*boxysize
2165           zj=zj_safe+zshift*boxzsize
2166           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2167           if(dist_temp.lt.dist_init) then
2168             dist_init=dist_temp
2169             xj_temp=xj
2170             yj_temp=yj
2171             zj_temp=zj
2172             subchap=1
2173           endif
2174        enddo
2175        enddo
2176        enddo
2177        if (subchap.eq.1) then
2178           xj=xj_temp-xi
2179           yj=yj_temp-yi
2180           zj=zj_temp-zi
2181        else
2182           xj=xj_safe-xi
2183           yj=yj_safe-yi
2184           zj=zj_safe-zi
2185        endif
2186             dxj=dc_norm(1,nres+j)
2187             dyj=dc_norm(2,nres+j)
2188             dzj=dc_norm(3,nres+j)
2189             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
2190             rij=dsqrt(rrij)
2191 C Calculate angle-dependent terms of energy and contributions to their
2192 C derivatives.
2193             call sc_angular
2194             sigsq=1.0D0/sigsq
2195             sig=sig0ij*dsqrt(sigsq)
2196             rij_shift=1.0D0/rij-sig+r0ij
2197 C I hate to put IF's in the loops, but here don't have another choice!!!!
2198             if (rij_shift.le.0.0D0) then
2199               evdw=1.0D20
2200               return
2201             endif
2202             sigder=-sig*sigsq
2203 c---------------------------------------------------------------
2204             rij_shift=1.0D0/rij_shift
2205             fac=rij_shift**expon
2206             e1=fac*fac*aa
2207             e2=fac*bb
2208             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
2209             eps2der=evdwij*eps3rt
2210             eps3der=evdwij*eps2rt
2211             fac_augm=rrij**expon
2212             e_augm=augm(itypi,itypj)*fac_augm
2213             evdwij=evdwij*eps2rt*eps3rt
2214             evdw=evdw+evdwij+e_augm
2215             if (lprn) then
2216             sigm=dabs(aa/bb)**(1.0D0/6.0D0)
2217             epsi=bb**2/aa
2218             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
2219      &        restyp(itypi),i,restyp(itypj),j,
2220      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
2221      &        chi1,chi2,chip1,chip2,
2222      &        eps1,eps2rt**2,eps3rt**2,
2223      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
2224      &        evdwij+e_augm
2225             endif
2226 C Calculate gradient components.
2227             e1=e1*eps1*eps2rt**2*eps3rt**2
2228             fac=-expon*(e1+evdwij)*rij_shift
2229             sigder=fac*sigder
2230             fac=rij*fac-2*expon*rrij*e_augm
2231             fac=fac+evdwij/sss*sssgrad/sigma(itypi,itypj)*rij
2232 C Calculate the radial part of the gradient
2233             gg(1)=xj*fac
2234             gg(2)=yj*fac
2235             gg(3)=zj*fac
2236 C Calculate angular part of the gradient.
2237             call sc_grad
2238           enddo      ! j
2239         enddo        ! iint
2240       enddo          ! i
2241       end
2242 C-----------------------------------------------------------------------------
2243       subroutine sc_angular
2244 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
2245 C om12. Called by ebp, egb, and egbv.
2246       implicit none
2247       include 'COMMON.CALC'
2248       include 'COMMON.IOUNITS'
2249       erij(1)=xj*rij
2250       erij(2)=yj*rij
2251       erij(3)=zj*rij
2252       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
2253       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
2254       om12=dxi*dxj+dyi*dyj+dzi*dzj
2255       chiom12=chi12*om12
2256 C Calculate eps1(om12) and its derivative in om12
2257       faceps1=1.0D0-om12*chiom12
2258       faceps1_inv=1.0D0/faceps1
2259       eps1=dsqrt(faceps1_inv)
2260 C Following variable is eps1*deps1/dom12
2261       eps1_om12=faceps1_inv*chiom12
2262 c diagnostics only
2263 c      faceps1_inv=om12
2264 c      eps1=om12
2265 c      eps1_om12=1.0d0
2266 c      write (iout,*) "om12",om12," eps1",eps1
2267 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
2268 C and om12.
2269       om1om2=om1*om2
2270       chiom1=chi1*om1
2271       chiom2=chi2*om2
2272       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
2273       sigsq=1.0D0-facsig*faceps1_inv
2274       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
2275       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
2276       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
2277 c diagnostics only
2278 c      sigsq=1.0d0
2279 c      sigsq_om1=0.0d0
2280 c      sigsq_om2=0.0d0
2281 c      sigsq_om12=0.0d0
2282 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
2283 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
2284 c     &    " eps1",eps1
2285 C Calculate eps2 and its derivatives in om1, om2, and om12.
2286       chipom1=chip1*om1
2287       chipom2=chip2*om2
2288       chipom12=chip12*om12
2289       facp=1.0D0-om12*chipom12
2290       facp_inv=1.0D0/facp
2291       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
2292 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
2293 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
2294 C Following variable is the square root of eps2
2295       eps2rt=1.0D0-facp1*facp_inv
2296 C Following three variables are the derivatives of the square root of eps
2297 C in om1, om2, and om12.
2298       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
2299       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
2300       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
2301 C Evaluate the "asymmetric" factor in the VDW constant, eps3
2302       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
2303 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
2304 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
2305 c     &  " eps2rt_om12",eps2rt_om12
2306 C Calculate whole angle-dependent part of epsilon and contributions
2307 C to its derivatives
2308       return
2309       end
2310 C----------------------------------------------------------------------------
2311       subroutine sc_grad
2312       implicit real*8 (a-h,o-z)
2313       include 'DIMENSIONS'
2314       include 'COMMON.CHAIN'
2315       include 'COMMON.DERIV'
2316       include 'COMMON.CALC'
2317       include 'COMMON.IOUNITS'
2318       double precision dcosom1(3),dcosom2(3)
2319 cc      print *,'sss=',sss
2320       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
2321       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
2322       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
2323      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
2324 c diagnostics only
2325 c      eom1=0.0d0
2326 c      eom2=0.0d0
2327 c      eom12=evdwij*eps1_om12
2328 c end diagnostics
2329 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
2330 c     &  " sigder",sigder
2331 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
2332 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
2333       do k=1,3
2334         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
2335         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
2336       enddo
2337       do k=1,3
2338         gg(k)=(gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k))*sss
2339       enddo
2340 c      write (iout,*) "gg",(gg(k),k=1,3)
2341       do k=1,3
2342         gvdwx(k,i)=gvdwx(k,i)-gg(k)+gg_lipi(k)
2343      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2344      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv*sss
2345         gvdwx(k,j)=gvdwx(k,j)+gg(k)+gg_lipj(k)
2346      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2347      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv*sss
2348 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
2349 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
2350 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
2351 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
2352       enddo
2353 C
2354 C Calculate the components of the gradient in DC and X
2355 C
2356 cgrad      do k=i,j-1
2357 cgrad        do l=1,3
2358 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
2359 cgrad        enddo
2360 cgrad      enddo
2361       do l=1,3
2362         gvdwc(l,i)=gvdwc(l,i)-gg(l)+gg_lipi(l)
2363         gvdwc(l,j)=gvdwc(l,j)+gg(l)+gg_lipj(l)
2364       enddo
2365       return
2366       end
2367 C-----------------------------------------------------------------------
2368       subroutine e_softsphere(evdw)
2369 C
2370 C This subroutine calculates the interaction energy of nonbonded side chains
2371 C assuming the LJ potential of interaction.
2372 C
2373       implicit real*8 (a-h,o-z)
2374       include 'DIMENSIONS'
2375       parameter (accur=1.0d-10)
2376       include 'COMMON.GEO'
2377       include 'COMMON.VAR'
2378       include 'COMMON.LOCAL'
2379       include 'COMMON.CHAIN'
2380       include 'COMMON.DERIV'
2381       include 'COMMON.INTERACT'
2382       include 'COMMON.TORSION'
2383       include 'COMMON.SBRIDGE'
2384       include 'COMMON.NAMES'
2385       include 'COMMON.IOUNITS'
2386       include 'COMMON.CONTACTS'
2387       dimension gg(3)
2388 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
2389       evdw=0.0D0
2390       do i=iatsc_s,iatsc_e
2391         itypi=iabs(itype(i))
2392         if (itypi.eq.ntyp1) cycle
2393         itypi1=iabs(itype(i+1))
2394         xi=c(1,nres+i)
2395         yi=c(2,nres+i)
2396         zi=c(3,nres+i)
2397 C
2398 C Calculate SC interaction energy.
2399 C
2400         do iint=1,nint_gr(i)
2401 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
2402 cd   &                  'iend=',iend(i,iint)
2403           do j=istart(i,iint),iend(i,iint)
2404             itypj=iabs(itype(j))
2405             if (itypj.eq.ntyp1) cycle
2406             xj=c(1,nres+j)-xi
2407             yj=c(2,nres+j)-yi
2408             zj=c(3,nres+j)-zi
2409             rij=xj*xj+yj*yj+zj*zj
2410 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
2411             r0ij=r0(itypi,itypj)
2412             r0ijsq=r0ij*r0ij
2413 c            print *,i,j,r0ij,dsqrt(rij)
2414             if (rij.lt.r0ijsq) then
2415               evdwij=0.25d0*(rij-r0ijsq)**2
2416               fac=rij-r0ijsq
2417             else
2418               evdwij=0.0d0
2419               fac=0.0d0
2420             endif
2421             evdw=evdw+evdwij
2422 C
2423 C Calculate the components of the gradient in DC and X
2424 C
2425             gg(1)=xj*fac
2426             gg(2)=yj*fac
2427             gg(3)=zj*fac
2428             do k=1,3
2429               gvdwx(k,i)=gvdwx(k,i)-gg(k)
2430               gvdwx(k,j)=gvdwx(k,j)+gg(k)
2431               gvdwc(k,i)=gvdwc(k,i)-gg(k)
2432               gvdwc(k,j)=gvdwc(k,j)+gg(k)
2433             enddo
2434 cgrad            do k=i,j-1
2435 cgrad              do l=1,3
2436 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
2437 cgrad              enddo
2438 cgrad            enddo
2439           enddo ! j
2440         enddo ! iint
2441       enddo ! i
2442       return
2443       end
2444 C--------------------------------------------------------------------------
2445       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
2446      &              eello_turn4)
2447 C
2448 C Soft-sphere potential of p-p interaction
2449 C
2450       implicit real*8 (a-h,o-z)
2451       include 'DIMENSIONS'
2452       include 'COMMON.CONTROL'
2453       include 'COMMON.IOUNITS'
2454       include 'COMMON.GEO'
2455       include 'COMMON.VAR'
2456       include 'COMMON.LOCAL'
2457       include 'COMMON.CHAIN'
2458       include 'COMMON.DERIV'
2459       include 'COMMON.INTERACT'
2460       include 'COMMON.CONTACTS'
2461       include 'COMMON.TORSION'
2462       include 'COMMON.VECTORS'
2463       include 'COMMON.FFIELD'
2464       dimension ggg(3)
2465       integer xshift,yshift,zshift
2466 C      write(iout,*) 'In EELEC_soft_sphere'
2467       ees=0.0D0
2468       evdw1=0.0D0
2469       eel_loc=0.0d0
2470       eello_turn3=0.0d0
2471       eello_turn4=0.0d0
2472       ind=0
2473       do i=iatel_s,iatel_e
2474         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2475         dxi=dc(1,i)
2476         dyi=dc(2,i)
2477         dzi=dc(3,i)
2478         xmedi=c(1,i)+0.5d0*dxi
2479         ymedi=c(2,i)+0.5d0*dyi
2480         zmedi=c(3,i)+0.5d0*dzi
2481           xmedi=mod(xmedi,boxxsize)
2482           if (xmedi.lt.0) xmedi=xmedi+boxxsize
2483           ymedi=mod(ymedi,boxysize)
2484           if (ymedi.lt.0) ymedi=ymedi+boxysize
2485           zmedi=mod(zmedi,boxzsize)
2486           if (zmedi.lt.0) zmedi=zmedi+boxzsize
2487         num_conti=0
2488 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2489         do j=ielstart(i),ielend(i)
2490           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
2491           ind=ind+1
2492           iteli=itel(i)
2493           itelj=itel(j)
2494           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2495           r0ij=rpp(iteli,itelj)
2496           r0ijsq=r0ij*r0ij
2497           dxj=dc(1,j)
2498           dyj=dc(2,j)
2499           dzj=dc(3,j)
2500           xj=c(1,j)+0.5D0*dxj
2501           yj=c(2,j)+0.5D0*dyj
2502           zj=c(3,j)+0.5D0*dzj
2503           xj=mod(xj,boxxsize)
2504           if (xj.lt.0) xj=xj+boxxsize
2505           yj=mod(yj,boxysize)
2506           if (yj.lt.0) yj=yj+boxysize
2507           zj=mod(zj,boxzsize)
2508           if (zj.lt.0) zj=zj+boxzsize
2509       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
2510       xj_safe=xj
2511       yj_safe=yj
2512       zj_safe=zj
2513       isubchap=0
2514       do xshift=-1,1
2515       do yshift=-1,1
2516       do zshift=-1,1
2517           xj=xj_safe+xshift*boxxsize
2518           yj=yj_safe+yshift*boxysize
2519           zj=zj_safe+zshift*boxzsize
2520           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
2521           if(dist_temp.lt.dist_init) then
2522             dist_init=dist_temp
2523             xj_temp=xj
2524             yj_temp=yj
2525             zj_temp=zj
2526             isubchap=1
2527           endif
2528        enddo
2529        enddo
2530        enddo
2531        if (isubchap.eq.1) then
2532           xj=xj_temp-xmedi
2533           yj=yj_temp-ymedi
2534           zj=zj_temp-zmedi
2535        else
2536           xj=xj_safe-xmedi
2537           yj=yj_safe-ymedi
2538           zj=zj_safe-zmedi
2539        endif
2540           rij=xj*xj+yj*yj+zj*zj
2541             sss=sscale(sqrt(rij))
2542             sssgrad=sscagrad(sqrt(rij))
2543           if (rij.lt.r0ijsq) then
2544             evdw1ij=0.25d0*(rij-r0ijsq)**2
2545             fac=rij-r0ijsq
2546           else
2547             evdw1ij=0.0d0
2548             fac=0.0d0
2549           endif
2550           evdw1=evdw1+evdw1ij*sss
2551 C
2552 C Calculate contributions to the Cartesian gradient.
2553 C
2554           ggg(1)=fac*xj*sssgrad
2555           ggg(2)=fac*yj*sssgrad
2556           ggg(3)=fac*zj*sssgrad
2557           do k=1,3
2558             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
2559             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
2560           enddo
2561 *
2562 * Loop over residues i+1 thru j-1.
2563 *
2564 cgrad          do k=i+1,j-1
2565 cgrad            do l=1,3
2566 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
2567 cgrad            enddo
2568 cgrad          enddo
2569         enddo ! j
2570       enddo   ! i
2571 cgrad      do i=nnt,nct-1
2572 cgrad        do k=1,3
2573 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2574 cgrad        enddo
2575 cgrad        do j=i+1,nct-1
2576 cgrad          do k=1,3
2577 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2578 cgrad          enddo
2579 cgrad        enddo
2580 cgrad      enddo
2581       return
2582       end
2583 c------------------------------------------------------------------------------
2584       subroutine vec_and_deriv
2585       implicit real*8 (a-h,o-z)
2586       include 'DIMENSIONS'
2587 #ifdef MPI
2588       include 'mpif.h'
2589 #endif
2590       include 'COMMON.IOUNITS'
2591       include 'COMMON.GEO'
2592       include 'COMMON.VAR'
2593       include 'COMMON.LOCAL'
2594       include 'COMMON.CHAIN'
2595       include 'COMMON.VECTORS'
2596       include 'COMMON.SETUP'
2597       include 'COMMON.TIME1'
2598       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2599 C Compute the local reference systems. For reference system (i), the
2600 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2601 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2602 #ifdef PARVEC
2603       do i=ivec_start,ivec_end
2604 #else
2605       do i=1,nres-1
2606 #endif
2607           if (i.eq.nres-1) then
2608 C Case of the last full residue
2609 C Compute the Z-axis
2610             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2611             costh=dcos(pi-theta(nres))
2612             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2613             do k=1,3
2614               uz(k,i)=fac*uz(k,i)
2615             enddo
2616 C Compute the derivatives of uz
2617             uzder(1,1,1)= 0.0d0
2618             uzder(2,1,1)=-dc_norm(3,i-1)
2619             uzder(3,1,1)= dc_norm(2,i-1)
2620             uzder(1,2,1)= dc_norm(3,i-1)
2621             uzder(2,2,1)= 0.0d0
2622             uzder(3,2,1)=-dc_norm(1,i-1)
2623             uzder(1,3,1)=-dc_norm(2,i-1)
2624             uzder(2,3,1)= dc_norm(1,i-1)
2625             uzder(3,3,1)= 0.0d0
2626             uzder(1,1,2)= 0.0d0
2627             uzder(2,1,2)= dc_norm(3,i)
2628             uzder(3,1,2)=-dc_norm(2,i)
2629             uzder(1,2,2)=-dc_norm(3,i)
2630             uzder(2,2,2)= 0.0d0
2631             uzder(3,2,2)= dc_norm(1,i)
2632             uzder(1,3,2)= dc_norm(2,i)
2633             uzder(2,3,2)=-dc_norm(1,i)
2634             uzder(3,3,2)= 0.0d0
2635 C Compute the Y-axis
2636             facy=fac
2637             do k=1,3
2638               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2639             enddo
2640 C Compute the derivatives of uy
2641             do j=1,3
2642               do k=1,3
2643                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2644      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2645                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2646               enddo
2647               uyder(j,j,1)=uyder(j,j,1)-costh
2648               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2649             enddo
2650             do j=1,2
2651               do k=1,3
2652                 do l=1,3
2653                   uygrad(l,k,j,i)=uyder(l,k,j)
2654                   uzgrad(l,k,j,i)=uzder(l,k,j)
2655                 enddo
2656               enddo
2657             enddo
2658             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2659             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2660             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2661             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2662           else
2663 C Other residues
2664 C Compute the Z-axis
2665             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2666             costh=dcos(pi-theta(i+2))
2667             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2668             do k=1,3
2669               uz(k,i)=fac*uz(k,i)
2670             enddo
2671 C Compute the derivatives of uz
2672             uzder(1,1,1)= 0.0d0
2673             uzder(2,1,1)=-dc_norm(3,i+1)
2674             uzder(3,1,1)= dc_norm(2,i+1)
2675             uzder(1,2,1)= dc_norm(3,i+1)
2676             uzder(2,2,1)= 0.0d0
2677             uzder(3,2,1)=-dc_norm(1,i+1)
2678             uzder(1,3,1)=-dc_norm(2,i+1)
2679             uzder(2,3,1)= dc_norm(1,i+1)
2680             uzder(3,3,1)= 0.0d0
2681             uzder(1,1,2)= 0.0d0
2682             uzder(2,1,2)= dc_norm(3,i)
2683             uzder(3,1,2)=-dc_norm(2,i)
2684             uzder(1,2,2)=-dc_norm(3,i)
2685             uzder(2,2,2)= 0.0d0
2686             uzder(3,2,2)= dc_norm(1,i)
2687             uzder(1,3,2)= dc_norm(2,i)
2688             uzder(2,3,2)=-dc_norm(1,i)
2689             uzder(3,3,2)= 0.0d0
2690 C Compute the Y-axis
2691             facy=fac
2692             do k=1,3
2693               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2694             enddo
2695 C Compute the derivatives of uy
2696             do j=1,3
2697               do k=1,3
2698                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2699      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2700                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2701               enddo
2702               uyder(j,j,1)=uyder(j,j,1)-costh
2703               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2704             enddo
2705             do j=1,2
2706               do k=1,3
2707                 do l=1,3
2708                   uygrad(l,k,j,i)=uyder(l,k,j)
2709                   uzgrad(l,k,j,i)=uzder(l,k,j)
2710                 enddo
2711               enddo
2712             enddo
2713             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2714             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2715             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2716             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2717           endif
2718       enddo
2719       do i=1,nres-1
2720         vbld_inv_temp(1)=vbld_inv(i+1)
2721         if (i.lt.nres-1) then
2722           vbld_inv_temp(2)=vbld_inv(i+2)
2723           else
2724           vbld_inv_temp(2)=vbld_inv(i)
2725           endif
2726         do j=1,2
2727           do k=1,3
2728             do l=1,3
2729               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2730               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2731             enddo
2732           enddo
2733         enddo
2734       enddo
2735 #if defined(PARVEC) && defined(MPI)
2736       if (nfgtasks1.gt.1) then
2737         time00=MPI_Wtime()
2738 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2739 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2740 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2741         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2742      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2743      &   FG_COMM1,IERR)
2744         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2745      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2746      &   FG_COMM1,IERR)
2747         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2748      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2749      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2750         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2751      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2752      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2753         time_gather=time_gather+MPI_Wtime()-time00
2754       endif
2755 #endif
2756 #ifdef DEBUG
2757       if (fg_rank.eq.0) then
2758         write (iout,*) "Arrays UY and UZ"
2759         do i=1,nres-1
2760           write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2761      &     (uz(k,i),k=1,3)
2762         enddo
2763       endif
2764 #endif
2765       return
2766       end
2767 C-----------------------------------------------------------------------------
2768       subroutine check_vecgrad
2769       implicit real*8 (a-h,o-z)
2770       include 'DIMENSIONS'
2771       include 'COMMON.IOUNITS'
2772       include 'COMMON.GEO'
2773       include 'COMMON.VAR'
2774       include 'COMMON.LOCAL'
2775       include 'COMMON.CHAIN'
2776       include 'COMMON.VECTORS'
2777       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2778       dimension uyt(3,maxres),uzt(3,maxres)
2779       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2780       double precision delta /1.0d-7/
2781       call vec_and_deriv
2782 cd      do i=1,nres
2783 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2784 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2785 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2786 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2787 cd     &     (dc_norm(if90,i),if90=1,3)
2788 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2789 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2790 cd          write(iout,'(a)')
2791 cd      enddo
2792       do i=1,nres
2793         do j=1,2
2794           do k=1,3
2795             do l=1,3
2796               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2797               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2798             enddo
2799           enddo
2800         enddo
2801       enddo
2802       call vec_and_deriv
2803       do i=1,nres
2804         do j=1,3
2805           uyt(j,i)=uy(j,i)
2806           uzt(j,i)=uz(j,i)
2807         enddo
2808       enddo
2809       do i=1,nres
2810 cd        write (iout,*) 'i=',i
2811         do k=1,3
2812           erij(k)=dc_norm(k,i)
2813         enddo
2814         do j=1,3
2815           do k=1,3
2816             dc_norm(k,i)=erij(k)
2817           enddo
2818           dc_norm(j,i)=dc_norm(j,i)+delta
2819 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2820 c          do k=1,3
2821 c            dc_norm(k,i)=dc_norm(k,i)/fac
2822 c          enddo
2823 c          write (iout,*) (dc_norm(k,i),k=1,3)
2824 c          write (iout,*) (erij(k),k=1,3)
2825           call vec_and_deriv
2826           do k=1,3
2827             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2828             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2829             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2830             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2831           enddo
2832 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2833 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2834 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2835         enddo
2836         do k=1,3
2837           dc_norm(k,i)=erij(k)
2838         enddo
2839 cd        do k=1,3
2840 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2841 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2842 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2843 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2844 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2845 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2846 cd          write (iout,'(a)')
2847 cd        enddo
2848       enddo
2849       return
2850       end
2851 C--------------------------------------------------------------------------
2852       subroutine set_matrices
2853       implicit real*8 (a-h,o-z)
2854       include 'DIMENSIONS'
2855 #ifdef MPI
2856       include "mpif.h"
2857       include "COMMON.SETUP"
2858       integer IERR
2859       integer status(MPI_STATUS_SIZE)
2860 #endif
2861       include 'COMMON.IOUNITS'
2862       include 'COMMON.GEO'
2863       include 'COMMON.VAR'
2864       include 'COMMON.LOCAL'
2865       include 'COMMON.CHAIN'
2866       include 'COMMON.DERIV'
2867       include 'COMMON.INTERACT'
2868       include 'COMMON.CONTACTS'
2869       include 'COMMON.TORSION'
2870       include 'COMMON.VECTORS'
2871       include 'COMMON.FFIELD'
2872       double precision auxvec(2),auxmat(2,2)
2873 C
2874 C Compute the virtual-bond-torsional-angle dependent quantities needed
2875 C to calculate the el-loc multibody terms of various order.
2876 C
2877 c      write(iout,*) 'nphi=',nphi,nres
2878 c      write(iout,*) "itype2loc",itype2loc
2879 #ifdef PARMAT
2880       do i=ivec_start+2,ivec_end+2
2881 #else
2882       do i=3,nres+1
2883 #endif
2884         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2885           iti = itype2loc(itype(i-2))
2886         else
2887           iti=nloctyp
2888         endif
2889 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2890         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2891           iti1 = itype2loc(itype(i-1))
2892         else
2893           iti1=nloctyp
2894         endif
2895 c        write(iout,*),i
2896 #ifdef NEWCORR
2897         cost1=dcos(theta(i-1))
2898         sint1=dsin(theta(i-1))
2899         sint1sq=sint1*sint1
2900         sint1cub=sint1sq*sint1
2901         sint1cost1=2*sint1*cost1
2902 c        write (iout,*) "bnew1",i,iti
2903 c        write (iout,*) (bnew1(k,1,iti),k=1,3)
2904 c        write (iout,*) (bnew1(k,2,iti),k=1,3)
2905 c        write (iout,*) "bnew2",i,iti
2906 c        write (iout,*) (bnew2(k,1,iti),k=1,3)
2907 c        write (iout,*) (bnew2(k,2,iti),k=1,3)
2908         do k=1,2
2909           b1k=bnew1(1,k,iti)+(bnew1(2,k,iti)+bnew1(3,k,iti)*cost1)*cost1
2910           b1(k,i-2)=sint1*b1k
2911           gtb1(k,i-2)=cost1*b1k-sint1sq*
2912      &              (bnew1(2,k,iti)+2*bnew1(3,k,iti)*cost1)
2913           b2k=bnew2(1,k,iti)+(bnew2(2,k,iti)+bnew2(3,k,iti)*cost1)*cost1
2914           b2(k,i-2)=sint1*b2k
2915           gtb2(k,i-2)=cost1*b2k-sint1sq*
2916      &              (bnew2(2,k,iti)+2*bnew2(3,k,iti)*cost1)
2917         enddo
2918         do k=1,2
2919           aux=ccnew(1,k,iti)+(ccnew(2,k,iti)+ccnew(3,k,iti)*cost1)*cost1
2920           cc(1,k,i-2)=sint1sq*aux
2921           gtcc(1,k,i-2)=sint1cost1*aux-sint1cub*
2922      &              (ccnew(2,k,iti)+2*ccnew(3,k,iti)*cost1)
2923           aux=ddnew(1,k,iti)+(ddnew(2,k,iti)+ddnew(3,k,iti)*cost1)*cost1
2924           dd(1,k,i-2)=sint1sq*aux
2925           gtdd(1,k,i-2)=sint1cost1*aux-sint1cub*
2926      &              (ddnew(2,k,iti)+2*ddnew(3,k,iti)*cost1)
2927         enddo
2928         cc(2,1,i-2)=cc(1,2,i-2)
2929         cc(2,2,i-2)=-cc(1,1,i-2)
2930         gtcc(2,1,i-2)=gtcc(1,2,i-2)
2931         gtcc(2,2,i-2)=-gtcc(1,1,i-2)
2932         dd(2,1,i-2)=dd(1,2,i-2)
2933         dd(2,2,i-2)=-dd(1,1,i-2)
2934         gtdd(2,1,i-2)=gtdd(1,2,i-2)
2935         gtdd(2,2,i-2)=-gtdd(1,1,i-2)
2936         do k=1,2
2937           do l=1,2
2938             aux=eenew(1,l,k,iti)+eenew(2,l,k,iti)*cost1
2939             EE(l,k,i-2)=sint1sq*aux
2940             gtEE(l,k,i-2)=sint1cost1*aux-sint1cub*eenew(2,l,k,iti)
2941           enddo
2942         enddo
2943         EE(1,1,i-2)=EE(1,1,i-2)+e0new(1,iti)*cost1
2944         EE(1,2,i-2)=EE(1,2,i-2)+e0new(2,iti)+e0new(3,iti)*cost1
2945         EE(2,1,i-2)=EE(2,1,i-2)+e0new(2,iti)*cost1+e0new(3,iti)
2946         EE(2,2,i-2)=EE(2,2,i-2)-e0new(1,iti)
2947         gtEE(1,1,i-2)=gtEE(1,1,i-2)-e0new(1,iti)*sint1
2948         gtEE(1,2,i-2)=gtEE(1,2,i-2)-e0new(3,iti)*sint1
2949         gtEE(2,1,i-2)=gtEE(2,1,i-2)-e0new(2,iti)*sint1
2950 c        b1tilde(1,i-2)=b1(1,i-2)
2951 c        b1tilde(2,i-2)=-b1(2,i-2)
2952 c        b2tilde(1,i-2)=b2(1,i-2)
2953 c        b2tilde(2,i-2)=-b2(2,i-2)
2954 #ifdef DEBUG
2955         write (iout,*) 'i=',i-2,gtb1(2,i-2),gtb1(1,i-2)
2956         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
2957         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
2958         write (iout,*) 'theta=', theta(i-1)
2959 #endif
2960 #else
2961         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2962           iti = itype2loc(itype(i-2))
2963         else
2964           iti=nloctyp
2965         endif
2966 c        write (iout,*) "i",i-1," itype",itype(i-2)," iti",iti
2967 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2968         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2969           iti1 = itype2loc(itype(i-1))
2970         else
2971           iti1=nloctyp
2972         endif
2973         b1(1,i-2)=b(3,iti)
2974         b1(2,i-2)=b(5,iti)
2975         b2(1,i-2)=b(2,iti)
2976         b2(2,i-2)=b(4,iti)
2977         do k=1,2
2978           do l=1,2
2979            CC(k,l,i-2)=ccold(k,l,iti)
2980            DD(k,l,i-2)=ddold(k,l,iti)
2981            EE(k,l,i-2)=eeold(k,l,iti)
2982           enddo
2983         enddo
2984 #endif
2985         b1tilde(1,i-2)= b1(1,i-2)
2986         b1tilde(2,i-2)=-b1(2,i-2)
2987         b2tilde(1,i-2)= b2(1,i-2)
2988         b2tilde(2,i-2)=-b2(2,i-2)
2989 c
2990         Ctilde(1,1,i-2)= CC(1,1,i-2)
2991         Ctilde(1,2,i-2)= CC(1,2,i-2)
2992         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2993         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2994 c
2995         Dtilde(1,1,i-2)= DD(1,1,i-2)
2996         Dtilde(1,2,i-2)= DD(1,2,i-2)
2997         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2998         Dtilde(2,2,i-2)=-DD(2,2,i-2)
2999 #ifdef DEBUG
3000         write(iout,*) "i",i," iti",iti
3001         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3002         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3003 #endif
3004       enddo
3005 #ifdef PARMAT
3006       do i=ivec_start+2,ivec_end+2
3007 #else
3008       do i=3,nres+1
3009 #endif
3010         if (i .lt. nres+1) then
3011           sin1=dsin(phi(i))
3012           cos1=dcos(phi(i))
3013           sintab(i-2)=sin1
3014           costab(i-2)=cos1
3015           obrot(1,i-2)=cos1
3016           obrot(2,i-2)=sin1
3017           sin2=dsin(2*phi(i))
3018           cos2=dcos(2*phi(i))
3019           sintab2(i-2)=sin2
3020           costab2(i-2)=cos2
3021           obrot2(1,i-2)=cos2
3022           obrot2(2,i-2)=sin2
3023           Ug(1,1,i-2)=-cos1
3024           Ug(1,2,i-2)=-sin1
3025           Ug(2,1,i-2)=-sin1
3026           Ug(2,2,i-2)= cos1
3027           Ug2(1,1,i-2)=-cos2
3028           Ug2(1,2,i-2)=-sin2
3029           Ug2(2,1,i-2)=-sin2
3030           Ug2(2,2,i-2)= cos2
3031         else
3032           costab(i-2)=1.0d0
3033           sintab(i-2)=0.0d0
3034           obrot(1,i-2)=1.0d0
3035           obrot(2,i-2)=0.0d0
3036           obrot2(1,i-2)=0.0d0
3037           obrot2(2,i-2)=0.0d0
3038           Ug(1,1,i-2)=1.0d0
3039           Ug(1,2,i-2)=0.0d0
3040           Ug(2,1,i-2)=0.0d0
3041           Ug(2,2,i-2)=1.0d0
3042           Ug2(1,1,i-2)=0.0d0
3043           Ug2(1,2,i-2)=0.0d0
3044           Ug2(2,1,i-2)=0.0d0
3045           Ug2(2,2,i-2)=0.0d0
3046         endif
3047         if (i .gt. 3 .and. i .lt. nres+1) then
3048           obrot_der(1,i-2)=-sin1
3049           obrot_der(2,i-2)= cos1
3050           Ugder(1,1,i-2)= sin1
3051           Ugder(1,2,i-2)=-cos1
3052           Ugder(2,1,i-2)=-cos1
3053           Ugder(2,2,i-2)=-sin1
3054           dwacos2=cos2+cos2
3055           dwasin2=sin2+sin2
3056           obrot2_der(1,i-2)=-dwasin2
3057           obrot2_der(2,i-2)= dwacos2
3058           Ug2der(1,1,i-2)= dwasin2
3059           Ug2der(1,2,i-2)=-dwacos2
3060           Ug2der(2,1,i-2)=-dwacos2
3061           Ug2der(2,2,i-2)=-dwasin2
3062         else
3063           obrot_der(1,i-2)=0.0d0
3064           obrot_der(2,i-2)=0.0d0
3065           Ugder(1,1,i-2)=0.0d0
3066           Ugder(1,2,i-2)=0.0d0
3067           Ugder(2,1,i-2)=0.0d0
3068           Ugder(2,2,i-2)=0.0d0
3069           obrot2_der(1,i-2)=0.0d0
3070           obrot2_der(2,i-2)=0.0d0
3071           Ug2der(1,1,i-2)=0.0d0
3072           Ug2der(1,2,i-2)=0.0d0
3073           Ug2der(2,1,i-2)=0.0d0
3074           Ug2der(2,2,i-2)=0.0d0
3075         endif
3076 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3077         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3078           iti = itype2loc(itype(i-2))
3079         else
3080           iti=nloctyp
3081         endif
3082 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3083         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3084           iti1 = itype2loc(itype(i-1))
3085         else
3086           iti1=nloctyp
3087         endif
3088 cd        write (iout,*) '*******i',i,' iti1',iti
3089 cd        write (iout,*) 'b1',b1(:,iti)
3090 cd        write (iout,*) 'b2',b2(:,iti)
3091 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3092 c        if (i .gt. iatel_s+2) then
3093         if (i .gt. nnt+2) then
3094           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3095 #ifdef NEWCORR
3096           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3097 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3098 #endif
3099 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3100 c     &    EE(1,2,iti),EE(2,2,i)
3101           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3102           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3103 c          write(iout,*) "Macierz EUG",
3104 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3105 c     &    eug(2,2,i-2)
3106           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3107      &    then
3108           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3109           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3110           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3111           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3112           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3113           endif
3114         else
3115           do k=1,2
3116             Ub2(k,i-2)=0.0d0
3117             Ctobr(k,i-2)=0.0d0
3118             Dtobr2(k,i-2)=0.0d0
3119             do l=1,2
3120               EUg(l,k,i-2)=0.0d0
3121               CUg(l,k,i-2)=0.0d0
3122               DUg(l,k,i-2)=0.0d0
3123               DtUg2(l,k,i-2)=0.0d0
3124             enddo
3125           enddo
3126         endif
3127         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3128         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3129         do k=1,2
3130           muder(k,i-2)=Ub2der(k,i-2)
3131         enddo
3132 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3133         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3134           if (itype(i-1).le.ntyp) then
3135             iti1 = itype2loc(itype(i-1))
3136           else
3137             iti1=nloctyp
3138           endif
3139         else
3140           iti1=nloctyp
3141         endif
3142         do k=1,2
3143           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3144 c          mu(k,i-2)=b1(k,i-1)
3145 c          mu(k,i-2)=Ub2(k,i-2)
3146         enddo
3147 #ifdef MUOUT
3148         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3149      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3150      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3151      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3152      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3153      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3154 #endif
3155 cd        write (iout,*) 'mu1',mu1(:,i-2)
3156 cd        write (iout,*) 'mu2',mu2(:,i-2)
3157 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3158         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3159      &  then
3160         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3161         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3162         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3163         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3164         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3165 C Vectors and matrices dependent on a single virtual-bond dihedral.
3166         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3167         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3168         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3169         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3170         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3171         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3172         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3173         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3174         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3175         endif
3176       enddo
3177 C Matrices dependent on two consecutive virtual-bond dihedrals.
3178 C The order of matrices is from left to right.
3179       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3180      &then
3181 c      do i=max0(ivec_start,2),ivec_end
3182       do i=2,nres-1
3183         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3184         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3185         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3186         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3187         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3188         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3189         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3190         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3191       enddo
3192       endif
3193 #if defined(MPI) && defined(PARMAT)
3194 #ifdef DEBUG
3195 c      if (fg_rank.eq.0) then
3196         write (iout,*) "Arrays UG and UGDER before GATHER"
3197         do i=1,nres-1
3198           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3199      &     ((ug(l,k,i),l=1,2),k=1,2),
3200      &     ((ugder(l,k,i),l=1,2),k=1,2)
3201         enddo
3202         write (iout,*) "Arrays UG2 and UG2DER"
3203         do i=1,nres-1
3204           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3205      &     ((ug2(l,k,i),l=1,2),k=1,2),
3206      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3207         enddo
3208         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3209         do i=1,nres-1
3210           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3211      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3212      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3213         enddo
3214         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3215         do i=1,nres-1
3216           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3217      &     costab(i),sintab(i),costab2(i),sintab2(i)
3218         enddo
3219         write (iout,*) "Array MUDER"
3220         do i=1,nres-1
3221           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3222         enddo
3223 c      endif
3224 #endif
3225       if (nfgtasks.gt.1) then
3226         time00=MPI_Wtime()
3227 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3228 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3229 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3230 #ifdef MATGATHER
3231         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3232      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3233      &   FG_COMM1,IERR)
3234         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3235      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3236      &   FG_COMM1,IERR)
3237         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3238      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3239      &   FG_COMM1,IERR)
3240         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3241      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3242      &   FG_COMM1,IERR)
3243         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3244      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3245      &   FG_COMM1,IERR)
3246         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3247      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3248      &   FG_COMM1,IERR)
3249         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3250      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3251      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3252         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3253      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3254      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3255         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3256      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3257      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3258         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3259      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3260      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3261         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3262      &  then
3263         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3264      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3265      &   FG_COMM1,IERR)
3266         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3267      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3268      &   FG_COMM1,IERR)
3269         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3270      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3271      &   FG_COMM1,IERR)
3272        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3273      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3274      &   FG_COMM1,IERR)
3275         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3276      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3277      &   FG_COMM1,IERR)
3278         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3279      &   ivec_count(fg_rank1),
3280      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3281      &   FG_COMM1,IERR)
3282         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3283      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3284      &   FG_COMM1,IERR)
3285         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3286      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3287      &   FG_COMM1,IERR)
3288         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3289      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3290      &   FG_COMM1,IERR)
3291         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3292      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3293      &   FG_COMM1,IERR)
3294         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3295      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3296      &   FG_COMM1,IERR)
3297         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3298      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3299      &   FG_COMM1,IERR)
3300         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3301      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3302      &   FG_COMM1,IERR)
3303         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3304      &   ivec_count(fg_rank1),
3305      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3306      &   FG_COMM1,IERR)
3307         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3308      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3309      &   FG_COMM1,IERR)
3310        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3311      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3312      &   FG_COMM1,IERR)
3313         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3314      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3315      &   FG_COMM1,IERR)
3316        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3317      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3318      &   FG_COMM1,IERR)
3319         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3320      &   ivec_count(fg_rank1),
3321      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3322      &   FG_COMM1,IERR)
3323         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3324      &   ivec_count(fg_rank1),
3325      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3326      &   FG_COMM1,IERR)
3327         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3328      &   ivec_count(fg_rank1),
3329      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3330      &   MPI_MAT2,FG_COMM1,IERR)
3331         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3332      &   ivec_count(fg_rank1),
3333      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3334      &   MPI_MAT2,FG_COMM1,IERR)
3335         endif
3336 #else
3337 c Passes matrix info through the ring
3338       isend=fg_rank1
3339       irecv=fg_rank1-1
3340       if (irecv.lt.0) irecv=nfgtasks1-1
3341       iprev=irecv
3342       inext=fg_rank1+1
3343       if (inext.ge.nfgtasks1) inext=0
3344       do i=1,nfgtasks1-1
3345 c        write (iout,*) "isend",isend," irecv",irecv
3346 c        call flush(iout)
3347         lensend=lentyp(isend)
3348         lenrecv=lentyp(irecv)
3349 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3350 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3351 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3352 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3353 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3354 c        write (iout,*) "Gather ROTAT1"
3355 c        call flush(iout)
3356 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3357 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3358 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3359 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3360 c        write (iout,*) "Gather ROTAT2"
3361 c        call flush(iout)
3362         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3363      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3364      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3365      &   iprev,4400+irecv,FG_COMM,status,IERR)
3366 c        write (iout,*) "Gather ROTAT_OLD"
3367 c        call flush(iout)
3368         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3369      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3370      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3371      &   iprev,5500+irecv,FG_COMM,status,IERR)
3372 c        write (iout,*) "Gather PRECOMP11"
3373 c        call flush(iout)
3374         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3375      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3376      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3377      &   iprev,6600+irecv,FG_COMM,status,IERR)
3378 c        write (iout,*) "Gather PRECOMP12"
3379 c        call flush(iout)
3380         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3381      &  then
3382         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3383      &   MPI_ROTAT2(lensend),inext,7700+isend,
3384      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3385      &   iprev,7700+irecv,FG_COMM,status,IERR)
3386 c        write (iout,*) "Gather PRECOMP21"
3387 c        call flush(iout)
3388         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3389      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3390      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3391      &   iprev,8800+irecv,FG_COMM,status,IERR)
3392 c        write (iout,*) "Gather PRECOMP22"
3393 c        call flush(iout)
3394         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3395      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3396      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3397      &   MPI_PRECOMP23(lenrecv),
3398      &   iprev,9900+irecv,FG_COMM,status,IERR)
3399 c        write (iout,*) "Gather PRECOMP23"
3400 c        call flush(iout)
3401         endif
3402         isend=irecv
3403         irecv=irecv-1
3404         if (irecv.lt.0) irecv=nfgtasks1-1
3405       enddo
3406 #endif
3407         time_gather=time_gather+MPI_Wtime()-time00
3408       endif
3409 #ifdef DEBUG
3410 c      if (fg_rank.eq.0) then
3411         write (iout,*) "Arrays UG and UGDER"
3412         do i=1,nres-1
3413           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3414      &     ((ug(l,k,i),l=1,2),k=1,2),
3415      &     ((ugder(l,k,i),l=1,2),k=1,2)
3416         enddo
3417         write (iout,*) "Arrays UG2 and UG2DER"
3418         do i=1,nres-1
3419           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3420      &     ((ug2(l,k,i),l=1,2),k=1,2),
3421      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3422         enddo
3423         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3424         do i=1,nres-1
3425           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3426      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3427      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3428         enddo
3429         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3430         do i=1,nres-1
3431           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3432      &     costab(i),sintab(i),costab2(i),sintab2(i)
3433         enddo
3434         write (iout,*) "Array MUDER"
3435         do i=1,nres-1
3436           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3437         enddo
3438 c      endif
3439 #endif
3440 #endif
3441 cd      do i=1,nres
3442 cd        iti = itype2loc(itype(i))
3443 cd        write (iout,*) i
3444 cd        do j=1,2
3445 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3446 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3447 cd        enddo
3448 cd      enddo
3449       return
3450       end
3451 C--------------------------------------------------------------------------
3452       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3453 C
3454 C This subroutine calculates the average interaction energy and its gradient
3455 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3456 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3457 C The potential depends both on the distance of peptide-group centers and on
3458 C the orientation of the CA-CA virtual bonds.
3459 C
3460       implicit real*8 (a-h,o-z)
3461 #ifdef MPI
3462       include 'mpif.h'
3463 #endif
3464       include 'DIMENSIONS'
3465       include 'COMMON.CONTROL'
3466       include 'COMMON.SETUP'
3467       include 'COMMON.IOUNITS'
3468       include 'COMMON.GEO'
3469       include 'COMMON.VAR'
3470       include 'COMMON.LOCAL'
3471       include 'COMMON.CHAIN'
3472       include 'COMMON.DERIV'
3473       include 'COMMON.INTERACT'
3474       include 'COMMON.CONTACTS'
3475       include 'COMMON.TORSION'
3476       include 'COMMON.VECTORS'
3477       include 'COMMON.FFIELD'
3478       include 'COMMON.TIME1'
3479       include 'COMMON.SPLITELE'
3480       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3481      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3482       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3483      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3484       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3485      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3486      &    num_conti,j1,j2
3487 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3488 #ifdef MOMENT
3489       double precision scal_el /1.0d0/
3490 #else
3491       double precision scal_el /0.5d0/
3492 #endif
3493 C 12/13/98
3494 C 13-go grudnia roku pamietnego...
3495       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3496      &                   0.0d0,1.0d0,0.0d0,
3497      &                   0.0d0,0.0d0,1.0d0/
3498 cd      write(iout,*) 'In EELEC'
3499 cd      do i=1,nloctyp
3500 cd        write(iout,*) 'Type',i
3501 cd        write(iout,*) 'B1',B1(:,i)
3502 cd        write(iout,*) 'B2',B2(:,i)
3503 cd        write(iout,*) 'CC',CC(:,:,i)
3504 cd        write(iout,*) 'DD',DD(:,:,i)
3505 cd        write(iout,*) 'EE',EE(:,:,i)
3506 cd      enddo
3507 cd      call check_vecgrad
3508 cd      stop
3509       if (icheckgrad.eq.1) then
3510         do i=1,nres-1
3511           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3512           do k=1,3
3513             dc_norm(k,i)=dc(k,i)*fac
3514           enddo
3515 c          write (iout,*) 'i',i,' fac',fac
3516         enddo
3517       endif
3518       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3519      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3520      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3521 c        call vec_and_deriv
3522 #ifdef TIMING
3523         time01=MPI_Wtime()
3524 #endif
3525         call set_matrices
3526 #ifdef TIMING
3527         time_mat=time_mat+MPI_Wtime()-time01
3528 #endif
3529       endif
3530 cd      do i=1,nres-1
3531 cd        write (iout,*) 'i=',i
3532 cd        do k=1,3
3533 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3534 cd        enddo
3535 cd        do k=1,3
3536 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3537 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3538 cd        enddo
3539 cd      enddo
3540       t_eelecij=0.0d0
3541       ees=0.0D0
3542       evdw1=0.0D0
3543       eel_loc=0.0d0
3544       eello_turn3=0.0d0
3545       eello_turn4=0.0d0
3546       ind=0
3547       do i=1,nres
3548         num_cont_hb(i)=0
3549       enddo
3550 cd      print '(a)','Enter EELEC'
3551 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3552       do i=1,nres
3553         gel_loc_loc(i)=0.0d0
3554         gcorr_loc(i)=0.0d0
3555       enddo
3556 c
3557 c
3558 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3559 C
3560 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3561 C
3562 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3563       do i=iturn3_start,iturn3_end
3564 c        if (i.le.1) cycle
3565 C        write(iout,*) "tu jest i",i
3566         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3567 C changes suggested by Ana to avoid out of bounds
3568 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3569 c     & .or.((i+4).gt.nres)
3570 c     & .or.((i-1).le.0)
3571 C end of changes by Ana
3572      &  .or. itype(i+2).eq.ntyp1
3573      &  .or. itype(i+3).eq.ntyp1) cycle
3574 C Adam: Instructions below will switch off existing interactions
3575 c        if(i.gt.1)then
3576 c          if(itype(i-1).eq.ntyp1)cycle
3577 c        end if
3578 c        if(i.LT.nres-3)then
3579 c          if (itype(i+4).eq.ntyp1) cycle
3580 c        end if
3581         dxi=dc(1,i)
3582         dyi=dc(2,i)
3583         dzi=dc(3,i)
3584         dx_normi=dc_norm(1,i)
3585         dy_normi=dc_norm(2,i)
3586         dz_normi=dc_norm(3,i)
3587         xmedi=c(1,i)+0.5d0*dxi
3588         ymedi=c(2,i)+0.5d0*dyi
3589         zmedi=c(3,i)+0.5d0*dzi
3590           xmedi=mod(xmedi,boxxsize)
3591           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3592           ymedi=mod(ymedi,boxysize)
3593           if (ymedi.lt.0) ymedi=ymedi+boxysize
3594           zmedi=mod(zmedi,boxzsize)
3595           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3596         num_conti=0
3597         call eelecij(i,i+2,ees,evdw1,eel_loc)
3598         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3599         num_cont_hb(i)=num_conti
3600       enddo
3601       do i=iturn4_start,iturn4_end
3602         if (i.lt.1) cycle
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     & .or.((i+5).gt.nres)
3606 c     & .or.((i-1).le.0)
3607 C end of changes suggested by Ana
3608      &    .or. itype(i+3).eq.ntyp1
3609      &    .or. itype(i+4).eq.ntyp1
3610 c     &    .or. itype(i+5).eq.ntyp1
3611 c     &    .or. itype(i).eq.ntyp1
3612 c     &    .or. itype(i-1).eq.ntyp1
3613      &                             ) cycle
3614         dxi=dc(1,i)
3615         dyi=dc(2,i)
3616         dzi=dc(3,i)
3617         dx_normi=dc_norm(1,i)
3618         dy_normi=dc_norm(2,i)
3619         dz_normi=dc_norm(3,i)
3620         xmedi=c(1,i)+0.5d0*dxi
3621         ymedi=c(2,i)+0.5d0*dyi
3622         zmedi=c(3,i)+0.5d0*dzi
3623 C Return atom into box, boxxsize is size of box in x dimension
3624 c  194   continue
3625 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3626 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3627 C Condition for being inside the proper box
3628 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3629 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3630 c        go to 194
3631 c        endif
3632 c  195   continue
3633 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3634 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3635 C Condition for being inside the proper box
3636 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3637 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3638 c        go to 195
3639 c        endif
3640 c  196   continue
3641 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3642 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3643 C Condition for being inside the proper box
3644 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3645 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3646 c        go to 196
3647 c        endif
3648           xmedi=mod(xmedi,boxxsize)
3649           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3650           ymedi=mod(ymedi,boxysize)
3651           if (ymedi.lt.0) ymedi=ymedi+boxysize
3652           zmedi=mod(zmedi,boxzsize)
3653           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3654
3655         num_conti=num_cont_hb(i)
3656 c        write(iout,*) "JESTEM W PETLI"
3657         call eelecij(i,i+3,ees,evdw1,eel_loc)
3658         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3659      &   call eturn4(i,eello_turn4)
3660         num_cont_hb(i)=num_conti
3661       enddo   ! i
3662 C Loop over all neighbouring boxes
3663 C      do xshift=-1,1
3664 C      do yshift=-1,1
3665 C      do zshift=-1,1
3666 c
3667 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3668 c
3669 CTU KURWA
3670       do i=iatel_s,iatel_e
3671 C        do i=75,75
3672 c        if (i.le.1) cycle
3673         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3674 C changes suggested by Ana to avoid out of bounds
3675 c     & .or.((i+2).gt.nres)
3676 c     & .or.((i-1).le.0)
3677 C end of changes by Ana
3678 c     &  .or. itype(i+2).eq.ntyp1
3679 c     &  .or. itype(i-1).eq.ntyp1
3680      &                ) cycle
3681         dxi=dc(1,i)
3682         dyi=dc(2,i)
3683         dzi=dc(3,i)
3684         dx_normi=dc_norm(1,i)
3685         dy_normi=dc_norm(2,i)
3686         dz_normi=dc_norm(3,i)
3687         xmedi=c(1,i)+0.5d0*dxi
3688         ymedi=c(2,i)+0.5d0*dyi
3689         zmedi=c(3,i)+0.5d0*dzi
3690           xmedi=mod(xmedi,boxxsize)
3691           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3692           ymedi=mod(ymedi,boxysize)
3693           if (ymedi.lt.0) ymedi=ymedi+boxysize
3694           zmedi=mod(zmedi,boxzsize)
3695           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3696 C          xmedi=xmedi+xshift*boxxsize
3697 C          ymedi=ymedi+yshift*boxysize
3698 C          zmedi=zmedi+zshift*boxzsize
3699
3700 C Return tom into box, boxxsize is size of box in x dimension
3701 c  164   continue
3702 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3703 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3704 C Condition for being inside the proper box
3705 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3706 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3707 c        go to 164
3708 c        endif
3709 c  165   continue
3710 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3711 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3712 C Condition for being inside the proper box
3713 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3714 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3715 c        go to 165
3716 c        endif
3717 c  166   continue
3718 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3719 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3720 cC Condition for being inside the proper box
3721 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3722 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3723 c        go to 166
3724 c        endif
3725
3726 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3727         num_conti=num_cont_hb(i)
3728 C I TU KURWA
3729         do j=ielstart(i),ielend(i)
3730 C          do j=16,17
3731 C          write (iout,*) i,j
3732 C         if (j.le.1) cycle
3733           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3734 C changes suggested by Ana to avoid out of bounds
3735 c     & .or.((j+2).gt.nres)
3736 c     & .or.((j-1).le.0)
3737 C end of changes by Ana
3738 c     & .or.itype(j+2).eq.ntyp1
3739 c     & .or.itype(j-1).eq.ntyp1
3740      &) cycle
3741           call eelecij(i,j,ees,evdw1,eel_loc)
3742         enddo ! j
3743         num_cont_hb(i)=num_conti
3744       enddo   ! i
3745 C     enddo   ! zshift
3746 C      enddo   ! yshift
3747 C      enddo   ! xshift
3748
3749 c      write (iout,*) "Number of loop steps in EELEC:",ind
3750 cd      do i=1,nres
3751 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3752 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3753 cd      enddo
3754 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3755 ccc      eel_loc=eel_loc+eello_turn3
3756 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3757       return
3758       end
3759 C-------------------------------------------------------------------------------
3760       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3761       implicit real*8 (a-h,o-z)
3762       include 'DIMENSIONS'
3763 #ifdef MPI
3764       include "mpif.h"
3765 #endif
3766       include 'COMMON.CONTROL'
3767       include 'COMMON.IOUNITS'
3768       include 'COMMON.GEO'
3769       include 'COMMON.VAR'
3770       include 'COMMON.LOCAL'
3771       include 'COMMON.CHAIN'
3772       include 'COMMON.DERIV'
3773       include 'COMMON.INTERACT'
3774       include 'COMMON.CONTACTS'
3775       include 'COMMON.TORSION'
3776       include 'COMMON.VECTORS'
3777       include 'COMMON.FFIELD'
3778       include 'COMMON.TIME1'
3779       include 'COMMON.SPLITELE'
3780       include 'COMMON.SHIELD'
3781       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3782      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3783       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3784      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3785      &    gmuij2(4),gmuji2(4)
3786       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3787      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3788      &    num_conti,j1,j2
3789 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3790 #ifdef MOMENT
3791       double precision scal_el /1.0d0/
3792 #else
3793       double precision scal_el /0.5d0/
3794 #endif
3795 C 12/13/98
3796 C 13-go grudnia roku pamietnego...
3797       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3798      &                   0.0d0,1.0d0,0.0d0,
3799      &                   0.0d0,0.0d0,1.0d0/
3800        integer xshift,yshift,zshift
3801 c          time00=MPI_Wtime()
3802 cd      write (iout,*) "eelecij",i,j
3803 c          ind=ind+1
3804           iteli=itel(i)
3805           itelj=itel(j)
3806           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3807           aaa=app(iteli,itelj)
3808           bbb=bpp(iteli,itelj)
3809           ael6i=ael6(iteli,itelj)
3810           ael3i=ael3(iteli,itelj)
3811           dxj=dc(1,j)
3812           dyj=dc(2,j)
3813           dzj=dc(3,j)
3814           dx_normj=dc_norm(1,j)
3815           dy_normj=dc_norm(2,j)
3816           dz_normj=dc_norm(3,j)
3817 C          xj=c(1,j)+0.5D0*dxj-xmedi
3818 C          yj=c(2,j)+0.5D0*dyj-ymedi
3819 C          zj=c(3,j)+0.5D0*dzj-zmedi
3820           xj=c(1,j)+0.5D0*dxj
3821           yj=c(2,j)+0.5D0*dyj
3822           zj=c(3,j)+0.5D0*dzj
3823           xj=mod(xj,boxxsize)
3824           if (xj.lt.0) xj=xj+boxxsize
3825           yj=mod(yj,boxysize)
3826           if (yj.lt.0) yj=yj+boxysize
3827           zj=mod(zj,boxzsize)
3828           if (zj.lt.0) zj=zj+boxzsize
3829           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3830       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3831       xj_safe=xj
3832       yj_safe=yj
3833       zj_safe=zj
3834       isubchap=0
3835       do xshift=-1,1
3836       do yshift=-1,1
3837       do zshift=-1,1
3838           xj=xj_safe+xshift*boxxsize
3839           yj=yj_safe+yshift*boxysize
3840           zj=zj_safe+zshift*boxzsize
3841           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3842           if(dist_temp.lt.dist_init) then
3843             dist_init=dist_temp
3844             xj_temp=xj
3845             yj_temp=yj
3846             zj_temp=zj
3847             isubchap=1
3848           endif
3849        enddo
3850        enddo
3851        enddo
3852        if (isubchap.eq.1) then
3853           xj=xj_temp-xmedi
3854           yj=yj_temp-ymedi
3855           zj=zj_temp-zmedi
3856        else
3857           xj=xj_safe-xmedi
3858           yj=yj_safe-ymedi
3859           zj=zj_safe-zmedi
3860        endif
3861 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3862 c  174   continue
3863 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3864 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3865 C Condition for being inside the proper box
3866 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3867 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3868 c        go to 174
3869 c        endif
3870 c  175   continue
3871 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3872 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3873 C Condition for being inside the proper box
3874 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3875 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3876 c        go to 175
3877 c        endif
3878 c  176   continue
3879 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3880 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3881 C Condition for being inside the proper box
3882 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3883 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3884 c        go to 176
3885 c        endif
3886 C        endif !endPBC condintion
3887 C        xj=xj-xmedi
3888 C        yj=yj-ymedi
3889 C        zj=zj-zmedi
3890           rij=xj*xj+yj*yj+zj*zj
3891
3892             sss=sscale(sqrt(rij))
3893             sssgrad=sscagrad(sqrt(rij))
3894 c            if (sss.gt.0.0d0) then
3895           rrmij=1.0D0/rij
3896           rij=dsqrt(rij)
3897           rmij=1.0D0/rij
3898           r3ij=rrmij*rmij
3899           r6ij=r3ij*r3ij
3900           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3901           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3902           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3903           fac=cosa-3.0D0*cosb*cosg
3904           ev1=aaa*r6ij*r6ij
3905 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3906           if (j.eq.i+2) ev1=scal_el*ev1
3907           ev2=bbb*r6ij
3908           fac3=ael6i*r6ij
3909           fac4=ael3i*r3ij
3910           evdwij=(ev1+ev2)
3911           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3912           el2=fac4*fac
3913 C MARYSIA
3914 C          eesij=(el1+el2)
3915 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3916           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3917           if (shield_mode.gt.0) then
3918 C          fac_shield(i)=0.4
3919 C          fac_shield(j)=0.6
3920           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3921           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3922           eesij=(el1+el2)
3923           ees=ees+eesij
3924           else
3925           fac_shield(i)=1.0
3926           fac_shield(j)=1.0
3927           eesij=(el1+el2)
3928           ees=ees+eesij
3929           endif
3930           evdw1=evdw1+evdwij*sss
3931 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3932 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3933 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3934 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3935
3936           if (energy_dec) then
3937               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
3938      &'evdw1',i,j,evdwij
3939      &,iteli,itelj,aaa,evdw1,sss
3940               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3941      &fac_shield(i),fac_shield(j)
3942           endif
3943
3944 C
3945 C Calculate contributions to the Cartesian gradient.
3946 C
3947 #ifdef SPLITELE
3948           facvdw=-6*rrmij*(ev1+evdwij)*sss
3949           facel=-3*rrmij*(el1+eesij)
3950           fac1=fac
3951           erij(1)=xj*rmij
3952           erij(2)=yj*rmij
3953           erij(3)=zj*rmij
3954
3955 *
3956 * Radial derivatives. First process both termini of the fragment (i,j)
3957 *
3958           ggg(1)=facel*xj
3959           ggg(2)=facel*yj
3960           ggg(3)=facel*zj
3961           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3962      &  (shield_mode.gt.0)) then
3963 C          print *,i,j
3964           do ilist=1,ishield_list(i)
3965            iresshield=shield_list(ilist,i)
3966            do k=1,3
3967            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3968      &      *2.0
3969            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3970      &              rlocshield
3971      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3972             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3973 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3974 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3975 C             if (iresshield.gt.i) then
3976 C               do ishi=i+1,iresshield-1
3977 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3978 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3979 C
3980 C              enddo
3981 C             else
3982 C               do ishi=iresshield,i
3983 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3984 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3985 C
3986 C               enddo
3987 C              endif
3988            enddo
3989           enddo
3990           do ilist=1,ishield_list(j)
3991            iresshield=shield_list(ilist,j)
3992            do k=1,3
3993            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3994      &     *2.0
3995            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3996      &              rlocshield
3997      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3998            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3999
4000 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4001 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4002 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4003 C             if (iresshield.gt.j) then
4004 C               do ishi=j+1,iresshield-1
4005 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4006 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4007 C
4008 C               enddo
4009 C            else
4010 C               do ishi=iresshield,j
4011 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4012 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4013 C               enddo
4014 C              endif
4015            enddo
4016           enddo
4017
4018           do k=1,3
4019             gshieldc(k,i)=gshieldc(k,i)+
4020      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4021             gshieldc(k,j)=gshieldc(k,j)+
4022      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4023             gshieldc(k,i-1)=gshieldc(k,i-1)+
4024      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4025             gshieldc(k,j-1)=gshieldc(k,j-1)+
4026      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4027
4028            enddo
4029            endif
4030 c          do k=1,3
4031 c            ghalf=0.5D0*ggg(k)
4032 c            gelc(k,i)=gelc(k,i)+ghalf
4033 c            gelc(k,j)=gelc(k,j)+ghalf
4034 c          enddo
4035 c 9/28/08 AL Gradient compotents will be summed only at the end
4036 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4037           do k=1,3
4038             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4039 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4040             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4041 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4042 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4043 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4044 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4045 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4046           enddo
4047 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4048
4049 *
4050 * Loop over residues i+1 thru j-1.
4051 *
4052 cgrad          do k=i+1,j-1
4053 cgrad            do l=1,3
4054 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4055 cgrad            enddo
4056 cgrad          enddo
4057           if (sss.gt.0.0) then
4058           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4059           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4060           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4061           else
4062           ggg(1)=0.0
4063           ggg(2)=0.0
4064           ggg(3)=0.0
4065           endif
4066 c          do k=1,3
4067 c            ghalf=0.5D0*ggg(k)
4068 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4069 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4070 c          enddo
4071 c 9/28/08 AL Gradient compotents will be summed only at the end
4072           do k=1,3
4073             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4074             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4075           enddo
4076 *
4077 * Loop over residues i+1 thru j-1.
4078 *
4079 cgrad          do k=i+1,j-1
4080 cgrad            do l=1,3
4081 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4082 cgrad            enddo
4083 cgrad          enddo
4084 #else
4085 C MARYSIA
4086           facvdw=(ev1+evdwij)*sss
4087           facel=(el1+eesij)
4088           fac1=fac
4089           fac=-3*rrmij*(facvdw+facvdw+facel)
4090           erij(1)=xj*rmij
4091           erij(2)=yj*rmij
4092           erij(3)=zj*rmij
4093 *
4094 * Radial derivatives. First process both termini of the fragment (i,j)
4095 *
4096           ggg(1)=fac*xj
4097 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4098           ggg(2)=fac*yj
4099 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4100           ggg(3)=fac*zj
4101 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4102 c          do k=1,3
4103 c            ghalf=0.5D0*ggg(k)
4104 c            gelc(k,i)=gelc(k,i)+ghalf
4105 c            gelc(k,j)=gelc(k,j)+ghalf
4106 c          enddo
4107 c 9/28/08 AL Gradient compotents will be summed only at the end
4108           do k=1,3
4109             gelc_long(k,j)=gelc(k,j)+ggg(k)
4110             gelc_long(k,i)=gelc(k,i)-ggg(k)
4111           enddo
4112 *
4113 * Loop over residues i+1 thru j-1.
4114 *
4115 cgrad          do k=i+1,j-1
4116 cgrad            do l=1,3
4117 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4118 cgrad            enddo
4119 cgrad          enddo
4120 c 9/28/08 AL Gradient compotents will be summed only at the end
4121           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4122           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4123           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4124           do k=1,3
4125             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4126             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4127           enddo
4128 #endif
4129 *
4130 * Angular part
4131 *
4132           ecosa=2.0D0*fac3*fac1+fac4
4133           fac4=-3.0D0*fac4
4134           fac3=-6.0D0*fac3
4135           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4136           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4137           do k=1,3
4138             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4139             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4140           enddo
4141 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4142 cd   &          (dcosg(k),k=1,3)
4143           do k=1,3
4144             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4145      &      fac_shield(i)**2*fac_shield(j)**2
4146           enddo
4147 c          do k=1,3
4148 c            ghalf=0.5D0*ggg(k)
4149 c            gelc(k,i)=gelc(k,i)+ghalf
4150 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4151 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4152 c            gelc(k,j)=gelc(k,j)+ghalf
4153 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4154 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4155 c          enddo
4156 cgrad          do k=i+1,j-1
4157 cgrad            do l=1,3
4158 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4159 cgrad            enddo
4160 cgrad          enddo
4161 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4162           do k=1,3
4163             gelc(k,i)=gelc(k,i)
4164      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4165      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4166      &           *fac_shield(i)**2*fac_shield(j)**2
4167             gelc(k,j)=gelc(k,j)
4168      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4169      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4170      &           *fac_shield(i)**2*fac_shield(j)**2
4171             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4172             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4173           enddo
4174 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4175
4176 C MARYSIA
4177 c          endif !sscale
4178           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4179      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4180      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4181 C
4182 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4183 C   energy of a peptide unit is assumed in the form of a second-order
4184 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4185 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4186 C   are computed for EVERY pair of non-contiguous peptide groups.
4187 C
4188
4189           if (j.lt.nres-1) then
4190             j1=j+1
4191             j2=j-1
4192           else
4193             j1=j-1
4194             j2=j-2
4195           endif
4196           kkk=0
4197           lll=0
4198           do k=1,2
4199             do l=1,2
4200               kkk=kkk+1
4201               muij(kkk)=mu(k,i)*mu(l,j)
4202 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4203 #ifdef NEWCORR
4204              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4205 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4206              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4207              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4208 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4209              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4210 #endif
4211             enddo
4212           enddo
4213 #ifdef DEBUG
4214           write (iout,*) 'EELEC: i',i,' j',j
4215           write (iout,*) 'j',j,' j1',j1,' j2',j2
4216           write(iout,*) 'muij',muij
4217 #endif
4218           ury=scalar(uy(1,i),erij)
4219           urz=scalar(uz(1,i),erij)
4220           vry=scalar(uy(1,j),erij)
4221           vrz=scalar(uz(1,j),erij)
4222           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4223           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4224           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4225           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4226           fac=dsqrt(-ael6i)*r3ij
4227 #ifdef DEBUG
4228           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4229           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4230      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4231      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4232      &      "uzvz",scalar(uz(1,i),uz(1,j))
4233           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4234           write (iout,*) "fac",fac
4235 #endif
4236           a22=a22*fac
4237           a23=a23*fac
4238           a32=a32*fac
4239           a33=a33*fac
4240 #ifdef DEBUG
4241           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4242 #endif
4243 #undef DEBUG
4244 cd          write (iout,'(4i5,4f10.5)')
4245 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4246 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4247 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4248 cd     &      uy(:,j),uz(:,j)
4249 cd          write (iout,'(4f10.5)')
4250 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4251 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4252 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4253 cd           write (iout,'(9f10.5/)')
4254 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4255 C Derivatives of the elements of A in virtual-bond vectors
4256           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4257           do k=1,3
4258             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4259             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4260             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4261             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4262             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4263             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4264             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4265             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4266             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4267             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4268             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4269             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4270           enddo
4271 C Compute radial contributions to the gradient
4272           facr=-3.0d0*rrmij
4273           a22der=a22*facr
4274           a23der=a23*facr
4275           a32der=a32*facr
4276           a33der=a33*facr
4277           agg(1,1)=a22der*xj
4278           agg(2,1)=a22der*yj
4279           agg(3,1)=a22der*zj
4280           agg(1,2)=a23der*xj
4281           agg(2,2)=a23der*yj
4282           agg(3,2)=a23der*zj
4283           agg(1,3)=a32der*xj
4284           agg(2,3)=a32der*yj
4285           agg(3,3)=a32der*zj
4286           agg(1,4)=a33der*xj
4287           agg(2,4)=a33der*yj
4288           agg(3,4)=a33der*zj
4289 C Add the contributions coming from er
4290           fac3=-3.0d0*fac
4291           do k=1,3
4292             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4293             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4294             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4295             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4296           enddo
4297           do k=1,3
4298 C Derivatives in DC(i)
4299 cgrad            ghalf1=0.5d0*agg(k,1)
4300 cgrad            ghalf2=0.5d0*agg(k,2)
4301 cgrad            ghalf3=0.5d0*agg(k,3)
4302 cgrad            ghalf4=0.5d0*agg(k,4)
4303             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4304      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4305             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4306      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4307             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4308      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4309             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4310      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4311 C Derivatives in DC(i+1)
4312             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4313      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4314             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4315      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4316             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4317      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4318             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4319      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4320 C Derivatives in DC(j)
4321             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4322      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4323             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4324      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4325             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4326      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4327             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4328      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4329 C Derivatives in DC(j+1) or DC(nres-1)
4330             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4331      &      -3.0d0*vryg(k,3)*ury)
4332             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4333      &      -3.0d0*vrzg(k,3)*ury)
4334             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4335      &      -3.0d0*vryg(k,3)*urz)
4336             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4337      &      -3.0d0*vrzg(k,3)*urz)
4338 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4339 cgrad              do l=1,4
4340 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4341 cgrad              enddo
4342 cgrad            endif
4343           enddo
4344           acipa(1,1)=a22
4345           acipa(1,2)=a23
4346           acipa(2,1)=a32
4347           acipa(2,2)=a33
4348           a22=-a22
4349           a23=-a23
4350           do l=1,2
4351             do k=1,3
4352               agg(k,l)=-agg(k,l)
4353               aggi(k,l)=-aggi(k,l)
4354               aggi1(k,l)=-aggi1(k,l)
4355               aggj(k,l)=-aggj(k,l)
4356               aggj1(k,l)=-aggj1(k,l)
4357             enddo
4358           enddo
4359           if (j.lt.nres-1) then
4360             a22=-a22
4361             a32=-a32
4362             do l=1,3,2
4363               do k=1,3
4364                 agg(k,l)=-agg(k,l)
4365                 aggi(k,l)=-aggi(k,l)
4366                 aggi1(k,l)=-aggi1(k,l)
4367                 aggj(k,l)=-aggj(k,l)
4368                 aggj1(k,l)=-aggj1(k,l)
4369               enddo
4370             enddo
4371           else
4372             a22=-a22
4373             a23=-a23
4374             a32=-a32
4375             a33=-a33
4376             do l=1,4
4377               do k=1,3
4378                 agg(k,l)=-agg(k,l)
4379                 aggi(k,l)=-aggi(k,l)
4380                 aggi1(k,l)=-aggi1(k,l)
4381                 aggj(k,l)=-aggj(k,l)
4382                 aggj1(k,l)=-aggj1(k,l)
4383               enddo
4384             enddo
4385           endif
4386           ENDIF ! WCORR
4387           IF (wel_loc.gt.0.0d0) THEN
4388 C Contribution to the local-electrostatic energy coming from the i-j pair
4389           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4390      &     +a33*muij(4)
4391 #ifdef DEBUG
4392           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4393      &     " a33",a33
4394           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4395      &     " wel_loc",wel_loc
4396 #endif
4397           if (shield_mode.eq.0) then
4398            fac_shield(i)=1.0
4399            fac_shield(j)=1.0
4400 C          else
4401 C           fac_shield(i)=0.4
4402 C           fac_shield(j)=0.6
4403           endif
4404           eel_loc_ij=eel_loc_ij
4405      &    *fac_shield(i)*fac_shield(j)
4406 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4407 c     &            'eelloc',i,j,eel_loc_ij
4408 C Now derivative over eel_loc
4409           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4410      &  (shield_mode.gt.0)) then
4411 C          print *,i,j
4412
4413           do ilist=1,ishield_list(i)
4414            iresshield=shield_list(ilist,i)
4415            do k=1,3
4416            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4417      &                                          /fac_shield(i)
4418 C     &      *2.0
4419            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4420      &              rlocshield
4421      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4422             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4423      &      +rlocshield
4424            enddo
4425           enddo
4426           do ilist=1,ishield_list(j)
4427            iresshield=shield_list(ilist,j)
4428            do k=1,3
4429            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4430      &                                       /fac_shield(j)
4431 C     &     *2.0
4432            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4433      &              rlocshield
4434      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4435            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4436      &             +rlocshield
4437
4438            enddo
4439           enddo
4440
4441           do k=1,3
4442             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4443      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4444             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4445      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4446             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4447      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4448             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4449      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4450            enddo
4451            endif
4452
4453
4454 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4455 c     &                     ' eel_loc_ij',eel_loc_ij
4456 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4457 C Calculate patrial derivative for theta angle
4458 #ifdef NEWCORR
4459          geel_loc_ij=(a22*gmuij1(1)
4460      &     +a23*gmuij1(2)
4461      &     +a32*gmuij1(3)
4462      &     +a33*gmuij1(4))
4463      &    *fac_shield(i)*fac_shield(j)
4464 c         write(iout,*) "derivative over thatai"
4465 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4466 c     &   a33*gmuij1(4)
4467          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4468      &      geel_loc_ij*wel_loc
4469 c         write(iout,*) "derivative over thatai-1"
4470 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4471 c     &   a33*gmuij2(4)
4472          geel_loc_ij=
4473      &     a22*gmuij2(1)
4474      &     +a23*gmuij2(2)
4475      &     +a32*gmuij2(3)
4476      &     +a33*gmuij2(4)
4477          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4478      &      geel_loc_ij*wel_loc
4479      &    *fac_shield(i)*fac_shield(j)
4480
4481 c  Derivative over j residue
4482          geel_loc_ji=a22*gmuji1(1)
4483      &     +a23*gmuji1(2)
4484      &     +a32*gmuji1(3)
4485      &     +a33*gmuji1(4)
4486 c         write(iout,*) "derivative over thataj"
4487 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4488 c     &   a33*gmuji1(4)
4489
4490         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4491      &      geel_loc_ji*wel_loc
4492      &    *fac_shield(i)*fac_shield(j)
4493
4494          geel_loc_ji=
4495      &     +a22*gmuji2(1)
4496      &     +a23*gmuji2(2)
4497      &     +a32*gmuji2(3)
4498      &     +a33*gmuji2(4)
4499 c         write(iout,*) "derivative over thataj-1"
4500 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4501 c     &   a33*gmuji2(4)
4502          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4503      &      geel_loc_ji*wel_loc
4504      &    *fac_shield(i)*fac_shield(j)
4505 #endif
4506 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4507
4508           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4509      &            'eelloc',i,j,eel_loc_ij
4510 c           if (eel_loc_ij.ne.0)
4511 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4512 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4513
4514           eel_loc=eel_loc+eel_loc_ij
4515 C Partial derivatives in virtual-bond dihedral angles gamma
4516           if (i.gt.1)
4517      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4518      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4519      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4520      &    *fac_shield(i)*fac_shield(j)
4521
4522           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4523      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4524      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4525      &    *fac_shield(i)*fac_shield(j)
4526 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4527           do l=1,3
4528             ggg(l)=(agg(l,1)*muij(1)+
4529      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4530      &    *fac_shield(i)*fac_shield(j)
4531             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4532             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4533 cgrad            ghalf=0.5d0*ggg(l)
4534 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4535 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4536           enddo
4537 cgrad          do k=i+1,j2
4538 cgrad            do l=1,3
4539 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4540 cgrad            enddo
4541 cgrad          enddo
4542 C Remaining derivatives of eello
4543           do l=1,3
4544             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4545      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4546      &    *fac_shield(i)*fac_shield(j)
4547
4548             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4549      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4550      &    *fac_shield(i)*fac_shield(j)
4551
4552             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4553      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4554      &    *fac_shield(i)*fac_shield(j)
4555
4556             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4557      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4558      &    *fac_shield(i)*fac_shield(j)
4559
4560           enddo
4561           ENDIF
4562 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4563 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4564           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4565      &       .and. num_conti.le.maxconts) then
4566 c            write (iout,*) i,j," entered corr"
4567 C
4568 C Calculate the contact function. The ith column of the array JCONT will
4569 C contain the numbers of atoms that make contacts with the atom I (of numbers
4570 C greater than I). The arrays FACONT and GACONT will contain the values of
4571 C the contact function and its derivative.
4572 c           r0ij=1.02D0*rpp(iteli,itelj)
4573 c           r0ij=1.11D0*rpp(iteli,itelj)
4574             r0ij=2.20D0*rpp(iteli,itelj)
4575 c           r0ij=1.55D0*rpp(iteli,itelj)
4576             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4577             if (fcont.gt.0.0D0) then
4578               num_conti=num_conti+1
4579               if (num_conti.gt.maxconts) then
4580                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4581      &                         ' will skip next contacts for this conf.'
4582               else
4583                 jcont_hb(num_conti,i)=j
4584 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4585 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4586                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4587      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4588 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4589 C  terms.
4590                 d_cont(num_conti,i)=rij
4591 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4592 C     --- Electrostatic-interaction matrix ---
4593                 a_chuj(1,1,num_conti,i)=a22
4594                 a_chuj(1,2,num_conti,i)=a23
4595                 a_chuj(2,1,num_conti,i)=a32
4596                 a_chuj(2,2,num_conti,i)=a33
4597 C     --- Gradient of rij
4598                 do kkk=1,3
4599                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4600                 enddo
4601                 kkll=0
4602                 do k=1,2
4603                   do l=1,2
4604                     kkll=kkll+1
4605                     do m=1,3
4606                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4607                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4608                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4609                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4610                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4611                     enddo
4612                   enddo
4613                 enddo
4614                 ENDIF
4615                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4616 C Calculate contact energies
4617                 cosa4=4.0D0*cosa
4618                 wij=cosa-3.0D0*cosb*cosg
4619                 cosbg1=cosb+cosg
4620                 cosbg2=cosb-cosg
4621 c               fac3=dsqrt(-ael6i)/r0ij**3
4622                 fac3=dsqrt(-ael6i)*r3ij
4623 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4624                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4625                 if (ees0tmp.gt.0) then
4626                   ees0pij=dsqrt(ees0tmp)
4627                 else
4628                   ees0pij=0
4629                 endif
4630 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4631                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4632                 if (ees0tmp.gt.0) then
4633                   ees0mij=dsqrt(ees0tmp)
4634                 else
4635                   ees0mij=0
4636                 endif
4637 c               ees0mij=0.0D0
4638                 if (shield_mode.eq.0) then
4639                 fac_shield(i)=1.0d0
4640                 fac_shield(j)=1.0d0
4641                 else
4642                 ees0plist(num_conti,i)=j
4643 C                fac_shield(i)=0.4d0
4644 C                fac_shield(j)=0.6d0
4645                 endif
4646                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4647      &          *fac_shield(i)*fac_shield(j)
4648                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4649      &          *fac_shield(i)*fac_shield(j)
4650 C Diagnostics. Comment out or remove after debugging!
4651 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4652 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4653 c               ees0m(num_conti,i)=0.0D0
4654 C End diagnostics.
4655 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4656 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4657 C Angular derivatives of the contact function
4658                 ees0pij1=fac3/ees0pij
4659                 ees0mij1=fac3/ees0mij
4660                 fac3p=-3.0D0*fac3*rrmij
4661                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4662                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4663 c               ees0mij1=0.0D0
4664                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4665                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4666                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4667                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4668                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4669                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4670                 ecosap=ecosa1+ecosa2
4671                 ecosbp=ecosb1+ecosb2
4672                 ecosgp=ecosg1+ecosg2
4673                 ecosam=ecosa1-ecosa2
4674                 ecosbm=ecosb1-ecosb2
4675                 ecosgm=ecosg1-ecosg2
4676 C Diagnostics
4677 c               ecosap=ecosa1
4678 c               ecosbp=ecosb1
4679 c               ecosgp=ecosg1
4680 c               ecosam=0.0D0
4681 c               ecosbm=0.0D0
4682 c               ecosgm=0.0D0
4683 C End diagnostics
4684                 facont_hb(num_conti,i)=fcont
4685                 fprimcont=fprimcont/rij
4686 cd              facont_hb(num_conti,i)=1.0D0
4687 C Following line is for diagnostics.
4688 cd              fprimcont=0.0D0
4689                 do k=1,3
4690                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4691                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4692                 enddo
4693                 do k=1,3
4694                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4695                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4696                 enddo
4697                 gggp(1)=gggp(1)+ees0pijp*xj
4698                 gggp(2)=gggp(2)+ees0pijp*yj
4699                 gggp(3)=gggp(3)+ees0pijp*zj
4700                 gggm(1)=gggm(1)+ees0mijp*xj
4701                 gggm(2)=gggm(2)+ees0mijp*yj
4702                 gggm(3)=gggm(3)+ees0mijp*zj
4703 C Derivatives due to the contact function
4704                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4705                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4706                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4707                 do k=1,3
4708 c
4709 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4710 c          following the change of gradient-summation algorithm.
4711 c
4712 cgrad                  ghalfp=0.5D0*gggp(k)
4713 cgrad                  ghalfm=0.5D0*gggm(k)
4714                   gacontp_hb1(k,num_conti,i)=!ghalfp
4715      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4716      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4717      &          *fac_shield(i)*fac_shield(j)
4718
4719                   gacontp_hb2(k,num_conti,i)=!ghalfp
4720      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4721      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4722      &          *fac_shield(i)*fac_shield(j)
4723
4724                   gacontp_hb3(k,num_conti,i)=gggp(k)
4725      &          *fac_shield(i)*fac_shield(j)
4726
4727                   gacontm_hb1(k,num_conti,i)=!ghalfm
4728      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4729      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4730      &          *fac_shield(i)*fac_shield(j)
4731
4732                   gacontm_hb2(k,num_conti,i)=!ghalfm
4733      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4734      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4735      &          *fac_shield(i)*fac_shield(j)
4736
4737                   gacontm_hb3(k,num_conti,i)=gggm(k)
4738      &          *fac_shield(i)*fac_shield(j)
4739
4740                 enddo
4741 C Diagnostics. Comment out or remove after debugging!
4742 cdiag           do k=1,3
4743 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4744 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4745 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4746 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4747 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4748 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4749 cdiag           enddo
4750               ENDIF ! wcorr
4751               endif  ! num_conti.le.maxconts
4752             endif  ! fcont.gt.0
4753           endif    ! j.gt.i+1
4754           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4755             do k=1,4
4756               do l=1,3
4757                 ghalf=0.5d0*agg(l,k)
4758                 aggi(l,k)=aggi(l,k)+ghalf
4759                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4760                 aggj(l,k)=aggj(l,k)+ghalf
4761               enddo
4762             enddo
4763             if (j.eq.nres-1 .and. i.lt.j-2) then
4764               do k=1,4
4765                 do l=1,3
4766                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4767                 enddo
4768               enddo
4769             endif
4770           endif
4771 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4772       return
4773       end
4774 C-----------------------------------------------------------------------------
4775       subroutine eturn3(i,eello_turn3)
4776 C Third- and fourth-order contributions from turns
4777       implicit real*8 (a-h,o-z)
4778       include 'DIMENSIONS'
4779       include 'COMMON.IOUNITS'
4780       include 'COMMON.GEO'
4781       include 'COMMON.VAR'
4782       include 'COMMON.LOCAL'
4783       include 'COMMON.CHAIN'
4784       include 'COMMON.DERIV'
4785       include 'COMMON.INTERACT'
4786       include 'COMMON.CONTACTS'
4787       include 'COMMON.TORSION'
4788       include 'COMMON.VECTORS'
4789       include 'COMMON.FFIELD'
4790       include 'COMMON.CONTROL'
4791       include 'COMMON.SHIELD'
4792       dimension ggg(3)
4793       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4794      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4795      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4796      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4797      &  auxgmat2(2,2),auxgmatt2(2,2)
4798       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4799      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4800       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4801      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4802      &    num_conti,j1,j2
4803       j=i+2
4804 c      write (iout,*) "eturn3",i,j,j1,j2
4805       a_temp(1,1)=a22
4806       a_temp(1,2)=a23
4807       a_temp(2,1)=a32
4808       a_temp(2,2)=a33
4809 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4810 C
4811 C               Third-order contributions
4812 C
4813 C                 (i+2)o----(i+3)
4814 C                      | |
4815 C                      | |
4816 C                 (i+1)o----i
4817 C
4818 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4819 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4820         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4821 c auxalary matices for theta gradient
4822 c auxalary matrix for i+1 and constant i+2
4823         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4824 c auxalary matrix for i+2 and constant i+1
4825         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4826         call transpose2(auxmat(1,1),auxmat1(1,1))
4827         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4828         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4829         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4830         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4831         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4832         if (shield_mode.eq.0) then
4833         fac_shield(i)=1.0
4834         fac_shield(j)=1.0
4835 C        else
4836 C        fac_shield(i)=0.4
4837 C        fac_shield(j)=0.6
4838         endif
4839         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4840      &  *fac_shield(i)*fac_shield(j)
4841         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4842      &  *fac_shield(i)*fac_shield(j)
4843         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4844      &    eello_t3
4845 C#ifdef NEWCORR
4846 C Derivatives in theta
4847         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4848      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4849      &   *fac_shield(i)*fac_shield(j)
4850         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4851      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4852      &   *fac_shield(i)*fac_shield(j)
4853 C#endif
4854
4855 C Derivatives in shield mode
4856           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4857      &  (shield_mode.gt.0)) then
4858 C          print *,i,j
4859
4860           do ilist=1,ishield_list(i)
4861            iresshield=shield_list(ilist,i)
4862            do k=1,3
4863            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4864 C     &      *2.0
4865            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4866      &              rlocshield
4867      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4868             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4869      &      +rlocshield
4870            enddo
4871           enddo
4872           do ilist=1,ishield_list(j)
4873            iresshield=shield_list(ilist,j)
4874            do k=1,3
4875            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4876 C     &     *2.0
4877            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4878      &              rlocshield
4879      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4880            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4881      &             +rlocshield
4882
4883            enddo
4884           enddo
4885
4886           do k=1,3
4887             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4888      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4889             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4890      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4891             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4892      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4893             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4894      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4895            enddo
4896            endif
4897
4898 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4899 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4900 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4901 cd     &    ' eello_turn3_num',4*eello_turn3_num
4902 C Derivatives in gamma(i)
4903         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4904         call transpose2(auxmat2(1,1),auxmat3(1,1))
4905         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4906         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4907      &   *fac_shield(i)*fac_shield(j)
4908 C Derivatives in gamma(i+1)
4909         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4910         call transpose2(auxmat2(1,1),auxmat3(1,1))
4911         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4912         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4913      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4914      &   *fac_shield(i)*fac_shield(j)
4915 C Cartesian derivatives
4916         do l=1,3
4917 c            ghalf1=0.5d0*agg(l,1)
4918 c            ghalf2=0.5d0*agg(l,2)
4919 c            ghalf3=0.5d0*agg(l,3)
4920 c            ghalf4=0.5d0*agg(l,4)
4921           a_temp(1,1)=aggi(l,1)!+ghalf1
4922           a_temp(1,2)=aggi(l,2)!+ghalf2
4923           a_temp(2,1)=aggi(l,3)!+ghalf3
4924           a_temp(2,2)=aggi(l,4)!+ghalf4
4925           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4926           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4927      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4928      &   *fac_shield(i)*fac_shield(j)
4929
4930           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4931           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4932           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4933           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4934           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4935           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4936      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4937      &   *fac_shield(i)*fac_shield(j)
4938           a_temp(1,1)=aggj(l,1)!+ghalf1
4939           a_temp(1,2)=aggj(l,2)!+ghalf2
4940           a_temp(2,1)=aggj(l,3)!+ghalf3
4941           a_temp(2,2)=aggj(l,4)!+ghalf4
4942           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4943           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4944      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4945      &   *fac_shield(i)*fac_shield(j)
4946           a_temp(1,1)=aggj1(l,1)
4947           a_temp(1,2)=aggj1(l,2)
4948           a_temp(2,1)=aggj1(l,3)
4949           a_temp(2,2)=aggj1(l,4)
4950           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4951           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4952      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4953      &   *fac_shield(i)*fac_shield(j)
4954         enddo
4955       return
4956       end
4957 C-------------------------------------------------------------------------------
4958       subroutine eturn4(i,eello_turn4)
4959 C Third- and fourth-order contributions from turns
4960       implicit real*8 (a-h,o-z)
4961       include 'DIMENSIONS'
4962       include 'COMMON.IOUNITS'
4963       include 'COMMON.GEO'
4964       include 'COMMON.VAR'
4965       include 'COMMON.LOCAL'
4966       include 'COMMON.CHAIN'
4967       include 'COMMON.DERIV'
4968       include 'COMMON.INTERACT'
4969       include 'COMMON.CONTACTS'
4970       include 'COMMON.TORSION'
4971       include 'COMMON.VECTORS'
4972       include 'COMMON.FFIELD'
4973       include 'COMMON.CONTROL'
4974       include 'COMMON.SHIELD'
4975       dimension ggg(3)
4976       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4977      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4978      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4979      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4980      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4981      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4982      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4983       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4984      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4985       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4986      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4987      &    num_conti,j1,j2
4988       j=i+3
4989 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4990 C
4991 C               Fourth-order contributions
4992 C
4993 C                 (i+3)o----(i+4)
4994 C                     /  |
4995 C               (i+2)o   |
4996 C                     \  |
4997 C                 (i+1)o----i
4998 C
4999 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5000 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5001 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5002 c        write(iout,*)"WCHODZE W PROGRAM"
5003         a_temp(1,1)=a22
5004         a_temp(1,2)=a23
5005         a_temp(2,1)=a32
5006         a_temp(2,2)=a33
5007         iti1=itype2loc(itype(i+1))
5008         iti2=itype2loc(itype(i+2))
5009         iti3=itype2loc(itype(i+3))
5010 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5011         call transpose2(EUg(1,1,i+1),e1t(1,1))
5012         call transpose2(Eug(1,1,i+2),e2t(1,1))
5013         call transpose2(Eug(1,1,i+3),e3t(1,1))
5014 C Ematrix derivative in theta
5015         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5016         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5017         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5018         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5019 c       eta1 in derivative theta
5020         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5021         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5022 c       auxgvec is derivative of Ub2 so i+3 theta
5023         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5024 c       auxalary matrix of E i+1
5025         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5026 c        s1=0.0
5027 c        gs1=0.0
5028         s1=scalar2(b1(1,i+2),auxvec(1))
5029 c derivative of theta i+2 with constant i+3
5030         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5031 c derivative of theta i+2 with constant i+2
5032         gs32=scalar2(b1(1,i+2),auxgvec(1))
5033 c derivative of E matix in theta of i+1
5034         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5035
5036         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5037 c       ea31 in derivative theta
5038         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5039         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5040 c auxilary matrix auxgvec of Ub2 with constant E matirx
5041         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5042 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5043         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5044
5045 c        s2=0.0
5046 c        gs2=0.0
5047         s2=scalar2(b1(1,i+1),auxvec(1))
5048 c derivative of theta i+1 with constant i+3
5049         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5050 c derivative of theta i+2 with constant i+1
5051         gs21=scalar2(b1(1,i+1),auxgvec(1))
5052 c derivative of theta i+3 with constant i+1
5053         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5054 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5055 c     &  gtb1(1,i+1)
5056         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5057 c two derivatives over diffetent matrices
5058 c gtae3e2 is derivative over i+3
5059         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5060 c ae3gte2 is derivative over i+2
5061         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5062         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5063 c three possible derivative over theta E matices
5064 c i+1
5065         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5066 c i+2
5067         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5068 c i+3
5069         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5070         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5071
5072         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5073         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5074         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5075         if (shield_mode.eq.0) then
5076         fac_shield(i)=1.0
5077         fac_shield(j)=1.0
5078 C        else
5079 C        fac_shield(i)=0.6
5080 C        fac_shield(j)=0.4
5081         endif
5082         eello_turn4=eello_turn4-(s1+s2+s3)
5083      &  *fac_shield(i)*fac_shield(j)
5084         eello_t4=-(s1+s2+s3)
5085      &  *fac_shield(i)*fac_shield(j)
5086 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5087         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5088      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5089 C Now derivative over shield:
5090           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5091      &  (shield_mode.gt.0)) then
5092 C          print *,i,j
5093
5094           do ilist=1,ishield_list(i)
5095            iresshield=shield_list(ilist,i)
5096            do k=1,3
5097            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5098 C     &      *2.0
5099            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5100      &              rlocshield
5101      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5102             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5103      &      +rlocshield
5104            enddo
5105           enddo
5106           do ilist=1,ishield_list(j)
5107            iresshield=shield_list(ilist,j)
5108            do k=1,3
5109            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5110 C     &     *2.0
5111            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5112      &              rlocshield
5113      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5114            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5115      &             +rlocshield
5116
5117            enddo
5118           enddo
5119
5120           do k=1,3
5121             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5122      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5123             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5124      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5125             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5126      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5127             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5128      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5129            enddo
5130            endif
5131
5132
5133
5134
5135
5136
5137 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5138 cd     &    ' eello_turn4_num',8*eello_turn4_num
5139 #ifdef NEWCORR
5140         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5141      &                  -(gs13+gsE13+gsEE1)*wturn4
5142      &  *fac_shield(i)*fac_shield(j)
5143         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5144      &                    -(gs23+gs21+gsEE2)*wturn4
5145      &  *fac_shield(i)*fac_shield(j)
5146
5147         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5148      &                    -(gs32+gsE31+gsEE3)*wturn4
5149      &  *fac_shield(i)*fac_shield(j)
5150
5151 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5152 c     &   gs2
5153 #endif
5154         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5155      &      'eturn4',i,j,-(s1+s2+s3)
5156 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5157 c     &    ' eello_turn4_num',8*eello_turn4_num
5158 C Derivatives in gamma(i)
5159         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5160         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5161         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5162         s1=scalar2(b1(1,i+2),auxvec(1))
5163         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5164         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5165         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5166      &  *fac_shield(i)*fac_shield(j)
5167 C Derivatives in gamma(i+1)
5168         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5169         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5170         s2=scalar2(b1(1,i+1),auxvec(1))
5171         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5172         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5173         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5174         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5175      &  *fac_shield(i)*fac_shield(j)
5176 C Derivatives in gamma(i+2)
5177         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5178         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5179         s1=scalar2(b1(1,i+2),auxvec(1))
5180         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5181         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5182         s2=scalar2(b1(1,i+1),auxvec(1))
5183         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5184         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5185         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5186         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5187      &  *fac_shield(i)*fac_shield(j)
5188 C Cartesian derivatives
5189 C Derivatives of this turn contributions in DC(i+2)
5190         if (j.lt.nres-1) then
5191           do l=1,3
5192             a_temp(1,1)=agg(l,1)
5193             a_temp(1,2)=agg(l,2)
5194             a_temp(2,1)=agg(l,3)
5195             a_temp(2,2)=agg(l,4)
5196             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5197             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5198             s1=scalar2(b1(1,i+2),auxvec(1))
5199             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5200             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5201             s2=scalar2(b1(1,i+1),auxvec(1))
5202             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5203             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5204             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5205             ggg(l)=-(s1+s2+s3)
5206             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5207      &  *fac_shield(i)*fac_shield(j)
5208           enddo
5209         endif
5210 C Remaining derivatives of this turn contribution
5211         do l=1,3
5212           a_temp(1,1)=aggi(l,1)
5213           a_temp(1,2)=aggi(l,2)
5214           a_temp(2,1)=aggi(l,3)
5215           a_temp(2,2)=aggi(l,4)
5216           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5217           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5218           s1=scalar2(b1(1,i+2),auxvec(1))
5219           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5220           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5221           s2=scalar2(b1(1,i+1),auxvec(1))
5222           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5223           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5224           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5225           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5226      &  *fac_shield(i)*fac_shield(j)
5227           a_temp(1,1)=aggi1(l,1)
5228           a_temp(1,2)=aggi1(l,2)
5229           a_temp(2,1)=aggi1(l,3)
5230           a_temp(2,2)=aggi1(l,4)
5231           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5232           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5233           s1=scalar2(b1(1,i+2),auxvec(1))
5234           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5235           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5236           s2=scalar2(b1(1,i+1),auxvec(1))
5237           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5238           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5239           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5240           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5241      &  *fac_shield(i)*fac_shield(j)
5242           a_temp(1,1)=aggj(l,1)
5243           a_temp(1,2)=aggj(l,2)
5244           a_temp(2,1)=aggj(l,3)
5245           a_temp(2,2)=aggj(l,4)
5246           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5247           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5248           s1=scalar2(b1(1,i+2),auxvec(1))
5249           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5250           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5251           s2=scalar2(b1(1,i+1),auxvec(1))
5252           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5253           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5254           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5255           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5256      &  *fac_shield(i)*fac_shield(j)
5257           a_temp(1,1)=aggj1(l,1)
5258           a_temp(1,2)=aggj1(l,2)
5259           a_temp(2,1)=aggj1(l,3)
5260           a_temp(2,2)=aggj1(l,4)
5261           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5262           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5263           s1=scalar2(b1(1,i+2),auxvec(1))
5264           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5265           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5266           s2=scalar2(b1(1,i+1),auxvec(1))
5267           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5268           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5269           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5270 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5271           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5272      &  *fac_shield(i)*fac_shield(j)
5273         enddo
5274       return
5275       end
5276 C-----------------------------------------------------------------------------
5277       subroutine vecpr(u,v,w)
5278       implicit real*8(a-h,o-z)
5279       dimension u(3),v(3),w(3)
5280       w(1)=u(2)*v(3)-u(3)*v(2)
5281       w(2)=-u(1)*v(3)+u(3)*v(1)
5282       w(3)=u(1)*v(2)-u(2)*v(1)
5283       return
5284       end
5285 C-----------------------------------------------------------------------------
5286       subroutine unormderiv(u,ugrad,unorm,ungrad)
5287 C This subroutine computes the derivatives of a normalized vector u, given
5288 C the derivatives computed without normalization conditions, ugrad. Returns
5289 C ungrad.
5290       implicit none
5291       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5292       double precision vec(3)
5293       double precision scalar
5294       integer i,j
5295 c      write (2,*) 'ugrad',ugrad
5296 c      write (2,*) 'u',u
5297       do i=1,3
5298         vec(i)=scalar(ugrad(1,i),u(1))
5299       enddo
5300 c      write (2,*) 'vec',vec
5301       do i=1,3
5302         do j=1,3
5303           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5304         enddo
5305       enddo
5306 c      write (2,*) 'ungrad',ungrad
5307       return
5308       end
5309 C-----------------------------------------------------------------------------
5310       subroutine escp_soft_sphere(evdw2,evdw2_14)
5311 C
5312 C This subroutine calculates the excluded-volume interaction energy between
5313 C peptide-group centers and side chains and its gradient in virtual-bond and
5314 C side-chain vectors.
5315 C
5316       implicit real*8 (a-h,o-z)
5317       include 'DIMENSIONS'
5318       include 'COMMON.GEO'
5319       include 'COMMON.VAR'
5320       include 'COMMON.LOCAL'
5321       include 'COMMON.CHAIN'
5322       include 'COMMON.DERIV'
5323       include 'COMMON.INTERACT'
5324       include 'COMMON.FFIELD'
5325       include 'COMMON.IOUNITS'
5326       include 'COMMON.CONTROL'
5327       dimension ggg(3)
5328       integer xshift,yshift,zshift
5329       evdw2=0.0D0
5330       evdw2_14=0.0d0
5331       r0_scp=4.5d0
5332 cd    print '(a)','Enter ESCP'
5333 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5334 C      do xshift=-1,1
5335 C      do yshift=-1,1
5336 C      do zshift=-1,1
5337       do i=iatscp_s,iatscp_e
5338         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5339         iteli=itel(i)
5340         xi=0.5D0*(c(1,i)+c(1,i+1))
5341         yi=0.5D0*(c(2,i)+c(2,i+1))
5342         zi=0.5D0*(c(3,i)+c(3,i+1))
5343 C Return atom into box, boxxsize is size of box in x dimension
5344 c  134   continue
5345 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5346 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5347 C Condition for being inside the proper box
5348 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5349 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5350 c        go to 134
5351 c        endif
5352 c  135   continue
5353 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5354 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5355 C Condition for being inside the proper box
5356 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5357 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5358 c        go to 135
5359 c c       endif
5360 c  136   continue
5361 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5362 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5363 cC Condition for being inside the proper box
5364 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5365 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5366 c        go to 136
5367 c        endif
5368           xi=mod(xi,boxxsize)
5369           if (xi.lt.0) xi=xi+boxxsize
5370           yi=mod(yi,boxysize)
5371           if (yi.lt.0) yi=yi+boxysize
5372           zi=mod(zi,boxzsize)
5373           if (zi.lt.0) zi=zi+boxzsize
5374 C          xi=xi+xshift*boxxsize
5375 C          yi=yi+yshift*boxysize
5376 C          zi=zi+zshift*boxzsize
5377         do iint=1,nscp_gr(i)
5378
5379         do j=iscpstart(i,iint),iscpend(i,iint)
5380           if (itype(j).eq.ntyp1) cycle
5381           itypj=iabs(itype(j))
5382 C Uncomment following three lines for SC-p interactions
5383 c         xj=c(1,nres+j)-xi
5384 c         yj=c(2,nres+j)-yi
5385 c         zj=c(3,nres+j)-zi
5386 C Uncomment following three lines for Ca-p interactions
5387           xj=c(1,j)
5388           yj=c(2,j)
5389           zj=c(3,j)
5390 c  174   continue
5391 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5392 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5393 C Condition for being inside the proper box
5394 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5395 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5396 c        go to 174
5397 c        endif
5398 c  175   continue
5399 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5400 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5401 cC Condition for being inside the proper box
5402 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5403 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5404 c        go to 175
5405 c        endif
5406 c  176   continue
5407 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5408 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5409 C Condition for being inside the proper box
5410 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5411 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5412 c        go to 176
5413           xj=mod(xj,boxxsize)
5414           if (xj.lt.0) xj=xj+boxxsize
5415           yj=mod(yj,boxysize)
5416           if (yj.lt.0) yj=yj+boxysize
5417           zj=mod(zj,boxzsize)
5418           if (zj.lt.0) zj=zj+boxzsize
5419       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5420       xj_safe=xj
5421       yj_safe=yj
5422       zj_safe=zj
5423       subchap=0
5424       do xshift=-1,1
5425       do yshift=-1,1
5426       do zshift=-1,1
5427           xj=xj_safe+xshift*boxxsize
5428           yj=yj_safe+yshift*boxysize
5429           zj=zj_safe+zshift*boxzsize
5430           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5431           if(dist_temp.lt.dist_init) then
5432             dist_init=dist_temp
5433             xj_temp=xj
5434             yj_temp=yj
5435             zj_temp=zj
5436             subchap=1
5437           endif
5438        enddo
5439        enddo
5440        enddo
5441        if (subchap.eq.1) then
5442           xj=xj_temp-xi
5443           yj=yj_temp-yi
5444           zj=zj_temp-zi
5445        else
5446           xj=xj_safe-xi
5447           yj=yj_safe-yi
5448           zj=zj_safe-zi
5449        endif
5450 c c       endif
5451 C          xj=xj-xi
5452 C          yj=yj-yi
5453 C          zj=zj-zi
5454           rij=xj*xj+yj*yj+zj*zj
5455
5456           r0ij=r0_scp
5457           r0ijsq=r0ij*r0ij
5458           if (rij.lt.r0ijsq) then
5459             evdwij=0.25d0*(rij-r0ijsq)**2
5460             fac=rij-r0ijsq
5461           else
5462             evdwij=0.0d0
5463             fac=0.0d0
5464           endif
5465           evdw2=evdw2+evdwij
5466 C
5467 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5468 C
5469           ggg(1)=xj*fac
5470           ggg(2)=yj*fac
5471           ggg(3)=zj*fac
5472 cgrad          if (j.lt.i) then
5473 cd          write (iout,*) 'j<i'
5474 C Uncomment following three lines for SC-p interactions
5475 c           do k=1,3
5476 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5477 c           enddo
5478 cgrad          else
5479 cd          write (iout,*) 'j>i'
5480 cgrad            do k=1,3
5481 cgrad              ggg(k)=-ggg(k)
5482 C Uncomment following line for SC-p interactions
5483 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5484 cgrad            enddo
5485 cgrad          endif
5486 cgrad          do k=1,3
5487 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5488 cgrad          enddo
5489 cgrad          kstart=min0(i+1,j)
5490 cgrad          kend=max0(i-1,j-1)
5491 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5492 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5493 cgrad          do k=kstart,kend
5494 cgrad            do l=1,3
5495 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5496 cgrad            enddo
5497 cgrad          enddo
5498           do k=1,3
5499             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5500             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5501           enddo
5502         enddo
5503
5504         enddo ! iint
5505       enddo ! i
5506 C      enddo !zshift
5507 C      enddo !yshift
5508 C      enddo !xshift
5509       return
5510       end
5511 C-----------------------------------------------------------------------------
5512       subroutine escp(evdw2,evdw2_14)
5513 C
5514 C This subroutine calculates the excluded-volume interaction energy between
5515 C peptide-group centers and side chains and its gradient in virtual-bond and
5516 C side-chain vectors.
5517 C
5518       implicit real*8 (a-h,o-z)
5519       include 'DIMENSIONS'
5520       include 'COMMON.GEO'
5521       include 'COMMON.VAR'
5522       include 'COMMON.LOCAL'
5523       include 'COMMON.CHAIN'
5524       include 'COMMON.DERIV'
5525       include 'COMMON.INTERACT'
5526       include 'COMMON.FFIELD'
5527       include 'COMMON.IOUNITS'
5528       include 'COMMON.CONTROL'
5529       include 'COMMON.SPLITELE'
5530       integer xshift,yshift,zshift
5531       dimension ggg(3)
5532       evdw2=0.0D0
5533       evdw2_14=0.0d0
5534 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5535 cd    print '(a)','Enter ESCP'
5536 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5537 C      do xshift=-1,1
5538 C      do yshift=-1,1
5539 C      do zshift=-1,1
5540       if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5541       do i=iatscp_s,iatscp_e
5542         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5543         iteli=itel(i)
5544         xi=0.5D0*(c(1,i)+c(1,i+1))
5545         yi=0.5D0*(c(2,i)+c(2,i+1))
5546         zi=0.5D0*(c(3,i)+c(3,i+1))
5547           xi=mod(xi,boxxsize)
5548           if (xi.lt.0) xi=xi+boxxsize
5549           yi=mod(yi,boxysize)
5550           if (yi.lt.0) yi=yi+boxysize
5551           zi=mod(zi,boxzsize)
5552           if (zi.lt.0) zi=zi+boxzsize
5553 c          xi=xi+xshift*boxxsize
5554 c          yi=yi+yshift*boxysize
5555 c          zi=zi+zshift*boxzsize
5556 c        print *,xi,yi,zi,'polozenie i'
5557 C Return atom into box, boxxsize is size of box in x dimension
5558 c  134   continue
5559 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5560 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5561 C Condition for being inside the proper box
5562 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5563 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5564 c        go to 134
5565 c        endif
5566 c  135   continue
5567 c          print *,xi,boxxsize,"pierwszy"
5568
5569 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5570 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5571 C Condition for being inside the proper box
5572 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5573 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5574 c        go to 135
5575 c        endif
5576 c  136   continue
5577 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5578 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5579 C Condition for being inside the proper box
5580 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5581 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5582 c        go to 136
5583 c        endif
5584         do iint=1,nscp_gr(i)
5585
5586         do j=iscpstart(i,iint),iscpend(i,iint)
5587           itypj=iabs(itype(j))
5588           if (itypj.eq.ntyp1) cycle
5589 C Uncomment following three lines for SC-p interactions
5590 c         xj=c(1,nres+j)-xi
5591 c         yj=c(2,nres+j)-yi
5592 c         zj=c(3,nres+j)-zi
5593 C Uncomment following three lines for Ca-p interactions
5594           xj=c(1,j)
5595           yj=c(2,j)
5596           zj=c(3,j)
5597           xj=mod(xj,boxxsize)
5598           if (xj.lt.0) xj=xj+boxxsize
5599           yj=mod(yj,boxysize)
5600           if (yj.lt.0) yj=yj+boxysize
5601           zj=mod(zj,boxzsize)
5602           if (zj.lt.0) zj=zj+boxzsize
5603 c  174   continue
5604 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5605 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5606 C Condition for being inside the proper box
5607 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5608 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5609 c        go to 174
5610 c        endif
5611 c  175   continue
5612 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5613 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5614 cC Condition for being inside the proper box
5615 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5616 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5617 c        go to 175
5618 c        endif
5619 c  176   continue
5620 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5621 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5622 C Condition for being inside the proper box
5623 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5624 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5625 c        go to 176
5626 c        endif
5627 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5628       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5629       xj_safe=xj
5630       yj_safe=yj
5631       zj_safe=zj
5632       subchap=0
5633       do xshift=-1,1
5634       do yshift=-1,1
5635       do zshift=-1,1
5636           xj=xj_safe+xshift*boxxsize
5637           yj=yj_safe+yshift*boxysize
5638           zj=zj_safe+zshift*boxzsize
5639           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5640           if(dist_temp.lt.dist_init) then
5641             dist_init=dist_temp
5642             xj_temp=xj
5643             yj_temp=yj
5644             zj_temp=zj
5645             subchap=1
5646           endif
5647        enddo
5648        enddo
5649        enddo
5650        if (subchap.eq.1) then
5651           xj=xj_temp-xi
5652           yj=yj_temp-yi
5653           zj=zj_temp-zi
5654        else
5655           xj=xj_safe-xi
5656           yj=yj_safe-yi
5657           zj=zj_safe-zi
5658        endif
5659 c          print *,xj,yj,zj,'polozenie j'
5660           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5661 c          print *,rrij
5662           sss=sscale(1.0d0/(dsqrt(rrij)))
5663 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5664 c          if (sss.eq.0) print *,'czasem jest OK'
5665           if (sss.le.0.0d0) cycle
5666           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5667           fac=rrij**expon2
5668           e1=fac*fac*aad(itypj,iteli)
5669           e2=fac*bad(itypj,iteli)
5670           if (iabs(j-i) .le. 2) then
5671             e1=scal14*e1
5672             e2=scal14*e2
5673             evdw2_14=evdw2_14+(e1+e2)*sss
5674           endif
5675           evdwij=e1+e2
5676           evdw2=evdw2+evdwij*sss
5677           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5678      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5679      &       bad(itypj,iteli)
5680 C
5681 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5682 C
5683           fac=-(evdwij+e1)*rrij*sss
5684           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5685           ggg(1)=xj*fac
5686           ggg(2)=yj*fac
5687           ggg(3)=zj*fac
5688 cgrad          if (j.lt.i) then
5689 cd          write (iout,*) 'j<i'
5690 C Uncomment following three lines for SC-p interactions
5691 c           do k=1,3
5692 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5693 c           enddo
5694 cgrad          else
5695 cd          write (iout,*) 'j>i'
5696 cgrad            do k=1,3
5697 cgrad              ggg(k)=-ggg(k)
5698 C Uncomment following line for SC-p interactions
5699 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5700 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5701 cgrad            enddo
5702 cgrad          endif
5703 cgrad          do k=1,3
5704 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5705 cgrad          enddo
5706 cgrad          kstart=min0(i+1,j)
5707 cgrad          kend=max0(i-1,j-1)
5708 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5709 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5710 cgrad          do k=kstart,kend
5711 cgrad            do l=1,3
5712 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5713 cgrad            enddo
5714 cgrad          enddo
5715           do k=1,3
5716             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5717             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5718           enddo
5719 c        endif !endif for sscale cutoff
5720         enddo ! j
5721
5722         enddo ! iint
5723       enddo ! i
5724 c      enddo !zshift
5725 c      enddo !yshift
5726 c      enddo !xshift
5727       do i=1,nct
5728         do j=1,3
5729           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5730           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5731           gradx_scp(j,i)=expon*gradx_scp(j,i)
5732         enddo
5733       enddo
5734 C******************************************************************************
5735 C
5736 C                              N O T E !!!
5737 C
5738 C To save time the factor EXPON has been extracted from ALL components
5739 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5740 C use!
5741 C
5742 C******************************************************************************
5743       return
5744       end
5745 C--------------------------------------------------------------------------
5746       subroutine edis(ehpb)
5747 C
5748 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5749 C
5750       implicit real*8 (a-h,o-z)
5751       include 'DIMENSIONS'
5752       include 'COMMON.SBRIDGE'
5753       include 'COMMON.CHAIN'
5754       include 'COMMON.DERIV'
5755       include 'COMMON.VAR'
5756       include 'COMMON.INTERACT'
5757       include 'COMMON.IOUNITS'
5758       include 'COMMON.CONTROL'
5759       dimension ggg(3)
5760       ehpb=0.0D0
5761       do i=1,3
5762        ggg(i)=0.0d0
5763       enddo
5764 C      write (iout,*) ,"link_end",link_end,constr_dist
5765 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5766 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5767 c     &  " constr_dist",constr_dist
5768       if (link_end.eq.0) return
5769       do i=link_start,link_end
5770 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5771 C CA-CA distance used in regularization of structure.
5772         ii=ihpb(i)
5773         jj=jhpb(i)
5774 C iii and jjj point to the residues for which the distance is assigned.
5775         if (ii.gt.nres) then
5776           iii=ii-nres
5777           jjj=jj-nres
5778         else
5779           iii=ii
5780           jjj=jj
5781         endif
5782 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5783 c     &    dhpb(i),dhpb1(i),forcon(i)
5784 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5785 C    distance and angle dependent SS bond potential.
5786 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5787 C     & iabs(itype(jjj)).eq.1) then
5788 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5789 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5790         if (.not.dyn_ss .and. i.le.nss) then
5791 C 15/02/13 CC dynamic SSbond - additional check
5792           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5793      &        iabs(itype(jjj)).eq.1) then
5794            call ssbond_ene(iii,jjj,eij)
5795            ehpb=ehpb+2*eij
5796          endif
5797 cd          write (iout,*) "eij",eij
5798 cd   &   ' waga=',waga,' fac=',fac
5799 !        else if (ii.gt.nres .and. jj.gt.nres) then
5800         else
5801 C Calculate the distance between the two points and its difference from the
5802 C target distance.
5803           dd=dist(ii,jj)
5804           if (irestr_type(i).eq.11) then
5805             ehpb=ehpb+fordepth(i)!**4.0d0
5806      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5807             fac=fordepth(i)!**4.0d0
5808      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5809             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5810      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5811      &        ehpb,irestr_type(i)
5812           else if (irestr_type(i).eq.10) then
5813 c AL 6//19/2018 cross-link restraints
5814             xdis = 0.5d0*(dd/forcon(i))**2
5815             expdis = dexp(-xdis)
5816 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5817             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5818 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5819 c     &          " wboltzd",wboltzd
5820             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5821 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5822             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5823      &           *expdis/(aux*forcon(i)**2)
5824             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5825      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5826      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5827           else if (irestr_type(i).eq.2) then
5828 c Quartic restraints
5829             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5830             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5831      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5832      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5833             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5834           else
5835 c Quadratic restraints
5836             rdis=dd-dhpb(i)
5837 C Get the force constant corresponding to this distance.
5838             waga=forcon(i)
5839 C Calculate the contribution to energy.
5840             ehpb=ehpb+0.5d0*waga*rdis*rdis
5841             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5842      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5843      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5844 C
5845 C Evaluate gradient.
5846 C
5847             fac=waga*rdis/dd
5848           endif
5849 c Calculate Cartesian gradient
5850           do j=1,3
5851             ggg(j)=fac*(c(j,jj)-c(j,ii))
5852           enddo
5853 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5854 C If this is a SC-SC distance, we need to calculate the contributions to the
5855 C Cartesian gradient in the SC vectors (ghpbx).
5856           if (iii.lt.ii) then
5857             do j=1,3
5858               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5859               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5860             enddo
5861           endif
5862           do k=1,3
5863             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5864             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5865           enddo
5866         endif
5867       enddo
5868       return
5869       end
5870 C--------------------------------------------------------------------------
5871       subroutine ssbond_ene(i,j,eij)
5872 C
5873 C Calculate the distance and angle dependent SS-bond potential energy
5874 C using a free-energy function derived based on RHF/6-31G** ab initio
5875 C calculations of diethyl disulfide.
5876 C
5877 C A. Liwo and U. Kozlowska, 11/24/03
5878 C
5879       implicit real*8 (a-h,o-z)
5880       include 'DIMENSIONS'
5881       include 'COMMON.SBRIDGE'
5882       include 'COMMON.CHAIN'
5883       include 'COMMON.DERIV'
5884       include 'COMMON.LOCAL'
5885       include 'COMMON.INTERACT'
5886       include 'COMMON.VAR'
5887       include 'COMMON.IOUNITS'
5888       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5889       itypi=iabs(itype(i))
5890       xi=c(1,nres+i)
5891       yi=c(2,nres+i)
5892       zi=c(3,nres+i)
5893       dxi=dc_norm(1,nres+i)
5894       dyi=dc_norm(2,nres+i)
5895       dzi=dc_norm(3,nres+i)
5896 c      dsci_inv=dsc_inv(itypi)
5897       dsci_inv=vbld_inv(nres+i)
5898       itypj=iabs(itype(j))
5899 c      dscj_inv=dsc_inv(itypj)
5900       dscj_inv=vbld_inv(nres+j)
5901       xj=c(1,nres+j)-xi
5902       yj=c(2,nres+j)-yi
5903       zj=c(3,nres+j)-zi
5904       dxj=dc_norm(1,nres+j)
5905       dyj=dc_norm(2,nres+j)
5906       dzj=dc_norm(3,nres+j)
5907       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5908       rij=dsqrt(rrij)
5909       erij(1)=xj*rij
5910       erij(2)=yj*rij
5911       erij(3)=zj*rij
5912       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5913       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5914       om12=dxi*dxj+dyi*dyj+dzi*dzj
5915       do k=1,3
5916         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5917         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5918       enddo
5919       rij=1.0d0/rij
5920       deltad=rij-d0cm
5921       deltat1=1.0d0-om1
5922       deltat2=1.0d0+om2
5923       deltat12=om2-om1+2.0d0
5924       cosphi=om12-om1*om2
5925       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5926      &  +akct*deltad*deltat12
5927      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5928 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5929 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5930 c     &  " deltat12",deltat12," eij",eij
5931       ed=2*akcm*deltad+akct*deltat12
5932       pom1=akct*deltad
5933       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5934       eom1=-2*akth*deltat1-pom1-om2*pom2
5935       eom2= 2*akth*deltat2+pom1-om1*pom2
5936       eom12=pom2
5937       do k=1,3
5938         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5939         ghpbx(k,i)=ghpbx(k,i)-ggk
5940      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
5941      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
5942         ghpbx(k,j)=ghpbx(k,j)+ggk
5943      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
5944      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
5945         ghpbc(k,i)=ghpbc(k,i)-ggk
5946         ghpbc(k,j)=ghpbc(k,j)+ggk
5947       enddo
5948 C
5949 C Calculate the components of the gradient in DC and X
5950 C
5951 cgrad      do k=i,j-1
5952 cgrad        do l=1,3
5953 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
5954 cgrad        enddo
5955 cgrad      enddo
5956       return
5957       end
5958 C--------------------------------------------------------------------------
5959       subroutine ebond(estr)
5960 c
5961 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
5962 c
5963       implicit real*8 (a-h,o-z)
5964       include 'DIMENSIONS'
5965       include 'COMMON.LOCAL'
5966       include 'COMMON.GEO'
5967       include 'COMMON.INTERACT'
5968       include 'COMMON.DERIV'
5969       include 'COMMON.VAR'
5970       include 'COMMON.CHAIN'
5971       include 'COMMON.IOUNITS'
5972       include 'COMMON.NAMES'
5973       include 'COMMON.FFIELD'
5974       include 'COMMON.CONTROL'
5975       include 'COMMON.SETUP'
5976       double precision u(3),ud(3)
5977       estr=0.0d0
5978       estr1=0.0d0
5979       do i=ibondp_start,ibondp_end
5980         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
5981 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
5982 c          do j=1,3
5983 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
5984 c     &      *dc(j,i-1)/vbld(i)
5985 c          enddo
5986 c          if (energy_dec) write(iout,*)
5987 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
5988 c        else
5989 C       Checking if it involves dummy (NH3+ or COO-) group
5990          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
5991 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
5992         diff = vbld(i)-vbldpDUM
5993         if (energy_dec) write(iout,*) "dum_bond",i,diff
5994          else
5995 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
5996         diff = vbld(i)-vbldp0
5997          endif
5998         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
5999      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6000         estr=estr+diff*diff
6001         do j=1,3
6002           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6003         enddo
6004 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6005 c        endif
6006       enddo
6007
6008       estr=0.5d0*AKP*estr+estr1
6009 c
6010 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6011 c
6012       do i=ibond_start,ibond_end
6013         iti=iabs(itype(i))
6014         if (iti.ne.10 .and. iti.ne.ntyp1) then
6015           nbi=nbondterm(iti)
6016           if (nbi.eq.1) then
6017             diff=vbld(i+nres)-vbldsc0(1,iti)
6018             if (energy_dec)  write (iout,*)
6019      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6020      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6021             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6022             do j=1,3
6023               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6024             enddo
6025           else
6026             do j=1,nbi
6027               diff=vbld(i+nres)-vbldsc0(j,iti)
6028               ud(j)=aksc(j,iti)*diff
6029               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6030             enddo
6031             uprod=u(1)
6032             do j=2,nbi
6033               uprod=uprod*u(j)
6034             enddo
6035             usum=0.0d0
6036             usumsqder=0.0d0
6037             do j=1,nbi
6038               uprod1=1.0d0
6039               uprod2=1.0d0
6040               do k=1,nbi
6041                 if (k.ne.j) then
6042                   uprod1=uprod1*u(k)
6043                   uprod2=uprod2*u(k)*u(k)
6044                 endif
6045               enddo
6046               usum=usum+uprod1
6047               usumsqder=usumsqder+ud(j)*uprod2
6048             enddo
6049             estr=estr+uprod/usum
6050             do j=1,3
6051              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6052             enddo
6053           endif
6054         endif
6055       enddo
6056       return
6057       end
6058 #ifdef CRYST_THETA
6059 C--------------------------------------------------------------------------
6060       subroutine ebend(etheta)
6061 C
6062 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6063 C angles gamma and its derivatives in consecutive thetas and gammas.
6064 C
6065       implicit real*8 (a-h,o-z)
6066       include 'DIMENSIONS'
6067       include 'COMMON.LOCAL'
6068       include 'COMMON.GEO'
6069       include 'COMMON.INTERACT'
6070       include 'COMMON.DERIV'
6071       include 'COMMON.VAR'
6072       include 'COMMON.CHAIN'
6073       include 'COMMON.IOUNITS'
6074       include 'COMMON.NAMES'
6075       include 'COMMON.FFIELD'
6076       include 'COMMON.CONTROL'
6077       include 'COMMON.TORCNSTR'
6078       common /calcthet/ term1,term2,termm,diffak,ratak,
6079      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6080      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6081       double precision y(2),z(2)
6082       delta=0.02d0*pi
6083 c      time11=dexp(-2*time)
6084 c      time12=1.0d0
6085       etheta=0.0D0
6086 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6087       do i=ithet_start,ithet_end
6088         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6089      &  .or.itype(i).eq.ntyp1) cycle
6090 C Zero the energy function and its derivative at 0 or pi.
6091         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6092         it=itype(i-1)
6093         ichir1=isign(1,itype(i-2))
6094         ichir2=isign(1,itype(i))
6095          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6096          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6097          if (itype(i-1).eq.10) then
6098           itype1=isign(10,itype(i-2))
6099           ichir11=isign(1,itype(i-2))
6100           ichir12=isign(1,itype(i-2))
6101           itype2=isign(10,itype(i))
6102           ichir21=isign(1,itype(i))
6103           ichir22=isign(1,itype(i))
6104          endif
6105
6106         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6107 #ifdef OSF
6108           phii=phi(i)
6109           if (phii.ne.phii) phii=150.0
6110 #else
6111           phii=phi(i)
6112 #endif
6113           y(1)=dcos(phii)
6114           y(2)=dsin(phii)
6115         else
6116           y(1)=0.0D0
6117           y(2)=0.0D0
6118         endif
6119         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6120 #ifdef OSF
6121           phii1=phi(i+1)
6122           if (phii1.ne.phii1) phii1=150.0
6123           phii1=pinorm(phii1)
6124           z(1)=cos(phii1)
6125 #else
6126           phii1=phi(i+1)
6127 #endif
6128           z(1)=dcos(phii1)
6129           z(2)=dsin(phii1)
6130         else
6131           z(1)=0.0D0
6132           z(2)=0.0D0
6133         endif
6134 C Calculate the "mean" value of theta from the part of the distribution
6135 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6136 C In following comments this theta will be referred to as t_c.
6137         thet_pred_mean=0.0d0
6138         do k=1,2
6139             athetk=athet(k,it,ichir1,ichir2)
6140             bthetk=bthet(k,it,ichir1,ichir2)
6141           if (it.eq.10) then
6142              athetk=athet(k,itype1,ichir11,ichir12)
6143              bthetk=bthet(k,itype2,ichir21,ichir22)
6144           endif
6145          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6146 c         write(iout,*) 'chuj tu', y(k),z(k)
6147         enddo
6148         dthett=thet_pred_mean*ssd
6149         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6150 C Derivatives of the "mean" values in gamma1 and gamma2.
6151         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6152      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6153          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6154      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6155          if (it.eq.10) then
6156       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6157      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6158         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6159      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6160          endif
6161         if (theta(i).gt.pi-delta) then
6162           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6163      &         E_tc0)
6164           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6165           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6166           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6167      &        E_theta)
6168           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6169      &        E_tc)
6170         else if (theta(i).lt.delta) then
6171           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6172           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6173           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6174      &        E_theta)
6175           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6176           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6177      &        E_tc)
6178         else
6179           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6180      &        E_theta,E_tc)
6181         endif
6182         etheta=etheta+ethetai
6183         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6184      &      'ebend',i,ethetai,theta(i),itype(i)
6185         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6186         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6187         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6188       enddo
6189
6190 C Ufff.... We've done all this!!!
6191       return
6192       end
6193 C---------------------------------------------------------------------------
6194       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6195      &     E_tc)
6196       implicit real*8 (a-h,o-z)
6197       include 'DIMENSIONS'
6198       include 'COMMON.LOCAL'
6199       include 'COMMON.IOUNITS'
6200       common /calcthet/ term1,term2,termm,diffak,ratak,
6201      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6202      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6203 C Calculate the contributions to both Gaussian lobes.
6204 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6205 C The "polynomial part" of the "standard deviation" of this part of
6206 C the distributioni.
6207 ccc        write (iout,*) thetai,thet_pred_mean
6208         sig=polthet(3,it)
6209         do j=2,0,-1
6210           sig=sig*thet_pred_mean+polthet(j,it)
6211         enddo
6212 C Derivative of the "interior part" of the "standard deviation of the"
6213 C gamma-dependent Gaussian lobe in t_c.
6214         sigtc=3*polthet(3,it)
6215         do j=2,1,-1
6216           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6217         enddo
6218         sigtc=sig*sigtc
6219 C Set the parameters of both Gaussian lobes of the distribution.
6220 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6221         fac=sig*sig+sigc0(it)
6222         sigcsq=fac+fac
6223         sigc=1.0D0/sigcsq
6224 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6225         sigsqtc=-4.0D0*sigcsq*sigtc
6226 c       print *,i,sig,sigtc,sigsqtc
6227 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6228         sigtc=-sigtc/(fac*fac)
6229 C Following variable is sigma(t_c)**(-2)
6230         sigcsq=sigcsq*sigcsq
6231         sig0i=sig0(it)
6232         sig0inv=1.0D0/sig0i**2
6233         delthec=thetai-thet_pred_mean
6234         delthe0=thetai-theta0i
6235         term1=-0.5D0*sigcsq*delthec*delthec
6236         term2=-0.5D0*sig0inv*delthe0*delthe0
6237 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6238 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6239 C NaNs in taking the logarithm. We extract the largest exponent which is added
6240 C to the energy (this being the log of the distribution) at the end of energy
6241 C term evaluation for this virtual-bond angle.
6242         if (term1.gt.term2) then
6243           termm=term1
6244           term2=dexp(term2-termm)
6245           term1=1.0d0
6246         else
6247           termm=term2
6248           term1=dexp(term1-termm)
6249           term2=1.0d0
6250         endif
6251 C The ratio between the gamma-independent and gamma-dependent lobes of
6252 C the distribution is a Gaussian function of thet_pred_mean too.
6253         diffak=gthet(2,it)-thet_pred_mean
6254         ratak=diffak/gthet(3,it)**2
6255         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6256 C Let's differentiate it in thet_pred_mean NOW.
6257         aktc=ak*ratak
6258 C Now put together the distribution terms to make complete distribution.
6259         termexp=term1+ak*term2
6260         termpre=sigc+ak*sig0i
6261 C Contribution of the bending energy from this theta is just the -log of
6262 C the sum of the contributions from the two lobes and the pre-exponential
6263 C factor. Simple enough, isn't it?
6264         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6265 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6266 C NOW the derivatives!!!
6267 C 6/6/97 Take into account the deformation.
6268         E_theta=(delthec*sigcsq*term1
6269      &       +ak*delthe0*sig0inv*term2)/termexp
6270         E_tc=((sigtc+aktc*sig0i)/termpre
6271      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6272      &       aktc*term2)/termexp)
6273       return
6274       end
6275 c-----------------------------------------------------------------------------
6276       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6277       implicit real*8 (a-h,o-z)
6278       include 'DIMENSIONS'
6279       include 'COMMON.LOCAL'
6280       include 'COMMON.IOUNITS'
6281       common /calcthet/ term1,term2,termm,diffak,ratak,
6282      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6283      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6284       delthec=thetai-thet_pred_mean
6285       delthe0=thetai-theta0i
6286 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6287       t3 = thetai-thet_pred_mean
6288       t6 = t3**2
6289       t9 = term1
6290       t12 = t3*sigcsq
6291       t14 = t12+t6*sigsqtc
6292       t16 = 1.0d0
6293       t21 = thetai-theta0i
6294       t23 = t21**2
6295       t26 = term2
6296       t27 = t21*t26
6297       t32 = termexp
6298       t40 = t32**2
6299       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6300      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6301      & *(-t12*t9-ak*sig0inv*t27)
6302       return
6303       end
6304 #else
6305 C--------------------------------------------------------------------------
6306       subroutine ebend(etheta)
6307 C
6308 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6309 C angles gamma and its derivatives in consecutive thetas and gammas.
6310 C ab initio-derived potentials from
6311 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6312 C
6313       implicit real*8 (a-h,o-z)
6314       include 'DIMENSIONS'
6315       include 'COMMON.LOCAL'
6316       include 'COMMON.GEO'
6317       include 'COMMON.INTERACT'
6318       include 'COMMON.DERIV'
6319       include 'COMMON.VAR'
6320       include 'COMMON.CHAIN'
6321       include 'COMMON.IOUNITS'
6322       include 'COMMON.NAMES'
6323       include 'COMMON.FFIELD'
6324       include 'COMMON.CONTROL'
6325       include 'COMMON.TORCNSTR'
6326       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6327      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6328      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6329      & sinph1ph2(maxdouble,maxdouble)
6330       logical lprn /.false./, lprn1 /.false./
6331       etheta=0.0D0
6332       do i=ithet_start,ithet_end
6333 c        print *,i,itype(i-1),itype(i),itype(i-2)
6334         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6335      &  .or.itype(i).eq.ntyp1) cycle
6336 C        print *,i,theta(i)
6337         if (iabs(itype(i+1)).eq.20) iblock=2
6338         if (iabs(itype(i+1)).ne.20) iblock=1
6339         dethetai=0.0d0
6340         dephii=0.0d0
6341         dephii1=0.0d0
6342         theti2=0.5d0*theta(i)
6343         ityp2=ithetyp((itype(i-1)))
6344         do k=1,nntheterm
6345           coskt(k)=dcos(k*theti2)
6346           sinkt(k)=dsin(k*theti2)
6347         enddo
6348 C        print *,ethetai
6349         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6350 #ifdef OSF
6351           phii=phi(i)
6352           if (phii.ne.phii) phii=150.0
6353 #else
6354           phii=phi(i)
6355 #endif
6356           ityp1=ithetyp((itype(i-2)))
6357 C propagation of chirality for glycine type
6358           do k=1,nsingle
6359             cosph1(k)=dcos(k*phii)
6360             sinph1(k)=dsin(k*phii)
6361           enddo
6362         else
6363           phii=0.0d0
6364           do k=1,nsingle
6365           ityp1=ithetyp((itype(i-2)))
6366             cosph1(k)=0.0d0
6367             sinph1(k)=0.0d0
6368           enddo
6369         endif
6370         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6371 #ifdef OSF
6372           phii1=phi(i+1)
6373           if (phii1.ne.phii1) phii1=150.0
6374           phii1=pinorm(phii1)
6375 #else
6376           phii1=phi(i+1)
6377 #endif
6378           ityp3=ithetyp((itype(i)))
6379           do k=1,nsingle
6380             cosph2(k)=dcos(k*phii1)
6381             sinph2(k)=dsin(k*phii1)
6382           enddo
6383         else
6384           phii1=0.0d0
6385           ityp3=ithetyp((itype(i)))
6386           do k=1,nsingle
6387             cosph2(k)=0.0d0
6388             sinph2(k)=0.0d0
6389           enddo
6390         endif
6391         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6392         do k=1,ndouble
6393           do l=1,k-1
6394             ccl=cosph1(l)*cosph2(k-l)
6395             ssl=sinph1(l)*sinph2(k-l)
6396             scl=sinph1(l)*cosph2(k-l)
6397             csl=cosph1(l)*sinph2(k-l)
6398             cosph1ph2(l,k)=ccl-ssl
6399             cosph1ph2(k,l)=ccl+ssl
6400             sinph1ph2(l,k)=scl+csl
6401             sinph1ph2(k,l)=scl-csl
6402           enddo
6403         enddo
6404         if (lprn) then
6405         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6406      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6407         write (iout,*) "coskt and sinkt"
6408         do k=1,nntheterm
6409           write (iout,*) k,coskt(k),sinkt(k)
6410         enddo
6411         endif
6412         do k=1,ntheterm
6413           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6414           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6415      &      *coskt(k)
6416           if (lprn)
6417      &    write (iout,*) "k",k,"
6418      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6419      &     " ethetai",ethetai
6420         enddo
6421         if (lprn) then
6422         write (iout,*) "cosph and sinph"
6423         do k=1,nsingle
6424           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6425         enddo
6426         write (iout,*) "cosph1ph2 and sinph2ph2"
6427         do k=2,ndouble
6428           do l=1,k-1
6429             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6430      &         sinph1ph2(l,k),sinph1ph2(k,l)
6431           enddo
6432         enddo
6433         write(iout,*) "ethetai",ethetai
6434         endif
6435 C       print *,ethetai
6436         do m=1,ntheterm2
6437           do k=1,nsingle
6438             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6439      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6440      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6441      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6442             ethetai=ethetai+sinkt(m)*aux
6443             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6444             dephii=dephii+k*sinkt(m)*(
6445      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6446      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6447             dephii1=dephii1+k*sinkt(m)*(
6448      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6449      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6450             if (lprn)
6451      &      write (iout,*) "m",m," k",k," bbthet",
6452      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6453      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6454      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6455      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6456 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6457           enddo
6458         enddo
6459 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6460 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6461 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6462 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6463         if (lprn)
6464      &  write(iout,*) "ethetai",ethetai
6465 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6466         do m=1,ntheterm3
6467           do k=2,ndouble
6468             do l=1,k-1
6469               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6470      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6471      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6472      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6473               ethetai=ethetai+sinkt(m)*aux
6474               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6475               dephii=dephii+l*sinkt(m)*(
6476      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6477      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6478      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6479      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6480               dephii1=dephii1+(k-l)*sinkt(m)*(
6481      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6482      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6483      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6484      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6485               if (lprn) then
6486               write (iout,*) "m",m," k",k," l",l," ffthet",
6487      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6488      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6489      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6490      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6491      &            " ethetai",ethetai
6492               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6493      &            cosph1ph2(k,l)*sinkt(m),
6494      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6495               endif
6496             enddo
6497           enddo
6498         enddo
6499 10      continue
6500 c        lprn1=.true.
6501 C        print *,ethetai
6502         if (lprn1)
6503      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6504      &   i,theta(i)*rad2deg,phii*rad2deg,
6505      &   phii1*rad2deg,ethetai
6506 c        lprn1=.false.
6507         etheta=etheta+ethetai
6508         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6509         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6510         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6511       enddo
6512
6513       return
6514       end
6515 #endif
6516 #ifdef CRYST_SC
6517 c-----------------------------------------------------------------------------
6518       subroutine esc(escloc)
6519 C Calculate the local energy of a side chain and its derivatives in the
6520 C corresponding virtual-bond valence angles THETA and the spherical angles
6521 C ALPHA and OMEGA.
6522       implicit real*8 (a-h,o-z)
6523       include 'DIMENSIONS'
6524       include 'COMMON.GEO'
6525       include 'COMMON.LOCAL'
6526       include 'COMMON.VAR'
6527       include 'COMMON.INTERACT'
6528       include 'COMMON.DERIV'
6529       include 'COMMON.CHAIN'
6530       include 'COMMON.IOUNITS'
6531       include 'COMMON.NAMES'
6532       include 'COMMON.FFIELD'
6533       include 'COMMON.CONTROL'
6534       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6535      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6536       common /sccalc/ time11,time12,time112,theti,it,nlobit
6537       delta=0.02d0*pi
6538       escloc=0.0D0
6539 c     write (iout,'(a)') 'ESC'
6540       do i=loc_start,loc_end
6541         it=itype(i)
6542         if (it.eq.ntyp1) cycle
6543         if (it.eq.10) goto 1
6544         nlobit=nlob(iabs(it))
6545 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6546 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6547         theti=theta(i+1)-pipol
6548         x(1)=dtan(theti)
6549         x(2)=alph(i)
6550         x(3)=omeg(i)
6551
6552         if (x(2).gt.pi-delta) then
6553           xtemp(1)=x(1)
6554           xtemp(2)=pi-delta
6555           xtemp(3)=x(3)
6556           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6557           xtemp(2)=pi
6558           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6559           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6560      &        escloci,dersc(2))
6561           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6562      &        ddersc0(1),dersc(1))
6563           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6564      &        ddersc0(3),dersc(3))
6565           xtemp(2)=pi-delta
6566           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6567           xtemp(2)=pi
6568           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6569           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6570      &            dersc0(2),esclocbi,dersc02)
6571           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6572      &            dersc12,dersc01)
6573           call splinthet(x(2),0.5d0*delta,ss,ssd)
6574           dersc0(1)=dersc01
6575           dersc0(2)=dersc02
6576           dersc0(3)=0.0d0
6577           do k=1,3
6578             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6579           enddo
6580           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6581 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6582 c    &             esclocbi,ss,ssd
6583           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6584 c         escloci=esclocbi
6585 c         write (iout,*) escloci
6586         else if (x(2).lt.delta) then
6587           xtemp(1)=x(1)
6588           xtemp(2)=delta
6589           xtemp(3)=x(3)
6590           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6591           xtemp(2)=0.0d0
6592           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6593           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6594      &        escloci,dersc(2))
6595           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6596      &        ddersc0(1),dersc(1))
6597           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6598      &        ddersc0(3),dersc(3))
6599           xtemp(2)=delta
6600           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6601           xtemp(2)=0.0d0
6602           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6603           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6604      &            dersc0(2),esclocbi,dersc02)
6605           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6606      &            dersc12,dersc01)
6607           dersc0(1)=dersc01
6608           dersc0(2)=dersc02
6609           dersc0(3)=0.0d0
6610           call splinthet(x(2),0.5d0*delta,ss,ssd)
6611           do k=1,3
6612             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6613           enddo
6614           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6615 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6616 c    &             esclocbi,ss,ssd
6617           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6618 c         write (iout,*) escloci
6619         else
6620           call enesc(x,escloci,dersc,ddummy,.false.)
6621         endif
6622
6623         escloc=escloc+escloci
6624         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6625      &     'escloc',i,escloci
6626 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6627
6628         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6629      &   wscloc*dersc(1)
6630         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6631         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6632     1   continue
6633       enddo
6634       return
6635       end
6636 C---------------------------------------------------------------------------
6637       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6638       implicit real*8 (a-h,o-z)
6639       include 'DIMENSIONS'
6640       include 'COMMON.GEO'
6641       include 'COMMON.LOCAL'
6642       include 'COMMON.IOUNITS'
6643       common /sccalc/ time11,time12,time112,theti,it,nlobit
6644       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6645       double precision contr(maxlob,-1:1)
6646       logical mixed
6647 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6648         escloc_i=0.0D0
6649         do j=1,3
6650           dersc(j)=0.0D0
6651           if (mixed) ddersc(j)=0.0d0
6652         enddo
6653         x3=x(3)
6654
6655 C Because of periodicity of the dependence of the SC energy in omega we have
6656 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6657 C To avoid underflows, first compute & store the exponents.
6658
6659         do iii=-1,1
6660
6661           x(3)=x3+iii*dwapi
6662
6663           do j=1,nlobit
6664             do k=1,3
6665               z(k)=x(k)-censc(k,j,it)
6666             enddo
6667             do k=1,3
6668               Axk=0.0D0
6669               do l=1,3
6670                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6671               enddo
6672               Ax(k,j,iii)=Axk
6673             enddo
6674             expfac=0.0D0
6675             do k=1,3
6676               expfac=expfac+Ax(k,j,iii)*z(k)
6677             enddo
6678             contr(j,iii)=expfac
6679           enddo ! j
6680
6681         enddo ! iii
6682
6683         x(3)=x3
6684 C As in the case of ebend, we want to avoid underflows in exponentiation and
6685 C subsequent NaNs and INFs in energy calculation.
6686 C Find the largest exponent
6687         emin=contr(1,-1)
6688         do iii=-1,1
6689           do j=1,nlobit
6690             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6691           enddo
6692         enddo
6693         emin=0.5D0*emin
6694 cd      print *,'it=',it,' emin=',emin
6695
6696 C Compute the contribution to SC energy and derivatives
6697         do iii=-1,1
6698
6699           do j=1,nlobit
6700 #ifdef OSF
6701             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6702             if(adexp.ne.adexp) adexp=1.0
6703             expfac=dexp(adexp)
6704 #else
6705             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6706 #endif
6707 cd          print *,'j=',j,' expfac=',expfac
6708             escloc_i=escloc_i+expfac
6709             do k=1,3
6710               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6711             enddo
6712             if (mixed) then
6713               do k=1,3,2
6714                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6715      &            +gaussc(k,2,j,it))*expfac
6716               enddo
6717             endif
6718           enddo
6719
6720         enddo ! iii
6721
6722         dersc(1)=dersc(1)/cos(theti)**2
6723         ddersc(1)=ddersc(1)/cos(theti)**2
6724         ddersc(3)=ddersc(3)
6725
6726         escloci=-(dlog(escloc_i)-emin)
6727         do j=1,3
6728           dersc(j)=dersc(j)/escloc_i
6729         enddo
6730         if (mixed) then
6731           do j=1,3,2
6732             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6733           enddo
6734         endif
6735       return
6736       end
6737 C------------------------------------------------------------------------------
6738       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6739       implicit real*8 (a-h,o-z)
6740       include 'DIMENSIONS'
6741       include 'COMMON.GEO'
6742       include 'COMMON.LOCAL'
6743       include 'COMMON.IOUNITS'
6744       common /sccalc/ time11,time12,time112,theti,it,nlobit
6745       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6746       double precision contr(maxlob)
6747       logical mixed
6748
6749       escloc_i=0.0D0
6750
6751       do j=1,3
6752         dersc(j)=0.0D0
6753       enddo
6754
6755       do j=1,nlobit
6756         do k=1,2
6757           z(k)=x(k)-censc(k,j,it)
6758         enddo
6759         z(3)=dwapi
6760         do k=1,3
6761           Axk=0.0D0
6762           do l=1,3
6763             Axk=Axk+gaussc(l,k,j,it)*z(l)
6764           enddo
6765           Ax(k,j)=Axk
6766         enddo
6767         expfac=0.0D0
6768         do k=1,3
6769           expfac=expfac+Ax(k,j)*z(k)
6770         enddo
6771         contr(j)=expfac
6772       enddo ! j
6773
6774 C As in the case of ebend, we want to avoid underflows in exponentiation and
6775 C subsequent NaNs and INFs in energy calculation.
6776 C Find the largest exponent
6777       emin=contr(1)
6778       do j=1,nlobit
6779         if (emin.gt.contr(j)) emin=contr(j)
6780       enddo
6781       emin=0.5D0*emin
6782
6783 C Compute the contribution to SC energy and derivatives
6784
6785       dersc12=0.0d0
6786       do j=1,nlobit
6787         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6788         escloc_i=escloc_i+expfac
6789         do k=1,2
6790           dersc(k)=dersc(k)+Ax(k,j)*expfac
6791         enddo
6792         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6793      &            +gaussc(1,2,j,it))*expfac
6794         dersc(3)=0.0d0
6795       enddo
6796
6797       dersc(1)=dersc(1)/cos(theti)**2
6798       dersc12=dersc12/cos(theti)**2
6799       escloci=-(dlog(escloc_i)-emin)
6800       do j=1,2
6801         dersc(j)=dersc(j)/escloc_i
6802       enddo
6803       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6804       return
6805       end
6806 #else
6807 c----------------------------------------------------------------------------------
6808       subroutine esc(escloc)
6809 C Calculate the local energy of a side chain and its derivatives in the
6810 C corresponding virtual-bond valence angles THETA and the spherical angles
6811 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6812 C added by Urszula Kozlowska. 07/11/2007
6813 C
6814       implicit real*8 (a-h,o-z)
6815       include 'DIMENSIONS'
6816       include 'COMMON.GEO'
6817       include 'COMMON.LOCAL'
6818       include 'COMMON.VAR'
6819       include 'COMMON.SCROT'
6820       include 'COMMON.INTERACT'
6821       include 'COMMON.DERIV'
6822       include 'COMMON.CHAIN'
6823       include 'COMMON.IOUNITS'
6824       include 'COMMON.NAMES'
6825       include 'COMMON.FFIELD'
6826       include 'COMMON.CONTROL'
6827       include 'COMMON.VECTORS'
6828       double precision x_prime(3),y_prime(3),z_prime(3)
6829      &    , sumene,dsc_i,dp2_i,x(65),
6830      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6831      &    de_dxx,de_dyy,de_dzz,de_dt
6832       double precision s1_t,s1_6_t,s2_t,s2_6_t
6833       double precision
6834      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6835      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6836      & dt_dCi(3),dt_dCi1(3)
6837       common /sccalc/ time11,time12,time112,theti,it,nlobit
6838       delta=0.02d0*pi
6839       escloc=0.0D0
6840       do i=loc_start,loc_end
6841         if (itype(i).eq.ntyp1) cycle
6842         costtab(i+1) =dcos(theta(i+1))
6843         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6844         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6845         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6846         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6847         cosfac=dsqrt(cosfac2)
6848         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6849         sinfac=dsqrt(sinfac2)
6850         it=iabs(itype(i))
6851         if (it.eq.10) goto 1
6852 c
6853 C  Compute the axes of tghe local cartesian coordinates system; store in
6854 c   x_prime, y_prime and z_prime
6855 c
6856         do j=1,3
6857           x_prime(j) = 0.00
6858           y_prime(j) = 0.00
6859           z_prime(j) = 0.00
6860         enddo
6861 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6862 C     &   dc_norm(3,i+nres)
6863         do j = 1,3
6864           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6865           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6866         enddo
6867         do j = 1,3
6868           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6869         enddo
6870 c       write (2,*) "i",i
6871 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6872 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6873 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6874 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6875 c      & " xy",scalar(x_prime(1),y_prime(1)),
6876 c      & " xz",scalar(x_prime(1),z_prime(1)),
6877 c      & " yy",scalar(y_prime(1),y_prime(1)),
6878 c      & " yz",scalar(y_prime(1),z_prime(1)),
6879 c      & " zz",scalar(z_prime(1),z_prime(1))
6880 c
6881 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6882 C to local coordinate system. Store in xx, yy, zz.
6883 c
6884         xx=0.0d0
6885         yy=0.0d0
6886         zz=0.0d0
6887         do j = 1,3
6888           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6889           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6890           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6891         enddo
6892
6893         xxtab(i)=xx
6894         yytab(i)=yy
6895         zztab(i)=zz
6896 C
6897 C Compute the energy of the ith side cbain
6898 C
6899 c        write (2,*) "xx",xx," yy",yy," zz",zz
6900         it=iabs(itype(i))
6901         do j = 1,65
6902           x(j) = sc_parmin(j,it)
6903         enddo
6904 #ifdef CHECK_COORD
6905 Cc diagnostics - remove later
6906         xx1 = dcos(alph(2))
6907         yy1 = dsin(alph(2))*dcos(omeg(2))
6908         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6909         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6910      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6911      &    xx1,yy1,zz1
6912 C,"  --- ", xx_w,yy_w,zz_w
6913 c end diagnostics
6914 #endif
6915         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6916      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6917      &   + x(10)*yy*zz
6918         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6919      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6920      & + x(20)*yy*zz
6921         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6922      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6923      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6924      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6925      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6926      &  +x(40)*xx*yy*zz
6927         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6928      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6929      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6930      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6931      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6932      &  +x(60)*xx*yy*zz
6933         dsc_i   = 0.743d0+x(61)
6934         dp2_i   = 1.9d0+x(62)
6935         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6936      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6937         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6938      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6939         s1=(1+x(63))/(0.1d0 + dscp1)
6940         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
6941         s2=(1+x(65))/(0.1d0 + dscp2)
6942         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
6943         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
6944      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
6945 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
6946 c     &   sumene4,
6947 c     &   dscp1,dscp2,sumene
6948 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6949         escloc = escloc + sumene
6950 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
6951 c     & ,zz,xx,yy
6952 c#define DEBUG
6953 #ifdef DEBUG
6954 C
6955 C This section to check the numerical derivatives of the energy of ith side
6956 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
6957 C #define DEBUG in the code to turn it on.
6958 C
6959         write (2,*) "sumene               =",sumene
6960         aincr=1.0d-7
6961         xxsave=xx
6962         xx=xx+aincr
6963         write (2,*) xx,yy,zz
6964         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6965         de_dxx_num=(sumenep-sumene)/aincr
6966         xx=xxsave
6967         write (2,*) "xx+ sumene from enesc=",sumenep
6968         yysave=yy
6969         yy=yy+aincr
6970         write (2,*) xx,yy,zz
6971         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6972         de_dyy_num=(sumenep-sumene)/aincr
6973         yy=yysave
6974         write (2,*) "yy+ sumene from enesc=",sumenep
6975         zzsave=zz
6976         zz=zz+aincr
6977         write (2,*) xx,yy,zz
6978         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6979         de_dzz_num=(sumenep-sumene)/aincr
6980         zz=zzsave
6981         write (2,*) "zz+ sumene from enesc=",sumenep
6982         costsave=cost2tab(i+1)
6983         sintsave=sint2tab(i+1)
6984         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
6985         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
6986         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
6987         de_dt_num=(sumenep-sumene)/aincr
6988         write (2,*) " t+ sumene from enesc=",sumenep
6989         cost2tab(i+1)=costsave
6990         sint2tab(i+1)=sintsave
6991 C End of diagnostics section.
6992 #endif
6993 C
6994 C Compute the gradient of esc
6995 C
6996 c        zz=zz*dsign(1.0,dfloat(itype(i)))
6997         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
6998         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
6999         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7000         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7001         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7002         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7003         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7004         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7005         pom1=(sumene3*sint2tab(i+1)+sumene1)
7006      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7007         pom2=(sumene4*cost2tab(i+1)+sumene2)
7008      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7009         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7010         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7011      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7012      &  +x(40)*yy*zz
7013         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7014         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7015      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7016      &  +x(60)*yy*zz
7017         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7018      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7019      &        +(pom1+pom2)*pom_dx
7020 #ifdef DEBUG
7021         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7022 #endif
7023 C
7024         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7025         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7026      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7027      &  +x(40)*xx*zz
7028         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7029         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7030      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7031      &  +x(59)*zz**2 +x(60)*xx*zz
7032         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7033      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7034      &        +(pom1-pom2)*pom_dy
7035 #ifdef DEBUG
7036         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7037 #endif
7038 C
7039         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7040      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7041      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7042      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7043      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7044      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7045      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7046      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7047 #ifdef DEBUG
7048         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7049 #endif
7050 C
7051         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7052      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7053      &  +pom1*pom_dt1+pom2*pom_dt2
7054 #ifdef DEBUG
7055         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7056 #endif
7057 c#undef DEBUG
7058 c
7059 C
7060        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7061        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7062        cosfac2xx=cosfac2*xx
7063        sinfac2yy=sinfac2*yy
7064        do k = 1,3
7065          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7066      &      vbld_inv(i+1)
7067          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7068      &      vbld_inv(i)
7069          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7070          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7071 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7072 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7073 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7074 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7075          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7076          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7077          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7078          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7079          dZZ_Ci1(k)=0.0d0
7080          dZZ_Ci(k)=0.0d0
7081          do j=1,3
7082            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7083      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7084            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7085      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7086          enddo
7087
7088          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7089          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7090          dZZ_XYZ(k)=vbld_inv(i+nres)*
7091      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7092 c
7093          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7094          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7095        enddo
7096
7097        do k=1,3
7098          dXX_Ctab(k,i)=dXX_Ci(k)
7099          dXX_C1tab(k,i)=dXX_Ci1(k)
7100          dYY_Ctab(k,i)=dYY_Ci(k)
7101          dYY_C1tab(k,i)=dYY_Ci1(k)
7102          dZZ_Ctab(k,i)=dZZ_Ci(k)
7103          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7104          dXX_XYZtab(k,i)=dXX_XYZ(k)
7105          dYY_XYZtab(k,i)=dYY_XYZ(k)
7106          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7107        enddo
7108
7109        do k = 1,3
7110 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7111 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7112 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7113 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7114 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7115 c     &    dt_dci(k)
7116 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7117 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7118          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7119      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7120          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7121      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7122          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7123      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7124        enddo
7125 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7126 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7127
7128 C to check gradient call subroutine check_grad
7129
7130     1 continue
7131       enddo
7132       return
7133       end
7134 c------------------------------------------------------------------------------
7135       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7136       implicit none
7137       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7138      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7139       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7140      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7141      &   + x(10)*yy*zz
7142       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7143      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7144      & + x(20)*yy*zz
7145       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7146      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7147      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7148      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7149      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7150      &  +x(40)*xx*yy*zz
7151       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7152      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7153      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7154      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7155      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7156      &  +x(60)*xx*yy*zz
7157       dsc_i   = 0.743d0+x(61)
7158       dp2_i   = 1.9d0+x(62)
7159       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7160      &          *(xx*cost2+yy*sint2))
7161       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7162      &          *(xx*cost2-yy*sint2))
7163       s1=(1+x(63))/(0.1d0 + dscp1)
7164       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7165       s2=(1+x(65))/(0.1d0 + dscp2)
7166       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7167       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7168      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7169       enesc=sumene
7170       return
7171       end
7172 #endif
7173 c------------------------------------------------------------------------------
7174       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7175 C
7176 C This procedure calculates two-body contact function g(rij) and its derivative:
7177 C
7178 C           eps0ij                                     !       x < -1
7179 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7180 C            0                                         !       x > 1
7181 C
7182 C where x=(rij-r0ij)/delta
7183 C
7184 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7185 C
7186       implicit none
7187       double precision rij,r0ij,eps0ij,fcont,fprimcont
7188       double precision x,x2,x4,delta
7189 c     delta=0.02D0*r0ij
7190 c      delta=0.2D0*r0ij
7191       x=(rij-r0ij)/delta
7192       if (x.lt.-1.0D0) then
7193         fcont=eps0ij
7194         fprimcont=0.0D0
7195       else if (x.le.1.0D0) then
7196         x2=x*x
7197         x4=x2*x2
7198         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7199         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7200       else
7201         fcont=0.0D0
7202         fprimcont=0.0D0
7203       endif
7204       return
7205       end
7206 c------------------------------------------------------------------------------
7207       subroutine splinthet(theti,delta,ss,ssder)
7208       implicit real*8 (a-h,o-z)
7209       include 'DIMENSIONS'
7210       include 'COMMON.VAR'
7211       include 'COMMON.GEO'
7212       thetup=pi-delta
7213       thetlow=delta
7214       if (theti.gt.pipol) then
7215         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7216       else
7217         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7218         ssder=-ssder
7219       endif
7220       return
7221       end
7222 c------------------------------------------------------------------------------
7223       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7224       implicit none
7225       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7226       double precision ksi,ksi2,ksi3,a1,a2,a3
7227       a1=fprim0*delta/(f1-f0)
7228       a2=3.0d0-2.0d0*a1
7229       a3=a1-2.0d0
7230       ksi=(x-x0)/delta
7231       ksi2=ksi*ksi
7232       ksi3=ksi2*ksi
7233       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7234       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7235       return
7236       end
7237 c------------------------------------------------------------------------------
7238       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7239       implicit none
7240       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7241       double precision ksi,ksi2,ksi3,a1,a2,a3
7242       ksi=(x-x0)/delta
7243       ksi2=ksi*ksi
7244       ksi3=ksi2*ksi
7245       a1=fprim0x*delta
7246       a2=3*(f1x-f0x)-2*fprim0x*delta
7247       a3=fprim0x*delta-2*(f1x-f0x)
7248       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7249       return
7250       end
7251 C-----------------------------------------------------------------------------
7252 #ifdef CRYST_TOR
7253 C-----------------------------------------------------------------------------
7254       subroutine etor(etors)
7255       implicit real*8 (a-h,o-z)
7256       include 'DIMENSIONS'
7257       include 'COMMON.VAR'
7258       include 'COMMON.GEO'
7259       include 'COMMON.LOCAL'
7260       include 'COMMON.TORSION'
7261       include 'COMMON.INTERACT'
7262       include 'COMMON.DERIV'
7263       include 'COMMON.CHAIN'
7264       include 'COMMON.NAMES'
7265       include 'COMMON.IOUNITS'
7266       include 'COMMON.FFIELD'
7267       include 'COMMON.TORCNSTR'
7268       include 'COMMON.CONTROL'
7269       logical lprn
7270 C Set lprn=.true. for debugging
7271       lprn=.false.
7272 c      lprn=.true.
7273       etors=0.0D0
7274       do i=iphi_start,iphi_end
7275       etors_ii=0.0D0
7276         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7277      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7278         itori=itortyp(itype(i-2))
7279         itori1=itortyp(itype(i-1))
7280         phii=phi(i)
7281         gloci=0.0D0
7282 C Proline-Proline pair is a special case...
7283         if (itori.eq.3 .and. itori1.eq.3) then
7284           if (phii.gt.-dwapi3) then
7285             cosphi=dcos(3*phii)
7286             fac=1.0D0/(1.0D0-cosphi)
7287             etorsi=v1(1,3,3)*fac
7288             etorsi=etorsi+etorsi
7289             etors=etors+etorsi-v1(1,3,3)
7290             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7291             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7292           endif
7293           do j=1,3
7294             v1ij=v1(j+1,itori,itori1)
7295             v2ij=v2(j+1,itori,itori1)
7296             cosphi=dcos(j*phii)
7297             sinphi=dsin(j*phii)
7298             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7299             if (energy_dec) etors_ii=etors_ii+
7300      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7301             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7302           enddo
7303         else
7304           do j=1,nterm_old
7305             v1ij=v1(j,itori,itori1)
7306             v2ij=v2(j,itori,itori1)
7307             cosphi=dcos(j*phii)
7308             sinphi=dsin(j*phii)
7309             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7310             if (energy_dec) etors_ii=etors_ii+
7311      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7312             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7313           enddo
7314         endif
7315         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7316              'etor',i,etors_ii
7317         if (lprn)
7318      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7319      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7320      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7321         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7322 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7323       enddo
7324       return
7325       end
7326 c------------------------------------------------------------------------------
7327       subroutine etor_d(etors_d)
7328       etors_d=0.0d0
7329       return
7330       end
7331 c----------------------------------------------------------------------------
7332 #else
7333       subroutine etor(etors)
7334       implicit real*8 (a-h,o-z)
7335       include 'DIMENSIONS'
7336       include 'COMMON.VAR'
7337       include 'COMMON.GEO'
7338       include 'COMMON.LOCAL'
7339       include 'COMMON.TORSION'
7340       include 'COMMON.INTERACT'
7341       include 'COMMON.DERIV'
7342       include 'COMMON.CHAIN'
7343       include 'COMMON.NAMES'
7344       include 'COMMON.IOUNITS'
7345       include 'COMMON.FFIELD'
7346       include 'COMMON.TORCNSTR'
7347       include 'COMMON.CONTROL'
7348       logical lprn
7349 C Set lprn=.true. for debugging
7350       lprn=.false.
7351 c     lprn=.true.
7352       etors=0.0D0
7353       do i=iphi_start,iphi_end
7354 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7355 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7356 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7357 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7358         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7359      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7360 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7361 C For introducing the NH3+ and COO- group please check the etor_d for reference
7362 C and guidance
7363         etors_ii=0.0D0
7364          if (iabs(itype(i)).eq.20) then
7365          iblock=2
7366          else
7367          iblock=1
7368          endif
7369         itori=itortyp(itype(i-2))
7370         itori1=itortyp(itype(i-1))
7371         phii=phi(i)
7372         gloci=0.0D0
7373 C Regular cosine and sine terms
7374         do j=1,nterm(itori,itori1,iblock)
7375           v1ij=v1(j,itori,itori1,iblock)
7376           v2ij=v2(j,itori,itori1,iblock)
7377           cosphi=dcos(j*phii)
7378           sinphi=dsin(j*phii)
7379           etors=etors+v1ij*cosphi+v2ij*sinphi
7380           if (energy_dec) etors_ii=etors_ii+
7381      &                v1ij*cosphi+v2ij*sinphi
7382           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7383         enddo
7384 C Lorentz terms
7385 C                         v1
7386 C  E = SUM ----------------------------------- - v1
7387 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7388 C
7389         cosphi=dcos(0.5d0*phii)
7390         sinphi=dsin(0.5d0*phii)
7391         do j=1,nlor(itori,itori1,iblock)
7392           vl1ij=vlor1(j,itori,itori1)
7393           vl2ij=vlor2(j,itori,itori1)
7394           vl3ij=vlor3(j,itori,itori1)
7395           pom=vl2ij*cosphi+vl3ij*sinphi
7396           pom1=1.0d0/(pom*pom+1.0d0)
7397           etors=etors+vl1ij*pom1
7398           if (energy_dec) etors_ii=etors_ii+
7399      &                vl1ij*pom1
7400           pom=-pom*pom1*pom1
7401           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7402         enddo
7403 C Subtract the constant term
7404         etors=etors-v0(itori,itori1,iblock)
7405           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7406      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7407         if (lprn)
7408      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7409      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7410      &  (v1(j,itori,itori1,iblock),j=1,6),
7411      &  (v2(j,itori,itori1,iblock),j=1,6)
7412         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7413 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7414       enddo
7415       return
7416       end
7417 c----------------------------------------------------------------------------
7418       subroutine etor_d(etors_d)
7419 C 6/23/01 Compute double torsional energy
7420       implicit real*8 (a-h,o-z)
7421       include 'DIMENSIONS'
7422       include 'COMMON.VAR'
7423       include 'COMMON.GEO'
7424       include 'COMMON.LOCAL'
7425       include 'COMMON.TORSION'
7426       include 'COMMON.INTERACT'
7427       include 'COMMON.DERIV'
7428       include 'COMMON.CHAIN'
7429       include 'COMMON.NAMES'
7430       include 'COMMON.IOUNITS'
7431       include 'COMMON.FFIELD'
7432       include 'COMMON.TORCNSTR'
7433       logical lprn
7434 C Set lprn=.true. for debugging
7435       lprn=.false.
7436 c     lprn=.true.
7437       etors_d=0.0D0
7438 c      write(iout,*) "a tu??"
7439       do i=iphid_start,iphid_end
7440 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7441 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7442 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7443 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7444 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7445          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7446      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7447      &  (itype(i+1).eq.ntyp1)) cycle
7448 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7449         itori=itortyp(itype(i-2))
7450         itori1=itortyp(itype(i-1))
7451         itori2=itortyp(itype(i))
7452         phii=phi(i)
7453         phii1=phi(i+1)
7454         gloci1=0.0D0
7455         gloci2=0.0D0
7456         iblock=1
7457         if (iabs(itype(i+1)).eq.20) iblock=2
7458 C Iblock=2 Proline type
7459 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7460 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7461 C        if (itype(i+1).eq.ntyp1) iblock=3
7462 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7463 C IS or IS NOT need for this
7464 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7465 C        is (itype(i-3).eq.ntyp1) ntblock=2
7466 C        ntblock is N-terminal blocking group
7467
7468 C Regular cosine and sine terms
7469         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7470 C Example of changes for NH3+ blocking group
7471 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7472 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7473           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7474           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7475           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7476           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7477           cosphi1=dcos(j*phii)
7478           sinphi1=dsin(j*phii)
7479           cosphi2=dcos(j*phii1)
7480           sinphi2=dsin(j*phii1)
7481           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7482      &     v2cij*cosphi2+v2sij*sinphi2
7483           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7484           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7485         enddo
7486         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7487           do l=1,k-1
7488             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7489             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7490             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7491             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7492             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7493             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7494             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7495             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7496             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7497      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7498             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7499      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7500             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7501      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7502           enddo
7503         enddo
7504         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7505         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7506       enddo
7507       return
7508       end
7509 #endif
7510 C----------------------------------------------------------------------------------
7511 C The rigorous attempt to derive energy function
7512       subroutine etor_kcc(etors)
7513       implicit real*8 (a-h,o-z)
7514       include 'DIMENSIONS'
7515       include 'COMMON.VAR'
7516       include 'COMMON.GEO'
7517       include 'COMMON.LOCAL'
7518       include 'COMMON.TORSION'
7519       include 'COMMON.INTERACT'
7520       include 'COMMON.DERIV'
7521       include 'COMMON.CHAIN'
7522       include 'COMMON.NAMES'
7523       include 'COMMON.IOUNITS'
7524       include 'COMMON.FFIELD'
7525       include 'COMMON.TORCNSTR'
7526       include 'COMMON.CONTROL'
7527       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7528       logical lprn
7529 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7530 C Set lprn=.true. for debugging
7531       lprn=energy_dec
7532 c     lprn=.true.
7533 C      print *,"wchodze kcc"
7534       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7535       etors=0.0D0
7536       do i=iphi_start,iphi_end
7537 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7538 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7539 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7540 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7541         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7542      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7543         itori=itortyp(itype(i-2))
7544         itori1=itortyp(itype(i-1))
7545         phii=phi(i)
7546         glocig=0.0D0
7547         glocit1=0.0d0
7548         glocit2=0.0d0
7549 C to avoid multiple devision by 2
7550 c        theti22=0.5d0*theta(i)
7551 C theta 12 is the theta_1 /2
7552 C theta 22 is theta_2 /2
7553 c        theti12=0.5d0*theta(i-1)
7554 C and appropriate sinus function
7555         sinthet1=dsin(theta(i-1))
7556         sinthet2=dsin(theta(i))
7557         costhet1=dcos(theta(i-1))
7558         costhet2=dcos(theta(i))
7559 C to speed up lets store its mutliplication
7560         sint1t2=sinthet2*sinthet1
7561         sint1t2n=1.0d0
7562 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7563 C +d_n*sin(n*gamma)) *
7564 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7565 C we have two sum 1) Non-Chebyshev which is with n and gamma
7566         nval=nterm_kcc_Tb(itori,itori1)
7567         c1(0)=0.0d0
7568         c2(0)=0.0d0
7569         c1(1)=1.0d0
7570         c2(1)=1.0d0
7571         do j=2,nval
7572           c1(j)=c1(j-1)*costhet1
7573           c2(j)=c2(j-1)*costhet2
7574         enddo
7575         etori=0.0d0
7576         do j=1,nterm_kcc(itori,itori1)
7577           cosphi=dcos(j*phii)
7578           sinphi=dsin(j*phii)
7579           sint1t2n1=sint1t2n
7580           sint1t2n=sint1t2n*sint1t2
7581           sumvalc=0.0d0
7582           gradvalct1=0.0d0
7583           gradvalct2=0.0d0
7584           do k=1,nval
7585             do l=1,nval
7586               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7587               gradvalct1=gradvalct1+
7588      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7589               gradvalct2=gradvalct2+
7590      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7591             enddo
7592           enddo
7593           gradvalct1=-gradvalct1*sinthet1
7594           gradvalct2=-gradvalct2*sinthet2
7595           sumvals=0.0d0
7596           gradvalst1=0.0d0
7597           gradvalst2=0.0d0
7598           do k=1,nval
7599             do l=1,nval
7600               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7601               gradvalst1=gradvalst1+
7602      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7603               gradvalst2=gradvalst2+
7604      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7605             enddo
7606           enddo
7607           gradvalst1=-gradvalst1*sinthet1
7608           gradvalst2=-gradvalst2*sinthet2
7609           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7610           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7611 C glocig is the gradient local i site in gamma
7612           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7613 C now gradient over theta_1
7614           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7615      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7616           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7617      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7618         enddo ! j
7619         etors=etors+etori
7620 C derivative over gamma
7621         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7622 C derivative over theta1
7623         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7624 C now derivative over theta2
7625         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7626         if (lprn) then
7627           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7628      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7629           write (iout,*) "c1",(c1(k),k=0,nval),
7630      &    " c2",(c2(k),k=0,nval)
7631         endif
7632       enddo
7633       return
7634       end
7635 c---------------------------------------------------------------------------------------------
7636       subroutine etor_constr(edihcnstr)
7637       implicit real*8 (a-h,o-z)
7638       include 'DIMENSIONS'
7639       include 'COMMON.VAR'
7640       include 'COMMON.GEO'
7641       include 'COMMON.LOCAL'
7642       include 'COMMON.TORSION'
7643       include 'COMMON.INTERACT'
7644       include 'COMMON.DERIV'
7645       include 'COMMON.CHAIN'
7646       include 'COMMON.NAMES'
7647       include 'COMMON.IOUNITS'
7648       include 'COMMON.FFIELD'
7649       include 'COMMON.TORCNSTR'
7650       include 'COMMON.BOUNDS'
7651       include 'COMMON.CONTROL'
7652 ! 6/20/98 - dihedral angle constraints
7653       edihcnstr=0.0d0
7654 c      do i=1,ndih_constr
7655       if (raw_psipred) then
7656         do i=idihconstr_start,idihconstr_end
7657           itori=idih_constr(i)
7658           phii=phi(itori)
7659           gaudih_i=vpsipred(1,i)
7660           gauder_i=0.0d0
7661           do j=1,2
7662             s = sdihed(j,i)
7663             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7664             dexpcos_i=dexp(-cos_i*cos_i)
7665             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7666             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7667      &            *cos_i*dexpcos_i/s**2
7668           enddo
7669           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7670           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7671           if (energy_dec)
7672      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7673      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7674      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7675      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7676      &     -wdihc*dlog(gaudih_i)
7677         enddo
7678       else
7679
7680       do i=idihconstr_start,idihconstr_end
7681         itori=idih_constr(i)
7682         phii=phi(itori)
7683         difi=pinorm(phii-phi0(i))
7684         if (difi.gt.drange(i)) then
7685           difi=difi-drange(i)
7686           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7687           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7688         else if (difi.lt.-drange(i)) then
7689           difi=difi+drange(i)
7690           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7691           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7692         else
7693           difi=0.0
7694         endif
7695       enddo
7696
7697       endif
7698
7699       return
7700       end
7701 c----------------------------------------------------------------------------
7702 C The rigorous attempt to derive energy function
7703       subroutine ebend_kcc(etheta)
7704
7705       implicit real*8 (a-h,o-z)
7706       include 'DIMENSIONS'
7707       include 'COMMON.VAR'
7708       include 'COMMON.GEO'
7709       include 'COMMON.LOCAL'
7710       include 'COMMON.TORSION'
7711       include 'COMMON.INTERACT'
7712       include 'COMMON.DERIV'
7713       include 'COMMON.CHAIN'
7714       include 'COMMON.NAMES'
7715       include 'COMMON.IOUNITS'
7716       include 'COMMON.FFIELD'
7717       include 'COMMON.TORCNSTR'
7718       include 'COMMON.CONTROL'
7719       logical lprn
7720       double precision thybt1(maxang_kcc)
7721 C Set lprn=.true. for debugging
7722       lprn=energy_dec
7723 c     lprn=.true.
7724 C      print *,"wchodze kcc"
7725       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7726       etheta=0.0D0
7727       do i=ithet_start,ithet_end
7728 c        print *,i,itype(i-1),itype(i),itype(i-2)
7729         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7730      &  .or.itype(i).eq.ntyp1) cycle
7731         iti=iabs(itortyp(itype(i-1)))
7732         sinthet=dsin(theta(i))
7733         costhet=dcos(theta(i))
7734         do j=1,nbend_kcc_Tb(iti)
7735           thybt1(j)=v1bend_chyb(j,iti)
7736         enddo
7737         sumth1thyb=v1bend_chyb(0,iti)+
7738      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7739         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7740      &    sumth1thyb
7741         ihelp=nbend_kcc_Tb(iti)-1
7742         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7743         etheta=etheta+sumth1thyb
7744 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7745         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7746       enddo
7747       return
7748       end
7749 c-------------------------------------------------------------------------------------
7750       subroutine etheta_constr(ethetacnstr)
7751
7752       implicit real*8 (a-h,o-z)
7753       include 'DIMENSIONS'
7754       include 'COMMON.VAR'
7755       include 'COMMON.GEO'
7756       include 'COMMON.LOCAL'
7757       include 'COMMON.TORSION'
7758       include 'COMMON.INTERACT'
7759       include 'COMMON.DERIV'
7760       include 'COMMON.CHAIN'
7761       include 'COMMON.NAMES'
7762       include 'COMMON.IOUNITS'
7763       include 'COMMON.FFIELD'
7764       include 'COMMON.TORCNSTR'
7765       include 'COMMON.CONTROL'
7766       ethetacnstr=0.0d0
7767 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7768       do i=ithetaconstr_start,ithetaconstr_end
7769         itheta=itheta_constr(i)
7770         thetiii=theta(itheta)
7771         difi=pinorm(thetiii-theta_constr0(i))
7772         if (difi.gt.theta_drange(i)) then
7773           difi=difi-theta_drange(i)
7774           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7775           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7776      &    +for_thet_constr(i)*difi**3
7777         else if (difi.lt.-drange(i)) then
7778           difi=difi+drange(i)
7779           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7780           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7781      &    +for_thet_constr(i)*difi**3
7782         else
7783           difi=0.0
7784         endif
7785        if (energy_dec) then
7786         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7787      &    i,itheta,rad2deg*thetiii,
7788      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7789      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7790      &    gloc(itheta+nphi-2,icg)
7791         endif
7792       enddo
7793       return
7794       end
7795 c------------------------------------------------------------------------------
7796       subroutine eback_sc_corr(esccor)
7797 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7798 c        conformational states; temporarily implemented as differences
7799 c        between UNRES torsional potentials (dependent on three types of
7800 c        residues) and the torsional potentials dependent on all 20 types
7801 c        of residues computed from AM1  energy surfaces of terminally-blocked
7802 c        amino-acid residues.
7803       implicit real*8 (a-h,o-z)
7804       include 'DIMENSIONS'
7805       include 'COMMON.VAR'
7806       include 'COMMON.GEO'
7807       include 'COMMON.LOCAL'
7808       include 'COMMON.TORSION'
7809       include 'COMMON.SCCOR'
7810       include 'COMMON.INTERACT'
7811       include 'COMMON.DERIV'
7812       include 'COMMON.CHAIN'
7813       include 'COMMON.NAMES'
7814       include 'COMMON.IOUNITS'
7815       include 'COMMON.FFIELD'
7816       include 'COMMON.CONTROL'
7817       logical lprn
7818 C Set lprn=.true. for debugging
7819       lprn=.false.
7820 c      lprn=.true.
7821 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7822       esccor=0.0D0
7823       do i=itau_start,itau_end
7824         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7825         esccor_ii=0.0D0
7826         isccori=isccortyp(itype(i-2))
7827         isccori1=isccortyp(itype(i-1))
7828 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7829         phii=phi(i)
7830         do intertyp=1,3 !intertyp
7831 cc Added 09 May 2012 (Adasko)
7832 cc  Intertyp means interaction type of backbone mainchain correlation:
7833 c   1 = SC...Ca...Ca...Ca
7834 c   2 = Ca...Ca...Ca...SC
7835 c   3 = SC...Ca...Ca...SCi
7836         gloci=0.0D0
7837         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7838      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7839      &      (itype(i-1).eq.ntyp1)))
7840      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7841      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7842      &     .or.(itype(i).eq.ntyp1)))
7843      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7844      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7845      &      (itype(i-3).eq.ntyp1)))) cycle
7846         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7847         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7848      & cycle
7849        do j=1,nterm_sccor(isccori,isccori1)
7850           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7851           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7852           cosphi=dcos(j*tauangle(intertyp,i))
7853           sinphi=dsin(j*tauangle(intertyp,i))
7854           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7855           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7856         enddo
7857 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7858         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7859         if (lprn)
7860      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7861      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7862      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7863      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7864         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7865        enddo !intertyp
7866       enddo
7867
7868       return
7869       end
7870 c----------------------------------------------------------------------------
7871       subroutine multibody(ecorr)
7872 C This subroutine calculates multi-body contributions to energy following
7873 C the idea of Skolnick et al. If side chains I and J make a contact and
7874 C at the same time side chains I+1 and J+1 make a contact, an extra
7875 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7876       implicit real*8 (a-h,o-z)
7877       include 'DIMENSIONS'
7878       include 'COMMON.IOUNITS'
7879       include 'COMMON.DERIV'
7880       include 'COMMON.INTERACT'
7881       include 'COMMON.CONTACTS'
7882       double precision gx(3),gx1(3)
7883       logical lprn
7884
7885 C Set lprn=.true. for debugging
7886       lprn=.false.
7887
7888       if (lprn) then
7889         write (iout,'(a)') 'Contact function values:'
7890         do i=nnt,nct-2
7891           write (iout,'(i2,20(1x,i2,f10.5))')
7892      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7893         enddo
7894       endif
7895       ecorr=0.0D0
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       do i=nnt,nct-2
7903
7904         DO ISHIFT = 3,4
7905
7906         i1=i+ishift
7907         num_conti=num_cont(i)
7908         num_conti1=num_cont(i1)
7909         do jj=1,num_conti
7910           j=jcont(jj,i)
7911           do kk=1,num_conti1
7912             j1=jcont(kk,i1)
7913             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7914 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7915 cd   &                   ' ishift=',ishift
7916 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7917 C The system gains extra energy.
7918               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7919             endif   ! j1==j+-ishift
7920           enddo     ! kk
7921         enddo       ! jj
7922
7923         ENDDO ! ISHIFT
7924
7925       enddo         ! i
7926       return
7927       end
7928 c------------------------------------------------------------------------------
7929       double precision function esccorr(i,j,k,l,jj,kk)
7930       implicit real*8 (a-h,o-z)
7931       include 'DIMENSIONS'
7932       include 'COMMON.IOUNITS'
7933       include 'COMMON.DERIV'
7934       include 'COMMON.INTERACT'
7935       include 'COMMON.CONTACTS'
7936       include 'COMMON.SHIELD'
7937       double precision gx(3),gx1(3)
7938       logical lprn
7939       lprn=.false.
7940       eij=facont(jj,i)
7941       ekl=facont(kk,k)
7942 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
7943 C Calculate the multi-body contribution to energy.
7944 C Calculate multi-body contributions to the gradient.
7945 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
7946 cd   & k,l,(gacont(m,kk,k),m=1,3)
7947       do m=1,3
7948         gx(m) =ekl*gacont(m,jj,i)
7949         gx1(m)=eij*gacont(m,kk,k)
7950         gradxorr(m,i)=gradxorr(m,i)-gx(m)
7951         gradxorr(m,j)=gradxorr(m,j)+gx(m)
7952         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
7953         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
7954       enddo
7955       do m=i,j-1
7956         do ll=1,3
7957           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
7958         enddo
7959       enddo
7960       do m=k,l-1
7961         do ll=1,3
7962           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
7963         enddo
7964       enddo
7965       esccorr=-eij*ekl
7966       return
7967       end
7968 c------------------------------------------------------------------------------
7969       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
7970 C This subroutine calculates multi-body contributions to hydrogen-bonding
7971       implicit real*8 (a-h,o-z)
7972       include 'DIMENSIONS'
7973       include 'COMMON.IOUNITS'
7974 #ifdef MPI
7975       include "mpif.h"
7976       parameter (max_cont=maxconts)
7977       parameter (max_dim=26)
7978       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
7979       double precision zapas(max_dim,maxconts,max_fg_procs),
7980      &  zapas_recv(max_dim,maxconts,max_fg_procs)
7981       common /przechowalnia/ zapas
7982       integer status(MPI_STATUS_SIZE),req(maxconts*2),
7983      &  status_array(MPI_STATUS_SIZE,maxconts*2)
7984 #endif
7985       include 'COMMON.SETUP'
7986       include 'COMMON.FFIELD'
7987       include 'COMMON.DERIV'
7988       include 'COMMON.INTERACT'
7989       include 'COMMON.CONTACTS'
7990       include 'COMMON.CONTROL'
7991       include 'COMMON.LOCAL'
7992       double precision gx(3),gx1(3),time00
7993       logical lprn,ldone
7994
7995 C Set lprn=.true. for debugging
7996       lprn=.false.
7997 #ifdef MPI
7998       n_corr=0
7999       n_corr1=0
8000       if (nfgtasks.le.1) goto 30
8001       if (lprn) then
8002         write (iout,'(a)') 'Contact function values before RECEIVE:'
8003         do i=nnt,nct-2
8004           write (iout,'(2i3,50(1x,i2,f5.2))')
8005      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8006      &    j=1,num_cont_hb(i))
8007         enddo
8008         call flush(iout)
8009       endif
8010       do i=1,ntask_cont_from
8011         ncont_recv(i)=0
8012       enddo
8013       do i=1,ntask_cont_to
8014         ncont_sent(i)=0
8015       enddo
8016 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8017 c     & ntask_cont_to
8018 C Make the list of contacts to send to send to other procesors
8019 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8020 c      call flush(iout)
8021       do i=iturn3_start,iturn3_end
8022 c        write (iout,*) "make contact list turn3",i," num_cont",
8023 c     &    num_cont_hb(i)
8024         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8025       enddo
8026       do i=iturn4_start,iturn4_end
8027 c        write (iout,*) "make contact list turn4",i," num_cont",
8028 c     &   num_cont_hb(i)
8029         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8030       enddo
8031       do ii=1,nat_sent
8032         i=iat_sent(ii)
8033 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8034 c     &    num_cont_hb(i)
8035         do j=1,num_cont_hb(i)
8036         do k=1,4
8037           jjc=jcont_hb(j,i)
8038           iproc=iint_sent_local(k,jjc,ii)
8039 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8040           if (iproc.gt.0) then
8041             ncont_sent(iproc)=ncont_sent(iproc)+1
8042             nn=ncont_sent(iproc)
8043             zapas(1,nn,iproc)=i
8044             zapas(2,nn,iproc)=jjc
8045             zapas(3,nn,iproc)=facont_hb(j,i)
8046             zapas(4,nn,iproc)=ees0p(j,i)
8047             zapas(5,nn,iproc)=ees0m(j,i)
8048             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8049             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8050             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8051             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8052             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8053             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8054             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8055             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8056             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8057             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8058             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8059             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8060             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8061             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8062             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8063             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8064             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8065             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8066             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8067             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8068             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8069           endif
8070         enddo
8071         enddo
8072       enddo
8073       if (lprn) then
8074       write (iout,*)
8075      &  "Numbers of contacts to be sent to other processors",
8076      &  (ncont_sent(i),i=1,ntask_cont_to)
8077       write (iout,*) "Contacts sent"
8078       do ii=1,ntask_cont_to
8079         nn=ncont_sent(ii)
8080         iproc=itask_cont_to(ii)
8081         write (iout,*) nn," contacts to processor",iproc,
8082      &   " of CONT_TO_COMM group"
8083         do i=1,nn
8084           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8085         enddo
8086       enddo
8087       call flush(iout)
8088       endif
8089       CorrelType=477
8090       CorrelID=fg_rank+1
8091       CorrelType1=478
8092       CorrelID1=nfgtasks+fg_rank+1
8093       ireq=0
8094 C Receive the numbers of needed contacts from other processors
8095       do ii=1,ntask_cont_from
8096         iproc=itask_cont_from(ii)
8097         ireq=ireq+1
8098         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8099      &    FG_COMM,req(ireq),IERR)
8100       enddo
8101 c      write (iout,*) "IRECV ended"
8102 c      call flush(iout)
8103 C Send the number of contacts needed by other processors
8104       do ii=1,ntask_cont_to
8105         iproc=itask_cont_to(ii)
8106         ireq=ireq+1
8107         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8108      &    FG_COMM,req(ireq),IERR)
8109       enddo
8110 c      write (iout,*) "ISEND ended"
8111 c      write (iout,*) "number of requests (nn)",ireq
8112 c      call flush(iout)
8113       if (ireq.gt.0)
8114      &  call MPI_Waitall(ireq,req,status_array,ierr)
8115 c      write (iout,*)
8116 c     &  "Numbers of contacts to be received from other processors",
8117 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8118 c      call flush(iout)
8119 C Receive contacts
8120       ireq=0
8121       do ii=1,ntask_cont_from
8122         iproc=itask_cont_from(ii)
8123         nn=ncont_recv(ii)
8124 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8125 c     &   " of CONT_TO_COMM group"
8126 c        call flush(iout)
8127         if (nn.gt.0) then
8128           ireq=ireq+1
8129           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8130      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8131 c          write (iout,*) "ireq,req",ireq,req(ireq)
8132         endif
8133       enddo
8134 C Send the contacts to processors that need them
8135       do ii=1,ntask_cont_to
8136         iproc=itask_cont_to(ii)
8137         nn=ncont_sent(ii)
8138 c        write (iout,*) nn," contacts to processor",iproc,
8139 c     &   " of CONT_TO_COMM group"
8140         if (nn.gt.0) then
8141           ireq=ireq+1
8142           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8143      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8144 c          write (iout,*) "ireq,req",ireq,req(ireq)
8145 c          do i=1,nn
8146 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8147 c          enddo
8148         endif
8149       enddo
8150 c      write (iout,*) "number of requests (contacts)",ireq
8151 c      write (iout,*) "req",(req(i),i=1,4)
8152 c      call flush(iout)
8153       if (ireq.gt.0)
8154      & call MPI_Waitall(ireq,req,status_array,ierr)
8155       do iii=1,ntask_cont_from
8156         iproc=itask_cont_from(iii)
8157         nn=ncont_recv(iii)
8158         if (lprn) then
8159         write (iout,*) "Received",nn," contacts from processor",iproc,
8160      &   " of CONT_FROM_COMM group"
8161         call flush(iout)
8162         do i=1,nn
8163           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8164         enddo
8165         call flush(iout)
8166         endif
8167         do i=1,nn
8168           ii=zapas_recv(1,i,iii)
8169 c Flag the received contacts to prevent double-counting
8170           jj=-zapas_recv(2,i,iii)
8171 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8172 c          call flush(iout)
8173           nnn=num_cont_hb(ii)+1
8174           num_cont_hb(ii)=nnn
8175           jcont_hb(nnn,ii)=jj
8176           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8177           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8178           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8179           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8180           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8181           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8182           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8183           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8184           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8185           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8186           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8187           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8188           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8189           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8190           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8191           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8192           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8193           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8194           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8195           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8196           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8197           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8198           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8199           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8200         enddo
8201       enddo
8202       if (lprn) then
8203         write (iout,'(a)') 'Contact function values after receive:'
8204         do i=nnt,nct-2
8205           write (iout,'(2i3,50(1x,i3,f5.2))')
8206      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8207      &    j=1,num_cont_hb(i))
8208         enddo
8209         call flush(iout)
8210       endif
8211    30 continue
8212 #endif
8213       if (lprn) then
8214         write (iout,'(a)') 'Contact function values:'
8215         do i=nnt,nct-2
8216           write (iout,'(2i3,50(1x,i3,f5.2))')
8217      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8218      &    j=1,num_cont_hb(i))
8219         enddo
8220         call flush(iout)
8221       endif
8222       ecorr=0.0D0
8223 C Remove the loop below after debugging !!!
8224       do i=nnt,nct
8225         do j=1,3
8226           gradcorr(j,i)=0.0D0
8227           gradxorr(j,i)=0.0D0
8228         enddo
8229       enddo
8230 C Calculate the local-electrostatic correlation terms
8231       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8232         i1=i+1
8233         num_conti=num_cont_hb(i)
8234         num_conti1=num_cont_hb(i+1)
8235         do jj=1,num_conti
8236           j=jcont_hb(jj,i)
8237           jp=iabs(j)
8238           do kk=1,num_conti1
8239             j1=jcont_hb(kk,i1)
8240             jp1=iabs(j1)
8241 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8242 c     &         ' jj=',jj,' kk=',kk
8243 c            call flush(iout)
8244             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8245      &          .or. j.lt.0 .and. j1.gt.0) .and.
8246      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8247 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8248 C The system gains extra energy.
8249               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8250               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8251      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8252               n_corr=n_corr+1
8253             else if (j1.eq.j) then
8254 C Contacts I-J and I-(J+1) occur simultaneously.
8255 C The system loses extra energy.
8256 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8257             endif
8258           enddo ! kk
8259           do kk=1,num_conti
8260             j1=jcont_hb(kk,i)
8261 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8262 c    &         ' jj=',jj,' kk=',kk
8263             if (j1.eq.j+1) then
8264 C Contacts I-J and (I+1)-J occur simultaneously.
8265 C The system loses extra energy.
8266 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8267             endif ! j1==j+1
8268           enddo ! kk
8269         enddo ! jj
8270       enddo ! i
8271       return
8272       end
8273 c------------------------------------------------------------------------------
8274       subroutine add_hb_contact(ii,jj,itask)
8275       implicit real*8 (a-h,o-z)
8276       include "DIMENSIONS"
8277       include "COMMON.IOUNITS"
8278       integer max_cont
8279       integer max_dim
8280       parameter (max_cont=maxconts)
8281       parameter (max_dim=26)
8282       include "COMMON.CONTACTS"
8283       double precision zapas(max_dim,maxconts,max_fg_procs),
8284      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8285       common /przechowalnia/ zapas
8286       integer i,j,ii,jj,iproc,itask(4),nn
8287 c      write (iout,*) "itask",itask
8288       do i=1,2
8289         iproc=itask(i)
8290         if (iproc.gt.0) then
8291           do j=1,num_cont_hb(ii)
8292             jjc=jcont_hb(j,ii)
8293 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8294             if (jjc.eq.jj) then
8295               ncont_sent(iproc)=ncont_sent(iproc)+1
8296               nn=ncont_sent(iproc)
8297               zapas(1,nn,iproc)=ii
8298               zapas(2,nn,iproc)=jjc
8299               zapas(3,nn,iproc)=facont_hb(j,ii)
8300               zapas(4,nn,iproc)=ees0p(j,ii)
8301               zapas(5,nn,iproc)=ees0m(j,ii)
8302               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8303               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8304               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8305               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8306               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8307               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8308               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8309               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8310               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8311               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8312               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8313               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8314               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8315               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8316               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8317               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8318               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8319               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8320               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8321               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8322               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8323               exit
8324             endif
8325           enddo
8326         endif
8327       enddo
8328       return
8329       end
8330 c------------------------------------------------------------------------------
8331       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8332      &  n_corr1)
8333 C This subroutine calculates multi-body contributions to hydrogen-bonding
8334       implicit real*8 (a-h,o-z)
8335       include 'DIMENSIONS'
8336       include 'COMMON.IOUNITS'
8337 #ifdef MPI
8338       include "mpif.h"
8339       parameter (max_cont=maxconts)
8340       parameter (max_dim=70)
8341       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8342       double precision zapas(max_dim,maxconts,max_fg_procs),
8343      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8344       common /przechowalnia/ zapas
8345       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8346      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8347 #endif
8348       include 'COMMON.SETUP'
8349       include 'COMMON.FFIELD'
8350       include 'COMMON.DERIV'
8351       include 'COMMON.LOCAL'
8352       include 'COMMON.INTERACT'
8353       include 'COMMON.CONTACTS'
8354       include 'COMMON.CHAIN'
8355       include 'COMMON.CONTROL'
8356       include 'COMMON.SHIELD'
8357       double precision gx(3),gx1(3)
8358       integer num_cont_hb_old(maxres)
8359       logical lprn,ldone
8360       double precision eello4,eello5,eelo6,eello_turn6
8361       external eello4,eello5,eello6,eello_turn6
8362 C Set lprn=.true. for debugging
8363       lprn=.false.
8364       eturn6=0.0d0
8365 #ifdef MPI
8366       do i=1,nres
8367         num_cont_hb_old(i)=num_cont_hb(i)
8368       enddo
8369       n_corr=0
8370       n_corr1=0
8371       if (nfgtasks.le.1) goto 30
8372       if (lprn) then
8373         write (iout,'(a)') 'Contact function values before RECEIVE:'
8374         do i=nnt,nct-2
8375           write (iout,'(2i3,50(1x,i2,f5.2))')
8376      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8377      &    j=1,num_cont_hb(i))
8378         enddo
8379       endif
8380       do i=1,ntask_cont_from
8381         ncont_recv(i)=0
8382       enddo
8383       do i=1,ntask_cont_to
8384         ncont_sent(i)=0
8385       enddo
8386 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8387 c     & ntask_cont_to
8388 C Make the list of contacts to send to send to other procesors
8389       do i=iturn3_start,iturn3_end
8390 c        write (iout,*) "make contact list turn3",i," num_cont",
8391 c     &    num_cont_hb(i)
8392         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8393       enddo
8394       do i=iturn4_start,iturn4_end
8395 c        write (iout,*) "make contact list turn4",i," num_cont",
8396 c     &   num_cont_hb(i)
8397         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8398       enddo
8399       do ii=1,nat_sent
8400         i=iat_sent(ii)
8401 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8402 c     &    num_cont_hb(i)
8403         do j=1,num_cont_hb(i)
8404         do k=1,4
8405           jjc=jcont_hb(j,i)
8406           iproc=iint_sent_local(k,jjc,ii)
8407 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8408           if (iproc.ne.0) then
8409             ncont_sent(iproc)=ncont_sent(iproc)+1
8410             nn=ncont_sent(iproc)
8411             zapas(1,nn,iproc)=i
8412             zapas(2,nn,iproc)=jjc
8413             zapas(3,nn,iproc)=d_cont(j,i)
8414             ind=3
8415             do kk=1,3
8416               ind=ind+1
8417               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8418             enddo
8419             do kk=1,2
8420               do ll=1,2
8421                 ind=ind+1
8422                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8423               enddo
8424             enddo
8425             do jj=1,5
8426               do kk=1,3
8427                 do ll=1,2
8428                   do mm=1,2
8429                     ind=ind+1
8430                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8431                   enddo
8432                 enddo
8433               enddo
8434             enddo
8435           endif
8436         enddo
8437         enddo
8438       enddo
8439       if (lprn) then
8440       write (iout,*)
8441      &  "Numbers of contacts to be sent to other processors",
8442      &  (ncont_sent(i),i=1,ntask_cont_to)
8443       write (iout,*) "Contacts sent"
8444       do ii=1,ntask_cont_to
8445         nn=ncont_sent(ii)
8446         iproc=itask_cont_to(ii)
8447         write (iout,*) nn," contacts to processor",iproc,
8448      &   " of CONT_TO_COMM group"
8449         do i=1,nn
8450           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8451         enddo
8452       enddo
8453       call flush(iout)
8454       endif
8455       CorrelType=477
8456       CorrelID=fg_rank+1
8457       CorrelType1=478
8458       CorrelID1=nfgtasks+fg_rank+1
8459       ireq=0
8460 C Receive the numbers of needed contacts from other processors
8461       do ii=1,ntask_cont_from
8462         iproc=itask_cont_from(ii)
8463         ireq=ireq+1
8464         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8465      &    FG_COMM,req(ireq),IERR)
8466       enddo
8467 c      write (iout,*) "IRECV ended"
8468 c      call flush(iout)
8469 C Send the number of contacts needed by other processors
8470       do ii=1,ntask_cont_to
8471         iproc=itask_cont_to(ii)
8472         ireq=ireq+1
8473         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8474      &    FG_COMM,req(ireq),IERR)
8475       enddo
8476 c      write (iout,*) "ISEND ended"
8477 c      write (iout,*) "number of requests (nn)",ireq
8478 c      call flush(iout)
8479       if (ireq.gt.0)
8480      &  call MPI_Waitall(ireq,req,status_array,ierr)
8481 c      write (iout,*)
8482 c     &  "Numbers of contacts to be received from other processors",
8483 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8484 c      call flush(iout)
8485 C Receive contacts
8486       ireq=0
8487       do ii=1,ntask_cont_from
8488         iproc=itask_cont_from(ii)
8489         nn=ncont_recv(ii)
8490 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8491 c     &   " of CONT_TO_COMM group"
8492 c        call flush(iout)
8493         if (nn.gt.0) then
8494           ireq=ireq+1
8495           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8496      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8497 c          write (iout,*) "ireq,req",ireq,req(ireq)
8498         endif
8499       enddo
8500 C Send the contacts to processors that need them
8501       do ii=1,ntask_cont_to
8502         iproc=itask_cont_to(ii)
8503         nn=ncont_sent(ii)
8504 c        write (iout,*) nn," contacts to processor",iproc,
8505 c     &   " of CONT_TO_COMM group"
8506         if (nn.gt.0) then
8507           ireq=ireq+1
8508           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8509      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8510 c          write (iout,*) "ireq,req",ireq,req(ireq)
8511 c          do i=1,nn
8512 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8513 c          enddo
8514         endif
8515       enddo
8516 c      write (iout,*) "number of requests (contacts)",ireq
8517 c      write (iout,*) "req",(req(i),i=1,4)
8518 c      call flush(iout)
8519       if (ireq.gt.0)
8520      & call MPI_Waitall(ireq,req,status_array,ierr)
8521       do iii=1,ntask_cont_from
8522         iproc=itask_cont_from(iii)
8523         nn=ncont_recv(iii)
8524         if (lprn) then
8525         write (iout,*) "Received",nn," contacts from processor",iproc,
8526      &   " of CONT_FROM_COMM group"
8527         call flush(iout)
8528         do i=1,nn
8529           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8530         enddo
8531         call flush(iout)
8532         endif
8533         do i=1,nn
8534           ii=zapas_recv(1,i,iii)
8535 c Flag the received contacts to prevent double-counting
8536           jj=-zapas_recv(2,i,iii)
8537 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8538 c          call flush(iout)
8539           nnn=num_cont_hb(ii)+1
8540           num_cont_hb(ii)=nnn
8541           jcont_hb(nnn,ii)=jj
8542           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8543           ind=3
8544           do kk=1,3
8545             ind=ind+1
8546             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8547           enddo
8548           do kk=1,2
8549             do ll=1,2
8550               ind=ind+1
8551               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8552             enddo
8553           enddo
8554           do jj=1,5
8555             do kk=1,3
8556               do ll=1,2
8557                 do mm=1,2
8558                   ind=ind+1
8559                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8560                 enddo
8561               enddo
8562             enddo
8563           enddo
8564         enddo
8565       enddo
8566       if (lprn) then
8567         write (iout,'(a)') 'Contact function values after receive:'
8568         do i=nnt,nct-2
8569           write (iout,'(2i3,50(1x,i3,5f6.3))')
8570      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8571      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8572         enddo
8573         call flush(iout)
8574       endif
8575    30 continue
8576 #endif
8577       if (lprn) then
8578         write (iout,'(a)') 'Contact function values:'
8579         do i=nnt,nct-2
8580           write (iout,'(2i3,50(1x,i2,5f6.3))')
8581      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8582      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8583         enddo
8584       endif
8585       ecorr=0.0D0
8586       ecorr5=0.0d0
8587       ecorr6=0.0d0
8588 C Remove the loop below after debugging !!!
8589       do i=nnt,nct
8590         do j=1,3
8591           gradcorr(j,i)=0.0D0
8592           gradxorr(j,i)=0.0D0
8593         enddo
8594       enddo
8595 C Calculate the dipole-dipole interaction energies
8596       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8597       do i=iatel_s,iatel_e+1
8598         num_conti=num_cont_hb(i)
8599         do jj=1,num_conti
8600           j=jcont_hb(jj,i)
8601 #ifdef MOMENT
8602           call dipole(i,j,jj)
8603 #endif
8604         enddo
8605       enddo
8606       endif
8607 C Calculate the local-electrostatic correlation terms
8608 c                write (iout,*) "gradcorr5 in eello5 before loop"
8609 c                do iii=1,nres
8610 c                  write (iout,'(i5,3f10.5)')
8611 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8612 c                enddo
8613       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8614 c        write (iout,*) "corr loop i",i
8615         i1=i+1
8616         num_conti=num_cont_hb(i)
8617         num_conti1=num_cont_hb(i+1)
8618         do jj=1,num_conti
8619           j=jcont_hb(jj,i)
8620           jp=iabs(j)
8621           do kk=1,num_conti1
8622             j1=jcont_hb(kk,i1)
8623             jp1=iabs(j1)
8624 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8625 c     &         ' jj=',jj,' kk=',kk
8626 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8627             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8628      &          .or. j.lt.0 .and. j1.gt.0) .and.
8629      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8630 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8631 C The system gains extra energy.
8632               n_corr=n_corr+1
8633               sqd1=dsqrt(d_cont(jj,i))
8634               sqd2=dsqrt(d_cont(kk,i1))
8635               sred_geom = sqd1*sqd2
8636               IF (sred_geom.lt.cutoff_corr) THEN
8637                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8638      &            ekont,fprimcont)
8639 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8640 cd     &         ' jj=',jj,' kk=',kk
8641                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8642                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8643                 do l=1,3
8644                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8645                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8646                 enddo
8647                 n_corr1=n_corr1+1
8648 cd               write (iout,*) 'sred_geom=',sred_geom,
8649 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8650 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8651 cd               write (iout,*) "g_contij",g_contij
8652 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8653 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8654                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8655                 if (wcorr4.gt.0.0d0)
8656      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8657 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8658                   if (energy_dec.and.wcorr4.gt.0.0d0)
8659      1                 write (iout,'(a6,4i5,0pf7.3)')
8660      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8661 c                write (iout,*) "gradcorr5 before eello5"
8662 c                do iii=1,nres
8663 c                  write (iout,'(i5,3f10.5)')
8664 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8665 c                enddo
8666                 if (wcorr5.gt.0.0d0)
8667      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8668 c                write (iout,*) "gradcorr5 after eello5"
8669 c                do iii=1,nres
8670 c                  write (iout,'(i5,3f10.5)')
8671 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8672 c                enddo
8673                   if (energy_dec.and.wcorr5.gt.0.0d0)
8674      1                 write (iout,'(a6,4i5,0pf7.3)')
8675      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8676 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8677 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8678                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8679      &               .or. wturn6.eq.0.0d0))then
8680 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8681                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8682                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8683      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8684 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8685 cd     &            'ecorr6=',ecorr6
8686 cd                write (iout,'(4e15.5)') sred_geom,
8687 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8688 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8689 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8690                 else if (wturn6.gt.0.0d0
8691      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8692 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8693                   eturn6=eturn6+eello_turn6(i,jj,kk)
8694                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8695      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8696 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8697                 endif
8698               ENDIF
8699 1111          continue
8700             endif
8701           enddo ! kk
8702         enddo ! jj
8703       enddo ! i
8704       do i=1,nres
8705         num_cont_hb(i)=num_cont_hb_old(i)
8706       enddo
8707 c                write (iout,*) "gradcorr5 in eello5"
8708 c                do iii=1,nres
8709 c                  write (iout,'(i5,3f10.5)')
8710 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8711 c                enddo
8712       return
8713       end
8714 c------------------------------------------------------------------------------
8715       subroutine add_hb_contact_eello(ii,jj,itask)
8716       implicit real*8 (a-h,o-z)
8717       include "DIMENSIONS"
8718       include "COMMON.IOUNITS"
8719       integer max_cont
8720       integer max_dim
8721       parameter (max_cont=maxconts)
8722       parameter (max_dim=70)
8723       include "COMMON.CONTACTS"
8724       double precision zapas(max_dim,maxconts,max_fg_procs),
8725      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8726       common /przechowalnia/ zapas
8727       integer i,j,ii,jj,iproc,itask(4),nn
8728 c      write (iout,*) "itask",itask
8729       do i=1,2
8730         iproc=itask(i)
8731         if (iproc.gt.0) then
8732           do j=1,num_cont_hb(ii)
8733             jjc=jcont_hb(j,ii)
8734 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8735             if (jjc.eq.jj) then
8736               ncont_sent(iproc)=ncont_sent(iproc)+1
8737               nn=ncont_sent(iproc)
8738               zapas(1,nn,iproc)=ii
8739               zapas(2,nn,iproc)=jjc
8740               zapas(3,nn,iproc)=d_cont(j,ii)
8741               ind=3
8742               do kk=1,3
8743                 ind=ind+1
8744                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8745               enddo
8746               do kk=1,2
8747                 do ll=1,2
8748                   ind=ind+1
8749                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8750                 enddo
8751               enddo
8752               do jj=1,5
8753                 do kk=1,3
8754                   do ll=1,2
8755                     do mm=1,2
8756                       ind=ind+1
8757                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8758                     enddo
8759                   enddo
8760                 enddo
8761               enddo
8762               exit
8763             endif
8764           enddo
8765         endif
8766       enddo
8767       return
8768       end
8769 c------------------------------------------------------------------------------
8770       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8771       implicit real*8 (a-h,o-z)
8772       include 'DIMENSIONS'
8773       include 'COMMON.IOUNITS'
8774       include 'COMMON.DERIV'
8775       include 'COMMON.INTERACT'
8776       include 'COMMON.CONTACTS'
8777       include 'COMMON.SHIELD'
8778       include 'COMMON.CONTROL'
8779       double precision gx(3),gx1(3)
8780       logical lprn
8781       lprn=.false.
8782 C      print *,"wchodze",fac_shield(i),shield_mode
8783       eij=facont_hb(jj,i)
8784       ekl=facont_hb(kk,k)
8785       ees0pij=ees0p(jj,i)
8786       ees0pkl=ees0p(kk,k)
8787       ees0mij=ees0m(jj,i)
8788       ees0mkl=ees0m(kk,k)
8789       ekont=eij*ekl
8790       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8791 C*
8792 C     & fac_shield(i)**2*fac_shield(j)**2
8793 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8794 C Following 4 lines for diagnostics.
8795 cd    ees0pkl=0.0D0
8796 cd    ees0pij=1.0D0
8797 cd    ees0mkl=0.0D0
8798 cd    ees0mij=1.0D0
8799 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8800 c     & 'Contacts ',i,j,
8801 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8802 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8803 c     & 'gradcorr_long'
8804 C Calculate the multi-body contribution to energy.
8805 C      ecorr=ecorr+ekont*ees
8806 C Calculate multi-body contributions to the gradient.
8807       coeffpees0pij=coeffp*ees0pij
8808       coeffmees0mij=coeffm*ees0mij
8809       coeffpees0pkl=coeffp*ees0pkl
8810       coeffmees0mkl=coeffm*ees0mkl
8811       do ll=1,3
8812 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8813         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8814      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8815      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8816         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8817      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8818      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8819 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8820         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8821      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8822      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8823         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8824      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8825      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8826         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8827      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8828      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8829         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8830         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8831         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8832      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8833      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8834         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8835         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8836 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8837       enddo
8838 c      write (iout,*)
8839 cgrad      do m=i+1,j-1
8840 cgrad        do ll=1,3
8841 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8842 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8843 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8844 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8845 cgrad        enddo
8846 cgrad      enddo
8847 cgrad      do m=k+1,l-1
8848 cgrad        do ll=1,3
8849 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8850 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8851 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8852 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8853 cgrad        enddo
8854 cgrad      enddo
8855 c      write (iout,*) "ehbcorr",ekont*ees
8856 C      print *,ekont,ees,i,k
8857       ehbcorr=ekont*ees
8858 C now gradient over shielding
8859 C      return
8860       if (shield_mode.gt.0) then
8861        j=ees0plist(jj,i)
8862        l=ees0plist(kk,k)
8863 C        print *,i,j,fac_shield(i),fac_shield(j),
8864 C     &fac_shield(k),fac_shield(l)
8865         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8866      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8867           do ilist=1,ishield_list(i)
8868            iresshield=shield_list(ilist,i)
8869            do m=1,3
8870            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8871 C     &      *2.0
8872            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8873      &              rlocshield
8874      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8875             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8876      &+rlocshield
8877            enddo
8878           enddo
8879           do ilist=1,ishield_list(j)
8880            iresshield=shield_list(ilist,j)
8881            do m=1,3
8882            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8883 C     &     *2.0
8884            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8885      &              rlocshield
8886      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8887            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8888      &     +rlocshield
8889            enddo
8890           enddo
8891
8892           do ilist=1,ishield_list(k)
8893            iresshield=shield_list(ilist,k)
8894            do m=1,3
8895            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8896 C     &     *2.0
8897            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8898      &              rlocshield
8899      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8900            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8901      &     +rlocshield
8902            enddo
8903           enddo
8904           do ilist=1,ishield_list(l)
8905            iresshield=shield_list(ilist,l)
8906            do m=1,3
8907            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8908 C     &     *2.0
8909            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8910      &              rlocshield
8911      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8912            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8913      &     +rlocshield
8914            enddo
8915           enddo
8916 C          print *,gshieldx(m,iresshield)
8917           do m=1,3
8918             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8919      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8920             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8921      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8922             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8923      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8924             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8925      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8926
8927             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8928      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8929             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8930      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8931             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8932      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8933             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8934      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8935
8936            enddo
8937       endif
8938       endif
8939       return
8940       end
8941 #ifdef MOMENT
8942 C---------------------------------------------------------------------------
8943       subroutine dipole(i,j,jj)
8944       implicit real*8 (a-h,o-z)
8945       include 'DIMENSIONS'
8946       include 'COMMON.IOUNITS'
8947       include 'COMMON.CHAIN'
8948       include 'COMMON.FFIELD'
8949       include 'COMMON.DERIV'
8950       include 'COMMON.INTERACT'
8951       include 'COMMON.CONTACTS'
8952       include 'COMMON.TORSION'
8953       include 'COMMON.VAR'
8954       include 'COMMON.GEO'
8955       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
8956      &  auxmat(2,2)
8957       iti1 = itortyp(itype(i+1))
8958       if (j.lt.nres-1) then
8959         itj1 = itype2loc(itype(j+1))
8960       else
8961         itj1=nloctyp
8962       endif
8963       do iii=1,2
8964         dipi(iii,1)=Ub2(iii,i)
8965         dipderi(iii)=Ub2der(iii,i)
8966         dipi(iii,2)=b1(iii,i+1)
8967         dipj(iii,1)=Ub2(iii,j)
8968         dipderj(iii)=Ub2der(iii,j)
8969         dipj(iii,2)=b1(iii,j+1)
8970       enddo
8971       kkk=0
8972       do iii=1,2
8973         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
8974         do jjj=1,2
8975           kkk=kkk+1
8976           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8977         enddo
8978       enddo
8979       do kkk=1,5
8980         do lll=1,3
8981           mmm=0
8982           do iii=1,2
8983             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
8984      &        auxvec(1))
8985             do jjj=1,2
8986               mmm=mmm+1
8987               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
8988             enddo
8989           enddo
8990         enddo
8991       enddo
8992       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
8993       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
8994       do iii=1,2
8995         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
8996       enddo
8997       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
8998       do iii=1,2
8999         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9000       enddo
9001       return
9002       end
9003 #endif
9004 C---------------------------------------------------------------------------
9005       subroutine calc_eello(i,j,k,l,jj,kk)
9006 C
9007 C This subroutine computes matrices and vectors needed to calculate
9008 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9009 C
9010       implicit real*8 (a-h,o-z)
9011       include 'DIMENSIONS'
9012       include 'COMMON.IOUNITS'
9013       include 'COMMON.CHAIN'
9014       include 'COMMON.DERIV'
9015       include 'COMMON.INTERACT'
9016       include 'COMMON.CONTACTS'
9017       include 'COMMON.TORSION'
9018       include 'COMMON.VAR'
9019       include 'COMMON.GEO'
9020       include 'COMMON.FFIELD'
9021       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9022      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9023       logical lprn
9024       common /kutas/ lprn
9025 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9026 cd     & ' jj=',jj,' kk=',kk
9027 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9028 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9029 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9030       do iii=1,2
9031         do jjj=1,2
9032           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9033           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9034         enddo
9035       enddo
9036       call transpose2(aa1(1,1),aa1t(1,1))
9037       call transpose2(aa2(1,1),aa2t(1,1))
9038       do kkk=1,5
9039         do lll=1,3
9040           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9041      &      aa1tder(1,1,lll,kkk))
9042           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9043      &      aa2tder(1,1,lll,kkk))
9044         enddo
9045       enddo
9046       if (l.eq.j+1) then
9047 C parallel orientation of the two CA-CA-CA frames.
9048         if (i.gt.1) then
9049           iti=itype2loc(itype(i))
9050         else
9051           iti=nloctyp
9052         endif
9053         itk1=itype2loc(itype(k+1))
9054         itj=itype2loc(itype(j))
9055         if (l.lt.nres-1) then
9056           itl1=itype2loc(itype(l+1))
9057         else
9058           itl1=nloctyp
9059         endif
9060 C A1 kernel(j+1) A2T
9061 cd        do iii=1,2
9062 cd          write (iout,'(3f10.5,5x,3f10.5)')
9063 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9064 cd        enddo
9065         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9066      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9067      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9068 C Following matrices are needed only for 6-th order cumulants
9069         IF (wcorr6.gt.0.0d0) THEN
9070         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9071      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9072      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9073         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9074      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9075      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9076      &   ADtEAderx(1,1,1,1,1,1))
9077         lprn=.false.
9078         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9079      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9080      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9081      &   ADtEA1derx(1,1,1,1,1,1))
9082         ENDIF
9083 C End 6-th order cumulants
9084 cd        lprn=.false.
9085 cd        if (lprn) then
9086 cd        write (2,*) 'In calc_eello6'
9087 cd        do iii=1,2
9088 cd          write (2,*) 'iii=',iii
9089 cd          do kkk=1,5
9090 cd            write (2,*) 'kkk=',kkk
9091 cd            do jjj=1,2
9092 cd              write (2,'(3(2f10.5),5x)')
9093 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9094 cd            enddo
9095 cd          enddo
9096 cd        enddo
9097 cd        endif
9098         call transpose2(EUgder(1,1,k),auxmat(1,1))
9099         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9100         call transpose2(EUg(1,1,k),auxmat(1,1))
9101         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9102         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9103 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9104 c    in theta; to be sriten later.
9105 c#ifdef NEWCORR
9106 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9107 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9108 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9109 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9110 c#endif
9111         do iii=1,2
9112           do kkk=1,5
9113             do lll=1,3
9114               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9115      &          EAEAderx(1,1,lll,kkk,iii,1))
9116             enddo
9117           enddo
9118         enddo
9119 C A1T kernel(i+1) A2
9120         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9121      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9122      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9123 C Following matrices are needed only for 6-th order cumulants
9124         IF (wcorr6.gt.0.0d0) THEN
9125         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9126      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9127      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9128         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9129      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9130      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9131      &   ADtEAderx(1,1,1,1,1,2))
9132         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9133      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9134      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9135      &   ADtEA1derx(1,1,1,1,1,2))
9136         ENDIF
9137 C End 6-th order cumulants
9138         call transpose2(EUgder(1,1,l),auxmat(1,1))
9139         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9140         call transpose2(EUg(1,1,l),auxmat(1,1))
9141         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9142         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9143         do iii=1,2
9144           do kkk=1,5
9145             do lll=1,3
9146               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9147      &          EAEAderx(1,1,lll,kkk,iii,2))
9148             enddo
9149           enddo
9150         enddo
9151 C AEAb1 and AEAb2
9152 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9153 C They are needed only when the fifth- or the sixth-order cumulants are
9154 C indluded.
9155         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9156         call transpose2(AEA(1,1,1),auxmat(1,1))
9157         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9158         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9159         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9160         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9161         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9162         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9163         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9164         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9165         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9166         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9167         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9168         call transpose2(AEA(1,1,2),auxmat(1,1))
9169         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9170         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9171         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9172         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9173         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9174         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9175         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9176         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9177         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9178         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9179         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9180 C Calculate the Cartesian derivatives of the vectors.
9181         do iii=1,2
9182           do kkk=1,5
9183             do lll=1,3
9184               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9185               call matvec2(auxmat(1,1),b1(1,i),
9186      &          AEAb1derx(1,lll,kkk,iii,1,1))
9187               call matvec2(auxmat(1,1),Ub2(1,i),
9188      &          AEAb2derx(1,lll,kkk,iii,1,1))
9189               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9190      &          AEAb1derx(1,lll,kkk,iii,2,1))
9191               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9192      &          AEAb2derx(1,lll,kkk,iii,2,1))
9193               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9194               call matvec2(auxmat(1,1),b1(1,j),
9195      &          AEAb1derx(1,lll,kkk,iii,1,2))
9196               call matvec2(auxmat(1,1),Ub2(1,j),
9197      &          AEAb2derx(1,lll,kkk,iii,1,2))
9198               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9199      &          AEAb1derx(1,lll,kkk,iii,2,2))
9200               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9201      &          AEAb2derx(1,lll,kkk,iii,2,2))
9202             enddo
9203           enddo
9204         enddo
9205         ENDIF
9206 C End vectors
9207       else
9208 C Antiparallel orientation of the two CA-CA-CA frames.
9209         if (i.gt.1) then
9210           iti=itype2loc(itype(i))
9211         else
9212           iti=nloctyp
9213         endif
9214         itk1=itype2loc(itype(k+1))
9215         itl=itype2loc(itype(l))
9216         itj=itype2loc(itype(j))
9217         if (j.lt.nres-1) then
9218           itj1=itype2loc(itype(j+1))
9219         else
9220           itj1=nloctyp
9221         endif
9222 C A2 kernel(j-1)T A1T
9223         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9224      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9225      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9226 C Following matrices are needed only for 6-th order cumulants
9227         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9228      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9229         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9230      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9231      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9232         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9233      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9234      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9235      &   ADtEAderx(1,1,1,1,1,1))
9236         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9237      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9238      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9239      &   ADtEA1derx(1,1,1,1,1,1))
9240         ENDIF
9241 C End 6-th order cumulants
9242         call transpose2(EUgder(1,1,k),auxmat(1,1))
9243         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9244         call transpose2(EUg(1,1,k),auxmat(1,1))
9245         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9246         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9247         do iii=1,2
9248           do kkk=1,5
9249             do lll=1,3
9250               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9251      &          EAEAderx(1,1,lll,kkk,iii,1))
9252             enddo
9253           enddo
9254         enddo
9255 C A2T kernel(i+1)T A1
9256         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9257      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9258      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9259 C Following matrices are needed only for 6-th order cumulants
9260         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9261      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9262         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9263      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9264      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9265         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9266      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9267      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9268      &   ADtEAderx(1,1,1,1,1,2))
9269         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9270      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9271      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9272      &   ADtEA1derx(1,1,1,1,1,2))
9273         ENDIF
9274 C End 6-th order cumulants
9275         call transpose2(EUgder(1,1,j),auxmat(1,1))
9276         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9277         call transpose2(EUg(1,1,j),auxmat(1,1))
9278         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9279         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9280         do iii=1,2
9281           do kkk=1,5
9282             do lll=1,3
9283               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9284      &          EAEAderx(1,1,lll,kkk,iii,2))
9285             enddo
9286           enddo
9287         enddo
9288 C AEAb1 and AEAb2
9289 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9290 C They are needed only when the fifth- or the sixth-order cumulants are
9291 C indluded.
9292         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9293      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9294         call transpose2(AEA(1,1,1),auxmat(1,1))
9295         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9296         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9297         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9298         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9299         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9300         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9301         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9302         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9303         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9304         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9305         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9306         call transpose2(AEA(1,1,2),auxmat(1,1))
9307         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9308         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9309         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9310         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9311         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9312         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9313         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9314         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9315         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9316         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9317         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9318 C Calculate the Cartesian derivatives of the vectors.
9319         do iii=1,2
9320           do kkk=1,5
9321             do lll=1,3
9322               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9323               call matvec2(auxmat(1,1),b1(1,i),
9324      &          AEAb1derx(1,lll,kkk,iii,1,1))
9325               call matvec2(auxmat(1,1),Ub2(1,i),
9326      &          AEAb2derx(1,lll,kkk,iii,1,1))
9327               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9328      &          AEAb1derx(1,lll,kkk,iii,2,1))
9329               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9330      &          AEAb2derx(1,lll,kkk,iii,2,1))
9331               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9332               call matvec2(auxmat(1,1),b1(1,l),
9333      &          AEAb1derx(1,lll,kkk,iii,1,2))
9334               call matvec2(auxmat(1,1),Ub2(1,l),
9335      &          AEAb2derx(1,lll,kkk,iii,1,2))
9336               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9337      &          AEAb1derx(1,lll,kkk,iii,2,2))
9338               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9339      &          AEAb2derx(1,lll,kkk,iii,2,2))
9340             enddo
9341           enddo
9342         enddo
9343         ENDIF
9344 C End vectors
9345       endif
9346       return
9347       end
9348 C---------------------------------------------------------------------------
9349       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9350      &  KK,KKderg,AKA,AKAderg,AKAderx)
9351       implicit none
9352       integer nderg
9353       logical transp
9354       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9355      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9356      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9357       integer iii,kkk,lll
9358       integer jjj,mmm
9359       logical lprn
9360       common /kutas/ lprn
9361       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9362       do iii=1,nderg
9363         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9364      &    AKAderg(1,1,iii))
9365       enddo
9366 cd      if (lprn) write (2,*) 'In kernel'
9367       do kkk=1,5
9368 cd        if (lprn) write (2,*) 'kkk=',kkk
9369         do lll=1,3
9370           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9371      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9372 cd          if (lprn) then
9373 cd            write (2,*) 'lll=',lll
9374 cd            write (2,*) 'iii=1'
9375 cd            do jjj=1,2
9376 cd              write (2,'(3(2f10.5),5x)')
9377 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9378 cd            enddo
9379 cd          endif
9380           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9381      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9382 cd          if (lprn) then
9383 cd            write (2,*) 'lll=',lll
9384 cd            write (2,*) 'iii=2'
9385 cd            do jjj=1,2
9386 cd              write (2,'(3(2f10.5),5x)')
9387 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9388 cd            enddo
9389 cd          endif
9390         enddo
9391       enddo
9392       return
9393       end
9394 C---------------------------------------------------------------------------
9395       double precision function eello4(i,j,k,l,jj,kk)
9396       implicit real*8 (a-h,o-z)
9397       include 'DIMENSIONS'
9398       include 'COMMON.IOUNITS'
9399       include 'COMMON.CHAIN'
9400       include 'COMMON.DERIV'
9401       include 'COMMON.INTERACT'
9402       include 'COMMON.CONTACTS'
9403       include 'COMMON.TORSION'
9404       include 'COMMON.VAR'
9405       include 'COMMON.GEO'
9406       double precision pizda(2,2),ggg1(3),ggg2(3)
9407 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9408 cd        eello4=0.0d0
9409 cd        return
9410 cd      endif
9411 cd      print *,'eello4:',i,j,k,l,jj,kk
9412 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9413 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9414 cold      eij=facont_hb(jj,i)
9415 cold      ekl=facont_hb(kk,k)
9416 cold      ekont=eij*ekl
9417       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9418 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9419       gcorr_loc(k-1)=gcorr_loc(k-1)
9420      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9421       if (l.eq.j+1) then
9422         gcorr_loc(l-1)=gcorr_loc(l-1)
9423      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9424 C Al 4/16/16: Derivatives in theta, to be added later.
9425 c#ifdef NEWCORR
9426 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
9427 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9428 c#endif
9429       else
9430         gcorr_loc(j-1)=gcorr_loc(j-1)
9431      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9432 c#ifdef NEWCORR
9433 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
9434 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9435 c#endif
9436       endif
9437       do iii=1,2
9438         do kkk=1,5
9439           do lll=1,3
9440             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9441      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9442 cd            derx(lll,kkk,iii)=0.0d0
9443           enddo
9444         enddo
9445       enddo
9446 cd      gcorr_loc(l-1)=0.0d0
9447 cd      gcorr_loc(j-1)=0.0d0
9448 cd      gcorr_loc(k-1)=0.0d0
9449 cd      eel4=1.0d0
9450 cd      write (iout,*)'Contacts have occurred for peptide groups',
9451 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9452 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9453       if (j.lt.nres-1) then
9454         j1=j+1
9455         j2=j-1
9456       else
9457         j1=j-1
9458         j2=j-2
9459       endif
9460       if (l.lt.nres-1) then
9461         l1=l+1
9462         l2=l-1
9463       else
9464         l1=l-1
9465         l2=l-2
9466       endif
9467       do ll=1,3
9468 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9469 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9470         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9471         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9472 cgrad        ghalf=0.5d0*ggg1(ll)
9473         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9474         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9475         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9476         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9477         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9478         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9479 cgrad        ghalf=0.5d0*ggg2(ll)
9480         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9481         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9482         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9483         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9484         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9485         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9486       enddo
9487 cgrad      do m=i+1,j-1
9488 cgrad        do ll=1,3
9489 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9490 cgrad        enddo
9491 cgrad      enddo
9492 cgrad      do m=k+1,l-1
9493 cgrad        do ll=1,3
9494 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9495 cgrad        enddo
9496 cgrad      enddo
9497 cgrad      do m=i+2,j2
9498 cgrad        do ll=1,3
9499 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9500 cgrad        enddo
9501 cgrad      enddo
9502 cgrad      do m=k+2,l2
9503 cgrad        do ll=1,3
9504 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9505 cgrad        enddo
9506 cgrad      enddo
9507 cd      do iii=1,nres-3
9508 cd        write (2,*) iii,gcorr_loc(iii)
9509 cd      enddo
9510       eello4=ekont*eel4
9511 cd      write (2,*) 'ekont',ekont
9512 cd      write (iout,*) 'eello4',ekont*eel4
9513       return
9514       end
9515 C---------------------------------------------------------------------------
9516       double precision function eello5(i,j,k,l,jj,kk)
9517       implicit real*8 (a-h,o-z)
9518       include 'DIMENSIONS'
9519       include 'COMMON.IOUNITS'
9520       include 'COMMON.CHAIN'
9521       include 'COMMON.DERIV'
9522       include 'COMMON.INTERACT'
9523       include 'COMMON.CONTACTS'
9524       include 'COMMON.TORSION'
9525       include 'COMMON.VAR'
9526       include 'COMMON.GEO'
9527       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9528       double precision ggg1(3),ggg2(3)
9529 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9530 C                                                                              C
9531 C                            Parallel chains                                   C
9532 C                                                                              C
9533 C          o             o                   o             o                   C
9534 C         /l\           / \             \   / \           / \   /              C
9535 C        /   \         /   \             \ /   \         /   \ /               C
9536 C       j| o |l1       | o |              o| o |         | o |o                C
9537 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9538 C      \i/   \         /   \ /             /   \         /   \                 C
9539 C       o    k1             o                                                  C
9540 C         (I)          (II)                (III)          (IV)                 C
9541 C                                                                              C
9542 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9543 C                                                                              C
9544 C                            Antiparallel chains                               C
9545 C                                                                              C
9546 C          o             o                   o             o                   C
9547 C         /j\           / \             \   / \           / \   /              C
9548 C        /   \         /   \             \ /   \         /   \ /               C
9549 C      j1| o |l        | o |              o| o |         | o |o                C
9550 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9551 C      \i/   \         /   \ /             /   \         /   \                 C
9552 C       o     k1            o                                                  C
9553 C         (I)          (II)                (III)          (IV)                 C
9554 C                                                                              C
9555 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9556 C                                                                              C
9557 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9558 C                                                                              C
9559 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9560 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9561 cd        eello5=0.0d0
9562 cd        return
9563 cd      endif
9564 cd      write (iout,*)
9565 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9566 cd     &   ' and',k,l
9567       itk=itype2loc(itype(k))
9568       itl=itype2loc(itype(l))
9569       itj=itype2loc(itype(j))
9570       eello5_1=0.0d0
9571       eello5_2=0.0d0
9572       eello5_3=0.0d0
9573       eello5_4=0.0d0
9574 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9575 cd     &   eel5_3_num,eel5_4_num)
9576       do iii=1,2
9577         do kkk=1,5
9578           do lll=1,3
9579             derx(lll,kkk,iii)=0.0d0
9580           enddo
9581         enddo
9582       enddo
9583 cd      eij=facont_hb(jj,i)
9584 cd      ekl=facont_hb(kk,k)
9585 cd      ekont=eij*ekl
9586 cd      write (iout,*)'Contacts have occurred for peptide groups',
9587 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9588 cd      goto 1111
9589 C Contribution from the graph I.
9590 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9591 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9592       call transpose2(EUg(1,1,k),auxmat(1,1))
9593       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9594       vv(1)=pizda(1,1)-pizda(2,2)
9595       vv(2)=pizda(1,2)+pizda(2,1)
9596       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9597      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9598 C Explicit gradient in virtual-dihedral angles.
9599       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9600      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9601      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9602       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9603       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9604       vv(1)=pizda(1,1)-pizda(2,2)
9605       vv(2)=pizda(1,2)+pizda(2,1)
9606       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9607      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9608      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9609       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9610       vv(1)=pizda(1,1)-pizda(2,2)
9611       vv(2)=pizda(1,2)+pizda(2,1)
9612       if (l.eq.j+1) then
9613         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9614      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9615      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9616       else
9617         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9618      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9619      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9620       endif
9621 C Cartesian gradient
9622       do iii=1,2
9623         do kkk=1,5
9624           do lll=1,3
9625             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9626      &        pizda(1,1))
9627             vv(1)=pizda(1,1)-pizda(2,2)
9628             vv(2)=pizda(1,2)+pizda(2,1)
9629             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9630      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9631      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9632           enddo
9633         enddo
9634       enddo
9635 c      goto 1112
9636 c1111  continue
9637 C Contribution from graph II
9638       call transpose2(EE(1,1,k),auxmat(1,1))
9639       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9640       vv(1)=pizda(1,1)+pizda(2,2)
9641       vv(2)=pizda(2,1)-pizda(1,2)
9642       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9643      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9644 C Explicit gradient in virtual-dihedral angles.
9645       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9646      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9647       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9648       vv(1)=pizda(1,1)+pizda(2,2)
9649       vv(2)=pizda(2,1)-pizda(1,2)
9650       if (l.eq.j+1) then
9651         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9652      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9653      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9654       else
9655         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9656      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9657      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9658       endif
9659 C Cartesian gradient
9660       do iii=1,2
9661         do kkk=1,5
9662           do lll=1,3
9663             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9664      &        pizda(1,1))
9665             vv(1)=pizda(1,1)+pizda(2,2)
9666             vv(2)=pizda(2,1)-pizda(1,2)
9667             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9668      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9669      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9670           enddo
9671         enddo
9672       enddo
9673 cd      goto 1112
9674 cd1111  continue
9675       if (l.eq.j+1) then
9676 cd        goto 1110
9677 C Parallel orientation
9678 C Contribution from graph III
9679         call transpose2(EUg(1,1,l),auxmat(1,1))
9680         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9681         vv(1)=pizda(1,1)-pizda(2,2)
9682         vv(2)=pizda(1,2)+pizda(2,1)
9683         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9684      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9685 C Explicit gradient in virtual-dihedral angles.
9686         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9687      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9688      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9689         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9690         vv(1)=pizda(1,1)-pizda(2,2)
9691         vv(2)=pizda(1,2)+pizda(2,1)
9692         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9693      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9694      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9695         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9696         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9697         vv(1)=pizda(1,1)-pizda(2,2)
9698         vv(2)=pizda(1,2)+pizda(2,1)
9699         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9700      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9701      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9702 C Cartesian gradient
9703         do iii=1,2
9704           do kkk=1,5
9705             do lll=1,3
9706               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9707      &          pizda(1,1))
9708               vv(1)=pizda(1,1)-pizda(2,2)
9709               vv(2)=pizda(1,2)+pizda(2,1)
9710               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9711      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9712      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9713             enddo
9714           enddo
9715         enddo
9716 cd        goto 1112
9717 C Contribution from graph IV
9718 cd1110    continue
9719         call transpose2(EE(1,1,l),auxmat(1,1))
9720         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9721         vv(1)=pizda(1,1)+pizda(2,2)
9722         vv(2)=pizda(2,1)-pizda(1,2)
9723         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9724      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9725 C Explicit gradient in virtual-dihedral angles.
9726         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9727      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9728         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9729         vv(1)=pizda(1,1)+pizda(2,2)
9730         vv(2)=pizda(2,1)-pizda(1,2)
9731         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9732      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9733      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9734 C Cartesian gradient
9735         do iii=1,2
9736           do kkk=1,5
9737             do lll=1,3
9738               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9739      &          pizda(1,1))
9740               vv(1)=pizda(1,1)+pizda(2,2)
9741               vv(2)=pizda(2,1)-pizda(1,2)
9742               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9743      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9744      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9745             enddo
9746           enddo
9747         enddo
9748       else
9749 C Antiparallel orientation
9750 C Contribution from graph III
9751 c        goto 1110
9752         call transpose2(EUg(1,1,j),auxmat(1,1))
9753         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9754         vv(1)=pizda(1,1)-pizda(2,2)
9755         vv(2)=pizda(1,2)+pizda(2,1)
9756         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9757      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9758 C Explicit gradient in virtual-dihedral angles.
9759         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9760      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9761      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9762         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9763         vv(1)=pizda(1,1)-pizda(2,2)
9764         vv(2)=pizda(1,2)+pizda(2,1)
9765         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9766      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9767      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9768         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9769         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9770         vv(1)=pizda(1,1)-pizda(2,2)
9771         vv(2)=pizda(1,2)+pizda(2,1)
9772         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9773      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9774      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9775 C Cartesian gradient
9776         do iii=1,2
9777           do kkk=1,5
9778             do lll=1,3
9779               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9780      &          pizda(1,1))
9781               vv(1)=pizda(1,1)-pizda(2,2)
9782               vv(2)=pizda(1,2)+pizda(2,1)
9783               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9784      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9785      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9786             enddo
9787           enddo
9788         enddo
9789 cd        goto 1112
9790 C Contribution from graph IV
9791 1110    continue
9792         call transpose2(EE(1,1,j),auxmat(1,1))
9793         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9794         vv(1)=pizda(1,1)+pizda(2,2)
9795         vv(2)=pizda(2,1)-pizda(1,2)
9796         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9797      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9798 C Explicit gradient in virtual-dihedral angles.
9799         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9800      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9801         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9802         vv(1)=pizda(1,1)+pizda(2,2)
9803         vv(2)=pizda(2,1)-pizda(1,2)
9804         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9805      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9806      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9807 C Cartesian gradient
9808         do iii=1,2
9809           do kkk=1,5
9810             do lll=1,3
9811               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9812      &          pizda(1,1))
9813               vv(1)=pizda(1,1)+pizda(2,2)
9814               vv(2)=pizda(2,1)-pizda(1,2)
9815               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9816      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9817      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9818             enddo
9819           enddo
9820         enddo
9821       endif
9822 1112  continue
9823       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9824 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9825 cd        write (2,*) 'ijkl',i,j,k,l
9826 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9827 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9828 cd      endif
9829 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9830 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9831 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9832 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9833       if (j.lt.nres-1) then
9834         j1=j+1
9835         j2=j-1
9836       else
9837         j1=j-1
9838         j2=j-2
9839       endif
9840       if (l.lt.nres-1) then
9841         l1=l+1
9842         l2=l-1
9843       else
9844         l1=l-1
9845         l2=l-2
9846       endif
9847 cd      eij=1.0d0
9848 cd      ekl=1.0d0
9849 cd      ekont=1.0d0
9850 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9851 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9852 C        summed up outside the subrouine as for the other subroutines
9853 C        handling long-range interactions. The old code is commented out
9854 C        with "cgrad" to keep track of changes.
9855       do ll=1,3
9856 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9857 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9858         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9859         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9860 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9861 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9862 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9863 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9864 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9865 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9866 c     &   gradcorr5ij,
9867 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9868 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9869 cgrad        ghalf=0.5d0*ggg1(ll)
9870 cd        ghalf=0.0d0
9871         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9872         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9873         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9874         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9875         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9876         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9877 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9878 cgrad        ghalf=0.5d0*ggg2(ll)
9879 cd        ghalf=0.0d0
9880         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9881         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9882         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9883         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9884         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9885         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9886       enddo
9887 cd      goto 1112
9888 cgrad      do m=i+1,j-1
9889 cgrad        do ll=1,3
9890 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9891 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9892 cgrad        enddo
9893 cgrad      enddo
9894 cgrad      do m=k+1,l-1
9895 cgrad        do ll=1,3
9896 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9897 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9898 cgrad        enddo
9899 cgrad      enddo
9900 c1112  continue
9901 cgrad      do m=i+2,j2
9902 cgrad        do ll=1,3
9903 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9904 cgrad        enddo
9905 cgrad      enddo
9906 cgrad      do m=k+2,l2
9907 cgrad        do ll=1,3
9908 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9909 cgrad        enddo
9910 cgrad      enddo
9911 cd      do iii=1,nres-3
9912 cd        write (2,*) iii,g_corr5_loc(iii)
9913 cd      enddo
9914       eello5=ekont*eel5
9915 cd      write (2,*) 'ekont',ekont
9916 cd      write (iout,*) 'eello5',ekont*eel5
9917       return
9918       end
9919 c--------------------------------------------------------------------------
9920       double precision function eello6(i,j,k,l,jj,kk)
9921       implicit real*8 (a-h,o-z)
9922       include 'DIMENSIONS'
9923       include 'COMMON.IOUNITS'
9924       include 'COMMON.CHAIN'
9925       include 'COMMON.DERIV'
9926       include 'COMMON.INTERACT'
9927       include 'COMMON.CONTACTS'
9928       include 'COMMON.TORSION'
9929       include 'COMMON.VAR'
9930       include 'COMMON.GEO'
9931       include 'COMMON.FFIELD'
9932       double precision ggg1(3),ggg2(3)
9933 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9934 cd        eello6=0.0d0
9935 cd        return
9936 cd      endif
9937 cd      write (iout,*)
9938 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9939 cd     &   ' and',k,l
9940       eello6_1=0.0d0
9941       eello6_2=0.0d0
9942       eello6_3=0.0d0
9943       eello6_4=0.0d0
9944       eello6_5=0.0d0
9945       eello6_6=0.0d0
9946 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
9947 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
9948       do iii=1,2
9949         do kkk=1,5
9950           do lll=1,3
9951             derx(lll,kkk,iii)=0.0d0
9952           enddo
9953         enddo
9954       enddo
9955 cd      eij=facont_hb(jj,i)
9956 cd      ekl=facont_hb(kk,k)
9957 cd      ekont=eij*ekl
9958 cd      eij=1.0d0
9959 cd      ekl=1.0d0
9960 cd      ekont=1.0d0
9961       if (l.eq.j+1) then
9962         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9963         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
9964         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
9965         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9966         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
9967         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
9968       else
9969         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
9970         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
9971         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
9972         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
9973         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
9974           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
9975         else
9976           eello6_5=0.0d0
9977         endif
9978         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
9979       endif
9980 C If turn contributions are considered, they will be handled separately.
9981       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
9982 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
9983 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
9984 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
9985 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
9986 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
9987 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
9988 cd      goto 1112
9989       if (j.lt.nres-1) then
9990         j1=j+1
9991         j2=j-1
9992       else
9993         j1=j-1
9994         j2=j-2
9995       endif
9996       if (l.lt.nres-1) then
9997         l1=l+1
9998         l2=l-1
9999       else
10000         l1=l-1
10001         l2=l-2
10002       endif
10003       do ll=1,3
10004 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10005 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10006 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10007 cgrad        ghalf=0.5d0*ggg1(ll)
10008 cd        ghalf=0.0d0
10009         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10010         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10011         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10012         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10013         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10014         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10015         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10016         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10017 cgrad        ghalf=0.5d0*ggg2(ll)
10018 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10019 cd        ghalf=0.0d0
10020         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10021         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10022         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10023         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10024         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10025         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10026       enddo
10027 cd      goto 1112
10028 cgrad      do m=i+1,j-1
10029 cgrad        do ll=1,3
10030 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10031 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10032 cgrad        enddo
10033 cgrad      enddo
10034 cgrad      do m=k+1,l-1
10035 cgrad        do ll=1,3
10036 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10037 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10038 cgrad        enddo
10039 cgrad      enddo
10040 cgrad1112  continue
10041 cgrad      do m=i+2,j2
10042 cgrad        do ll=1,3
10043 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10044 cgrad        enddo
10045 cgrad      enddo
10046 cgrad      do m=k+2,l2
10047 cgrad        do ll=1,3
10048 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10049 cgrad        enddo
10050 cgrad      enddo
10051 cd      do iii=1,nres-3
10052 cd        write (2,*) iii,g_corr6_loc(iii)
10053 cd      enddo
10054       eello6=ekont*eel6
10055 cd      write (2,*) 'ekont',ekont
10056 cd      write (iout,*) 'eello6',ekont*eel6
10057       return
10058       end
10059 c--------------------------------------------------------------------------
10060       double precision function eello6_graph1(i,j,k,l,imat,swap)
10061       implicit real*8 (a-h,o-z)
10062       include 'DIMENSIONS'
10063       include 'COMMON.IOUNITS'
10064       include 'COMMON.CHAIN'
10065       include 'COMMON.DERIV'
10066       include 'COMMON.INTERACT'
10067       include 'COMMON.CONTACTS'
10068       include 'COMMON.TORSION'
10069       include 'COMMON.VAR'
10070       include 'COMMON.GEO'
10071       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10072       logical swap
10073       logical lprn
10074       common /kutas/ lprn
10075 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10076 C                                                                              C
10077 C      Parallel       Antiparallel                                             C
10078 C                                                                              C
10079 C          o             o                                                     C
10080 C         /l\           /j\                                                    C
10081 C        /   \         /   \                                                   C
10082 C       /| o |         | o |\                                                  C
10083 C     \ j|/k\|  /   \  |/k\|l /                                                C
10084 C      \ /   \ /     \ /   \ /                                                 C
10085 C       o     o       o     o                                                  C
10086 C       i             i                                                        C
10087 C                                                                              C
10088 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10089       itk=itype2loc(itype(k))
10090       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10091       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10092       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10093       call transpose2(EUgC(1,1,k),auxmat(1,1))
10094       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10095       vv1(1)=pizda1(1,1)-pizda1(2,2)
10096       vv1(2)=pizda1(1,2)+pizda1(2,1)
10097       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10098       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10099       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10100       s5=scalar2(vv(1),Dtobr2(1,i))
10101 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10102       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10103       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10104      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10105      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10106      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10107      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10108      & +scalar2(vv(1),Dtobr2der(1,i)))
10109       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10110       vv1(1)=pizda1(1,1)-pizda1(2,2)
10111       vv1(2)=pizda1(1,2)+pizda1(2,1)
10112       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10113       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10114       if (l.eq.j+1) then
10115         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10116      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10117      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10118      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10119      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10120       else
10121         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10122      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10123      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10124      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10125      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10126       endif
10127       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10128       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10129       vv1(1)=pizda1(1,1)-pizda1(2,2)
10130       vv1(2)=pizda1(1,2)+pizda1(2,1)
10131       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10132      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10133      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10134      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10135       do iii=1,2
10136         if (swap) then
10137           ind=3-iii
10138         else
10139           ind=iii
10140         endif
10141         do kkk=1,5
10142           do lll=1,3
10143             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10144             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10145             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10146             call transpose2(EUgC(1,1,k),auxmat(1,1))
10147             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10148      &        pizda1(1,1))
10149             vv1(1)=pizda1(1,1)-pizda1(2,2)
10150             vv1(2)=pizda1(1,2)+pizda1(2,1)
10151             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10152             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10153      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10154             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10155      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10156             s5=scalar2(vv(1),Dtobr2(1,i))
10157             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10158           enddo
10159         enddo
10160       enddo
10161       return
10162       end
10163 c----------------------------------------------------------------------------
10164       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10165       implicit real*8 (a-h,o-z)
10166       include 'DIMENSIONS'
10167       include 'COMMON.IOUNITS'
10168       include 'COMMON.CHAIN'
10169       include 'COMMON.DERIV'
10170       include 'COMMON.INTERACT'
10171       include 'COMMON.CONTACTS'
10172       include 'COMMON.TORSION'
10173       include 'COMMON.VAR'
10174       include 'COMMON.GEO'
10175       logical swap
10176       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10177      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10178       logical lprn
10179       common /kutas/ lprn
10180 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10181 C                                                                              C
10182 C      Parallel       Antiparallel                                             C
10183 C                                                                              C
10184 C          o             o                                                     C
10185 C     \   /l\           /j\   /                                                C
10186 C      \ /   \         /   \ /                                                 C
10187 C       o| o |         | o |o                                                  C
10188 C     \ j|/k\|      \  |/k\|l                                                  C
10189 C      \ /   \       \ /   \                                                   C
10190 C       o             o                                                        C
10191 C       i             i                                                        C
10192 C                                                                              C
10193 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10194 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10195 C AL 7/4/01 s1 would occur in the sixth-order moment,
10196 C           but not in a cluster cumulant
10197 #ifdef MOMENT
10198       s1=dip(1,jj,i)*dip(1,kk,k)
10199 #endif
10200       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10201       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10202       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10203       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10204       call transpose2(EUg(1,1,k),auxmat(1,1))
10205       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10206       vv(1)=pizda(1,1)-pizda(2,2)
10207       vv(2)=pizda(1,2)+pizda(2,1)
10208       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10209 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10210 #ifdef MOMENT
10211       eello6_graph2=-(s1+s2+s3+s4)
10212 #else
10213       eello6_graph2=-(s2+s3+s4)
10214 #endif
10215 c      eello6_graph2=-s3
10216 C Derivatives in gamma(i-1)
10217       if (i.gt.1) then
10218 #ifdef MOMENT
10219         s1=dipderg(1,jj,i)*dip(1,kk,k)
10220 #endif
10221         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10222         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10223         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10224         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10225 #ifdef MOMENT
10226         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10227 #else
10228         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10229 #endif
10230 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10231       endif
10232 C Derivatives in gamma(k-1)
10233 #ifdef MOMENT
10234       s1=dip(1,jj,i)*dipderg(1,kk,k)
10235 #endif
10236       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10237       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10238       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10239       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10240       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10241       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10242       vv(1)=pizda(1,1)-pizda(2,2)
10243       vv(2)=pizda(1,2)+pizda(2,1)
10244       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10245 #ifdef MOMENT
10246       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10247 #else
10248       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10249 #endif
10250 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10251 C Derivatives in gamma(j-1) or gamma(l-1)
10252       if (j.gt.1) then
10253 #ifdef MOMENT
10254         s1=dipderg(3,jj,i)*dip(1,kk,k)
10255 #endif
10256         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10257         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10258         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10259         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10260         vv(1)=pizda(1,1)-pizda(2,2)
10261         vv(2)=pizda(1,2)+pizda(2,1)
10262         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10263 #ifdef MOMENT
10264         if (swap) then
10265           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10266         else
10267           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10268         endif
10269 #endif
10270         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10271 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10272       endif
10273 C Derivatives in gamma(l-1) or gamma(j-1)
10274       if (l.gt.1) then
10275 #ifdef MOMENT
10276         s1=dip(1,jj,i)*dipderg(3,kk,k)
10277 #endif
10278         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10279         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10280         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10281         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10282         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10283         vv(1)=pizda(1,1)-pizda(2,2)
10284         vv(2)=pizda(1,2)+pizda(2,1)
10285         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10286 #ifdef MOMENT
10287         if (swap) then
10288           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10289         else
10290           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10291         endif
10292 #endif
10293         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10294 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10295       endif
10296 C Cartesian derivatives.
10297       if (lprn) then
10298         write (2,*) 'In eello6_graph2'
10299         do iii=1,2
10300           write (2,*) 'iii=',iii
10301           do kkk=1,5
10302             write (2,*) 'kkk=',kkk
10303             do jjj=1,2
10304               write (2,'(3(2f10.5),5x)')
10305      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10306             enddo
10307           enddo
10308         enddo
10309       endif
10310       do iii=1,2
10311         do kkk=1,5
10312           do lll=1,3
10313 #ifdef MOMENT
10314             if (iii.eq.1) then
10315               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10316             else
10317               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10318             endif
10319 #endif
10320             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10321      &        auxvec(1))
10322             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10323             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10324      &        auxvec(1))
10325             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10326             call transpose2(EUg(1,1,k),auxmat(1,1))
10327             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10328      &        pizda(1,1))
10329             vv(1)=pizda(1,1)-pizda(2,2)
10330             vv(2)=pizda(1,2)+pizda(2,1)
10331             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10332 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10333 #ifdef MOMENT
10334             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10335 #else
10336             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10337 #endif
10338             if (swap) then
10339               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10340             else
10341               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10342             endif
10343           enddo
10344         enddo
10345       enddo
10346       return
10347       end
10348 c----------------------------------------------------------------------------
10349       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10350       implicit real*8 (a-h,o-z)
10351       include 'DIMENSIONS'
10352       include 'COMMON.IOUNITS'
10353       include 'COMMON.CHAIN'
10354       include 'COMMON.DERIV'
10355       include 'COMMON.INTERACT'
10356       include 'COMMON.CONTACTS'
10357       include 'COMMON.TORSION'
10358       include 'COMMON.VAR'
10359       include 'COMMON.GEO'
10360       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10361       logical swap
10362 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10363 C                                                                              C
10364 C      Parallel       Antiparallel                                             C
10365 C                                                                              C
10366 C          o             o                                                     C
10367 C         /l\   /   \   /j\                                                    C
10368 C        /   \ /     \ /   \                                                   C
10369 C       /| o |o       o| o |\                                                  C
10370 C       j|/k\|  /      |/k\|l /                                                C
10371 C        /   \ /       /   \ /                                                 C
10372 C       /     o       /     o                                                  C
10373 C       i             i                                                        C
10374 C                                                                              C
10375 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10376 C
10377 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10378 C           energy moment and not to the cluster cumulant.
10379       iti=itortyp(itype(i))
10380       if (j.lt.nres-1) then
10381         itj1=itype2loc(itype(j+1))
10382       else
10383         itj1=nloctyp
10384       endif
10385       itk=itype2loc(itype(k))
10386       itk1=itype2loc(itype(k+1))
10387       if (l.lt.nres-1) then
10388         itl1=itype2loc(itype(l+1))
10389       else
10390         itl1=nloctyp
10391       endif
10392 #ifdef MOMENT
10393       s1=dip(4,jj,i)*dip(4,kk,k)
10394 #endif
10395       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10396       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10397       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10398       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10399       call transpose2(EE(1,1,k),auxmat(1,1))
10400       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10401       vv(1)=pizda(1,1)+pizda(2,2)
10402       vv(2)=pizda(2,1)-pizda(1,2)
10403       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10404 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10405 cd     & "sum",-(s2+s3+s4)
10406 #ifdef MOMENT
10407       eello6_graph3=-(s1+s2+s3+s4)
10408 #else
10409       eello6_graph3=-(s2+s3+s4)
10410 #endif
10411 c      eello6_graph3=-s4
10412 C Derivatives in gamma(k-1)
10413       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10414       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10415       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10416       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10417 C Derivatives in gamma(l-1)
10418       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10419       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10420       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10421       vv(1)=pizda(1,1)+pizda(2,2)
10422       vv(2)=pizda(2,1)-pizda(1,2)
10423       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10424       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10425 C Cartesian derivatives.
10426       do iii=1,2
10427         do kkk=1,5
10428           do lll=1,3
10429 #ifdef MOMENT
10430             if (iii.eq.1) then
10431               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10432             else
10433               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10434             endif
10435 #endif
10436             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10437      &        auxvec(1))
10438             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10439             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10440      &        auxvec(1))
10441             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10442             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10443      &        pizda(1,1))
10444             vv(1)=pizda(1,1)+pizda(2,2)
10445             vv(2)=pizda(2,1)-pizda(1,2)
10446             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10447 #ifdef MOMENT
10448             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10449 #else
10450             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10451 #endif
10452             if (swap) then
10453               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10454             else
10455               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10456             endif
10457 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10458           enddo
10459         enddo
10460       enddo
10461       return
10462       end
10463 c----------------------------------------------------------------------------
10464       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10465       implicit real*8 (a-h,o-z)
10466       include 'DIMENSIONS'
10467       include 'COMMON.IOUNITS'
10468       include 'COMMON.CHAIN'
10469       include 'COMMON.DERIV'
10470       include 'COMMON.INTERACT'
10471       include 'COMMON.CONTACTS'
10472       include 'COMMON.TORSION'
10473       include 'COMMON.VAR'
10474       include 'COMMON.GEO'
10475       include 'COMMON.FFIELD'
10476       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10477      & auxvec1(2),auxmat1(2,2)
10478       logical swap
10479 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10480 C                                                                              C
10481 C      Parallel       Antiparallel                                             C
10482 C                                                                              C
10483 C          o             o                                                     C
10484 C         /l\   /   \   /j\                                                    C
10485 C        /   \ /     \ /   \                                                   C
10486 C       /| o |o       o| o |\                                                  C
10487 C     \ j|/k\|      \  |/k\|l                                                  C
10488 C      \ /   \       \ /   \                                                   C
10489 C       o     \       o     \                                                  C
10490 C       i             i                                                        C
10491 C                                                                              C
10492 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10493 C
10494 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10495 C           energy moment and not to the cluster cumulant.
10496 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10497       iti=itype2loc(itype(i))
10498       itj=itype2loc(itype(j))
10499       if (j.lt.nres-1) then
10500         itj1=itype2loc(itype(j+1))
10501       else
10502         itj1=nloctyp
10503       endif
10504       itk=itype2loc(itype(k))
10505       if (k.lt.nres-1) then
10506         itk1=itype2loc(itype(k+1))
10507       else
10508         itk1=nloctyp
10509       endif
10510       itl=itype2loc(itype(l))
10511       if (l.lt.nres-1) then
10512         itl1=itype2loc(itype(l+1))
10513       else
10514         itl1=nloctyp
10515       endif
10516 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10517 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10518 cd     & ' itl',itl,' itl1',itl1
10519 #ifdef MOMENT
10520       if (imat.eq.1) then
10521         s1=dip(3,jj,i)*dip(3,kk,k)
10522       else
10523         s1=dip(2,jj,j)*dip(2,kk,l)
10524       endif
10525 #endif
10526       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10527       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10528       if (j.eq.l+1) then
10529         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10530         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10531       else
10532         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10533         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10534       endif
10535       call transpose2(EUg(1,1,k),auxmat(1,1))
10536       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10537       vv(1)=pizda(1,1)-pizda(2,2)
10538       vv(2)=pizda(2,1)+pizda(1,2)
10539       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10540 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10541 #ifdef MOMENT
10542       eello6_graph4=-(s1+s2+s3+s4)
10543 #else
10544       eello6_graph4=-(s2+s3+s4)
10545 #endif
10546 C Derivatives in gamma(i-1)
10547       if (i.gt.1) then
10548 #ifdef MOMENT
10549         if (imat.eq.1) then
10550           s1=dipderg(2,jj,i)*dip(3,kk,k)
10551         else
10552           s1=dipderg(4,jj,j)*dip(2,kk,l)
10553         endif
10554 #endif
10555         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10556         if (j.eq.l+1) then
10557           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10558           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10559         else
10560           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10561           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10562         endif
10563         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10564         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10565 cd          write (2,*) 'turn6 derivatives'
10566 #ifdef MOMENT
10567           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10568 #else
10569           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10570 #endif
10571         else
10572 #ifdef MOMENT
10573           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10574 #else
10575           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10576 #endif
10577         endif
10578       endif
10579 C Derivatives in gamma(k-1)
10580 #ifdef MOMENT
10581       if (imat.eq.1) then
10582         s1=dip(3,jj,i)*dipderg(2,kk,k)
10583       else
10584         s1=dip(2,jj,j)*dipderg(4,kk,l)
10585       endif
10586 #endif
10587       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10588       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10589       if (j.eq.l+1) then
10590         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10591         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10592       else
10593         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10594         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10595       endif
10596       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10597       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10598       vv(1)=pizda(1,1)-pizda(2,2)
10599       vv(2)=pizda(2,1)+pizda(1,2)
10600       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10601       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10602 #ifdef MOMENT
10603         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10604 #else
10605         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10606 #endif
10607       else
10608 #ifdef MOMENT
10609         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10610 #else
10611         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10612 #endif
10613       endif
10614 C Derivatives in gamma(j-1) or gamma(l-1)
10615       if (l.eq.j+1 .and. l.gt.1) then
10616         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10617         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10618         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10619         vv(1)=pizda(1,1)-pizda(2,2)
10620         vv(2)=pizda(2,1)+pizda(1,2)
10621         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10622         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10623       else if (j.gt.1) then
10624         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10625         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10626         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10627         vv(1)=pizda(1,1)-pizda(2,2)
10628         vv(2)=pizda(2,1)+pizda(1,2)
10629         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10630         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10631           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10632         else
10633           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10634         endif
10635       endif
10636 C Cartesian derivatives.
10637       do iii=1,2
10638         do kkk=1,5
10639           do lll=1,3
10640 #ifdef MOMENT
10641             if (iii.eq.1) then
10642               if (imat.eq.1) then
10643                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10644               else
10645                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10646               endif
10647             else
10648               if (imat.eq.1) then
10649                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10650               else
10651                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10652               endif
10653             endif
10654 #endif
10655             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10656      &        auxvec(1))
10657             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10658             if (j.eq.l+1) then
10659               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10660      &          b1(1,j+1),auxvec(1))
10661               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10662             else
10663               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10664      &          b1(1,l+1),auxvec(1))
10665               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10666             endif
10667             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10668      &        pizda(1,1))
10669             vv(1)=pizda(1,1)-pizda(2,2)
10670             vv(2)=pizda(2,1)+pizda(1,2)
10671             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10672             if (swap) then
10673               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10674 #ifdef MOMENT
10675                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10676      &             -(s1+s2+s4)
10677 #else
10678                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10679      &             -(s2+s4)
10680 #endif
10681                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10682               else
10683 #ifdef MOMENT
10684                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10685 #else
10686                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10687 #endif
10688                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10689               endif
10690             else
10691 #ifdef MOMENT
10692               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10693 #else
10694               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10695 #endif
10696               if (l.eq.j+1) then
10697                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10698               else
10699                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10700               endif
10701             endif
10702           enddo
10703         enddo
10704       enddo
10705       return
10706       end
10707 c----------------------------------------------------------------------------
10708       double precision function eello_turn6(i,jj,kk)
10709       implicit real*8 (a-h,o-z)
10710       include 'DIMENSIONS'
10711       include 'COMMON.IOUNITS'
10712       include 'COMMON.CHAIN'
10713       include 'COMMON.DERIV'
10714       include 'COMMON.INTERACT'
10715       include 'COMMON.CONTACTS'
10716       include 'COMMON.TORSION'
10717       include 'COMMON.VAR'
10718       include 'COMMON.GEO'
10719       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10720      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10721      &  ggg1(3),ggg2(3)
10722       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10723      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10724 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10725 C           the respective energy moment and not to the cluster cumulant.
10726       s1=0.0d0
10727       s8=0.0d0
10728       s13=0.0d0
10729 c
10730       eello_turn6=0.0d0
10731       j=i+4
10732       k=i+1
10733       l=i+3
10734       iti=itype2loc(itype(i))
10735       itk=itype2loc(itype(k))
10736       itk1=itype2loc(itype(k+1))
10737       itl=itype2loc(itype(l))
10738       itj=itype2loc(itype(j))
10739 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10740 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10741 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10742 cd        eello6=0.0d0
10743 cd        return
10744 cd      endif
10745 cd      write (iout,*)
10746 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10747 cd     &   ' and',k,l
10748 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10749       do iii=1,2
10750         do kkk=1,5
10751           do lll=1,3
10752             derx_turn(lll,kkk,iii)=0.0d0
10753           enddo
10754         enddo
10755       enddo
10756 cd      eij=1.0d0
10757 cd      ekl=1.0d0
10758 cd      ekont=1.0d0
10759       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10760 cd      eello6_5=0.0d0
10761 cd      write (2,*) 'eello6_5',eello6_5
10762 #ifdef MOMENT
10763       call transpose2(AEA(1,1,1),auxmat(1,1))
10764       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10765       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10766       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10767 #endif
10768       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10769       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10770       s2 = scalar2(b1(1,k),vtemp1(1))
10771 #ifdef MOMENT
10772       call transpose2(AEA(1,1,2),atemp(1,1))
10773       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10774       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10775       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10776 #endif
10777       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10778       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10779       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10780 #ifdef MOMENT
10781       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10782       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10783       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10784       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10785       ss13 = scalar2(b1(1,k),vtemp4(1))
10786       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10787 #endif
10788 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10789 c      s1=0.0d0
10790 c      s2=0.0d0
10791 c      s8=0.0d0
10792 c      s12=0.0d0
10793 c      s13=0.0d0
10794       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10795 C Derivatives in gamma(i+2)
10796       s1d =0.0d0
10797       s8d =0.0d0
10798 #ifdef MOMENT
10799       call transpose2(AEA(1,1,1),auxmatd(1,1))
10800       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10801       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10802       call transpose2(AEAderg(1,1,2),atempd(1,1))
10803       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10804       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10805 #endif
10806       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10807       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10808       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10809 c      s1d=0.0d0
10810 c      s2d=0.0d0
10811 c      s8d=0.0d0
10812 c      s12d=0.0d0
10813 c      s13d=0.0d0
10814       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10815 C Derivatives in gamma(i+3)
10816 #ifdef MOMENT
10817       call transpose2(AEA(1,1,1),auxmatd(1,1))
10818       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10819       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10820       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10821 #endif
10822       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10823       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10824       s2d = scalar2(b1(1,k),vtemp1d(1))
10825 #ifdef MOMENT
10826       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10827       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10828 #endif
10829       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10830 #ifdef MOMENT
10831       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10832       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10833       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10834 #endif
10835 c      s1d=0.0d0
10836 c      s2d=0.0d0
10837 c      s8d=0.0d0
10838 c      s12d=0.0d0
10839 c      s13d=0.0d0
10840 #ifdef MOMENT
10841       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10842      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10843 #else
10844       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10845      &               -0.5d0*ekont*(s2d+s12d)
10846 #endif
10847 C Derivatives in gamma(i+4)
10848       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10849       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10850       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10851 #ifdef MOMENT
10852       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10853       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10854       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10855 #endif
10856 c      s1d=0.0d0
10857 c      s2d=0.0d0
10858 c      s8d=0.0d0
10859 C      s12d=0.0d0
10860 c      s13d=0.0d0
10861 #ifdef MOMENT
10862       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10863 #else
10864       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10865 #endif
10866 C Derivatives in gamma(i+5)
10867 #ifdef MOMENT
10868       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10869       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10870       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10871 #endif
10872       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10873       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10874       s2d = scalar2(b1(1,k),vtemp1d(1))
10875 #ifdef MOMENT
10876       call transpose2(AEA(1,1,2),atempd(1,1))
10877       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10878       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10879 #endif
10880       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10881       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10882 #ifdef MOMENT
10883       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10884       ss13d = scalar2(b1(1,k),vtemp4d(1))
10885       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10886 #endif
10887 c      s1d=0.0d0
10888 c      s2d=0.0d0
10889 c      s8d=0.0d0
10890 c      s12d=0.0d0
10891 c      s13d=0.0d0
10892 #ifdef MOMENT
10893       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10894      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10895 #else
10896       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10897      &               -0.5d0*ekont*(s2d+s12d)
10898 #endif
10899 C Cartesian derivatives
10900       do iii=1,2
10901         do kkk=1,5
10902           do lll=1,3
10903 #ifdef MOMENT
10904             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10905             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10906             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10907 #endif
10908             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10909             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10910      &          vtemp1d(1))
10911             s2d = scalar2(b1(1,k),vtemp1d(1))
10912 #ifdef MOMENT
10913             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10914             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10915             s8d = -(atempd(1,1)+atempd(2,2))*
10916      &           scalar2(cc(1,1,l),vtemp2(1))
10917 #endif
10918             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10919      &           auxmatd(1,1))
10920             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10921             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10922 c      s1d=0.0d0
10923 c      s2d=0.0d0
10924 c      s8d=0.0d0
10925 c      s12d=0.0d0
10926 c      s13d=0.0d0
10927 #ifdef MOMENT
10928             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10929      &        - 0.5d0*(s1d+s2d)
10930 #else
10931             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10932      &        - 0.5d0*s2d
10933 #endif
10934 #ifdef MOMENT
10935             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10936      &        - 0.5d0*(s8d+s12d)
10937 #else
10938             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10939      &        - 0.5d0*s12d
10940 #endif
10941           enddo
10942         enddo
10943       enddo
10944 #ifdef MOMENT
10945       do kkk=1,5
10946         do lll=1,3
10947           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
10948      &      achuj_tempd(1,1))
10949           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
10950           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10951           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
10952           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
10953           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
10954      &      vtemp4d(1))
10955           ss13d = scalar2(b1(1,k),vtemp4d(1))
10956           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10957           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
10958         enddo
10959       enddo
10960 #endif
10961 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
10962 cd     &  16*eel_turn6_num
10963 cd      goto 1112
10964       if (j.lt.nres-1) then
10965         j1=j+1
10966         j2=j-1
10967       else
10968         j1=j-1
10969         j2=j-2
10970       endif
10971       if (l.lt.nres-1) then
10972         l1=l+1
10973         l2=l-1
10974       else
10975         l1=l-1
10976         l2=l-2
10977       endif
10978       do ll=1,3
10979 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
10980 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
10981 cgrad        ghalf=0.5d0*ggg1(ll)
10982 cd        ghalf=0.0d0
10983         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
10984         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
10985         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
10986      &    +ekont*derx_turn(ll,2,1)
10987         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
10988         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
10989      &    +ekont*derx_turn(ll,4,1)
10990         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
10991         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
10992         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
10993 cgrad        ghalf=0.5d0*ggg2(ll)
10994 cd        ghalf=0.0d0
10995         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
10996      &    +ekont*derx_turn(ll,2,2)
10997         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
10998         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
10999      &    +ekont*derx_turn(ll,4,2)
11000         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11001         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11002         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11003       enddo
11004 cd      goto 1112
11005 cgrad      do m=i+1,j-1
11006 cgrad        do ll=1,3
11007 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11008 cgrad        enddo
11009 cgrad      enddo
11010 cgrad      do m=k+1,l-1
11011 cgrad        do ll=1,3
11012 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11013 cgrad        enddo
11014 cgrad      enddo
11015 cgrad1112  continue
11016 cgrad      do m=i+2,j2
11017 cgrad        do ll=1,3
11018 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11019 cgrad        enddo
11020 cgrad      enddo
11021 cgrad      do m=k+2,l2
11022 cgrad        do ll=1,3
11023 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11024 cgrad        enddo
11025 cgrad      enddo
11026 cd      do iii=1,nres-3
11027 cd        write (2,*) iii,g_corr6_loc(iii)
11028 cd      enddo
11029       eello_turn6=ekont*eel_turn6
11030 cd      write (2,*) 'ekont',ekont
11031 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11032       return
11033       end
11034
11035 C-----------------------------------------------------------------------------
11036       double precision function scalar(u,v)
11037 !DIR$ INLINEALWAYS scalar
11038 #ifndef OSF
11039 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11040 #endif
11041       implicit none
11042       double precision u(3),v(3)
11043 cd      double precision sc
11044 cd      integer i
11045 cd      sc=0.0d0
11046 cd      do i=1,3
11047 cd        sc=sc+u(i)*v(i)
11048 cd      enddo
11049 cd      scalar=sc
11050
11051       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11052       return
11053       end
11054 crc-------------------------------------------------
11055       SUBROUTINE MATVEC2(A1,V1,V2)
11056 !DIR$ INLINEALWAYS MATVEC2
11057 #ifndef OSF
11058 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11059 #endif
11060       implicit real*8 (a-h,o-z)
11061       include 'DIMENSIONS'
11062       DIMENSION A1(2,2),V1(2),V2(2)
11063 c      DO 1 I=1,2
11064 c        VI=0.0
11065 c        DO 3 K=1,2
11066 c    3     VI=VI+A1(I,K)*V1(K)
11067 c        Vaux(I)=VI
11068 c    1 CONTINUE
11069
11070       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11071       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11072
11073       v2(1)=vaux1
11074       v2(2)=vaux2
11075       END
11076 C---------------------------------------
11077       SUBROUTINE MATMAT2(A1,A2,A3)
11078 #ifndef OSF
11079 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11080 #endif
11081       implicit real*8 (a-h,o-z)
11082       include 'DIMENSIONS'
11083       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11084 c      DIMENSION AI3(2,2)
11085 c        DO  J=1,2
11086 c          A3IJ=0.0
11087 c          DO K=1,2
11088 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11089 c          enddo
11090 c          A3(I,J)=A3IJ
11091 c       enddo
11092 c      enddo
11093
11094       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11095       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11096       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11097       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11098
11099       A3(1,1)=AI3_11
11100       A3(2,1)=AI3_21
11101       A3(1,2)=AI3_12
11102       A3(2,2)=AI3_22
11103       END
11104
11105 c-------------------------------------------------------------------------
11106       double precision function scalar2(u,v)
11107 !DIR$ INLINEALWAYS scalar2
11108       implicit none
11109       double precision u(2),v(2)
11110       double precision sc
11111       integer i
11112       scalar2=u(1)*v(1)+u(2)*v(2)
11113       return
11114       end
11115
11116 C-----------------------------------------------------------------------------
11117
11118       subroutine transpose2(a,at)
11119 !DIR$ INLINEALWAYS transpose2
11120 #ifndef OSF
11121 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11122 #endif
11123       implicit none
11124       double precision a(2,2),at(2,2)
11125       at(1,1)=a(1,1)
11126       at(1,2)=a(2,1)
11127       at(2,1)=a(1,2)
11128       at(2,2)=a(2,2)
11129       return
11130       end
11131 c--------------------------------------------------------------------------
11132       subroutine transpose(n,a,at)
11133       implicit none
11134       integer n,i,j
11135       double precision a(n,n),at(n,n)
11136       do i=1,n
11137         do j=1,n
11138           at(j,i)=a(i,j)
11139         enddo
11140       enddo
11141       return
11142       end
11143 C---------------------------------------------------------------------------
11144       subroutine prodmat3(a1,a2,kk,transp,prod)
11145 !DIR$ INLINEALWAYS prodmat3
11146 #ifndef OSF
11147 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11148 #endif
11149       implicit none
11150       integer i,j
11151       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11152       logical transp
11153 crc      double precision auxmat(2,2),prod_(2,2)
11154
11155       if (transp) then
11156 crc        call transpose2(kk(1,1),auxmat(1,1))
11157 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11158 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11159
11160            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11161      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11162            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11163      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11164            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11165      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11166            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11167      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11168
11169       else
11170 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11171 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11172
11173            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11174      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11175            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11176      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11177            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11178      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11179            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11180      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11181
11182       endif
11183 c      call transpose2(a2(1,1),a2t(1,1))
11184
11185 crc      print *,transp
11186 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11187 crc      print *,((prod(i,j),i=1,2),j=1,2)
11188
11189       return
11190       end
11191 CCC----------------------------------------------
11192       subroutine Eliptransfer(eliptran)
11193       implicit real*8 (a-h,o-z)
11194       include 'DIMENSIONS'
11195       include 'COMMON.GEO'
11196       include 'COMMON.VAR'
11197       include 'COMMON.LOCAL'
11198       include 'COMMON.CHAIN'
11199       include 'COMMON.DERIV'
11200       include 'COMMON.NAMES'
11201       include 'COMMON.INTERACT'
11202       include 'COMMON.IOUNITS'
11203       include 'COMMON.CALC'
11204       include 'COMMON.CONTROL'
11205       include 'COMMON.SPLITELE'
11206       include 'COMMON.SBRIDGE'
11207 C this is done by Adasko
11208 C      print *,"wchodze"
11209 C structure of box:
11210 C      water
11211 C--bordliptop-- buffore starts
11212 C--bufliptop--- here true lipid starts
11213 C      lipid
11214 C--buflipbot--- lipid ends buffore starts
11215 C--bordlipbot--buffore ends
11216       eliptran=0.0
11217       do i=ilip_start,ilip_end
11218 C       do i=1,1
11219         if (itype(i).eq.ntyp1) cycle
11220
11221         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11222         if (positi.le.0.0) positi=positi+boxzsize
11223 C        print *,i
11224 C first for peptide groups
11225 c for each residue check if it is in lipid or lipid water border area
11226        if ((positi.gt.bordlipbot)
11227      &.and.(positi.lt.bordliptop)) then
11228 C the energy transfer exist
11229         if (positi.lt.buflipbot) then
11230 C what fraction I am in
11231          fracinbuf=1.0d0-
11232      &        ((positi-bordlipbot)/lipbufthick)
11233 C lipbufthick is thickenes of lipid buffore
11234          sslip=sscalelip(fracinbuf)
11235          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11236          eliptran=eliptran+sslip*pepliptran
11237          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11238          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11239 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11240
11241 C        print *,"doing sccale for lower part"
11242 C         print *,i,sslip,fracinbuf,ssgradlip
11243         elseif (positi.gt.bufliptop) then
11244          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11245          sslip=sscalelip(fracinbuf)
11246          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11247          eliptran=eliptran+sslip*pepliptran
11248          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11249          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11250 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11251 C          print *, "doing sscalefor top part"
11252 C         print *,i,sslip,fracinbuf,ssgradlip
11253         else
11254          eliptran=eliptran+pepliptran
11255 C         print *,"I am in true lipid"
11256         endif
11257 C       else
11258 C       eliptran=elpitran+0.0 ! I am in water
11259        endif
11260        enddo
11261 C       print *, "nic nie bylo w lipidzie?"
11262 C now multiply all by the peptide group transfer factor
11263 C       eliptran=eliptran*pepliptran
11264 C now the same for side chains
11265 CV       do i=1,1
11266        do i=ilip_start,ilip_end
11267         if (itype(i).eq.ntyp1) cycle
11268         positi=(mod(c(3,i+nres),boxzsize))
11269         if (positi.le.0) positi=positi+boxzsize
11270 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11271 c for each residue check if it is in lipid or lipid water border area
11272 C       respos=mod(c(3,i+nres),boxzsize)
11273 C       print *,positi,bordlipbot,buflipbot
11274        if ((positi.gt.bordlipbot)
11275      & .and.(positi.lt.bordliptop)) then
11276 C the energy transfer exist
11277         if (positi.lt.buflipbot) then
11278          fracinbuf=1.0d0-
11279      &     ((positi-bordlipbot)/lipbufthick)
11280 C lipbufthick is thickenes of lipid buffore
11281          sslip=sscalelip(fracinbuf)
11282          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11283          eliptran=eliptran+sslip*liptranene(itype(i))
11284          gliptranx(3,i)=gliptranx(3,i)
11285      &+ssgradlip*liptranene(itype(i))
11286          gliptranc(3,i-1)= gliptranc(3,i-1)
11287      &+ssgradlip*liptranene(itype(i))
11288 C         print *,"doing sccale for lower part"
11289         elseif (positi.gt.bufliptop) then
11290          fracinbuf=1.0d0-
11291      &((bordliptop-positi)/lipbufthick)
11292          sslip=sscalelip(fracinbuf)
11293          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11294          eliptran=eliptran+sslip*liptranene(itype(i))
11295          gliptranx(3,i)=gliptranx(3,i)
11296      &+ssgradlip*liptranene(itype(i))
11297          gliptranc(3,i-1)= gliptranc(3,i-1)
11298      &+ssgradlip*liptranene(itype(i))
11299 C          print *, "doing sscalefor top part",sslip,fracinbuf
11300         else
11301          eliptran=eliptran+liptranene(itype(i))
11302 C         print *,"I am in true lipid"
11303         endif
11304         endif ! if in lipid or buffor
11305 C       else
11306 C       eliptran=elpitran+0.0 ! I am in water
11307        enddo
11308        return
11309        end
11310 C---------------------------------------------------------
11311 C AFM soubroutine for constant force
11312        subroutine AFMforce(Eafmforce)
11313        implicit real*8 (a-h,o-z)
11314       include 'DIMENSIONS'
11315       include 'COMMON.GEO'
11316       include 'COMMON.VAR'
11317       include 'COMMON.LOCAL'
11318       include 'COMMON.CHAIN'
11319       include 'COMMON.DERIV'
11320       include 'COMMON.NAMES'
11321       include 'COMMON.INTERACT'
11322       include 'COMMON.IOUNITS'
11323       include 'COMMON.CALC'
11324       include 'COMMON.CONTROL'
11325       include 'COMMON.SPLITELE'
11326       include 'COMMON.SBRIDGE'
11327       real*8 diffafm(3)
11328       dist=0.0d0
11329       Eafmforce=0.0d0
11330       do i=1,3
11331       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11332       dist=dist+diffafm(i)**2
11333       enddo
11334       dist=dsqrt(dist)
11335       Eafmforce=-forceAFMconst*(dist-distafminit)
11336       do i=1,3
11337       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11338       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11339       enddo
11340 C      print *,'AFM',Eafmforce
11341       return
11342       end
11343 C---------------------------------------------------------
11344 C AFM subroutine with pseudoconstant velocity
11345        subroutine AFMvel(Eafmforce)
11346        implicit real*8 (a-h,o-z)
11347       include 'DIMENSIONS'
11348       include 'COMMON.GEO'
11349       include 'COMMON.VAR'
11350       include 'COMMON.LOCAL'
11351       include 'COMMON.CHAIN'
11352       include 'COMMON.DERIV'
11353       include 'COMMON.NAMES'
11354       include 'COMMON.INTERACT'
11355       include 'COMMON.IOUNITS'
11356       include 'COMMON.CALC'
11357       include 'COMMON.CONTROL'
11358       include 'COMMON.SPLITELE'
11359       include 'COMMON.SBRIDGE'
11360       real*8 diffafm(3)
11361 C Only for check grad COMMENT if not used for checkgrad
11362 C      totT=3.0d0
11363 C--------------------------------------------------------
11364 C      print *,"wchodze"
11365       dist=0.0d0
11366       Eafmforce=0.0d0
11367       do i=1,3
11368       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11369       dist=dist+diffafm(i)**2
11370       enddo
11371       dist=dsqrt(dist)
11372       Eafmforce=0.5d0*forceAFMconst
11373      & *(distafminit+totTafm*velAFMconst-dist)**2
11374 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11375       do i=1,3
11376       gradafm(i,afmend-1)=-forceAFMconst*
11377      &(distafminit+totTafm*velAFMconst-dist)
11378      &*diffafm(i)/dist
11379       gradafm(i,afmbeg-1)=forceAFMconst*
11380      &(distafminit+totTafm*velAFMconst-dist)
11381      &*diffafm(i)/dist
11382       enddo
11383 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11384       return
11385       end
11386 C-----------------------------------------------------------
11387 C first for shielding is setting of function of side-chains
11388        subroutine set_shield_fac
11389       implicit real*8 (a-h,o-z)
11390       include 'DIMENSIONS'
11391       include 'COMMON.CHAIN'
11392       include 'COMMON.DERIV'
11393       include 'COMMON.IOUNITS'
11394       include 'COMMON.SHIELD'
11395       include 'COMMON.INTERACT'
11396 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11397       double precision div77_81/0.974996043d0/,
11398      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11399
11400 C the vector between center of side_chain and peptide group
11401        double precision pep_side(3),long,side_calf(3),
11402      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11403      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11404 C the line belowe needs to be changed for FGPROC>1
11405       do i=1,nres-1
11406       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11407       ishield_list(i)=0
11408 Cif there two consequtive dummy atoms there is no peptide group between them
11409 C the line below has to be changed for FGPROC>1
11410       VolumeTotal=0.0
11411       do k=1,nres
11412        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11413        dist_pep_side=0.0
11414        dist_side_calf=0.0
11415        do j=1,3
11416 C first lets set vector conecting the ithe side-chain with kth side-chain
11417       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11418 C      pep_side(j)=2.0d0
11419 C and vector conecting the side-chain with its proper calfa
11420       side_calf(j)=c(j,k+nres)-c(j,k)
11421 C      side_calf(j)=2.0d0
11422       pept_group(j)=c(j,i)-c(j,i+1)
11423 C lets have their lenght
11424       dist_pep_side=pep_side(j)**2+dist_pep_side
11425       dist_side_calf=dist_side_calf+side_calf(j)**2
11426       dist_pept_group=dist_pept_group+pept_group(j)**2
11427       enddo
11428        dist_pep_side=dsqrt(dist_pep_side)
11429        dist_pept_group=dsqrt(dist_pept_group)
11430        dist_side_calf=dsqrt(dist_side_calf)
11431       do j=1,3
11432         pep_side_norm(j)=pep_side(j)/dist_pep_side
11433         side_calf_norm(j)=dist_side_calf
11434       enddo
11435 C now sscale fraction
11436        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11437 C       print *,buff_shield,"buff"
11438 C now sscale
11439         if (sh_frac_dist.le.0.0) cycle
11440 C If we reach here it means that this side chain reaches the shielding sphere
11441 C Lets add him to the list for gradient
11442         ishield_list(i)=ishield_list(i)+1
11443 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11444 C this list is essential otherwise problem would be O3
11445         shield_list(ishield_list(i),i)=k
11446 C Lets have the sscale value
11447         if (sh_frac_dist.gt.1.0) then
11448          scale_fac_dist=1.0d0
11449          do j=1,3
11450          sh_frac_dist_grad(j)=0.0d0
11451          enddo
11452         else
11453          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11454      &                   *(2.0*sh_frac_dist-3.0d0)
11455          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11456      &                  /dist_pep_side/buff_shield*0.5
11457 C remember for the final gradient multiply sh_frac_dist_grad(j)
11458 C for side_chain by factor -2 !
11459          do j=1,3
11460          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11461 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11462 C     &                    sh_frac_dist_grad(j)
11463          enddo
11464         endif
11465 C        if ((i.eq.3).and.(k.eq.2)) then
11466 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11467 C     & ,"TU"
11468 C        endif
11469
11470 C this is what is now we have the distance scaling now volume...
11471       short=short_r_sidechain(itype(k))
11472       long=long_r_sidechain(itype(k))
11473       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11474 C now costhet_grad
11475 C       costhet=0.0d0
11476        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11477 C       costhet_fac=0.0d0
11478        do j=1,3
11479          costhet_grad(j)=costhet_fac*pep_side(j)
11480        enddo
11481 C remember for the final gradient multiply costhet_grad(j)
11482 C for side_chain by factor -2 !
11483 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11484 C pep_side0pept_group is vector multiplication
11485       pep_side0pept_group=0.0
11486       do j=1,3
11487       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11488       enddo
11489       cosalfa=(pep_side0pept_group/
11490      & (dist_pep_side*dist_side_calf))
11491       fac_alfa_sin=1.0-cosalfa**2
11492       fac_alfa_sin=dsqrt(fac_alfa_sin)
11493       rkprim=fac_alfa_sin*(long-short)+short
11494 C now costhet_grad
11495        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11496        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11497
11498        do j=1,3
11499          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11500      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11501      &*(long-short)/fac_alfa_sin*cosalfa/
11502      &((dist_pep_side*dist_side_calf))*
11503      &((side_calf(j))-cosalfa*
11504      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11505
11506         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11507      &*(long-short)/fac_alfa_sin*cosalfa
11508      &/((dist_pep_side*dist_side_calf))*
11509      &(pep_side(j)-
11510      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11511        enddo
11512
11513       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11514      &                    /VSolvSphere_div
11515      &                    *wshield
11516 C now the gradient...
11517 C grad_shield is gradient of Calfa for peptide groups
11518 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11519 C     &               costhet,cosphi
11520 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11521 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11522       do j=1,3
11523       grad_shield(j,i)=grad_shield(j,i)
11524 C gradient po skalowaniu
11525      &                +(sh_frac_dist_grad(j)
11526 C  gradient po costhet
11527      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11528      &-scale_fac_dist*(cosphi_grad_long(j))
11529      &/(1.0-cosphi) )*div77_81
11530      &*VofOverlap
11531 C grad_shield_side is Cbeta sidechain gradient
11532       grad_shield_side(j,ishield_list(i),i)=
11533      &        (sh_frac_dist_grad(j)*(-2.0d0)
11534      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11535      &       +scale_fac_dist*(cosphi_grad_long(j))
11536      &        *2.0d0/(1.0-cosphi))
11537      &        *div77_81*VofOverlap
11538
11539        grad_shield_loc(j,ishield_list(i),i)=
11540      &   scale_fac_dist*cosphi_grad_loc(j)
11541      &        *2.0d0/(1.0-cosphi)
11542      &        *div77_81*VofOverlap
11543       enddo
11544       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11545       enddo
11546       fac_shield(i)=VolumeTotal*div77_81+div4_81
11547 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11548       enddo
11549       return
11550       end
11551 C--------------------------------------------------------------------------
11552       double precision function tschebyshev(m,n,x,y)
11553       implicit none
11554       include "DIMENSIONS"
11555       integer i,m,n
11556       double precision x(n),y,yy(0:maxvar),aux
11557 c Tschebyshev polynomial. Note that the first term is omitted
11558 c m=0: the constant term is included
11559 c m=1: the constant term is not included
11560       yy(0)=1.0d0
11561       yy(1)=y
11562       do i=2,n
11563         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11564       enddo
11565       aux=0.0d0
11566       do i=m,n
11567         aux=aux+x(i)*yy(i)
11568       enddo
11569       tschebyshev=aux
11570       return
11571       end
11572 C--------------------------------------------------------------------------
11573       double precision function gradtschebyshev(m,n,x,y)
11574       implicit none
11575       include "DIMENSIONS"
11576       integer i,m,n
11577       double precision x(n+1),y,yy(0:maxvar),aux
11578 c Tschebyshev polynomial. Note that the first term is omitted
11579 c m=0: the constant term is included
11580 c m=1: the constant term is not included
11581       yy(0)=1.0d0
11582       yy(1)=2.0d0*y
11583       do i=2,n
11584         yy(i)=2*y*yy(i-1)-yy(i-2)
11585       enddo
11586       aux=0.0d0
11587       do i=m,n
11588         aux=aux+x(i+1)*yy(i)*(i+1)
11589 C        print *, x(i+1),yy(i),i
11590       enddo
11591       gradtschebyshev=aux
11592       return
11593       end
11594 C------------------------------------------------------------------------
11595 C first for shielding is setting of function of side-chains
11596        subroutine set_shield_fac2
11597       implicit real*8 (a-h,o-z)
11598       include 'DIMENSIONS'
11599       include 'COMMON.CHAIN'
11600       include 'COMMON.DERIV'
11601       include 'COMMON.IOUNITS'
11602       include 'COMMON.SHIELD'
11603       include 'COMMON.INTERACT'
11604 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11605       double precision div77_81/0.974996043d0/,
11606      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11607
11608 C the vector between center of side_chain and peptide group
11609        double precision pep_side(3),long,side_calf(3),
11610      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11611      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11612 C the line belowe needs to be changed for FGPROC>1
11613       do i=1,nres-1
11614       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11615       ishield_list(i)=0
11616 Cif there two consequtive dummy atoms there is no peptide group between them
11617 C the line below has to be changed for FGPROC>1
11618       VolumeTotal=0.0
11619       do k=1,nres
11620        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11621        dist_pep_side=0.0
11622        dist_side_calf=0.0
11623        do j=1,3
11624 C first lets set vector conecting the ithe side-chain with kth side-chain
11625       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11626 C      pep_side(j)=2.0d0
11627 C and vector conecting the side-chain with its proper calfa
11628       side_calf(j)=c(j,k+nres)-c(j,k)
11629 C      side_calf(j)=2.0d0
11630       pept_group(j)=c(j,i)-c(j,i+1)
11631 C lets have their lenght
11632       dist_pep_side=pep_side(j)**2+dist_pep_side
11633       dist_side_calf=dist_side_calf+side_calf(j)**2
11634       dist_pept_group=dist_pept_group+pept_group(j)**2
11635       enddo
11636        dist_pep_side=dsqrt(dist_pep_side)
11637        dist_pept_group=dsqrt(dist_pept_group)
11638        dist_side_calf=dsqrt(dist_side_calf)
11639       do j=1,3
11640         pep_side_norm(j)=pep_side(j)/dist_pep_side
11641         side_calf_norm(j)=dist_side_calf
11642       enddo
11643 C now sscale fraction
11644        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11645 C       print *,buff_shield,"buff"
11646 C now sscale
11647         if (sh_frac_dist.le.0.0) cycle
11648 C If we reach here it means that this side chain reaches the shielding sphere
11649 C Lets add him to the list for gradient
11650         ishield_list(i)=ishield_list(i)+1
11651 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11652 C this list is essential otherwise problem would be O3
11653         shield_list(ishield_list(i),i)=k
11654 C Lets have the sscale value
11655         if (sh_frac_dist.gt.1.0) then
11656          scale_fac_dist=1.0d0
11657          do j=1,3
11658          sh_frac_dist_grad(j)=0.0d0
11659          enddo
11660         else
11661          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11662      &                   *(2.0d0*sh_frac_dist-3.0d0)
11663          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11664      &                  /dist_pep_side/buff_shield*0.5d0
11665 C remember for the final gradient multiply sh_frac_dist_grad(j)
11666 C for side_chain by factor -2 !
11667          do j=1,3
11668          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11669 C         sh_frac_dist_grad(j)=0.0d0
11670 C         scale_fac_dist=1.0d0
11671 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11672 C     &                    sh_frac_dist_grad(j)
11673          enddo
11674         endif
11675 C this is what is now we have the distance scaling now volume...
11676       short=short_r_sidechain(itype(k))
11677       long=long_r_sidechain(itype(k))
11678       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11679       sinthet=short/dist_pep_side*costhet
11680 C now costhet_grad
11681 C       costhet=0.6d0
11682 C       sinthet=0.8
11683        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11684 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11685 C     &             -short/dist_pep_side**2/costhet)
11686 C       costhet_fac=0.0d0
11687        do j=1,3
11688          costhet_grad(j)=costhet_fac*pep_side(j)
11689        enddo
11690 C remember for the final gradient multiply costhet_grad(j)
11691 C for side_chain by factor -2 !
11692 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11693 C pep_side0pept_group is vector multiplication
11694       pep_side0pept_group=0.0d0
11695       do j=1,3
11696       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11697       enddo
11698       cosalfa=(pep_side0pept_group/
11699      & (dist_pep_side*dist_side_calf))
11700       fac_alfa_sin=1.0d0-cosalfa**2
11701       fac_alfa_sin=dsqrt(fac_alfa_sin)
11702       rkprim=fac_alfa_sin*(long-short)+short
11703 C      rkprim=short
11704
11705 C now costhet_grad
11706        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11707 C       cosphi=0.6
11708        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11709        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11710      &      dist_pep_side**2)
11711 C       sinphi=0.8
11712        do j=1,3
11713          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11714      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11715      &*(long-short)/fac_alfa_sin*cosalfa/
11716      &((dist_pep_side*dist_side_calf))*
11717      &((side_calf(j))-cosalfa*
11718      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11719 C       cosphi_grad_long(j)=0.0d0
11720         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11721      &*(long-short)/fac_alfa_sin*cosalfa
11722      &/((dist_pep_side*dist_side_calf))*
11723      &(pep_side(j)-
11724      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11725 C       cosphi_grad_loc(j)=0.0d0
11726        enddo
11727 C      print *,sinphi,sinthet
11728 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
11729 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
11730       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11731      &                    /VSolvSphere_div
11732 C     &                    *wshield
11733 C now the gradient...
11734       do j=1,3
11735       grad_shield(j,i)=grad_shield(j,i)
11736 C gradient po skalowaniu
11737      &                +(sh_frac_dist_grad(j)*VofOverlap
11738 C  gradient po costhet
11739      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11740      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11741      &       sinphi/sinthet*costhet*costhet_grad(j)
11742      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11743      & )*wshield
11744 C grad_shield_side is Cbeta sidechain gradient
11745       grad_shield_side(j,ishield_list(i),i)=
11746      &        (sh_frac_dist_grad(j)*(-2.0d0)
11747      &        *VofOverlap
11748      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11749      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11750      &       sinphi/sinthet*costhet*costhet_grad(j)
11751      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11752      &       )*wshield
11753
11754        grad_shield_loc(j,ishield_list(i),i)=
11755      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11756      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11757      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11758      &        ))
11759      &        *wshield
11760       enddo
11761 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
11762 c     & scale_fac_dist
11763       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11764       enddo
11765       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11766 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
11767 c     &  " wshield",wshield
11768 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
11769       enddo
11770       return
11771       end
11772 C-----------------------------------------------------------------------
11773 C-----------------------------------------------------------
11774 C This subroutine is to mimic the histone like structure but as well can be
11775 C utilizet to nanostructures (infinit) small modification has to be used to
11776 C make it finite (z gradient at the ends has to be changes as well as the x,y
11777 C gradient has to be modified at the ends
11778 C The energy function is Kihara potential
11779 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11780 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11781 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11782 C simple Kihara potential
11783       subroutine calctube(Etube)
11784        implicit real*8 (a-h,o-z)
11785       include 'DIMENSIONS'
11786       include 'COMMON.GEO'
11787       include 'COMMON.VAR'
11788       include 'COMMON.LOCAL'
11789       include 'COMMON.CHAIN'
11790       include 'COMMON.DERIV'
11791       include 'COMMON.NAMES'
11792       include 'COMMON.INTERACT'
11793       include 'COMMON.IOUNITS'
11794       include 'COMMON.CALC'
11795       include 'COMMON.CONTROL'
11796       include 'COMMON.SPLITELE'
11797       include 'COMMON.SBRIDGE'
11798       double precision tub_r,vectube(3),enetube(maxres*2)
11799       Etube=0.0d0
11800       do i=1,2*nres
11801         enetube(i)=0.0d0
11802       enddo
11803 C first we calculate the distance from tube center
11804 C first sugare-phosphate group for NARES this would be peptide group
11805 C for UNRES
11806       do i=1,nres
11807 C lets ommit dummy atoms for now
11808        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11809 C now calculate distance from center of tube and direction vectors
11810       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11811           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11812       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
11813           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11814       vectube(1)=vectube(1)-tubecenter(1)
11815       vectube(2)=vectube(2)-tubecenter(2)
11816
11817 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11818 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11819
11820 C as the tube is infinity we do not calculate the Z-vector use of Z
11821 C as chosen axis
11822       vectube(3)=0.0d0
11823 C now calculte the distance
11824        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11825 C now normalize vector
11826       vectube(1)=vectube(1)/tub_r
11827       vectube(2)=vectube(2)/tub_r
11828 C calculte rdiffrence between r and r0
11829       rdiff=tub_r-tubeR0
11830 C and its 6 power
11831       rdiff6=rdiff**6.0d0
11832 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11833        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11834 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
11835 C       print *,rdiff,rdiff6,pep_aa_tube
11836 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11837 C now we calculate gradient
11838        fac=(-12.0d0*pep_aa_tube/rdiff6+
11839      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
11840 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11841 C     &rdiff,fac
11842
11843 C now direction of gg_tube vector
11844         do j=1,3
11845         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11846         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11847         enddo
11848         enddo
11849 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11850         do i=1,nres
11851 C Lets not jump over memory as we use many times iti
11852          iti=itype(i)
11853 C lets ommit dummy atoms for now
11854          if ((iti.eq.ntyp1)
11855 C in UNRES uncomment the line below as GLY has no side-chain...
11856 C      .or.(iti.eq.10)
11857      &   ) cycle
11858           vectube(1)=c(1,i+nres)
11859           vectube(1)=mod(vectube(1),boxxsize)
11860           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11861           vectube(2)=c(2,i+nres)
11862           vectube(2)=mod(vectube(2),boxxsize)
11863           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11864
11865       vectube(1)=vectube(1)-tubecenter(1)
11866       vectube(2)=vectube(2)-tubecenter(2)
11867
11868 C as the tube is infinity we do not calculate the Z-vector use of Z
11869 C as chosen axis
11870       vectube(3)=0.0d0
11871 C now calculte the distance
11872        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11873 C now normalize vector
11874       vectube(1)=vectube(1)/tub_r
11875       vectube(2)=vectube(2)/tub_r
11876 C calculte rdiffrence between r and r0
11877       rdiff=tub_r-tubeR0
11878 C and its 6 power
11879       rdiff6=rdiff**6.0d0
11880 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11881        sc_aa_tube=sc_aa_tube_par(iti)
11882        sc_bb_tube=sc_bb_tube_par(iti)
11883        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
11884 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11885 C now we calculate gradient
11886        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
11887      &       6.0d0*sc_bb_tube/rdiff6/rdiff
11888 C now direction of gg_tube vector
11889          do j=1,3
11890           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
11891           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
11892          enddo
11893         enddo
11894         do i=1,2*nres
11895           Etube=Etube+enetube(i)
11896         enddo
11897 C        print *,"ETUBE", etube
11898         return
11899         end
11900 C TO DO 1) add to total energy
11901 C       2) add to gradient summation
11902 C       3) add reading parameters (AND of course oppening of PARAM file)
11903 C       4) add reading the center of tube
11904 C       5) add COMMONs
11905 C       6) add to zerograd
11906
11907 C-----------------------------------------------------------------------
11908 C-----------------------------------------------------------
11909 C This subroutine is to mimic the histone like structure but as well can be
11910 C utilizet to nanostructures (infinit) small modification has to be used to
11911 C make it finite (z gradient at the ends has to be changes as well as the x,y
11912 C gradient has to be modified at the ends
11913 C The energy function is Kihara potential
11914 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11915 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11916 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11917 C simple Kihara potential
11918       subroutine calctube2(Etube)
11919        implicit real*8 (a-h,o-z)
11920       include 'DIMENSIONS'
11921       include 'COMMON.GEO'
11922       include 'COMMON.VAR'
11923       include 'COMMON.LOCAL'
11924       include 'COMMON.CHAIN'
11925       include 'COMMON.DERIV'
11926       include 'COMMON.NAMES'
11927       include 'COMMON.INTERACT'
11928       include 'COMMON.IOUNITS'
11929       include 'COMMON.CALC'
11930       include 'COMMON.CONTROL'
11931       include 'COMMON.SPLITELE'
11932       include 'COMMON.SBRIDGE'
11933       double precision tub_r,vectube(3),enetube(maxres*2)
11934       Etube=0.0d0
11935       do i=1,2*nres
11936         enetube(i)=0.0d0
11937       enddo
11938 C first we calculate the distance from tube center
11939 C first sugare-phosphate group for NARES this would be peptide group
11940 C for UNRES
11941       do i=1,nres
11942 C lets ommit dummy atoms for now
11943        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11944 C now calculate distance from center of tube and direction vectors
11945       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11946           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11947       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
11948           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11949       vectube(1)=vectube(1)-tubecenter(1)
11950       vectube(2)=vectube(2)-tubecenter(2)
11951
11952 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11953 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11954
11955 C as the tube is infinity we do not calculate the Z-vector use of Z
11956 C as chosen axis
11957       vectube(3)=0.0d0
11958 C now calculte the distance
11959        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11960 C now normalize vector
11961       vectube(1)=vectube(1)/tub_r
11962       vectube(2)=vectube(2)/tub_r
11963 C calculte rdiffrence between r and r0
11964       rdiff=tub_r-tubeR0
11965 C and its 6 power
11966       rdiff6=rdiff**6.0d0
11967 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11968        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11969 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
11970 C       print *,rdiff,rdiff6,pep_aa_tube
11971 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11972 C now we calculate gradient
11973        fac=(-12.0d0*pep_aa_tube/rdiff6+
11974      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
11975 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11976 C     &rdiff,fac
11977
11978 C now direction of gg_tube vector
11979         do j=1,3
11980         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11981         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11982         enddo
11983         enddo
11984 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11985         do i=1,nres
11986 C Lets not jump over memory as we use many times iti
11987          iti=itype(i)
11988 C lets ommit dummy atoms for now
11989          if ((iti.eq.ntyp1)
11990 C in UNRES uncomment the line below as GLY has no side-chain...
11991      &      .or.(iti.eq.10)
11992      &   ) cycle
11993           vectube(1)=c(1,i+nres)
11994           vectube(1)=mod(vectube(1),boxxsize)
11995           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11996           vectube(2)=c(2,i+nres)
11997           vectube(2)=mod(vectube(2),boxxsize)
11998           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11999
12000       vectube(1)=vectube(1)-tubecenter(1)
12001       vectube(2)=vectube(2)-tubecenter(2)
12002 C THIS FRAGMENT MAKES TUBE FINITE
12003         positi=(mod(c(3,i+nres),boxzsize))
12004         if (positi.le.0) positi=positi+boxzsize
12005 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12006 c for each residue check if it is in lipid or lipid water border area
12007 C       respos=mod(c(3,i+nres),boxzsize)
12008        print *,positi,bordtubebot,buftubebot,bordtubetop
12009        if ((positi.gt.bordtubebot)
12010      & .and.(positi.lt.bordtubetop)) then
12011 C the energy transfer exist
12012         if (positi.lt.buftubebot) then
12013          fracinbuf=1.0d0-
12014      &     ((positi-bordtubebot)/tubebufthick)
12015 C lipbufthick is thickenes of lipid buffore
12016          sstube=sscalelip(fracinbuf)
12017          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12018          print *,ssgradtube, sstube,tubetranene(itype(i))
12019          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12020          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12021      &+ssgradtube*tubetranene(itype(i))
12022          gg_tube(3,i-1)= gg_tube(3,i-1)
12023      &+ssgradtube*tubetranene(itype(i))
12024 C         print *,"doing sccale for lower part"
12025         elseif (positi.gt.buftubetop) then
12026          fracinbuf=1.0d0-
12027      &((bordtubetop-positi)/tubebufthick)
12028          sstube=sscalelip(fracinbuf)
12029          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12030          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12031 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12032 C     &+ssgradtube*tubetranene(itype(i))
12033 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12034 C     &+ssgradtube*tubetranene(itype(i))
12035 C          print *, "doing sscalefor top part",sslip,fracinbuf
12036         else
12037          sstube=1.0d0
12038          ssgradtube=0.0d0
12039          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12040 C         print *,"I am in true lipid"
12041         endif
12042         else
12043 C          sstube=0.0d0
12044 C          ssgradtube=0.0d0
12045         cycle
12046         endif ! if in lipid or buffor
12047 CEND OF FINITE FRAGMENT
12048 C as the tube is infinity we do not calculate the Z-vector use of Z
12049 C as chosen axis
12050       vectube(3)=0.0d0
12051 C now calculte the distance
12052        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12053 C now normalize vector
12054       vectube(1)=vectube(1)/tub_r
12055       vectube(2)=vectube(2)/tub_r
12056 C calculte rdiffrence between r and r0
12057       rdiff=tub_r-tubeR0
12058 C and its 6 power
12059       rdiff6=rdiff**6.0d0
12060 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12061        sc_aa_tube=sc_aa_tube_par(iti)
12062        sc_bb_tube=sc_bb_tube_par(iti)
12063        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12064      &                 *sstube+enetube(i+nres)
12065 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12066 C now we calculate gradient
12067        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12068      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12069 C now direction of gg_tube vector
12070          do j=1,3
12071           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12072           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12073          enddo
12074          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12075      &+ssgradtube*enetube(i+nres)/sstube
12076          gg_tube(3,i-1)= gg_tube(3,i-1)
12077      &+ssgradtube*enetube(i+nres)/sstube
12078
12079         enddo
12080         do i=1,2*nres
12081           Etube=Etube+enetube(i)
12082         enddo
12083 C        print *,"ETUBE", etube
12084         return
12085         end
12086 C TO DO 1) add to total energy
12087 C       2) add to gradient summation
12088 C       3) add reading parameters (AND of course oppening of PARAM file)
12089 C       4) add reading the center of tube
12090 C       5) add COMMONs
12091 C       6) add to zerograd
12092 c----------------------------------------------------------------------------
12093       subroutine e_saxs(Esaxs_constr)
12094       implicit none
12095       include 'DIMENSIONS'
12096 #ifdef MPI
12097       include "mpif.h"
12098       include "COMMON.SETUP"
12099       integer IERR
12100 #endif
12101       include 'COMMON.SBRIDGE'
12102       include 'COMMON.CHAIN'
12103       include 'COMMON.GEO'
12104       include 'COMMON.DERIV'
12105       include 'COMMON.LOCAL'
12106       include 'COMMON.INTERACT'
12107       include 'COMMON.VAR'
12108       include 'COMMON.IOUNITS'
12109       include 'COMMON.MD'
12110       include 'COMMON.CONTROL'
12111       include 'COMMON.NAMES'
12112       include 'COMMON.TIME1'
12113       include 'COMMON.FFIELD'
12114 c
12115       double precision Esaxs_constr
12116       integer i,iint,j,k,l
12117       double precision PgradC(maxSAXS,3,maxres),
12118      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12119 #ifdef MPI
12120       double precision PgradC_(maxSAXS,3,maxres),
12121      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12122 #endif
12123       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12124      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12125      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12126      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12127       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12128       double precision dist,mygauss,mygaussder
12129       external dist
12130       integer llicz,lllicz
12131       double precision time01
12132 c  SAXS restraint penalty function
12133 #ifdef DEBUG
12134       write(iout,*) "------- SAXS penalty function start -------"
12135       write (iout,*) "nsaxs",nsaxs
12136       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12137       write (iout,*) "Psaxs"
12138       do i=1,nsaxs
12139         write (iout,'(i5,e15.5)') i, Psaxs(i)
12140       enddo
12141 #endif
12142 #ifdef TIMING
12143       time01=MPI_Wtime()
12144 #endif
12145       Esaxs_constr = 0.0d0
12146       do k=1,nsaxs
12147         Pcalc(k)=0.0d0
12148         do j=1,nres
12149           do l=1,3
12150             PgradC(k,l,j)=0.0d0
12151             PgradX(k,l,j)=0.0d0
12152           enddo
12153         enddo
12154       enddo
12155 c      lllicz=0
12156       do i=iatsc_s,iatsc_e
12157        if (itype(i).eq.ntyp1) cycle
12158        do iint=1,nint_gr(i)
12159          do j=istart(i,iint),iend(i,iint)
12160            if (itype(j).eq.ntyp1) cycle
12161 #ifdef ALLSAXS
12162            dijCACA=dist(i,j)
12163            dijCASC=dist(i,j+nres)
12164            dijSCCA=dist(i+nres,j)
12165            dijSCSC=dist(i+nres,j+nres)
12166            sigma2CACA=2.0d0/(pstok**2)
12167            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12168            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12169            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12170            do k=1,nsaxs
12171              dk = distsaxs(k)
12172              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12173              if (itype(j).ne.10) then
12174              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12175              else
12176              endif
12177              expCASC = 0.0d0
12178              if (itype(i).ne.10) then
12179              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12180              else
12181              expSCCA = 0.0d0
12182              endif
12183              if (itype(i).ne.10 .and. itype(j).ne.10) then
12184              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12185              else
12186              expSCSC = 0.0d0
12187              endif
12188              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12189 #ifdef DEBUG
12190              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12191 #endif
12192              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12193              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12194              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12195              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12196              do l=1,3
12197 c CA CA
12198                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12199                PgradC(k,l,i) = PgradC(k,l,i)-aux
12200                PgradC(k,l,j) = PgradC(k,l,j)+aux
12201 c CA SC
12202                if (itype(j).ne.10) then
12203                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12204                PgradC(k,l,i) = PgradC(k,l,i)-aux
12205                PgradC(k,l,j) = PgradC(k,l,j)+aux
12206                PgradX(k,l,j) = PgradX(k,l,j)+aux
12207                endif
12208 c SC CA
12209                if (itype(i).ne.10) then
12210                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12211                PgradX(k,l,i) = PgradX(k,l,i)-aux
12212                PgradC(k,l,i) = PgradC(k,l,i)-aux
12213                PgradC(k,l,j) = PgradC(k,l,j)+aux
12214                endif
12215 c SC SC
12216                if (itype(i).ne.10 .and. itype(j).ne.10) then
12217                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12218                PgradC(k,l,i) = PgradC(k,l,i)-aux
12219                PgradC(k,l,j) = PgradC(k,l,j)+aux
12220                PgradX(k,l,i) = PgradX(k,l,i)-aux
12221                PgradX(k,l,j) = PgradX(k,l,j)+aux
12222                endif
12223              enddo ! l
12224            enddo ! k
12225 #else
12226            dijCACA=dist(i,j)
12227            sigma2CACA=scal_rad**2*0.25d0/
12228      &        (restok(itype(j))**2+restok(itype(i))**2)
12229 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12230 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12231 #ifdef MYGAUSS
12232            sigmaCACA=dsqrt(sigma2CACA)
12233            threesig=3.0d0/sigmaCACA
12234 c           llicz=0
12235            do k=1,nsaxs
12236              dk = distsaxs(k)
12237              if (dabs(dijCACA-dk).ge.threesig) cycle
12238 c             llicz=llicz+1
12239 c             lllicz=lllicz+1
12240              aux = sigmaCACA*(dijCACA-dk)
12241              expCACA = mygauss(aux)
12242 c             if (expcaca.eq.0.0d0) cycle
12243              Pcalc(k) = Pcalc(k)+expCACA
12244              CACAgrad = -sigmaCACA*mygaussder(aux)
12245 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12246              do l=1,3
12247                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12248                PgradC(k,l,i) = PgradC(k,l,i)-aux
12249                PgradC(k,l,j) = PgradC(k,l,j)+aux
12250              enddo ! l
12251            enddo ! k
12252 c           write (iout,*) "i",i," j",j," llicz",llicz
12253 #else
12254            IF (saxs_cutoff.eq.0) THEN
12255            do k=1,nsaxs
12256              dk = distsaxs(k)
12257              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12258              Pcalc(k) = Pcalc(k)+expCACA
12259              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12260              do l=1,3
12261                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12262                PgradC(k,l,i) = PgradC(k,l,i)-aux
12263                PgradC(k,l,j) = PgradC(k,l,j)+aux
12264              enddo ! l
12265            enddo ! k
12266            ELSE
12267            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12268            do k=1,nsaxs
12269              dk = distsaxs(k)
12270 c             write (2,*) "ijk",i,j,k
12271              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12272              if (sss2.eq.0.0d0) cycle
12273              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12274              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12275      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12276      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
12277      &           sss2,ssgrad2
12278              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12279              Pcalc(k) = Pcalc(k)+expCACA
12280 #ifdef DEBUG
12281              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12282 #endif
12283              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12284      &             ssgrad2*expCACA/sss2
12285              do l=1,3
12286 c CA CA
12287                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12288                PgradC(k,l,i) = PgradC(k,l,i)+aux
12289                PgradC(k,l,j) = PgradC(k,l,j)-aux
12290              enddo ! l
12291            enddo ! k
12292            ENDIF
12293 #endif
12294 #endif
12295          enddo ! j
12296        enddo ! iint
12297       enddo ! i
12298 c#ifdef TIMING
12299 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
12300 c#endif
12301 c      write (iout,*) "lllicz",lllicz
12302 c#ifdef TIMING
12303 c      time01=MPI_Wtime()
12304 c#endif
12305 #ifdef MPI
12306       if (nfgtasks.gt.1) then
12307        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12308      &    MPI_SUM,FG_COMM,IERR)
12309 c        if (fg_rank.eq.king) then
12310           do k=1,nsaxs
12311             Pcalc(k) = Pcalc_(k)
12312           enddo
12313 c        endif
12314 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12315 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12316 c        if (fg_rank.eq.king) then
12317 c          do i=1,nres
12318 c            do l=1,3
12319 c              do k=1,nsaxs
12320 c                PgradC(k,l,i) = PgradC_(k,l,i)
12321 c              enddo
12322 c            enddo
12323 c          enddo
12324 c        endif
12325 #ifdef ALLSAXS
12326 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12327 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12328 c        if (fg_rank.eq.king) then
12329 c          do i=1,nres
12330 c            do l=1,3
12331 c              do k=1,nsaxs
12332 c                PgradX(k,l,i) = PgradX_(k,l,i)
12333 c              enddo
12334 c            enddo
12335 c          enddo
12336 c        endif
12337 #endif
12338       endif
12339 #endif
12340       Cnorm = 0.0d0
12341       do k=1,nsaxs
12342         Cnorm = Cnorm + Pcalc(k)
12343       enddo
12344 #ifdef MPI
12345       if (fg_rank.eq.king) then
12346 #endif
12347       Esaxs_constr = dlog(Cnorm)-wsaxs0
12348       do k=1,nsaxs
12349         if (Pcalc(k).gt.0.0d0)
12350      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12351 #ifdef DEBUG
12352         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12353 #endif
12354       enddo
12355 #ifdef DEBUG
12356       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12357 #endif
12358 #ifdef MPI
12359       endif
12360 #endif
12361       gsaxsC=0.0d0
12362       gsaxsX=0.0d0
12363       do i=nnt,nct
12364         do l=1,3
12365           auxC=0.0d0
12366           auxC1=0.0d0
12367           auxX=0.0d0
12368           auxX1=0.d0
12369           do k=1,nsaxs
12370             if (Pcalc(k).gt.0)
12371      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12372             auxC1 = auxC1+PgradC(k,l,i)
12373 #ifdef ALLSAXS
12374             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12375             auxX1 = auxX1+PgradX(k,l,i)
12376 #endif
12377           enddo
12378           gsaxsC(l,i) = auxC - auxC1/Cnorm
12379 #ifdef ALLSAXS
12380           gsaxsX(l,i) = auxX - auxX1/Cnorm
12381 #endif
12382 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12383 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
12384 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12385 c     *     " gradX",wsaxs*gsaxsX(l,i)
12386         enddo
12387       enddo
12388 #ifdef TIMING
12389       time_SAXS=time_SAXS+MPI_Wtime()-time01
12390 #endif
12391 #ifdef DEBUG
12392       write (iout,*) "gsaxsc"
12393       do i=nnt,nct
12394         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
12395       enddo
12396 #endif
12397 #ifdef MPI
12398 c      endif
12399 #endif
12400       return
12401       end
12402 c----------------------------------------------------------------------------
12403       subroutine e_saxsC(Esaxs_constr)
12404       implicit none
12405       include 'DIMENSIONS'
12406 #ifdef MPI
12407       include "mpif.h"
12408       include "COMMON.SETUP"
12409       integer IERR
12410 #endif
12411       include 'COMMON.SBRIDGE'
12412       include 'COMMON.CHAIN'
12413       include 'COMMON.GEO'
12414       include 'COMMON.DERIV'
12415       include 'COMMON.LOCAL'
12416       include 'COMMON.INTERACT'
12417       include 'COMMON.VAR'
12418       include 'COMMON.IOUNITS'
12419       include 'COMMON.MD'
12420       include 'COMMON.CONTROL'
12421       include 'COMMON.NAMES'
12422       include 'COMMON.TIME1'
12423       include 'COMMON.FFIELD'
12424 c
12425       double precision Esaxs_constr
12426       integer i,iint,j,k,l
12427       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
12428 #ifdef MPI
12429       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
12430 #endif
12431       double precision dk,dijCASPH,dijSCSPH,
12432      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
12433      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
12434      & auxX,auxX1,Cnorm
12435 c  SAXS restraint penalty function
12436 #ifdef DEBUG
12437       write(iout,*) "------- SAXS penalty function start -------"
12438       write (iout,*) "nsaxs",nsaxs
12439
12440       do i=nnt,nct
12441         print *,MyRank,"C",i,(C(j,i),j=1,3)
12442       enddo
12443       do i=nnt,nct
12444         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
12445       enddo
12446 #endif
12447       Esaxs_constr = 0.0d0
12448       logPtot=0.0d0
12449       do j=isaxs_start,isaxs_end
12450         Pcalc=0.0d0
12451         do i=1,nres
12452           do l=1,3
12453             PgradC(l,i)=0.0d0
12454             PgradX(l,i)=0.0d0
12455           enddo
12456         enddo
12457         do i=nnt,nct
12458           if (itype(i).eq.ntyp1) cycle
12459           dijCASPH=0.0d0
12460           dijSCSPH=0.0d0
12461           do l=1,3
12462             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
12463           enddo
12464           if (itype(i).ne.10) then
12465           do l=1,3
12466             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
12467           enddo
12468           endif
12469           sigma2CA=2.0d0/pstok**2
12470           sigma2SC=4.0d0/restok(itype(i))**2
12471           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
12472           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
12473           Pcalc = Pcalc+expCASPH+expSCSPH
12474 #ifdef DEBUG
12475           write(*,*) "processor i j Pcalc",
12476      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
12477 #endif
12478           CASPHgrad = sigma2CA*expCASPH
12479           SCSPHgrad = sigma2SC*expSCSPH
12480           do l=1,3
12481             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
12482             PgradX(l,i) = PgradX(l,i) + aux
12483             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
12484           enddo ! l
12485         enddo ! i
12486         do i=nnt,nct
12487           do l=1,3
12488             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
12489             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
12490           enddo
12491         enddo
12492         logPtot = logPtot - dlog(Pcalc)
12493 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
12494 c     &    " logPtot",logPtot
12495       enddo ! j
12496 #ifdef MPI
12497       if (nfgtasks.gt.1) then
12498 c        write (iout,*) "logPtot before reduction",logPtot
12499         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
12500      &    MPI_SUM,king,FG_COMM,IERR)
12501         logPtot = logPtot_
12502 c        write (iout,*) "logPtot after reduction",logPtot
12503         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
12504      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12505         if (fg_rank.eq.king) then
12506           do i=1,nres
12507             do l=1,3
12508               gsaxsC(l,i) = gsaxsC_(l,i)
12509             enddo
12510           enddo
12511         endif
12512         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
12513      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12514         if (fg_rank.eq.king) then
12515           do i=1,nres
12516             do l=1,3
12517               gsaxsX(l,i) = gsaxsX_(l,i)
12518             enddo
12519           enddo
12520         endif
12521       endif
12522 #endif
12523       Esaxs_constr = logPtot
12524       return
12525       end
12526 c----------------------------------------------------------------------------
12527       double precision function sscale2(r,r_cut,r0,rlamb)
12528       implicit none
12529       double precision r,gamm,r_cut,r0,rlamb,rr
12530       rr = dabs(r-r0)
12531 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
12532 c      write (2,*) "rr",rr
12533       if(rr.lt.r_cut-rlamb) then
12534         sscale2=1.0d0
12535       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
12536         gamm=(rr-(r_cut-rlamb))/rlamb
12537         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12538       else
12539         sscale2=0d0
12540       endif
12541       return
12542       end
12543 C-----------------------------------------------------------------------
12544       double precision function sscalgrad2(r,r_cut,r0,rlamb)
12545       implicit none
12546       double precision r,gamm,r_cut,r0,rlamb,rr
12547       rr = dabs(r-r0)
12548       if(rr.lt.r_cut-rlamb) then
12549         sscalgrad2=0.0d0
12550       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
12551         gamm=(rr-(r_cut-rlamb))/rlamb
12552         if (r.ge.r0) then
12553           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
12554         else
12555           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
12556         endif
12557       else
12558         sscalgrad2=0.0d0
12559       endif
12560       return
12561       end