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

   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),ggg_peak(3,100)
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," link_start_peak",link_start_peak,
5768 c     &  " link_end_peak",link_end_peak
5769       if (link_end.eq.0.and.link_end_peak.eq.0) return
5770       do i=link_start_peak,link_end_peak
5771         ehpb_peak=0.0d0
5772 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5773 c     &   ipeak(1,i),ipeak(2,i)
5774         do ip=ipeak(1,i),ipeak(2,i)
5775           ii=ihpb_peak(ip)
5776           jj=jhpb_peak(ip)
5777           dd=dist(ii,jj)
5778           iip=ip-ipeak(1,i)+1
5779 C iii and jjj point to the residues for which the distance is assigned.
5780           if (ii.gt.nres) then
5781             iii=ii-nres
5782             jjj=jj-nres
5783           else
5784             iii=ii
5785             jjj=jj
5786           endif
5787           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5788           aux=dexp(-scal_peak*aux)
5789           ehpb_peak=ehpb_peak+aux
5790           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5791      &      forcon_peak(ip))*aux/dd
5792           do j=1,3
5793             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5794           enddo
5795           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5796      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5797      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5798         enddo
5799 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5800         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5801         do ip=ipeak(1,i),ipeak(2,i)
5802           iip=ip-ipeak(1,i)+1
5803           do j=1,3
5804             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5805           enddo
5806           ii=ihpb_peak(ip)
5807           jj=jhpb_peak(ip)
5808 C iii and jjj point to the residues for which the distance is assigned.
5809           if (ii.gt.nres) then
5810             iii=ii-nres
5811             jjj=jj-nres
5812           else
5813             iii=ii
5814             jjj=jj
5815           endif
5816           if (iii.lt.ii) then
5817             do j=1,3
5818               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5819               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5820             enddo
5821           endif
5822           do k=1,3
5823             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5824             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5825           enddo
5826         enddo
5827       enddo
5828       do i=link_start,link_end
5829 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5830 C CA-CA distance used in regularization of structure.
5831         ii=ihpb(i)
5832         jj=jhpb(i)
5833 C iii and jjj point to the residues for which the distance is assigned.
5834         if (ii.gt.nres) then
5835           iii=ii-nres
5836           jjj=jj-nres
5837         else
5838           iii=ii
5839           jjj=jj
5840         endif
5841 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5842 c     &    dhpb(i),dhpb1(i),forcon(i)
5843 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5844 C    distance and angle dependent SS bond potential.
5845 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5846 C     & iabs(itype(jjj)).eq.1) then
5847 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5848 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5849         if (.not.dyn_ss .and. i.le.nss) then
5850 C 15/02/13 CC dynamic SSbond - additional check
5851           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5852      &        iabs(itype(jjj)).eq.1) then
5853            call ssbond_ene(iii,jjj,eij)
5854            ehpb=ehpb+2*eij
5855          endif
5856 cd          write (iout,*) "eij",eij
5857 cd   &   ' waga=',waga,' fac=',fac
5858 !        else if (ii.gt.nres .and. jj.gt.nres) then
5859         else
5860 C Calculate the distance between the two points and its difference from the
5861 C target distance.
5862           dd=dist(ii,jj)
5863           if (irestr_type(i).eq.11) then
5864             ehpb=ehpb+fordepth(i)!**4.0d0
5865      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5866             fac=fordepth(i)!**4.0d0
5867      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5868             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5869      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5870      &        ehpb,irestr_type(i)
5871           else if (irestr_type(i).eq.10) then
5872 c AL 6//19/2018 cross-link restraints
5873             xdis = 0.5d0*(dd/forcon(i))**2
5874             expdis = dexp(-xdis)
5875 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5876             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5877 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5878 c     &          " wboltzd",wboltzd
5879             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5880 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5881             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5882      &           *expdis/(aux*forcon(i)**2)
5883             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5884      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5885      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5886           else if (irestr_type(i).eq.2) then
5887 c Quartic restraints
5888             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5889             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5890      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5891      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5892             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5893           else
5894 c Quadratic restraints
5895             rdis=dd-dhpb(i)
5896 C Get the force constant corresponding to this distance.
5897             waga=forcon(i)
5898 C Calculate the contribution to energy.
5899             ehpb=ehpb+0.5d0*waga*rdis*rdis
5900             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5901      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5902      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5903 C
5904 C Evaluate gradient.
5905 C
5906             fac=waga*rdis/dd
5907           endif
5908 c Calculate Cartesian gradient
5909           do j=1,3
5910             ggg(j)=fac*(c(j,jj)-c(j,ii))
5911           enddo
5912 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5913 C If this is a SC-SC distance, we need to calculate the contributions to the
5914 C Cartesian gradient in the SC vectors (ghpbx).
5915           if (iii.lt.ii) then
5916             do j=1,3
5917               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5918               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5919             enddo
5920           endif
5921           do k=1,3
5922             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5923             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5924           enddo
5925         endif
5926       enddo
5927       return
5928       end
5929 C--------------------------------------------------------------------------
5930       subroutine ssbond_ene(i,j,eij)
5931 C
5932 C Calculate the distance and angle dependent SS-bond potential energy
5933 C using a free-energy function derived based on RHF/6-31G** ab initio
5934 C calculations of diethyl disulfide.
5935 C
5936 C A. Liwo and U. Kozlowska, 11/24/03
5937 C
5938       implicit real*8 (a-h,o-z)
5939       include 'DIMENSIONS'
5940       include 'COMMON.SBRIDGE'
5941       include 'COMMON.CHAIN'
5942       include 'COMMON.DERIV'
5943       include 'COMMON.LOCAL'
5944       include 'COMMON.INTERACT'
5945       include 'COMMON.VAR'
5946       include 'COMMON.IOUNITS'
5947       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
5948       itypi=iabs(itype(i))
5949       xi=c(1,nres+i)
5950       yi=c(2,nres+i)
5951       zi=c(3,nres+i)
5952       dxi=dc_norm(1,nres+i)
5953       dyi=dc_norm(2,nres+i)
5954       dzi=dc_norm(3,nres+i)
5955 c      dsci_inv=dsc_inv(itypi)
5956       dsci_inv=vbld_inv(nres+i)
5957       itypj=iabs(itype(j))
5958 c      dscj_inv=dsc_inv(itypj)
5959       dscj_inv=vbld_inv(nres+j)
5960       xj=c(1,nres+j)-xi
5961       yj=c(2,nres+j)-yi
5962       zj=c(3,nres+j)-zi
5963       dxj=dc_norm(1,nres+j)
5964       dyj=dc_norm(2,nres+j)
5965       dzj=dc_norm(3,nres+j)
5966       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5967       rij=dsqrt(rrij)
5968       erij(1)=xj*rij
5969       erij(2)=yj*rij
5970       erij(3)=zj*rij
5971       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
5972       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
5973       om12=dxi*dxj+dyi*dyj+dzi*dzj
5974       do k=1,3
5975         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
5976         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
5977       enddo
5978       rij=1.0d0/rij
5979       deltad=rij-d0cm
5980       deltat1=1.0d0-om1
5981       deltat2=1.0d0+om2
5982       deltat12=om2-om1+2.0d0
5983       cosphi=om12-om1*om2
5984       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
5985      &  +akct*deltad*deltat12
5986      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
5987 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
5988 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
5989 c     &  " deltat12",deltat12," eij",eij
5990       ed=2*akcm*deltad+akct*deltat12
5991       pom1=akct*deltad
5992       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
5993       eom1=-2*akth*deltat1-pom1-om2*pom2
5994       eom2= 2*akth*deltat2+pom1-om1*pom2
5995       eom12=pom2
5996       do k=1,3
5997         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
5998         ghpbx(k,i)=ghpbx(k,i)-ggk
5999      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6000      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6001         ghpbx(k,j)=ghpbx(k,j)+ggk
6002      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6003      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6004         ghpbc(k,i)=ghpbc(k,i)-ggk
6005         ghpbc(k,j)=ghpbc(k,j)+ggk
6006       enddo
6007 C
6008 C Calculate the components of the gradient in DC and X
6009 C
6010 cgrad      do k=i,j-1
6011 cgrad        do l=1,3
6012 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6013 cgrad        enddo
6014 cgrad      enddo
6015       return
6016       end
6017 C--------------------------------------------------------------------------
6018       subroutine ebond(estr)
6019 c
6020 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6021 c
6022       implicit real*8 (a-h,o-z)
6023       include 'DIMENSIONS'
6024       include 'COMMON.LOCAL'
6025       include 'COMMON.GEO'
6026       include 'COMMON.INTERACT'
6027       include 'COMMON.DERIV'
6028       include 'COMMON.VAR'
6029       include 'COMMON.CHAIN'
6030       include 'COMMON.IOUNITS'
6031       include 'COMMON.NAMES'
6032       include 'COMMON.FFIELD'
6033       include 'COMMON.CONTROL'
6034       include 'COMMON.SETUP'
6035       double precision u(3),ud(3)
6036       estr=0.0d0
6037       estr1=0.0d0
6038       do i=ibondp_start,ibondp_end
6039         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6040 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6041 c          do j=1,3
6042 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6043 c     &      *dc(j,i-1)/vbld(i)
6044 c          enddo
6045 c          if (energy_dec) write(iout,*)
6046 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6047 c        else
6048 C       Checking if it involves dummy (NH3+ or COO-) group
6049          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6050 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6051         diff = vbld(i)-vbldpDUM
6052         if (energy_dec) write(iout,*) "dum_bond",i,diff
6053          else
6054 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6055         diff = vbld(i)-vbldp0
6056          endif
6057         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6058      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6059         estr=estr+diff*diff
6060         do j=1,3
6061           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6062         enddo
6063 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6064 c        endif
6065       enddo
6066
6067       estr=0.5d0*AKP*estr+estr1
6068 c
6069 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6070 c
6071       do i=ibond_start,ibond_end
6072         iti=iabs(itype(i))
6073         if (iti.ne.10 .and. iti.ne.ntyp1) then
6074           nbi=nbondterm(iti)
6075           if (nbi.eq.1) then
6076             diff=vbld(i+nres)-vbldsc0(1,iti)
6077             if (energy_dec)  write (iout,*)
6078      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6079      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6080             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6081             do j=1,3
6082               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6083             enddo
6084           else
6085             do j=1,nbi
6086               diff=vbld(i+nres)-vbldsc0(j,iti)
6087               ud(j)=aksc(j,iti)*diff
6088               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6089             enddo
6090             uprod=u(1)
6091             do j=2,nbi
6092               uprod=uprod*u(j)
6093             enddo
6094             usum=0.0d0
6095             usumsqder=0.0d0
6096             do j=1,nbi
6097               uprod1=1.0d0
6098               uprod2=1.0d0
6099               do k=1,nbi
6100                 if (k.ne.j) then
6101                   uprod1=uprod1*u(k)
6102                   uprod2=uprod2*u(k)*u(k)
6103                 endif
6104               enddo
6105               usum=usum+uprod1
6106               usumsqder=usumsqder+ud(j)*uprod2
6107             enddo
6108             estr=estr+uprod/usum
6109             do j=1,3
6110              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6111             enddo
6112           endif
6113         endif
6114       enddo
6115       return
6116       end
6117 #ifdef CRYST_THETA
6118 C--------------------------------------------------------------------------
6119       subroutine ebend(etheta)
6120 C
6121 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6122 C angles gamma and its derivatives in consecutive thetas and gammas.
6123 C
6124       implicit real*8 (a-h,o-z)
6125       include 'DIMENSIONS'
6126       include 'COMMON.LOCAL'
6127       include 'COMMON.GEO'
6128       include 'COMMON.INTERACT'
6129       include 'COMMON.DERIV'
6130       include 'COMMON.VAR'
6131       include 'COMMON.CHAIN'
6132       include 'COMMON.IOUNITS'
6133       include 'COMMON.NAMES'
6134       include 'COMMON.FFIELD'
6135       include 'COMMON.CONTROL'
6136       include 'COMMON.TORCNSTR'
6137       common /calcthet/ term1,term2,termm,diffak,ratak,
6138      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6139      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6140       double precision y(2),z(2)
6141       delta=0.02d0*pi
6142 c      time11=dexp(-2*time)
6143 c      time12=1.0d0
6144       etheta=0.0D0
6145 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6146       do i=ithet_start,ithet_end
6147         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6148      &  .or.itype(i).eq.ntyp1) cycle
6149 C Zero the energy function and its derivative at 0 or pi.
6150         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6151         it=itype(i-1)
6152         ichir1=isign(1,itype(i-2))
6153         ichir2=isign(1,itype(i))
6154          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6155          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6156          if (itype(i-1).eq.10) then
6157           itype1=isign(10,itype(i-2))
6158           ichir11=isign(1,itype(i-2))
6159           ichir12=isign(1,itype(i-2))
6160           itype2=isign(10,itype(i))
6161           ichir21=isign(1,itype(i))
6162           ichir22=isign(1,itype(i))
6163          endif
6164
6165         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6166 #ifdef OSF
6167           phii=phi(i)
6168           if (phii.ne.phii) phii=150.0
6169 #else
6170           phii=phi(i)
6171 #endif
6172           y(1)=dcos(phii)
6173           y(2)=dsin(phii)
6174         else
6175           y(1)=0.0D0
6176           y(2)=0.0D0
6177         endif
6178         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6179 #ifdef OSF
6180           phii1=phi(i+1)
6181           if (phii1.ne.phii1) phii1=150.0
6182           phii1=pinorm(phii1)
6183           z(1)=cos(phii1)
6184 #else
6185           phii1=phi(i+1)
6186 #endif
6187           z(1)=dcos(phii1)
6188           z(2)=dsin(phii1)
6189         else
6190           z(1)=0.0D0
6191           z(2)=0.0D0
6192         endif
6193 C Calculate the "mean" value of theta from the part of the distribution
6194 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6195 C In following comments this theta will be referred to as t_c.
6196         thet_pred_mean=0.0d0
6197         do k=1,2
6198             athetk=athet(k,it,ichir1,ichir2)
6199             bthetk=bthet(k,it,ichir1,ichir2)
6200           if (it.eq.10) then
6201              athetk=athet(k,itype1,ichir11,ichir12)
6202              bthetk=bthet(k,itype2,ichir21,ichir22)
6203           endif
6204          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6205 c         write(iout,*) 'chuj tu', y(k),z(k)
6206         enddo
6207         dthett=thet_pred_mean*ssd
6208         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6209 C Derivatives of the "mean" values in gamma1 and gamma2.
6210         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6211      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6212          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6213      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6214          if (it.eq.10) then
6215       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6216      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6217         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6218      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6219          endif
6220         if (theta(i).gt.pi-delta) then
6221           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6222      &         E_tc0)
6223           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6224           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6225           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6226      &        E_theta)
6227           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6228      &        E_tc)
6229         else if (theta(i).lt.delta) then
6230           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6231           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6232           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6233      &        E_theta)
6234           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6235           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6236      &        E_tc)
6237         else
6238           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6239      &        E_theta,E_tc)
6240         endif
6241         etheta=etheta+ethetai
6242         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6243      &      'ebend',i,ethetai,theta(i),itype(i)
6244         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6245         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6246         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6247       enddo
6248
6249 C Ufff.... We've done all this!!!
6250       return
6251       end
6252 C---------------------------------------------------------------------------
6253       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6254      &     E_tc)
6255       implicit real*8 (a-h,o-z)
6256       include 'DIMENSIONS'
6257       include 'COMMON.LOCAL'
6258       include 'COMMON.IOUNITS'
6259       common /calcthet/ term1,term2,termm,diffak,ratak,
6260      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6261      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6262 C Calculate the contributions to both Gaussian lobes.
6263 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6264 C The "polynomial part" of the "standard deviation" of this part of
6265 C the distributioni.
6266 ccc        write (iout,*) thetai,thet_pred_mean
6267         sig=polthet(3,it)
6268         do j=2,0,-1
6269           sig=sig*thet_pred_mean+polthet(j,it)
6270         enddo
6271 C Derivative of the "interior part" of the "standard deviation of the"
6272 C gamma-dependent Gaussian lobe in t_c.
6273         sigtc=3*polthet(3,it)
6274         do j=2,1,-1
6275           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6276         enddo
6277         sigtc=sig*sigtc
6278 C Set the parameters of both Gaussian lobes of the distribution.
6279 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6280         fac=sig*sig+sigc0(it)
6281         sigcsq=fac+fac
6282         sigc=1.0D0/sigcsq
6283 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6284         sigsqtc=-4.0D0*sigcsq*sigtc
6285 c       print *,i,sig,sigtc,sigsqtc
6286 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6287         sigtc=-sigtc/(fac*fac)
6288 C Following variable is sigma(t_c)**(-2)
6289         sigcsq=sigcsq*sigcsq
6290         sig0i=sig0(it)
6291         sig0inv=1.0D0/sig0i**2
6292         delthec=thetai-thet_pred_mean
6293         delthe0=thetai-theta0i
6294         term1=-0.5D0*sigcsq*delthec*delthec
6295         term2=-0.5D0*sig0inv*delthe0*delthe0
6296 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6297 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6298 C NaNs in taking the logarithm. We extract the largest exponent which is added
6299 C to the energy (this being the log of the distribution) at the end of energy
6300 C term evaluation for this virtual-bond angle.
6301         if (term1.gt.term2) then
6302           termm=term1
6303           term2=dexp(term2-termm)
6304           term1=1.0d0
6305         else
6306           termm=term2
6307           term1=dexp(term1-termm)
6308           term2=1.0d0
6309         endif
6310 C The ratio between the gamma-independent and gamma-dependent lobes of
6311 C the distribution is a Gaussian function of thet_pred_mean too.
6312         diffak=gthet(2,it)-thet_pred_mean
6313         ratak=diffak/gthet(3,it)**2
6314         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6315 C Let's differentiate it in thet_pred_mean NOW.
6316         aktc=ak*ratak
6317 C Now put together the distribution terms to make complete distribution.
6318         termexp=term1+ak*term2
6319         termpre=sigc+ak*sig0i
6320 C Contribution of the bending energy from this theta is just the -log of
6321 C the sum of the contributions from the two lobes and the pre-exponential
6322 C factor. Simple enough, isn't it?
6323         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6324 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6325 C NOW the derivatives!!!
6326 C 6/6/97 Take into account the deformation.
6327         E_theta=(delthec*sigcsq*term1
6328      &       +ak*delthe0*sig0inv*term2)/termexp
6329         E_tc=((sigtc+aktc*sig0i)/termpre
6330      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6331      &       aktc*term2)/termexp)
6332       return
6333       end
6334 c-----------------------------------------------------------------------------
6335       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6336       implicit real*8 (a-h,o-z)
6337       include 'DIMENSIONS'
6338       include 'COMMON.LOCAL'
6339       include 'COMMON.IOUNITS'
6340       common /calcthet/ term1,term2,termm,diffak,ratak,
6341      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6342      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6343       delthec=thetai-thet_pred_mean
6344       delthe0=thetai-theta0i
6345 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6346       t3 = thetai-thet_pred_mean
6347       t6 = t3**2
6348       t9 = term1
6349       t12 = t3*sigcsq
6350       t14 = t12+t6*sigsqtc
6351       t16 = 1.0d0
6352       t21 = thetai-theta0i
6353       t23 = t21**2
6354       t26 = term2
6355       t27 = t21*t26
6356       t32 = termexp
6357       t40 = t32**2
6358       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6359      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6360      & *(-t12*t9-ak*sig0inv*t27)
6361       return
6362       end
6363 #else
6364 C--------------------------------------------------------------------------
6365       subroutine ebend(etheta)
6366 C
6367 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6368 C angles gamma and its derivatives in consecutive thetas and gammas.
6369 C ab initio-derived potentials from
6370 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6371 C
6372       implicit real*8 (a-h,o-z)
6373       include 'DIMENSIONS'
6374       include 'COMMON.LOCAL'
6375       include 'COMMON.GEO'
6376       include 'COMMON.INTERACT'
6377       include 'COMMON.DERIV'
6378       include 'COMMON.VAR'
6379       include 'COMMON.CHAIN'
6380       include 'COMMON.IOUNITS'
6381       include 'COMMON.NAMES'
6382       include 'COMMON.FFIELD'
6383       include 'COMMON.CONTROL'
6384       include 'COMMON.TORCNSTR'
6385       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6386      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6387      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6388      & sinph1ph2(maxdouble,maxdouble)
6389       logical lprn /.false./, lprn1 /.false./
6390       etheta=0.0D0
6391       do i=ithet_start,ithet_end
6392 c        print *,i,itype(i-1),itype(i),itype(i-2)
6393         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6394      &  .or.itype(i).eq.ntyp1) cycle
6395 C        print *,i,theta(i)
6396         if (iabs(itype(i+1)).eq.20) iblock=2
6397         if (iabs(itype(i+1)).ne.20) iblock=1
6398         dethetai=0.0d0
6399         dephii=0.0d0
6400         dephii1=0.0d0
6401         theti2=0.5d0*theta(i)
6402         ityp2=ithetyp((itype(i-1)))
6403         do k=1,nntheterm
6404           coskt(k)=dcos(k*theti2)
6405           sinkt(k)=dsin(k*theti2)
6406         enddo
6407 C        print *,ethetai
6408         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6409 #ifdef OSF
6410           phii=phi(i)
6411           if (phii.ne.phii) phii=150.0
6412 #else
6413           phii=phi(i)
6414 #endif
6415           ityp1=ithetyp((itype(i-2)))
6416 C propagation of chirality for glycine type
6417           do k=1,nsingle
6418             cosph1(k)=dcos(k*phii)
6419             sinph1(k)=dsin(k*phii)
6420           enddo
6421         else
6422           phii=0.0d0
6423           do k=1,nsingle
6424           ityp1=ithetyp((itype(i-2)))
6425             cosph1(k)=0.0d0
6426             sinph1(k)=0.0d0
6427           enddo
6428         endif
6429         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6430 #ifdef OSF
6431           phii1=phi(i+1)
6432           if (phii1.ne.phii1) phii1=150.0
6433           phii1=pinorm(phii1)
6434 #else
6435           phii1=phi(i+1)
6436 #endif
6437           ityp3=ithetyp((itype(i)))
6438           do k=1,nsingle
6439             cosph2(k)=dcos(k*phii1)
6440             sinph2(k)=dsin(k*phii1)
6441           enddo
6442         else
6443           phii1=0.0d0
6444           ityp3=ithetyp((itype(i)))
6445           do k=1,nsingle
6446             cosph2(k)=0.0d0
6447             sinph2(k)=0.0d0
6448           enddo
6449         endif
6450         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6451         do k=1,ndouble
6452           do l=1,k-1
6453             ccl=cosph1(l)*cosph2(k-l)
6454             ssl=sinph1(l)*sinph2(k-l)
6455             scl=sinph1(l)*cosph2(k-l)
6456             csl=cosph1(l)*sinph2(k-l)
6457             cosph1ph2(l,k)=ccl-ssl
6458             cosph1ph2(k,l)=ccl+ssl
6459             sinph1ph2(l,k)=scl+csl
6460             sinph1ph2(k,l)=scl-csl
6461           enddo
6462         enddo
6463         if (lprn) then
6464         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6465      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6466         write (iout,*) "coskt and sinkt"
6467         do k=1,nntheterm
6468           write (iout,*) k,coskt(k),sinkt(k)
6469         enddo
6470         endif
6471         do k=1,ntheterm
6472           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6473           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6474      &      *coskt(k)
6475           if (lprn)
6476      &    write (iout,*) "k",k,"
6477      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6478      &     " ethetai",ethetai
6479         enddo
6480         if (lprn) then
6481         write (iout,*) "cosph and sinph"
6482         do k=1,nsingle
6483           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6484         enddo
6485         write (iout,*) "cosph1ph2 and sinph2ph2"
6486         do k=2,ndouble
6487           do l=1,k-1
6488             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6489      &         sinph1ph2(l,k),sinph1ph2(k,l)
6490           enddo
6491         enddo
6492         write(iout,*) "ethetai",ethetai
6493         endif
6494 C       print *,ethetai
6495         do m=1,ntheterm2
6496           do k=1,nsingle
6497             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6498      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6499      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6500      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6501             ethetai=ethetai+sinkt(m)*aux
6502             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6503             dephii=dephii+k*sinkt(m)*(
6504      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6505      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6506             dephii1=dephii1+k*sinkt(m)*(
6507      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6508      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6509             if (lprn)
6510      &      write (iout,*) "m",m," k",k," bbthet",
6511      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6512      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6513      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6514      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6515 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6516           enddo
6517         enddo
6518 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6519 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6520 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6521 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6522         if (lprn)
6523      &  write(iout,*) "ethetai",ethetai
6524 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6525         do m=1,ntheterm3
6526           do k=2,ndouble
6527             do l=1,k-1
6528               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6529      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6530      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6531      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6532               ethetai=ethetai+sinkt(m)*aux
6533               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6534               dephii=dephii+l*sinkt(m)*(
6535      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6536      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6537      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6538      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6539               dephii1=dephii1+(k-l)*sinkt(m)*(
6540      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6541      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6542      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6543      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6544               if (lprn) then
6545               write (iout,*) "m",m," k",k," l",l," ffthet",
6546      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6547      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6548      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6549      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6550      &            " ethetai",ethetai
6551               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6552      &            cosph1ph2(k,l)*sinkt(m),
6553      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6554               endif
6555             enddo
6556           enddo
6557         enddo
6558 10      continue
6559 c        lprn1=.true.
6560 C        print *,ethetai
6561         if (lprn1)
6562      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6563      &   i,theta(i)*rad2deg,phii*rad2deg,
6564      &   phii1*rad2deg,ethetai
6565 c        lprn1=.false.
6566         etheta=etheta+ethetai
6567         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6568         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6569         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6570       enddo
6571
6572       return
6573       end
6574 #endif
6575 #ifdef CRYST_SC
6576 c-----------------------------------------------------------------------------
6577       subroutine esc(escloc)
6578 C Calculate the local energy of a side chain and its derivatives in the
6579 C corresponding virtual-bond valence angles THETA and the spherical angles
6580 C ALPHA and OMEGA.
6581       implicit real*8 (a-h,o-z)
6582       include 'DIMENSIONS'
6583       include 'COMMON.GEO'
6584       include 'COMMON.LOCAL'
6585       include 'COMMON.VAR'
6586       include 'COMMON.INTERACT'
6587       include 'COMMON.DERIV'
6588       include 'COMMON.CHAIN'
6589       include 'COMMON.IOUNITS'
6590       include 'COMMON.NAMES'
6591       include 'COMMON.FFIELD'
6592       include 'COMMON.CONTROL'
6593       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6594      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6595       common /sccalc/ time11,time12,time112,theti,it,nlobit
6596       delta=0.02d0*pi
6597       escloc=0.0D0
6598 c     write (iout,'(a)') 'ESC'
6599       do i=loc_start,loc_end
6600         it=itype(i)
6601         if (it.eq.ntyp1) cycle
6602         if (it.eq.10) goto 1
6603         nlobit=nlob(iabs(it))
6604 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6605 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6606         theti=theta(i+1)-pipol
6607         x(1)=dtan(theti)
6608         x(2)=alph(i)
6609         x(3)=omeg(i)
6610
6611         if (x(2).gt.pi-delta) then
6612           xtemp(1)=x(1)
6613           xtemp(2)=pi-delta
6614           xtemp(3)=x(3)
6615           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6616           xtemp(2)=pi
6617           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6618           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6619      &        escloci,dersc(2))
6620           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6621      &        ddersc0(1),dersc(1))
6622           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6623      &        ddersc0(3),dersc(3))
6624           xtemp(2)=pi-delta
6625           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6626           xtemp(2)=pi
6627           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6628           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6629      &            dersc0(2),esclocbi,dersc02)
6630           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6631      &            dersc12,dersc01)
6632           call splinthet(x(2),0.5d0*delta,ss,ssd)
6633           dersc0(1)=dersc01
6634           dersc0(2)=dersc02
6635           dersc0(3)=0.0d0
6636           do k=1,3
6637             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6638           enddo
6639           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6640 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6641 c    &             esclocbi,ss,ssd
6642           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6643 c         escloci=esclocbi
6644 c         write (iout,*) escloci
6645         else if (x(2).lt.delta) then
6646           xtemp(1)=x(1)
6647           xtemp(2)=delta
6648           xtemp(3)=x(3)
6649           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6650           xtemp(2)=0.0d0
6651           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6652           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6653      &        escloci,dersc(2))
6654           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6655      &        ddersc0(1),dersc(1))
6656           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6657      &        ddersc0(3),dersc(3))
6658           xtemp(2)=delta
6659           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6660           xtemp(2)=0.0d0
6661           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6662           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6663      &            dersc0(2),esclocbi,dersc02)
6664           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6665      &            dersc12,dersc01)
6666           dersc0(1)=dersc01
6667           dersc0(2)=dersc02
6668           dersc0(3)=0.0d0
6669           call splinthet(x(2),0.5d0*delta,ss,ssd)
6670           do k=1,3
6671             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6672           enddo
6673           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6674 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6675 c    &             esclocbi,ss,ssd
6676           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6677 c         write (iout,*) escloci
6678         else
6679           call enesc(x,escloci,dersc,ddummy,.false.)
6680         endif
6681
6682         escloc=escloc+escloci
6683         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6684      &     'escloc',i,escloci
6685 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6686
6687         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6688      &   wscloc*dersc(1)
6689         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6690         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6691     1   continue
6692       enddo
6693       return
6694       end
6695 C---------------------------------------------------------------------------
6696       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6697       implicit real*8 (a-h,o-z)
6698       include 'DIMENSIONS'
6699       include 'COMMON.GEO'
6700       include 'COMMON.LOCAL'
6701       include 'COMMON.IOUNITS'
6702       common /sccalc/ time11,time12,time112,theti,it,nlobit
6703       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6704       double precision contr(maxlob,-1:1)
6705       logical mixed
6706 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6707         escloc_i=0.0D0
6708         do j=1,3
6709           dersc(j)=0.0D0
6710           if (mixed) ddersc(j)=0.0d0
6711         enddo
6712         x3=x(3)
6713
6714 C Because of periodicity of the dependence of the SC energy in omega we have
6715 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6716 C To avoid underflows, first compute & store the exponents.
6717
6718         do iii=-1,1
6719
6720           x(3)=x3+iii*dwapi
6721
6722           do j=1,nlobit
6723             do k=1,3
6724               z(k)=x(k)-censc(k,j,it)
6725             enddo
6726             do k=1,3
6727               Axk=0.0D0
6728               do l=1,3
6729                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6730               enddo
6731               Ax(k,j,iii)=Axk
6732             enddo
6733             expfac=0.0D0
6734             do k=1,3
6735               expfac=expfac+Ax(k,j,iii)*z(k)
6736             enddo
6737             contr(j,iii)=expfac
6738           enddo ! j
6739
6740         enddo ! iii
6741
6742         x(3)=x3
6743 C As in the case of ebend, we want to avoid underflows in exponentiation and
6744 C subsequent NaNs and INFs in energy calculation.
6745 C Find the largest exponent
6746         emin=contr(1,-1)
6747         do iii=-1,1
6748           do j=1,nlobit
6749             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6750           enddo
6751         enddo
6752         emin=0.5D0*emin
6753 cd      print *,'it=',it,' emin=',emin
6754
6755 C Compute the contribution to SC energy and derivatives
6756         do iii=-1,1
6757
6758           do j=1,nlobit
6759 #ifdef OSF
6760             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6761             if(adexp.ne.adexp) adexp=1.0
6762             expfac=dexp(adexp)
6763 #else
6764             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6765 #endif
6766 cd          print *,'j=',j,' expfac=',expfac
6767             escloc_i=escloc_i+expfac
6768             do k=1,3
6769               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6770             enddo
6771             if (mixed) then
6772               do k=1,3,2
6773                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6774      &            +gaussc(k,2,j,it))*expfac
6775               enddo
6776             endif
6777           enddo
6778
6779         enddo ! iii
6780
6781         dersc(1)=dersc(1)/cos(theti)**2
6782         ddersc(1)=ddersc(1)/cos(theti)**2
6783         ddersc(3)=ddersc(3)
6784
6785         escloci=-(dlog(escloc_i)-emin)
6786         do j=1,3
6787           dersc(j)=dersc(j)/escloc_i
6788         enddo
6789         if (mixed) then
6790           do j=1,3,2
6791             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6792           enddo
6793         endif
6794       return
6795       end
6796 C------------------------------------------------------------------------------
6797       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6798       implicit real*8 (a-h,o-z)
6799       include 'DIMENSIONS'
6800       include 'COMMON.GEO'
6801       include 'COMMON.LOCAL'
6802       include 'COMMON.IOUNITS'
6803       common /sccalc/ time11,time12,time112,theti,it,nlobit
6804       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6805       double precision contr(maxlob)
6806       logical mixed
6807
6808       escloc_i=0.0D0
6809
6810       do j=1,3
6811         dersc(j)=0.0D0
6812       enddo
6813
6814       do j=1,nlobit
6815         do k=1,2
6816           z(k)=x(k)-censc(k,j,it)
6817         enddo
6818         z(3)=dwapi
6819         do k=1,3
6820           Axk=0.0D0
6821           do l=1,3
6822             Axk=Axk+gaussc(l,k,j,it)*z(l)
6823           enddo
6824           Ax(k,j)=Axk
6825         enddo
6826         expfac=0.0D0
6827         do k=1,3
6828           expfac=expfac+Ax(k,j)*z(k)
6829         enddo
6830         contr(j)=expfac
6831       enddo ! j
6832
6833 C As in the case of ebend, we want to avoid underflows in exponentiation and
6834 C subsequent NaNs and INFs in energy calculation.
6835 C Find the largest exponent
6836       emin=contr(1)
6837       do j=1,nlobit
6838         if (emin.gt.contr(j)) emin=contr(j)
6839       enddo
6840       emin=0.5D0*emin
6841
6842 C Compute the contribution to SC energy and derivatives
6843
6844       dersc12=0.0d0
6845       do j=1,nlobit
6846         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6847         escloc_i=escloc_i+expfac
6848         do k=1,2
6849           dersc(k)=dersc(k)+Ax(k,j)*expfac
6850         enddo
6851         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6852      &            +gaussc(1,2,j,it))*expfac
6853         dersc(3)=0.0d0
6854       enddo
6855
6856       dersc(1)=dersc(1)/cos(theti)**2
6857       dersc12=dersc12/cos(theti)**2
6858       escloci=-(dlog(escloc_i)-emin)
6859       do j=1,2
6860         dersc(j)=dersc(j)/escloc_i
6861       enddo
6862       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6863       return
6864       end
6865 #else
6866 c----------------------------------------------------------------------------------
6867       subroutine esc(escloc)
6868 C Calculate the local energy of a side chain and its derivatives in the
6869 C corresponding virtual-bond valence angles THETA and the spherical angles
6870 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6871 C added by Urszula Kozlowska. 07/11/2007
6872 C
6873       implicit real*8 (a-h,o-z)
6874       include 'DIMENSIONS'
6875       include 'COMMON.GEO'
6876       include 'COMMON.LOCAL'
6877       include 'COMMON.VAR'
6878       include 'COMMON.SCROT'
6879       include 'COMMON.INTERACT'
6880       include 'COMMON.DERIV'
6881       include 'COMMON.CHAIN'
6882       include 'COMMON.IOUNITS'
6883       include 'COMMON.NAMES'
6884       include 'COMMON.FFIELD'
6885       include 'COMMON.CONTROL'
6886       include 'COMMON.VECTORS'
6887       double precision x_prime(3),y_prime(3),z_prime(3)
6888      &    , sumene,dsc_i,dp2_i,x(65),
6889      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6890      &    de_dxx,de_dyy,de_dzz,de_dt
6891       double precision s1_t,s1_6_t,s2_t,s2_6_t
6892       double precision
6893      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6894      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6895      & dt_dCi(3),dt_dCi1(3)
6896       common /sccalc/ time11,time12,time112,theti,it,nlobit
6897       delta=0.02d0*pi
6898       escloc=0.0D0
6899       do i=loc_start,loc_end
6900         if (itype(i).eq.ntyp1) cycle
6901         costtab(i+1) =dcos(theta(i+1))
6902         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6903         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6904         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6905         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6906         cosfac=dsqrt(cosfac2)
6907         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6908         sinfac=dsqrt(sinfac2)
6909         it=iabs(itype(i))
6910         if (it.eq.10) goto 1
6911 c
6912 C  Compute the axes of tghe local cartesian coordinates system; store in
6913 c   x_prime, y_prime and z_prime
6914 c
6915         do j=1,3
6916           x_prime(j) = 0.00
6917           y_prime(j) = 0.00
6918           z_prime(j) = 0.00
6919         enddo
6920 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6921 C     &   dc_norm(3,i+nres)
6922         do j = 1,3
6923           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6924           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6925         enddo
6926         do j = 1,3
6927           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6928         enddo
6929 c       write (2,*) "i",i
6930 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6931 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6932 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6933 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6934 c      & " xy",scalar(x_prime(1),y_prime(1)),
6935 c      & " xz",scalar(x_prime(1),z_prime(1)),
6936 c      & " yy",scalar(y_prime(1),y_prime(1)),
6937 c      & " yz",scalar(y_prime(1),z_prime(1)),
6938 c      & " zz",scalar(z_prime(1),z_prime(1))
6939 c
6940 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6941 C to local coordinate system. Store in xx, yy, zz.
6942 c
6943         xx=0.0d0
6944         yy=0.0d0
6945         zz=0.0d0
6946         do j = 1,3
6947           xx = xx + x_prime(j)*dc_norm(j,i+nres)
6948           yy = yy + y_prime(j)*dc_norm(j,i+nres)
6949           zz = zz + z_prime(j)*dc_norm(j,i+nres)
6950         enddo
6951
6952         xxtab(i)=xx
6953         yytab(i)=yy
6954         zztab(i)=zz
6955 C
6956 C Compute the energy of the ith side cbain
6957 C
6958 c        write (2,*) "xx",xx," yy",yy," zz",zz
6959         it=iabs(itype(i))
6960         do j = 1,65
6961           x(j) = sc_parmin(j,it)
6962         enddo
6963 #ifdef CHECK_COORD
6964 Cc diagnostics - remove later
6965         xx1 = dcos(alph(2))
6966         yy1 = dsin(alph(2))*dcos(omeg(2))
6967         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
6968         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
6969      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
6970      &    xx1,yy1,zz1
6971 C,"  --- ", xx_w,yy_w,zz_w
6972 c end diagnostics
6973 #endif
6974         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
6975      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
6976      &   + x(10)*yy*zz
6977         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
6978      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
6979      & + x(20)*yy*zz
6980         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
6981      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
6982      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
6983      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
6984      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
6985      &  +x(40)*xx*yy*zz
6986         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
6987      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
6988      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
6989      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
6990      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
6991      &  +x(60)*xx*yy*zz
6992         dsc_i   = 0.743d0+x(61)
6993         dp2_i   = 1.9d0+x(62)
6994         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6995      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
6996         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
6997      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
6998         s1=(1+x(63))/(0.1d0 + dscp1)
6999         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7000         s2=(1+x(65))/(0.1d0 + dscp2)
7001         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7002         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7003      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7004 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7005 c     &   sumene4,
7006 c     &   dscp1,dscp2,sumene
7007 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7008         escloc = escloc + sumene
7009 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7010 c     & ,zz,xx,yy
7011 c#define DEBUG
7012 #ifdef DEBUG
7013 C
7014 C This section to check the numerical derivatives of the energy of ith side
7015 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7016 C #define DEBUG in the code to turn it on.
7017 C
7018         write (2,*) "sumene               =",sumene
7019         aincr=1.0d-7
7020         xxsave=xx
7021         xx=xx+aincr
7022         write (2,*) xx,yy,zz
7023         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7024         de_dxx_num=(sumenep-sumene)/aincr
7025         xx=xxsave
7026         write (2,*) "xx+ sumene from enesc=",sumenep
7027         yysave=yy
7028         yy=yy+aincr
7029         write (2,*) xx,yy,zz
7030         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7031         de_dyy_num=(sumenep-sumene)/aincr
7032         yy=yysave
7033         write (2,*) "yy+ sumene from enesc=",sumenep
7034         zzsave=zz
7035         zz=zz+aincr
7036         write (2,*) xx,yy,zz
7037         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7038         de_dzz_num=(sumenep-sumene)/aincr
7039         zz=zzsave
7040         write (2,*) "zz+ sumene from enesc=",sumenep
7041         costsave=cost2tab(i+1)
7042         sintsave=sint2tab(i+1)
7043         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7044         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7045         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7046         de_dt_num=(sumenep-sumene)/aincr
7047         write (2,*) " t+ sumene from enesc=",sumenep
7048         cost2tab(i+1)=costsave
7049         sint2tab(i+1)=sintsave
7050 C End of diagnostics section.
7051 #endif
7052 C
7053 C Compute the gradient of esc
7054 C
7055 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7056         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7057         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7058         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7059         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7060         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7061         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7062         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7063         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7064         pom1=(sumene3*sint2tab(i+1)+sumene1)
7065      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7066         pom2=(sumene4*cost2tab(i+1)+sumene2)
7067      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7068         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7069         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7070      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7071      &  +x(40)*yy*zz
7072         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7073         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7074      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7075      &  +x(60)*yy*zz
7076         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7077      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7078      &        +(pom1+pom2)*pom_dx
7079 #ifdef DEBUG
7080         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7081 #endif
7082 C
7083         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7084         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7085      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7086      &  +x(40)*xx*zz
7087         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7088         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7089      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7090      &  +x(59)*zz**2 +x(60)*xx*zz
7091         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7092      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7093      &        +(pom1-pom2)*pom_dy
7094 #ifdef DEBUG
7095         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7096 #endif
7097 C
7098         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7099      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7100      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7101      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7102      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7103      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7104      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7105      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7106 #ifdef DEBUG
7107         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7108 #endif
7109 C
7110         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7111      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7112      &  +pom1*pom_dt1+pom2*pom_dt2
7113 #ifdef DEBUG
7114         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7115 #endif
7116 c#undef DEBUG
7117 c
7118 C
7119        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7120        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7121        cosfac2xx=cosfac2*xx
7122        sinfac2yy=sinfac2*yy
7123        do k = 1,3
7124          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7125      &      vbld_inv(i+1)
7126          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7127      &      vbld_inv(i)
7128          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7129          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7130 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7131 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7132 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7133 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7134          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7135          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7136          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7137          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7138          dZZ_Ci1(k)=0.0d0
7139          dZZ_Ci(k)=0.0d0
7140          do j=1,3
7141            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7142      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7143            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7144      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7145          enddo
7146
7147          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7148          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7149          dZZ_XYZ(k)=vbld_inv(i+nres)*
7150      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7151 c
7152          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7153          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7154        enddo
7155
7156        do k=1,3
7157          dXX_Ctab(k,i)=dXX_Ci(k)
7158          dXX_C1tab(k,i)=dXX_Ci1(k)
7159          dYY_Ctab(k,i)=dYY_Ci(k)
7160          dYY_C1tab(k,i)=dYY_Ci1(k)
7161          dZZ_Ctab(k,i)=dZZ_Ci(k)
7162          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7163          dXX_XYZtab(k,i)=dXX_XYZ(k)
7164          dYY_XYZtab(k,i)=dYY_XYZ(k)
7165          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7166        enddo
7167
7168        do k = 1,3
7169 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7170 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7171 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7172 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7173 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7174 c     &    dt_dci(k)
7175 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7176 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7177          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7178      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7179          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7180      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7181          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7182      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7183        enddo
7184 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7185 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7186
7187 C to check gradient call subroutine check_grad
7188
7189     1 continue
7190       enddo
7191       return
7192       end
7193 c------------------------------------------------------------------------------
7194       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7195       implicit none
7196       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7197      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7198       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7199      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7200      &   + x(10)*yy*zz
7201       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7202      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7203      & + x(20)*yy*zz
7204       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7205      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7206      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7207      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7208      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7209      &  +x(40)*xx*yy*zz
7210       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7211      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7212      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7213      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7214      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7215      &  +x(60)*xx*yy*zz
7216       dsc_i   = 0.743d0+x(61)
7217       dp2_i   = 1.9d0+x(62)
7218       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7219      &          *(xx*cost2+yy*sint2))
7220       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7221      &          *(xx*cost2-yy*sint2))
7222       s1=(1+x(63))/(0.1d0 + dscp1)
7223       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7224       s2=(1+x(65))/(0.1d0 + dscp2)
7225       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7226       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7227      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7228       enesc=sumene
7229       return
7230       end
7231 #endif
7232 c------------------------------------------------------------------------------
7233       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7234 C
7235 C This procedure calculates two-body contact function g(rij) and its derivative:
7236 C
7237 C           eps0ij                                     !       x < -1
7238 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7239 C            0                                         !       x > 1
7240 C
7241 C where x=(rij-r0ij)/delta
7242 C
7243 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7244 C
7245       implicit none
7246       double precision rij,r0ij,eps0ij,fcont,fprimcont
7247       double precision x,x2,x4,delta
7248 c     delta=0.02D0*r0ij
7249 c      delta=0.2D0*r0ij
7250       x=(rij-r0ij)/delta
7251       if (x.lt.-1.0D0) then
7252         fcont=eps0ij
7253         fprimcont=0.0D0
7254       else if (x.le.1.0D0) then
7255         x2=x*x
7256         x4=x2*x2
7257         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7258         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7259       else
7260         fcont=0.0D0
7261         fprimcont=0.0D0
7262       endif
7263       return
7264       end
7265 c------------------------------------------------------------------------------
7266       subroutine splinthet(theti,delta,ss,ssder)
7267       implicit real*8 (a-h,o-z)
7268       include 'DIMENSIONS'
7269       include 'COMMON.VAR'
7270       include 'COMMON.GEO'
7271       thetup=pi-delta
7272       thetlow=delta
7273       if (theti.gt.pipol) then
7274         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7275       else
7276         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7277         ssder=-ssder
7278       endif
7279       return
7280       end
7281 c------------------------------------------------------------------------------
7282       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7283       implicit none
7284       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7285       double precision ksi,ksi2,ksi3,a1,a2,a3
7286       a1=fprim0*delta/(f1-f0)
7287       a2=3.0d0-2.0d0*a1
7288       a3=a1-2.0d0
7289       ksi=(x-x0)/delta
7290       ksi2=ksi*ksi
7291       ksi3=ksi2*ksi
7292       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7293       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7294       return
7295       end
7296 c------------------------------------------------------------------------------
7297       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7298       implicit none
7299       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7300       double precision ksi,ksi2,ksi3,a1,a2,a3
7301       ksi=(x-x0)/delta
7302       ksi2=ksi*ksi
7303       ksi3=ksi2*ksi
7304       a1=fprim0x*delta
7305       a2=3*(f1x-f0x)-2*fprim0x*delta
7306       a3=fprim0x*delta-2*(f1x-f0x)
7307       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7308       return
7309       end
7310 C-----------------------------------------------------------------------------
7311 #ifdef CRYST_TOR
7312 C-----------------------------------------------------------------------------
7313       subroutine etor(etors)
7314       implicit real*8 (a-h,o-z)
7315       include 'DIMENSIONS'
7316       include 'COMMON.VAR'
7317       include 'COMMON.GEO'
7318       include 'COMMON.LOCAL'
7319       include 'COMMON.TORSION'
7320       include 'COMMON.INTERACT'
7321       include 'COMMON.DERIV'
7322       include 'COMMON.CHAIN'
7323       include 'COMMON.NAMES'
7324       include 'COMMON.IOUNITS'
7325       include 'COMMON.FFIELD'
7326       include 'COMMON.TORCNSTR'
7327       include 'COMMON.CONTROL'
7328       logical lprn
7329 C Set lprn=.true. for debugging
7330       lprn=.false.
7331 c      lprn=.true.
7332       etors=0.0D0
7333       do i=iphi_start,iphi_end
7334       etors_ii=0.0D0
7335         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7336      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7337         itori=itortyp(itype(i-2))
7338         itori1=itortyp(itype(i-1))
7339         phii=phi(i)
7340         gloci=0.0D0
7341 C Proline-Proline pair is a special case...
7342         if (itori.eq.3 .and. itori1.eq.3) then
7343           if (phii.gt.-dwapi3) then
7344             cosphi=dcos(3*phii)
7345             fac=1.0D0/(1.0D0-cosphi)
7346             etorsi=v1(1,3,3)*fac
7347             etorsi=etorsi+etorsi
7348             etors=etors+etorsi-v1(1,3,3)
7349             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7350             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7351           endif
7352           do j=1,3
7353             v1ij=v1(j+1,itori,itori1)
7354             v2ij=v2(j+1,itori,itori1)
7355             cosphi=dcos(j*phii)
7356             sinphi=dsin(j*phii)
7357             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7358             if (energy_dec) etors_ii=etors_ii+
7359      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7360             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7361           enddo
7362         else
7363           do j=1,nterm_old
7364             v1ij=v1(j,itori,itori1)
7365             v2ij=v2(j,itori,itori1)
7366             cosphi=dcos(j*phii)
7367             sinphi=dsin(j*phii)
7368             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7369             if (energy_dec) etors_ii=etors_ii+
7370      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7371             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7372           enddo
7373         endif
7374         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7375              'etor',i,etors_ii
7376         if (lprn)
7377      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7378      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7379      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7380         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7381 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7382       enddo
7383       return
7384       end
7385 c------------------------------------------------------------------------------
7386       subroutine etor_d(etors_d)
7387       etors_d=0.0d0
7388       return
7389       end
7390 c----------------------------------------------------------------------------
7391 #else
7392       subroutine etor(etors)
7393       implicit real*8 (a-h,o-z)
7394       include 'DIMENSIONS'
7395       include 'COMMON.VAR'
7396       include 'COMMON.GEO'
7397       include 'COMMON.LOCAL'
7398       include 'COMMON.TORSION'
7399       include 'COMMON.INTERACT'
7400       include 'COMMON.DERIV'
7401       include 'COMMON.CHAIN'
7402       include 'COMMON.NAMES'
7403       include 'COMMON.IOUNITS'
7404       include 'COMMON.FFIELD'
7405       include 'COMMON.TORCNSTR'
7406       include 'COMMON.CONTROL'
7407       logical lprn
7408 C Set lprn=.true. for debugging
7409       lprn=.false.
7410 c     lprn=.true.
7411       etors=0.0D0
7412       do i=iphi_start,iphi_end
7413 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7414 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7415 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7416 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7417         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7418      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7419 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7420 C For introducing the NH3+ and COO- group please check the etor_d for reference
7421 C and guidance
7422         etors_ii=0.0D0
7423          if (iabs(itype(i)).eq.20) then
7424          iblock=2
7425          else
7426          iblock=1
7427          endif
7428         itori=itortyp(itype(i-2))
7429         itori1=itortyp(itype(i-1))
7430         phii=phi(i)
7431         gloci=0.0D0
7432 C Regular cosine and sine terms
7433         do j=1,nterm(itori,itori1,iblock)
7434           v1ij=v1(j,itori,itori1,iblock)
7435           v2ij=v2(j,itori,itori1,iblock)
7436           cosphi=dcos(j*phii)
7437           sinphi=dsin(j*phii)
7438           etors=etors+v1ij*cosphi+v2ij*sinphi
7439           if (energy_dec) etors_ii=etors_ii+
7440      &                v1ij*cosphi+v2ij*sinphi
7441           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7442         enddo
7443 C Lorentz terms
7444 C                         v1
7445 C  E = SUM ----------------------------------- - v1
7446 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7447 C
7448         cosphi=dcos(0.5d0*phii)
7449         sinphi=dsin(0.5d0*phii)
7450         do j=1,nlor(itori,itori1,iblock)
7451           vl1ij=vlor1(j,itori,itori1)
7452           vl2ij=vlor2(j,itori,itori1)
7453           vl3ij=vlor3(j,itori,itori1)
7454           pom=vl2ij*cosphi+vl3ij*sinphi
7455           pom1=1.0d0/(pom*pom+1.0d0)
7456           etors=etors+vl1ij*pom1
7457           if (energy_dec) etors_ii=etors_ii+
7458      &                vl1ij*pom1
7459           pom=-pom*pom1*pom1
7460           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7461         enddo
7462 C Subtract the constant term
7463         etors=etors-v0(itori,itori1,iblock)
7464           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7465      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7466         if (lprn)
7467      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7468      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7469      &  (v1(j,itori,itori1,iblock),j=1,6),
7470      &  (v2(j,itori,itori1,iblock),j=1,6)
7471         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7472 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7473       enddo
7474       return
7475       end
7476 c----------------------------------------------------------------------------
7477       subroutine etor_d(etors_d)
7478 C 6/23/01 Compute double torsional energy
7479       implicit real*8 (a-h,o-z)
7480       include 'DIMENSIONS'
7481       include 'COMMON.VAR'
7482       include 'COMMON.GEO'
7483       include 'COMMON.LOCAL'
7484       include 'COMMON.TORSION'
7485       include 'COMMON.INTERACT'
7486       include 'COMMON.DERIV'
7487       include 'COMMON.CHAIN'
7488       include 'COMMON.NAMES'
7489       include 'COMMON.IOUNITS'
7490       include 'COMMON.FFIELD'
7491       include 'COMMON.TORCNSTR'
7492       logical lprn
7493 C Set lprn=.true. for debugging
7494       lprn=.false.
7495 c     lprn=.true.
7496       etors_d=0.0D0
7497 c      write(iout,*) "a tu??"
7498       do i=iphid_start,iphid_end
7499 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7500 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7501 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7502 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7503 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7504          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7505      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7506      &  (itype(i+1).eq.ntyp1)) cycle
7507 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7508         itori=itortyp(itype(i-2))
7509         itori1=itortyp(itype(i-1))
7510         itori2=itortyp(itype(i))
7511         phii=phi(i)
7512         phii1=phi(i+1)
7513         gloci1=0.0D0
7514         gloci2=0.0D0
7515         iblock=1
7516         if (iabs(itype(i+1)).eq.20) iblock=2
7517 C Iblock=2 Proline type
7518 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7519 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7520 C        if (itype(i+1).eq.ntyp1) iblock=3
7521 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7522 C IS or IS NOT need for this
7523 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7524 C        is (itype(i-3).eq.ntyp1) ntblock=2
7525 C        ntblock is N-terminal blocking group
7526
7527 C Regular cosine and sine terms
7528         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7529 C Example of changes for NH3+ blocking group
7530 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7531 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7532           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7533           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7534           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7535           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7536           cosphi1=dcos(j*phii)
7537           sinphi1=dsin(j*phii)
7538           cosphi2=dcos(j*phii1)
7539           sinphi2=dsin(j*phii1)
7540           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7541      &     v2cij*cosphi2+v2sij*sinphi2
7542           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7543           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7544         enddo
7545         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7546           do l=1,k-1
7547             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7548             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7549             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7550             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7551             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7552             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7553             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7554             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7555             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7556      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7557             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7558      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7559             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7560      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7561           enddo
7562         enddo
7563         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7564         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7565       enddo
7566       return
7567       end
7568 #endif
7569 C----------------------------------------------------------------------------------
7570 C The rigorous attempt to derive energy function
7571       subroutine etor_kcc(etors)
7572       implicit real*8 (a-h,o-z)
7573       include 'DIMENSIONS'
7574       include 'COMMON.VAR'
7575       include 'COMMON.GEO'
7576       include 'COMMON.LOCAL'
7577       include 'COMMON.TORSION'
7578       include 'COMMON.INTERACT'
7579       include 'COMMON.DERIV'
7580       include 'COMMON.CHAIN'
7581       include 'COMMON.NAMES'
7582       include 'COMMON.IOUNITS'
7583       include 'COMMON.FFIELD'
7584       include 'COMMON.TORCNSTR'
7585       include 'COMMON.CONTROL'
7586       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7587       logical lprn
7588 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7589 C Set lprn=.true. for debugging
7590       lprn=energy_dec
7591 c     lprn=.true.
7592 C      print *,"wchodze kcc"
7593       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7594       etors=0.0D0
7595       do i=iphi_start,iphi_end
7596 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7597 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7598 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7599 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7600         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7601      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7602         itori=itortyp(itype(i-2))
7603         itori1=itortyp(itype(i-1))
7604         phii=phi(i)
7605         glocig=0.0D0
7606         glocit1=0.0d0
7607         glocit2=0.0d0
7608 C to avoid multiple devision by 2
7609 c        theti22=0.5d0*theta(i)
7610 C theta 12 is the theta_1 /2
7611 C theta 22 is theta_2 /2
7612 c        theti12=0.5d0*theta(i-1)
7613 C and appropriate sinus function
7614         sinthet1=dsin(theta(i-1))
7615         sinthet2=dsin(theta(i))
7616         costhet1=dcos(theta(i-1))
7617         costhet2=dcos(theta(i))
7618 C to speed up lets store its mutliplication
7619         sint1t2=sinthet2*sinthet1
7620         sint1t2n=1.0d0
7621 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7622 C +d_n*sin(n*gamma)) *
7623 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7624 C we have two sum 1) Non-Chebyshev which is with n and gamma
7625         nval=nterm_kcc_Tb(itori,itori1)
7626         c1(0)=0.0d0
7627         c2(0)=0.0d0
7628         c1(1)=1.0d0
7629         c2(1)=1.0d0
7630         do j=2,nval
7631           c1(j)=c1(j-1)*costhet1
7632           c2(j)=c2(j-1)*costhet2
7633         enddo
7634         etori=0.0d0
7635         do j=1,nterm_kcc(itori,itori1)
7636           cosphi=dcos(j*phii)
7637           sinphi=dsin(j*phii)
7638           sint1t2n1=sint1t2n
7639           sint1t2n=sint1t2n*sint1t2
7640           sumvalc=0.0d0
7641           gradvalct1=0.0d0
7642           gradvalct2=0.0d0
7643           do k=1,nval
7644             do l=1,nval
7645               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7646               gradvalct1=gradvalct1+
7647      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7648               gradvalct2=gradvalct2+
7649      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7650             enddo
7651           enddo
7652           gradvalct1=-gradvalct1*sinthet1
7653           gradvalct2=-gradvalct2*sinthet2
7654           sumvals=0.0d0
7655           gradvalst1=0.0d0
7656           gradvalst2=0.0d0
7657           do k=1,nval
7658             do l=1,nval
7659               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7660               gradvalst1=gradvalst1+
7661      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7662               gradvalst2=gradvalst2+
7663      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7664             enddo
7665           enddo
7666           gradvalst1=-gradvalst1*sinthet1
7667           gradvalst2=-gradvalst2*sinthet2
7668           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7669           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7670 C glocig is the gradient local i site in gamma
7671           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7672 C now gradient over theta_1
7673           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7674      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7675           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7676      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7677         enddo ! j
7678         etors=etors+etori
7679 C derivative over gamma
7680         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7681 C derivative over theta1
7682         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7683 C now derivative over theta2
7684         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7685         if (lprn) then
7686           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7687      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7688           write (iout,*) "c1",(c1(k),k=0,nval),
7689      &    " c2",(c2(k),k=0,nval)
7690         endif
7691       enddo
7692       return
7693       end
7694 c---------------------------------------------------------------------------------------------
7695       subroutine etor_constr(edihcnstr)
7696       implicit real*8 (a-h,o-z)
7697       include 'DIMENSIONS'
7698       include 'COMMON.VAR'
7699       include 'COMMON.GEO'
7700       include 'COMMON.LOCAL'
7701       include 'COMMON.TORSION'
7702       include 'COMMON.INTERACT'
7703       include 'COMMON.DERIV'
7704       include 'COMMON.CHAIN'
7705       include 'COMMON.NAMES'
7706       include 'COMMON.IOUNITS'
7707       include 'COMMON.FFIELD'
7708       include 'COMMON.TORCNSTR'
7709       include 'COMMON.BOUNDS'
7710       include 'COMMON.CONTROL'
7711 ! 6/20/98 - dihedral angle constraints
7712       edihcnstr=0.0d0
7713 c      do i=1,ndih_constr
7714       if (raw_psipred) then
7715         do i=idihconstr_start,idihconstr_end
7716           itori=idih_constr(i)
7717           phii=phi(itori)
7718           gaudih_i=vpsipred(1,i)
7719           gauder_i=0.0d0
7720           do j=1,2
7721             s = sdihed(j,i)
7722             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7723             dexpcos_i=dexp(-cos_i*cos_i)
7724             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7725             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7726      &            *cos_i*dexpcos_i/s**2
7727           enddo
7728           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7729           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7730           if (energy_dec)
7731      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7732      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7733      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7734      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7735      &     -wdihc*dlog(gaudih_i)
7736         enddo
7737       else
7738
7739       do i=idihconstr_start,idihconstr_end
7740         itori=idih_constr(i)
7741         phii=phi(itori)
7742         difi=pinorm(phii-phi0(i))
7743         if (difi.gt.drange(i)) then
7744           difi=difi-drange(i)
7745           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7746           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7747         else if (difi.lt.-drange(i)) then
7748           difi=difi+drange(i)
7749           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7750           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7751         else
7752           difi=0.0
7753         endif
7754       enddo
7755
7756       endif
7757
7758       return
7759       end
7760 c----------------------------------------------------------------------------
7761 C The rigorous attempt to derive energy function
7762       subroutine ebend_kcc(etheta)
7763
7764       implicit real*8 (a-h,o-z)
7765       include 'DIMENSIONS'
7766       include 'COMMON.VAR'
7767       include 'COMMON.GEO'
7768       include 'COMMON.LOCAL'
7769       include 'COMMON.TORSION'
7770       include 'COMMON.INTERACT'
7771       include 'COMMON.DERIV'
7772       include 'COMMON.CHAIN'
7773       include 'COMMON.NAMES'
7774       include 'COMMON.IOUNITS'
7775       include 'COMMON.FFIELD'
7776       include 'COMMON.TORCNSTR'
7777       include 'COMMON.CONTROL'
7778       logical lprn
7779       double precision thybt1(maxang_kcc)
7780 C Set lprn=.true. for debugging
7781       lprn=energy_dec
7782 c     lprn=.true.
7783 C      print *,"wchodze kcc"
7784       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7785       etheta=0.0D0
7786       do i=ithet_start,ithet_end
7787 c        print *,i,itype(i-1),itype(i),itype(i-2)
7788         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7789      &  .or.itype(i).eq.ntyp1) cycle
7790         iti=iabs(itortyp(itype(i-1)))
7791         sinthet=dsin(theta(i))
7792         costhet=dcos(theta(i))
7793         do j=1,nbend_kcc_Tb(iti)
7794           thybt1(j)=v1bend_chyb(j,iti)
7795         enddo
7796         sumth1thyb=v1bend_chyb(0,iti)+
7797      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7798         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7799      &    sumth1thyb
7800         ihelp=nbend_kcc_Tb(iti)-1
7801         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7802         etheta=etheta+sumth1thyb
7803 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7804         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7805       enddo
7806       return
7807       end
7808 c-------------------------------------------------------------------------------------
7809       subroutine etheta_constr(ethetacnstr)
7810
7811       implicit real*8 (a-h,o-z)
7812       include 'DIMENSIONS'
7813       include 'COMMON.VAR'
7814       include 'COMMON.GEO'
7815       include 'COMMON.LOCAL'
7816       include 'COMMON.TORSION'
7817       include 'COMMON.INTERACT'
7818       include 'COMMON.DERIV'
7819       include 'COMMON.CHAIN'
7820       include 'COMMON.NAMES'
7821       include 'COMMON.IOUNITS'
7822       include 'COMMON.FFIELD'
7823       include 'COMMON.TORCNSTR'
7824       include 'COMMON.CONTROL'
7825       ethetacnstr=0.0d0
7826 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7827       do i=ithetaconstr_start,ithetaconstr_end
7828         itheta=itheta_constr(i)
7829         thetiii=theta(itheta)
7830         difi=pinorm(thetiii-theta_constr0(i))
7831         if (difi.gt.theta_drange(i)) then
7832           difi=difi-theta_drange(i)
7833           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7834           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7835      &    +for_thet_constr(i)*difi**3
7836         else if (difi.lt.-drange(i)) then
7837           difi=difi+drange(i)
7838           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7839           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7840      &    +for_thet_constr(i)*difi**3
7841         else
7842           difi=0.0
7843         endif
7844        if (energy_dec) then
7845         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7846      &    i,itheta,rad2deg*thetiii,
7847      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7848      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7849      &    gloc(itheta+nphi-2,icg)
7850         endif
7851       enddo
7852       return
7853       end
7854 c------------------------------------------------------------------------------
7855       subroutine eback_sc_corr(esccor)
7856 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7857 c        conformational states; temporarily implemented as differences
7858 c        between UNRES torsional potentials (dependent on three types of
7859 c        residues) and the torsional potentials dependent on all 20 types
7860 c        of residues computed from AM1  energy surfaces of terminally-blocked
7861 c        amino-acid residues.
7862       implicit real*8 (a-h,o-z)
7863       include 'DIMENSIONS'
7864       include 'COMMON.VAR'
7865       include 'COMMON.GEO'
7866       include 'COMMON.LOCAL'
7867       include 'COMMON.TORSION'
7868       include 'COMMON.SCCOR'
7869       include 'COMMON.INTERACT'
7870       include 'COMMON.DERIV'
7871       include 'COMMON.CHAIN'
7872       include 'COMMON.NAMES'
7873       include 'COMMON.IOUNITS'
7874       include 'COMMON.FFIELD'
7875       include 'COMMON.CONTROL'
7876       logical lprn
7877 C Set lprn=.true. for debugging
7878       lprn=.false.
7879 c      lprn=.true.
7880 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7881       esccor=0.0D0
7882       do i=itau_start,itau_end
7883         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7884         esccor_ii=0.0D0
7885         isccori=isccortyp(itype(i-2))
7886         isccori1=isccortyp(itype(i-1))
7887 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7888         phii=phi(i)
7889         do intertyp=1,3 !intertyp
7890 cc Added 09 May 2012 (Adasko)
7891 cc  Intertyp means interaction type of backbone mainchain correlation:
7892 c   1 = SC...Ca...Ca...Ca
7893 c   2 = Ca...Ca...Ca...SC
7894 c   3 = SC...Ca...Ca...SCi
7895         gloci=0.0D0
7896         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7897      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7898      &      (itype(i-1).eq.ntyp1)))
7899      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7900      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7901      &     .or.(itype(i).eq.ntyp1)))
7902      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7903      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7904      &      (itype(i-3).eq.ntyp1)))) cycle
7905         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7906         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7907      & cycle
7908        do j=1,nterm_sccor(isccori,isccori1)
7909           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7910           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7911           cosphi=dcos(j*tauangle(intertyp,i))
7912           sinphi=dsin(j*tauangle(intertyp,i))
7913           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7914           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7915         enddo
7916 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7917         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7918         if (lprn)
7919      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7920      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7921      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7922      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7923         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7924        enddo !intertyp
7925       enddo
7926
7927       return
7928       end
7929 c----------------------------------------------------------------------------
7930       subroutine multibody(ecorr)
7931 C This subroutine calculates multi-body contributions to energy following
7932 C the idea of Skolnick et al. If side chains I and J make a contact and
7933 C at the same time side chains I+1 and J+1 make a contact, an extra
7934 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7935       implicit real*8 (a-h,o-z)
7936       include 'DIMENSIONS'
7937       include 'COMMON.IOUNITS'
7938       include 'COMMON.DERIV'
7939       include 'COMMON.INTERACT'
7940       include 'COMMON.CONTACTS'
7941       double precision gx(3),gx1(3)
7942       logical lprn
7943
7944 C Set lprn=.true. for debugging
7945       lprn=.false.
7946
7947       if (lprn) then
7948         write (iout,'(a)') 'Contact function values:'
7949         do i=nnt,nct-2
7950           write (iout,'(i2,20(1x,i2,f10.5))')
7951      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
7952         enddo
7953       endif
7954       ecorr=0.0D0
7955       do i=nnt,nct
7956         do j=1,3
7957           gradcorr(j,i)=0.0D0
7958           gradxorr(j,i)=0.0D0
7959         enddo
7960       enddo
7961       do i=nnt,nct-2
7962
7963         DO ISHIFT = 3,4
7964
7965         i1=i+ishift
7966         num_conti=num_cont(i)
7967         num_conti1=num_cont(i1)
7968         do jj=1,num_conti
7969           j=jcont(jj,i)
7970           do kk=1,num_conti1
7971             j1=jcont(kk,i1)
7972             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
7973 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
7974 cd   &                   ' ishift=',ishift
7975 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
7976 C The system gains extra energy.
7977               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
7978             endif   ! j1==j+-ishift
7979           enddo     ! kk
7980         enddo       ! jj
7981
7982         ENDDO ! ISHIFT
7983
7984       enddo         ! i
7985       return
7986       end
7987 c------------------------------------------------------------------------------
7988       double precision function esccorr(i,j,k,l,jj,kk)
7989       implicit real*8 (a-h,o-z)
7990       include 'DIMENSIONS'
7991       include 'COMMON.IOUNITS'
7992       include 'COMMON.DERIV'
7993       include 'COMMON.INTERACT'
7994       include 'COMMON.CONTACTS'
7995       include 'COMMON.SHIELD'
7996       double precision gx(3),gx1(3)
7997       logical lprn
7998       lprn=.false.
7999       eij=facont(jj,i)
8000       ekl=facont(kk,k)
8001 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8002 C Calculate the multi-body contribution to energy.
8003 C Calculate multi-body contributions to the gradient.
8004 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8005 cd   & k,l,(gacont(m,kk,k),m=1,3)
8006       do m=1,3
8007         gx(m) =ekl*gacont(m,jj,i)
8008         gx1(m)=eij*gacont(m,kk,k)
8009         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8010         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8011         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8012         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8013       enddo
8014       do m=i,j-1
8015         do ll=1,3
8016           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8017         enddo
8018       enddo
8019       do m=k,l-1
8020         do ll=1,3
8021           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8022         enddo
8023       enddo
8024       esccorr=-eij*ekl
8025       return
8026       end
8027 c------------------------------------------------------------------------------
8028       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8029 C This subroutine calculates multi-body contributions to hydrogen-bonding
8030       implicit real*8 (a-h,o-z)
8031       include 'DIMENSIONS'
8032       include 'COMMON.IOUNITS'
8033 #ifdef MPI
8034       include "mpif.h"
8035       parameter (max_cont=maxconts)
8036       parameter (max_dim=26)
8037       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8038       double precision zapas(max_dim,maxconts,max_fg_procs),
8039      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8040       common /przechowalnia/ zapas
8041       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8042      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8043 #endif
8044       include 'COMMON.SETUP'
8045       include 'COMMON.FFIELD'
8046       include 'COMMON.DERIV'
8047       include 'COMMON.INTERACT'
8048       include 'COMMON.CONTACTS'
8049       include 'COMMON.CONTROL'
8050       include 'COMMON.LOCAL'
8051       double precision gx(3),gx1(3),time00
8052       logical lprn,ldone
8053
8054 C Set lprn=.true. for debugging
8055       lprn=.false.
8056 #ifdef MPI
8057       n_corr=0
8058       n_corr1=0
8059       if (nfgtasks.le.1) goto 30
8060       if (lprn) then
8061         write (iout,'(a)') 'Contact function values before RECEIVE:'
8062         do i=nnt,nct-2
8063           write (iout,'(2i3,50(1x,i2,f5.2))')
8064      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8065      &    j=1,num_cont_hb(i))
8066         enddo
8067         call flush(iout)
8068       endif
8069       do i=1,ntask_cont_from
8070         ncont_recv(i)=0
8071       enddo
8072       do i=1,ntask_cont_to
8073         ncont_sent(i)=0
8074       enddo
8075 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8076 c     & ntask_cont_to
8077 C Make the list of contacts to send to send to other procesors
8078 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8079 c      call flush(iout)
8080       do i=iturn3_start,iturn3_end
8081 c        write (iout,*) "make contact list turn3",i," num_cont",
8082 c     &    num_cont_hb(i)
8083         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8084       enddo
8085       do i=iturn4_start,iturn4_end
8086 c        write (iout,*) "make contact list turn4",i," num_cont",
8087 c     &   num_cont_hb(i)
8088         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8089       enddo
8090       do ii=1,nat_sent
8091         i=iat_sent(ii)
8092 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8093 c     &    num_cont_hb(i)
8094         do j=1,num_cont_hb(i)
8095         do k=1,4
8096           jjc=jcont_hb(j,i)
8097           iproc=iint_sent_local(k,jjc,ii)
8098 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8099           if (iproc.gt.0) then
8100             ncont_sent(iproc)=ncont_sent(iproc)+1
8101             nn=ncont_sent(iproc)
8102             zapas(1,nn,iproc)=i
8103             zapas(2,nn,iproc)=jjc
8104             zapas(3,nn,iproc)=facont_hb(j,i)
8105             zapas(4,nn,iproc)=ees0p(j,i)
8106             zapas(5,nn,iproc)=ees0m(j,i)
8107             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8108             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8109             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8110             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8111             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8112             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8113             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8114             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8115             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8116             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8117             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8118             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8119             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8120             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8121             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8122             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8123             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8124             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8125             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8126             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8127             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8128           endif
8129         enddo
8130         enddo
8131       enddo
8132       if (lprn) then
8133       write (iout,*)
8134      &  "Numbers of contacts to be sent to other processors",
8135      &  (ncont_sent(i),i=1,ntask_cont_to)
8136       write (iout,*) "Contacts sent"
8137       do ii=1,ntask_cont_to
8138         nn=ncont_sent(ii)
8139         iproc=itask_cont_to(ii)
8140         write (iout,*) nn," contacts to processor",iproc,
8141      &   " of CONT_TO_COMM group"
8142         do i=1,nn
8143           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8144         enddo
8145       enddo
8146       call flush(iout)
8147       endif
8148       CorrelType=477
8149       CorrelID=fg_rank+1
8150       CorrelType1=478
8151       CorrelID1=nfgtasks+fg_rank+1
8152       ireq=0
8153 C Receive the numbers of needed contacts from other processors
8154       do ii=1,ntask_cont_from
8155         iproc=itask_cont_from(ii)
8156         ireq=ireq+1
8157         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8158      &    FG_COMM,req(ireq),IERR)
8159       enddo
8160 c      write (iout,*) "IRECV ended"
8161 c      call flush(iout)
8162 C Send the number of contacts needed by other processors
8163       do ii=1,ntask_cont_to
8164         iproc=itask_cont_to(ii)
8165         ireq=ireq+1
8166         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8167      &    FG_COMM,req(ireq),IERR)
8168       enddo
8169 c      write (iout,*) "ISEND ended"
8170 c      write (iout,*) "number of requests (nn)",ireq
8171 c      call flush(iout)
8172       if (ireq.gt.0)
8173      &  call MPI_Waitall(ireq,req,status_array,ierr)
8174 c      write (iout,*)
8175 c     &  "Numbers of contacts to be received from other processors",
8176 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8177 c      call flush(iout)
8178 C Receive contacts
8179       ireq=0
8180       do ii=1,ntask_cont_from
8181         iproc=itask_cont_from(ii)
8182         nn=ncont_recv(ii)
8183 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8184 c     &   " of CONT_TO_COMM group"
8185 c        call flush(iout)
8186         if (nn.gt.0) then
8187           ireq=ireq+1
8188           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8189      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8190 c          write (iout,*) "ireq,req",ireq,req(ireq)
8191         endif
8192       enddo
8193 C Send the contacts to processors that need them
8194       do ii=1,ntask_cont_to
8195         iproc=itask_cont_to(ii)
8196         nn=ncont_sent(ii)
8197 c        write (iout,*) nn," contacts to processor",iproc,
8198 c     &   " of CONT_TO_COMM group"
8199         if (nn.gt.0) then
8200           ireq=ireq+1
8201           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8202      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8203 c          write (iout,*) "ireq,req",ireq,req(ireq)
8204 c          do i=1,nn
8205 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8206 c          enddo
8207         endif
8208       enddo
8209 c      write (iout,*) "number of requests (contacts)",ireq
8210 c      write (iout,*) "req",(req(i),i=1,4)
8211 c      call flush(iout)
8212       if (ireq.gt.0)
8213      & call MPI_Waitall(ireq,req,status_array,ierr)
8214       do iii=1,ntask_cont_from
8215         iproc=itask_cont_from(iii)
8216         nn=ncont_recv(iii)
8217         if (lprn) then
8218         write (iout,*) "Received",nn," contacts from processor",iproc,
8219      &   " of CONT_FROM_COMM group"
8220         call flush(iout)
8221         do i=1,nn
8222           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8223         enddo
8224         call flush(iout)
8225         endif
8226         do i=1,nn
8227           ii=zapas_recv(1,i,iii)
8228 c Flag the received contacts to prevent double-counting
8229           jj=-zapas_recv(2,i,iii)
8230 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8231 c          call flush(iout)
8232           nnn=num_cont_hb(ii)+1
8233           num_cont_hb(ii)=nnn
8234           jcont_hb(nnn,ii)=jj
8235           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8236           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8237           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8238           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8239           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8240           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8241           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8242           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8243           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8244           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8245           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8246           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8247           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8248           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8249           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8250           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8251           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8252           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8253           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8254           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8255           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8256           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8257           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8258           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8259         enddo
8260       enddo
8261       if (lprn) then
8262         write (iout,'(a)') 'Contact function values after receive:'
8263         do i=nnt,nct-2
8264           write (iout,'(2i3,50(1x,i3,f5.2))')
8265      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8266      &    j=1,num_cont_hb(i))
8267         enddo
8268         call flush(iout)
8269       endif
8270    30 continue
8271 #endif
8272       if (lprn) then
8273         write (iout,'(a)') 'Contact function values:'
8274         do i=nnt,nct-2
8275           write (iout,'(2i3,50(1x,i3,f5.2))')
8276      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8277      &    j=1,num_cont_hb(i))
8278         enddo
8279         call flush(iout)
8280       endif
8281       ecorr=0.0D0
8282 C Remove the loop below after debugging !!!
8283       do i=nnt,nct
8284         do j=1,3
8285           gradcorr(j,i)=0.0D0
8286           gradxorr(j,i)=0.0D0
8287         enddo
8288       enddo
8289 C Calculate the local-electrostatic correlation terms
8290       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8291         i1=i+1
8292         num_conti=num_cont_hb(i)
8293         num_conti1=num_cont_hb(i+1)
8294         do jj=1,num_conti
8295           j=jcont_hb(jj,i)
8296           jp=iabs(j)
8297           do kk=1,num_conti1
8298             j1=jcont_hb(kk,i1)
8299             jp1=iabs(j1)
8300 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8301 c     &         ' jj=',jj,' kk=',kk
8302 c            call flush(iout)
8303             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8304      &          .or. j.lt.0 .and. j1.gt.0) .and.
8305      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8306 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8307 C The system gains extra energy.
8308               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8309               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8310      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8311               n_corr=n_corr+1
8312             else if (j1.eq.j) then
8313 C Contacts I-J and I-(J+1) occur simultaneously.
8314 C The system loses extra energy.
8315 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8316             endif
8317           enddo ! kk
8318           do kk=1,num_conti
8319             j1=jcont_hb(kk,i)
8320 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8321 c    &         ' jj=',jj,' kk=',kk
8322             if (j1.eq.j+1) then
8323 C Contacts I-J and (I+1)-J occur simultaneously.
8324 C The system loses extra energy.
8325 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8326             endif ! j1==j+1
8327           enddo ! kk
8328         enddo ! jj
8329       enddo ! i
8330       return
8331       end
8332 c------------------------------------------------------------------------------
8333       subroutine add_hb_contact(ii,jj,itask)
8334       implicit real*8 (a-h,o-z)
8335       include "DIMENSIONS"
8336       include "COMMON.IOUNITS"
8337       integer max_cont
8338       integer max_dim
8339       parameter (max_cont=maxconts)
8340       parameter (max_dim=26)
8341       include "COMMON.CONTACTS"
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 i,j,ii,jj,iproc,itask(4),nn
8346 c      write (iout,*) "itask",itask
8347       do i=1,2
8348         iproc=itask(i)
8349         if (iproc.gt.0) then
8350           do j=1,num_cont_hb(ii)
8351             jjc=jcont_hb(j,ii)
8352 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8353             if (jjc.eq.jj) then
8354               ncont_sent(iproc)=ncont_sent(iproc)+1
8355               nn=ncont_sent(iproc)
8356               zapas(1,nn,iproc)=ii
8357               zapas(2,nn,iproc)=jjc
8358               zapas(3,nn,iproc)=facont_hb(j,ii)
8359               zapas(4,nn,iproc)=ees0p(j,ii)
8360               zapas(5,nn,iproc)=ees0m(j,ii)
8361               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8362               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8363               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8364               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8365               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8366               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8367               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8368               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8369               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8370               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8371               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8372               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8373               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8374               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8375               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8376               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8377               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8378               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8379               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8380               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8381               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8382               exit
8383             endif
8384           enddo
8385         endif
8386       enddo
8387       return
8388       end
8389 c------------------------------------------------------------------------------
8390       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8391      &  n_corr1)
8392 C This subroutine calculates multi-body contributions to hydrogen-bonding
8393       implicit real*8 (a-h,o-z)
8394       include 'DIMENSIONS'
8395       include 'COMMON.IOUNITS'
8396 #ifdef MPI
8397       include "mpif.h"
8398       parameter (max_cont=maxconts)
8399       parameter (max_dim=70)
8400       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8401       double precision zapas(max_dim,maxconts,max_fg_procs),
8402      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8403       common /przechowalnia/ zapas
8404       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8405      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8406 #endif
8407       include 'COMMON.SETUP'
8408       include 'COMMON.FFIELD'
8409       include 'COMMON.DERIV'
8410       include 'COMMON.LOCAL'
8411       include 'COMMON.INTERACT'
8412       include 'COMMON.CONTACTS'
8413       include 'COMMON.CHAIN'
8414       include 'COMMON.CONTROL'
8415       include 'COMMON.SHIELD'
8416       double precision gx(3),gx1(3)
8417       integer num_cont_hb_old(maxres)
8418       logical lprn,ldone
8419       double precision eello4,eello5,eelo6,eello_turn6
8420       external eello4,eello5,eello6,eello_turn6
8421 C Set lprn=.true. for debugging
8422       lprn=.false.
8423       eturn6=0.0d0
8424 #ifdef MPI
8425       do i=1,nres
8426         num_cont_hb_old(i)=num_cont_hb(i)
8427       enddo
8428       n_corr=0
8429       n_corr1=0
8430       if (nfgtasks.le.1) goto 30
8431       if (lprn) then
8432         write (iout,'(a)') 'Contact function values before RECEIVE:'
8433         do i=nnt,nct-2
8434           write (iout,'(2i3,50(1x,i2,f5.2))')
8435      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8436      &    j=1,num_cont_hb(i))
8437         enddo
8438       endif
8439       do i=1,ntask_cont_from
8440         ncont_recv(i)=0
8441       enddo
8442       do i=1,ntask_cont_to
8443         ncont_sent(i)=0
8444       enddo
8445 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8446 c     & ntask_cont_to
8447 C Make the list of contacts to send to send to other procesors
8448       do i=iturn3_start,iturn3_end
8449 c        write (iout,*) "make contact list turn3",i," num_cont",
8450 c     &    num_cont_hb(i)
8451         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8452       enddo
8453       do i=iturn4_start,iturn4_end
8454 c        write (iout,*) "make contact list turn4",i," num_cont",
8455 c     &   num_cont_hb(i)
8456         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8457       enddo
8458       do ii=1,nat_sent
8459         i=iat_sent(ii)
8460 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8461 c     &    num_cont_hb(i)
8462         do j=1,num_cont_hb(i)
8463         do k=1,4
8464           jjc=jcont_hb(j,i)
8465           iproc=iint_sent_local(k,jjc,ii)
8466 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8467           if (iproc.ne.0) then
8468             ncont_sent(iproc)=ncont_sent(iproc)+1
8469             nn=ncont_sent(iproc)
8470             zapas(1,nn,iproc)=i
8471             zapas(2,nn,iproc)=jjc
8472             zapas(3,nn,iproc)=d_cont(j,i)
8473             ind=3
8474             do kk=1,3
8475               ind=ind+1
8476               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8477             enddo
8478             do kk=1,2
8479               do ll=1,2
8480                 ind=ind+1
8481                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8482               enddo
8483             enddo
8484             do jj=1,5
8485               do kk=1,3
8486                 do ll=1,2
8487                   do mm=1,2
8488                     ind=ind+1
8489                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8490                   enddo
8491                 enddo
8492               enddo
8493             enddo
8494           endif
8495         enddo
8496         enddo
8497       enddo
8498       if (lprn) then
8499       write (iout,*)
8500      &  "Numbers of contacts to be sent to other processors",
8501      &  (ncont_sent(i),i=1,ntask_cont_to)
8502       write (iout,*) "Contacts sent"
8503       do ii=1,ntask_cont_to
8504         nn=ncont_sent(ii)
8505         iproc=itask_cont_to(ii)
8506         write (iout,*) nn," contacts to processor",iproc,
8507      &   " of CONT_TO_COMM group"
8508         do i=1,nn
8509           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8510         enddo
8511       enddo
8512       call flush(iout)
8513       endif
8514       CorrelType=477
8515       CorrelID=fg_rank+1
8516       CorrelType1=478
8517       CorrelID1=nfgtasks+fg_rank+1
8518       ireq=0
8519 C Receive the numbers of needed contacts from other processors
8520       do ii=1,ntask_cont_from
8521         iproc=itask_cont_from(ii)
8522         ireq=ireq+1
8523         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8524      &    FG_COMM,req(ireq),IERR)
8525       enddo
8526 c      write (iout,*) "IRECV ended"
8527 c      call flush(iout)
8528 C Send the number of contacts needed by other processors
8529       do ii=1,ntask_cont_to
8530         iproc=itask_cont_to(ii)
8531         ireq=ireq+1
8532         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8533      &    FG_COMM,req(ireq),IERR)
8534       enddo
8535 c      write (iout,*) "ISEND ended"
8536 c      write (iout,*) "number of requests (nn)",ireq
8537 c      call flush(iout)
8538       if (ireq.gt.0)
8539      &  call MPI_Waitall(ireq,req,status_array,ierr)
8540 c      write (iout,*)
8541 c     &  "Numbers of contacts to be received from other processors",
8542 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8543 c      call flush(iout)
8544 C Receive contacts
8545       ireq=0
8546       do ii=1,ntask_cont_from
8547         iproc=itask_cont_from(ii)
8548         nn=ncont_recv(ii)
8549 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8550 c     &   " of CONT_TO_COMM group"
8551 c        call flush(iout)
8552         if (nn.gt.0) then
8553           ireq=ireq+1
8554           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8555      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8556 c          write (iout,*) "ireq,req",ireq,req(ireq)
8557         endif
8558       enddo
8559 C Send the contacts to processors that need them
8560       do ii=1,ntask_cont_to
8561         iproc=itask_cont_to(ii)
8562         nn=ncont_sent(ii)
8563 c        write (iout,*) nn," contacts to processor",iproc,
8564 c     &   " of CONT_TO_COMM group"
8565         if (nn.gt.0) then
8566           ireq=ireq+1
8567           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8568      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8569 c          write (iout,*) "ireq,req",ireq,req(ireq)
8570 c          do i=1,nn
8571 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8572 c          enddo
8573         endif
8574       enddo
8575 c      write (iout,*) "number of requests (contacts)",ireq
8576 c      write (iout,*) "req",(req(i),i=1,4)
8577 c      call flush(iout)
8578       if (ireq.gt.0)
8579      & call MPI_Waitall(ireq,req,status_array,ierr)
8580       do iii=1,ntask_cont_from
8581         iproc=itask_cont_from(iii)
8582         nn=ncont_recv(iii)
8583         if (lprn) then
8584         write (iout,*) "Received",nn," contacts from processor",iproc,
8585      &   " of CONT_FROM_COMM group"
8586         call flush(iout)
8587         do i=1,nn
8588           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8589         enddo
8590         call flush(iout)
8591         endif
8592         do i=1,nn
8593           ii=zapas_recv(1,i,iii)
8594 c Flag the received contacts to prevent double-counting
8595           jj=-zapas_recv(2,i,iii)
8596 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8597 c          call flush(iout)
8598           nnn=num_cont_hb(ii)+1
8599           num_cont_hb(ii)=nnn
8600           jcont_hb(nnn,ii)=jj
8601           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8602           ind=3
8603           do kk=1,3
8604             ind=ind+1
8605             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8606           enddo
8607           do kk=1,2
8608             do ll=1,2
8609               ind=ind+1
8610               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8611             enddo
8612           enddo
8613           do jj=1,5
8614             do kk=1,3
8615               do ll=1,2
8616                 do mm=1,2
8617                   ind=ind+1
8618                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8619                 enddo
8620               enddo
8621             enddo
8622           enddo
8623         enddo
8624       enddo
8625       if (lprn) then
8626         write (iout,'(a)') 'Contact function values after receive:'
8627         do i=nnt,nct-2
8628           write (iout,'(2i3,50(1x,i3,5f6.3))')
8629      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8630      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8631         enddo
8632         call flush(iout)
8633       endif
8634    30 continue
8635 #endif
8636       if (lprn) then
8637         write (iout,'(a)') 'Contact function values:'
8638         do i=nnt,nct-2
8639           write (iout,'(2i3,50(1x,i2,5f6.3))')
8640      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8641      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8642         enddo
8643       endif
8644       ecorr=0.0D0
8645       ecorr5=0.0d0
8646       ecorr6=0.0d0
8647 C Remove the loop below after debugging !!!
8648       do i=nnt,nct
8649         do j=1,3
8650           gradcorr(j,i)=0.0D0
8651           gradxorr(j,i)=0.0D0
8652         enddo
8653       enddo
8654 C Calculate the dipole-dipole interaction energies
8655       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8656       do i=iatel_s,iatel_e+1
8657         num_conti=num_cont_hb(i)
8658         do jj=1,num_conti
8659           j=jcont_hb(jj,i)
8660 #ifdef MOMENT
8661           call dipole(i,j,jj)
8662 #endif
8663         enddo
8664       enddo
8665       endif
8666 C Calculate the local-electrostatic correlation terms
8667 c                write (iout,*) "gradcorr5 in eello5 before loop"
8668 c                do iii=1,nres
8669 c                  write (iout,'(i5,3f10.5)')
8670 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8671 c                enddo
8672       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8673 c        write (iout,*) "corr loop i",i
8674         i1=i+1
8675         num_conti=num_cont_hb(i)
8676         num_conti1=num_cont_hb(i+1)
8677         do jj=1,num_conti
8678           j=jcont_hb(jj,i)
8679           jp=iabs(j)
8680           do kk=1,num_conti1
8681             j1=jcont_hb(kk,i1)
8682             jp1=iabs(j1)
8683 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8684 c     &         ' jj=',jj,' kk=',kk
8685 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8686             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8687      &          .or. j.lt.0 .and. j1.gt.0) .and.
8688      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8689 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8690 C The system gains extra energy.
8691               n_corr=n_corr+1
8692               sqd1=dsqrt(d_cont(jj,i))
8693               sqd2=dsqrt(d_cont(kk,i1))
8694               sred_geom = sqd1*sqd2
8695               IF (sred_geom.lt.cutoff_corr) THEN
8696                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8697      &            ekont,fprimcont)
8698 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8699 cd     &         ' jj=',jj,' kk=',kk
8700                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8701                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8702                 do l=1,3
8703                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8704                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8705                 enddo
8706                 n_corr1=n_corr1+1
8707 cd               write (iout,*) 'sred_geom=',sred_geom,
8708 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8709 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8710 cd               write (iout,*) "g_contij",g_contij
8711 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8712 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8713                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8714                 if (wcorr4.gt.0.0d0)
8715      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8716 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8717                   if (energy_dec.and.wcorr4.gt.0.0d0)
8718      1                 write (iout,'(a6,4i5,0pf7.3)')
8719      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8720 c                write (iout,*) "gradcorr5 before eello5"
8721 c                do iii=1,nres
8722 c                  write (iout,'(i5,3f10.5)')
8723 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8724 c                enddo
8725                 if (wcorr5.gt.0.0d0)
8726      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8727 c                write (iout,*) "gradcorr5 after eello5"
8728 c                do iii=1,nres
8729 c                  write (iout,'(i5,3f10.5)')
8730 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8731 c                enddo
8732                   if (energy_dec.and.wcorr5.gt.0.0d0)
8733      1                 write (iout,'(a6,4i5,0pf7.3)')
8734      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8735 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8736 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8737                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8738      &               .or. wturn6.eq.0.0d0))then
8739 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8740                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8741                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8742      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8743 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8744 cd     &            'ecorr6=',ecorr6
8745 cd                write (iout,'(4e15.5)') sred_geom,
8746 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8747 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8748 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8749                 else if (wturn6.gt.0.0d0
8750      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8751 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8752                   eturn6=eturn6+eello_turn6(i,jj,kk)
8753                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8754      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8755 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8756                 endif
8757               ENDIF
8758 1111          continue
8759             endif
8760           enddo ! kk
8761         enddo ! jj
8762       enddo ! i
8763       do i=1,nres
8764         num_cont_hb(i)=num_cont_hb_old(i)
8765       enddo
8766 c                write (iout,*) "gradcorr5 in eello5"
8767 c                do iii=1,nres
8768 c                  write (iout,'(i5,3f10.5)')
8769 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8770 c                enddo
8771       return
8772       end
8773 c------------------------------------------------------------------------------
8774       subroutine add_hb_contact_eello(ii,jj,itask)
8775       implicit real*8 (a-h,o-z)
8776       include "DIMENSIONS"
8777       include "COMMON.IOUNITS"
8778       integer max_cont
8779       integer max_dim
8780       parameter (max_cont=maxconts)
8781       parameter (max_dim=70)
8782       include "COMMON.CONTACTS"
8783       double precision zapas(max_dim,maxconts,max_fg_procs),
8784      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8785       common /przechowalnia/ zapas
8786       integer i,j,ii,jj,iproc,itask(4),nn
8787 c      write (iout,*) "itask",itask
8788       do i=1,2
8789         iproc=itask(i)
8790         if (iproc.gt.0) then
8791           do j=1,num_cont_hb(ii)
8792             jjc=jcont_hb(j,ii)
8793 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8794             if (jjc.eq.jj) then
8795               ncont_sent(iproc)=ncont_sent(iproc)+1
8796               nn=ncont_sent(iproc)
8797               zapas(1,nn,iproc)=ii
8798               zapas(2,nn,iproc)=jjc
8799               zapas(3,nn,iproc)=d_cont(j,ii)
8800               ind=3
8801               do kk=1,3
8802                 ind=ind+1
8803                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8804               enddo
8805               do kk=1,2
8806                 do ll=1,2
8807                   ind=ind+1
8808                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8809                 enddo
8810               enddo
8811               do jj=1,5
8812                 do kk=1,3
8813                   do ll=1,2
8814                     do mm=1,2
8815                       ind=ind+1
8816                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8817                     enddo
8818                   enddo
8819                 enddo
8820               enddo
8821               exit
8822             endif
8823           enddo
8824         endif
8825       enddo
8826       return
8827       end
8828 c------------------------------------------------------------------------------
8829       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8830       implicit real*8 (a-h,o-z)
8831       include 'DIMENSIONS'
8832       include 'COMMON.IOUNITS'
8833       include 'COMMON.DERIV'
8834       include 'COMMON.INTERACT'
8835       include 'COMMON.CONTACTS'
8836       include 'COMMON.SHIELD'
8837       include 'COMMON.CONTROL'
8838       double precision gx(3),gx1(3)
8839       logical lprn
8840       lprn=.false.
8841 C      print *,"wchodze",fac_shield(i),shield_mode
8842       eij=facont_hb(jj,i)
8843       ekl=facont_hb(kk,k)
8844       ees0pij=ees0p(jj,i)
8845       ees0pkl=ees0p(kk,k)
8846       ees0mij=ees0m(jj,i)
8847       ees0mkl=ees0m(kk,k)
8848       ekont=eij*ekl
8849       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8850 C*
8851 C     & fac_shield(i)**2*fac_shield(j)**2
8852 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8853 C Following 4 lines for diagnostics.
8854 cd    ees0pkl=0.0D0
8855 cd    ees0pij=1.0D0
8856 cd    ees0mkl=0.0D0
8857 cd    ees0mij=1.0D0
8858 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8859 c     & 'Contacts ',i,j,
8860 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8861 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8862 c     & 'gradcorr_long'
8863 C Calculate the multi-body contribution to energy.
8864 C      ecorr=ecorr+ekont*ees
8865 C Calculate multi-body contributions to the gradient.
8866       coeffpees0pij=coeffp*ees0pij
8867       coeffmees0mij=coeffm*ees0mij
8868       coeffpees0pkl=coeffp*ees0pkl
8869       coeffmees0mkl=coeffm*ees0mkl
8870       do ll=1,3
8871 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8872         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8873      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8874      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8875         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8876      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8877      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8878 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8879         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8880      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8881      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8882         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8883      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8884      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8885         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8886      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8887      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8888         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8889         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8890         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8891      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8892      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8893         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8894         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8895 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8896       enddo
8897 c      write (iout,*)
8898 cgrad      do m=i+1,j-1
8899 cgrad        do ll=1,3
8900 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8901 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8902 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8903 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8904 cgrad        enddo
8905 cgrad      enddo
8906 cgrad      do m=k+1,l-1
8907 cgrad        do ll=1,3
8908 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8909 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8910 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8911 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8912 cgrad        enddo
8913 cgrad      enddo
8914 c      write (iout,*) "ehbcorr",ekont*ees
8915 C      print *,ekont,ees,i,k
8916       ehbcorr=ekont*ees
8917 C now gradient over shielding
8918 C      return
8919       if (shield_mode.gt.0) then
8920        j=ees0plist(jj,i)
8921        l=ees0plist(kk,k)
8922 C        print *,i,j,fac_shield(i),fac_shield(j),
8923 C     &fac_shield(k),fac_shield(l)
8924         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8925      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8926           do ilist=1,ishield_list(i)
8927            iresshield=shield_list(ilist,i)
8928            do m=1,3
8929            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8930 C     &      *2.0
8931            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8932      &              rlocshield
8933      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8934             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8935      &+rlocshield
8936            enddo
8937           enddo
8938           do ilist=1,ishield_list(j)
8939            iresshield=shield_list(ilist,j)
8940            do m=1,3
8941            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8942 C     &     *2.0
8943            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8944      &              rlocshield
8945      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
8946            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8947      &     +rlocshield
8948            enddo
8949           enddo
8950
8951           do ilist=1,ishield_list(k)
8952            iresshield=shield_list(ilist,k)
8953            do m=1,3
8954            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
8955 C     &     *2.0
8956            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8957      &              rlocshield
8958      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
8959            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8960      &     +rlocshield
8961            enddo
8962           enddo
8963           do ilist=1,ishield_list(l)
8964            iresshield=shield_list(ilist,l)
8965            do m=1,3
8966            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
8967 C     &     *2.0
8968            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8969      &              rlocshield
8970      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
8971            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8972      &     +rlocshield
8973            enddo
8974           enddo
8975 C          print *,gshieldx(m,iresshield)
8976           do m=1,3
8977             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
8978      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8979             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
8980      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8981             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
8982      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
8983             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
8984      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
8985
8986             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
8987      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8988             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
8989      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8990             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
8991      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
8992             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
8993      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
8994
8995            enddo
8996       endif
8997       endif
8998       return
8999       end
9000 #ifdef MOMENT
9001 C---------------------------------------------------------------------------
9002       subroutine dipole(i,j,jj)
9003       implicit real*8 (a-h,o-z)
9004       include 'DIMENSIONS'
9005       include 'COMMON.IOUNITS'
9006       include 'COMMON.CHAIN'
9007       include 'COMMON.FFIELD'
9008       include 'COMMON.DERIV'
9009       include 'COMMON.INTERACT'
9010       include 'COMMON.CONTACTS'
9011       include 'COMMON.TORSION'
9012       include 'COMMON.VAR'
9013       include 'COMMON.GEO'
9014       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9015      &  auxmat(2,2)
9016       iti1 = itortyp(itype(i+1))
9017       if (j.lt.nres-1) then
9018         itj1 = itype2loc(itype(j+1))
9019       else
9020         itj1=nloctyp
9021       endif
9022       do iii=1,2
9023         dipi(iii,1)=Ub2(iii,i)
9024         dipderi(iii)=Ub2der(iii,i)
9025         dipi(iii,2)=b1(iii,i+1)
9026         dipj(iii,1)=Ub2(iii,j)
9027         dipderj(iii)=Ub2der(iii,j)
9028         dipj(iii,2)=b1(iii,j+1)
9029       enddo
9030       kkk=0
9031       do iii=1,2
9032         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9033         do jjj=1,2
9034           kkk=kkk+1
9035           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9036         enddo
9037       enddo
9038       do kkk=1,5
9039         do lll=1,3
9040           mmm=0
9041           do iii=1,2
9042             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9043      &        auxvec(1))
9044             do jjj=1,2
9045               mmm=mmm+1
9046               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9047             enddo
9048           enddo
9049         enddo
9050       enddo
9051       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9052       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9053       do iii=1,2
9054         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9055       enddo
9056       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9057       do iii=1,2
9058         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9059       enddo
9060       return
9061       end
9062 #endif
9063 C---------------------------------------------------------------------------
9064       subroutine calc_eello(i,j,k,l,jj,kk)
9065 C
9066 C This subroutine computes matrices and vectors needed to calculate
9067 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9068 C
9069       implicit real*8 (a-h,o-z)
9070       include 'DIMENSIONS'
9071       include 'COMMON.IOUNITS'
9072       include 'COMMON.CHAIN'
9073       include 'COMMON.DERIV'
9074       include 'COMMON.INTERACT'
9075       include 'COMMON.CONTACTS'
9076       include 'COMMON.TORSION'
9077       include 'COMMON.VAR'
9078       include 'COMMON.GEO'
9079       include 'COMMON.FFIELD'
9080       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9081      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9082       logical lprn
9083       common /kutas/ lprn
9084 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9085 cd     & ' jj=',jj,' kk=',kk
9086 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9087 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9088 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9089       do iii=1,2
9090         do jjj=1,2
9091           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9092           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9093         enddo
9094       enddo
9095       call transpose2(aa1(1,1),aa1t(1,1))
9096       call transpose2(aa2(1,1),aa2t(1,1))
9097       do kkk=1,5
9098         do lll=1,3
9099           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9100      &      aa1tder(1,1,lll,kkk))
9101           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9102      &      aa2tder(1,1,lll,kkk))
9103         enddo
9104       enddo
9105       if (l.eq.j+1) then
9106 C parallel orientation of the two CA-CA-CA frames.
9107         if (i.gt.1) then
9108           iti=itype2loc(itype(i))
9109         else
9110           iti=nloctyp
9111         endif
9112         itk1=itype2loc(itype(k+1))
9113         itj=itype2loc(itype(j))
9114         if (l.lt.nres-1) then
9115           itl1=itype2loc(itype(l+1))
9116         else
9117           itl1=nloctyp
9118         endif
9119 C A1 kernel(j+1) A2T
9120 cd        do iii=1,2
9121 cd          write (iout,'(3f10.5,5x,3f10.5)')
9122 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9123 cd        enddo
9124         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9125      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9126      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9127 C Following matrices are needed only for 6-th order cumulants
9128         IF (wcorr6.gt.0.0d0) THEN
9129         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9130      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9131      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9132         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9133      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9134      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9135      &   ADtEAderx(1,1,1,1,1,1))
9136         lprn=.false.
9137         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9138      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9139      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9140      &   ADtEA1derx(1,1,1,1,1,1))
9141         ENDIF
9142 C End 6-th order cumulants
9143 cd        lprn=.false.
9144 cd        if (lprn) then
9145 cd        write (2,*) 'In calc_eello6'
9146 cd        do iii=1,2
9147 cd          write (2,*) 'iii=',iii
9148 cd          do kkk=1,5
9149 cd            write (2,*) 'kkk=',kkk
9150 cd            do jjj=1,2
9151 cd              write (2,'(3(2f10.5),5x)')
9152 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9153 cd            enddo
9154 cd          enddo
9155 cd        enddo
9156 cd        endif
9157         call transpose2(EUgder(1,1,k),auxmat(1,1))
9158         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9159         call transpose2(EUg(1,1,k),auxmat(1,1))
9160         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9161         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9162 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9163 c    in theta; to be sriten later.
9164 c#ifdef NEWCORR
9165 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9166 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9167 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9168 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9169 c#endif
9170         do iii=1,2
9171           do kkk=1,5
9172             do lll=1,3
9173               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9174      &          EAEAderx(1,1,lll,kkk,iii,1))
9175             enddo
9176           enddo
9177         enddo
9178 C A1T kernel(i+1) A2
9179         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9180      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9181      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9182 C Following matrices are needed only for 6-th order cumulants
9183         IF (wcorr6.gt.0.0d0) THEN
9184         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9185      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9186      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9187         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9188      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9189      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9190      &   ADtEAderx(1,1,1,1,1,2))
9191         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9192      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9193      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9194      &   ADtEA1derx(1,1,1,1,1,2))
9195         ENDIF
9196 C End 6-th order cumulants
9197         call transpose2(EUgder(1,1,l),auxmat(1,1))
9198         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9199         call transpose2(EUg(1,1,l),auxmat(1,1))
9200         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9201         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9202         do iii=1,2
9203           do kkk=1,5
9204             do lll=1,3
9205               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9206      &          EAEAderx(1,1,lll,kkk,iii,2))
9207             enddo
9208           enddo
9209         enddo
9210 C AEAb1 and AEAb2
9211 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9212 C They are needed only when the fifth- or the sixth-order cumulants are
9213 C indluded.
9214         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9215         call transpose2(AEA(1,1,1),auxmat(1,1))
9216         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9217         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9218         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9219         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9220         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9221         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9222         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9223         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9224         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9225         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9226         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9227         call transpose2(AEA(1,1,2),auxmat(1,1))
9228         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9229         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9230         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9231         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9232         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9233         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9234         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9235         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9236         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9237         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9238         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9239 C Calculate the Cartesian derivatives of the vectors.
9240         do iii=1,2
9241           do kkk=1,5
9242             do lll=1,3
9243               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9244               call matvec2(auxmat(1,1),b1(1,i),
9245      &          AEAb1derx(1,lll,kkk,iii,1,1))
9246               call matvec2(auxmat(1,1),Ub2(1,i),
9247      &          AEAb2derx(1,lll,kkk,iii,1,1))
9248               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9249      &          AEAb1derx(1,lll,kkk,iii,2,1))
9250               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9251      &          AEAb2derx(1,lll,kkk,iii,2,1))
9252               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9253               call matvec2(auxmat(1,1),b1(1,j),
9254      &          AEAb1derx(1,lll,kkk,iii,1,2))
9255               call matvec2(auxmat(1,1),Ub2(1,j),
9256      &          AEAb2derx(1,lll,kkk,iii,1,2))
9257               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9258      &          AEAb1derx(1,lll,kkk,iii,2,2))
9259               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9260      &          AEAb2derx(1,lll,kkk,iii,2,2))
9261             enddo
9262           enddo
9263         enddo
9264         ENDIF
9265 C End vectors
9266       else
9267 C Antiparallel orientation of the two CA-CA-CA frames.
9268         if (i.gt.1) then
9269           iti=itype2loc(itype(i))
9270         else
9271           iti=nloctyp
9272         endif
9273         itk1=itype2loc(itype(k+1))
9274         itl=itype2loc(itype(l))
9275         itj=itype2loc(itype(j))
9276         if (j.lt.nres-1) then
9277           itj1=itype2loc(itype(j+1))
9278         else
9279           itj1=nloctyp
9280         endif
9281 C A2 kernel(j-1)T A1T
9282         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9283      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9284      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9285 C Following matrices are needed only for 6-th order cumulants
9286         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9287      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9288         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9289      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9290      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9291         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9292      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9293      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9294      &   ADtEAderx(1,1,1,1,1,1))
9295         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9296      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9297      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9298      &   ADtEA1derx(1,1,1,1,1,1))
9299         ENDIF
9300 C End 6-th order cumulants
9301         call transpose2(EUgder(1,1,k),auxmat(1,1))
9302         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9303         call transpose2(EUg(1,1,k),auxmat(1,1))
9304         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9305         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9306         do iii=1,2
9307           do kkk=1,5
9308             do lll=1,3
9309               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9310      &          EAEAderx(1,1,lll,kkk,iii,1))
9311             enddo
9312           enddo
9313         enddo
9314 C A2T kernel(i+1)T A1
9315         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9316      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9317      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9318 C Following matrices are needed only for 6-th order cumulants
9319         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9320      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9321         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9322      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9323      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9324         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9325      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9326      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9327      &   ADtEAderx(1,1,1,1,1,2))
9328         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9329      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9330      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9331      &   ADtEA1derx(1,1,1,1,1,2))
9332         ENDIF
9333 C End 6-th order cumulants
9334         call transpose2(EUgder(1,1,j),auxmat(1,1))
9335         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9336         call transpose2(EUg(1,1,j),auxmat(1,1))
9337         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9338         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9339         do iii=1,2
9340           do kkk=1,5
9341             do lll=1,3
9342               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9343      &          EAEAderx(1,1,lll,kkk,iii,2))
9344             enddo
9345           enddo
9346         enddo
9347 C AEAb1 and AEAb2
9348 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9349 C They are needed only when the fifth- or the sixth-order cumulants are
9350 C indluded.
9351         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9352      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9353         call transpose2(AEA(1,1,1),auxmat(1,1))
9354         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9355         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9356         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9357         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9358         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9359         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9360         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9361         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9362         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9363         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9364         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9365         call transpose2(AEA(1,1,2),auxmat(1,1))
9366         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9367         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9368         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9369         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9370         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9371         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9372         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9373         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9374         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9375         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9376         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9377 C Calculate the Cartesian derivatives of the vectors.
9378         do iii=1,2
9379           do kkk=1,5
9380             do lll=1,3
9381               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9382               call matvec2(auxmat(1,1),b1(1,i),
9383      &          AEAb1derx(1,lll,kkk,iii,1,1))
9384               call matvec2(auxmat(1,1),Ub2(1,i),
9385      &          AEAb2derx(1,lll,kkk,iii,1,1))
9386               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9387      &          AEAb1derx(1,lll,kkk,iii,2,1))
9388               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9389      &          AEAb2derx(1,lll,kkk,iii,2,1))
9390               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9391               call matvec2(auxmat(1,1),b1(1,l),
9392      &          AEAb1derx(1,lll,kkk,iii,1,2))
9393               call matvec2(auxmat(1,1),Ub2(1,l),
9394      &          AEAb2derx(1,lll,kkk,iii,1,2))
9395               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9396      &          AEAb1derx(1,lll,kkk,iii,2,2))
9397               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9398      &          AEAb2derx(1,lll,kkk,iii,2,2))
9399             enddo
9400           enddo
9401         enddo
9402         ENDIF
9403 C End vectors
9404       endif
9405       return
9406       end
9407 C---------------------------------------------------------------------------
9408       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9409      &  KK,KKderg,AKA,AKAderg,AKAderx)
9410       implicit none
9411       integer nderg
9412       logical transp
9413       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9414      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9415      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9416       integer iii,kkk,lll
9417       integer jjj,mmm
9418       logical lprn
9419       common /kutas/ lprn
9420       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9421       do iii=1,nderg
9422         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9423      &    AKAderg(1,1,iii))
9424       enddo
9425 cd      if (lprn) write (2,*) 'In kernel'
9426       do kkk=1,5
9427 cd        if (lprn) write (2,*) 'kkk=',kkk
9428         do lll=1,3
9429           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9430      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9431 cd          if (lprn) then
9432 cd            write (2,*) 'lll=',lll
9433 cd            write (2,*) 'iii=1'
9434 cd            do jjj=1,2
9435 cd              write (2,'(3(2f10.5),5x)')
9436 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9437 cd            enddo
9438 cd          endif
9439           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9440      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9441 cd          if (lprn) then
9442 cd            write (2,*) 'lll=',lll
9443 cd            write (2,*) 'iii=2'
9444 cd            do jjj=1,2
9445 cd              write (2,'(3(2f10.5),5x)')
9446 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9447 cd            enddo
9448 cd          endif
9449         enddo
9450       enddo
9451       return
9452       end
9453 C---------------------------------------------------------------------------
9454       double precision function eello4(i,j,k,l,jj,kk)
9455       implicit real*8 (a-h,o-z)
9456       include 'DIMENSIONS'
9457       include 'COMMON.IOUNITS'
9458       include 'COMMON.CHAIN'
9459       include 'COMMON.DERIV'
9460       include 'COMMON.INTERACT'
9461       include 'COMMON.CONTACTS'
9462       include 'COMMON.TORSION'
9463       include 'COMMON.VAR'
9464       include 'COMMON.GEO'
9465       double precision pizda(2,2),ggg1(3),ggg2(3)
9466 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9467 cd        eello4=0.0d0
9468 cd        return
9469 cd      endif
9470 cd      print *,'eello4:',i,j,k,l,jj,kk
9471 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9472 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9473 cold      eij=facont_hb(jj,i)
9474 cold      ekl=facont_hb(kk,k)
9475 cold      ekont=eij*ekl
9476       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9477 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9478       gcorr_loc(k-1)=gcorr_loc(k-1)
9479      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9480       if (l.eq.j+1) then
9481         gcorr_loc(l-1)=gcorr_loc(l-1)
9482      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9483 C Al 4/16/16: Derivatives in theta, to be added later.
9484 c#ifdef NEWCORR
9485 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
9486 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9487 c#endif
9488       else
9489         gcorr_loc(j-1)=gcorr_loc(j-1)
9490      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9491 c#ifdef NEWCORR
9492 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
9493 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9494 c#endif
9495       endif
9496       do iii=1,2
9497         do kkk=1,5
9498           do lll=1,3
9499             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9500      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9501 cd            derx(lll,kkk,iii)=0.0d0
9502           enddo
9503         enddo
9504       enddo
9505 cd      gcorr_loc(l-1)=0.0d0
9506 cd      gcorr_loc(j-1)=0.0d0
9507 cd      gcorr_loc(k-1)=0.0d0
9508 cd      eel4=1.0d0
9509 cd      write (iout,*)'Contacts have occurred for peptide groups',
9510 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9511 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9512       if (j.lt.nres-1) then
9513         j1=j+1
9514         j2=j-1
9515       else
9516         j1=j-1
9517         j2=j-2
9518       endif
9519       if (l.lt.nres-1) then
9520         l1=l+1
9521         l2=l-1
9522       else
9523         l1=l-1
9524         l2=l-2
9525       endif
9526       do ll=1,3
9527 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9528 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9529         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9530         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9531 cgrad        ghalf=0.5d0*ggg1(ll)
9532         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9533         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9534         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9535         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9536         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9537         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9538 cgrad        ghalf=0.5d0*ggg2(ll)
9539         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9540         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9541         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9542         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9543         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9544         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9545       enddo
9546 cgrad      do m=i+1,j-1
9547 cgrad        do ll=1,3
9548 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9549 cgrad        enddo
9550 cgrad      enddo
9551 cgrad      do m=k+1,l-1
9552 cgrad        do ll=1,3
9553 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9554 cgrad        enddo
9555 cgrad      enddo
9556 cgrad      do m=i+2,j2
9557 cgrad        do ll=1,3
9558 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9559 cgrad        enddo
9560 cgrad      enddo
9561 cgrad      do m=k+2,l2
9562 cgrad        do ll=1,3
9563 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9564 cgrad        enddo
9565 cgrad      enddo
9566 cd      do iii=1,nres-3
9567 cd        write (2,*) iii,gcorr_loc(iii)
9568 cd      enddo
9569       eello4=ekont*eel4
9570 cd      write (2,*) 'ekont',ekont
9571 cd      write (iout,*) 'eello4',ekont*eel4
9572       return
9573       end
9574 C---------------------------------------------------------------------------
9575       double precision function eello5(i,j,k,l,jj,kk)
9576       implicit real*8 (a-h,o-z)
9577       include 'DIMENSIONS'
9578       include 'COMMON.IOUNITS'
9579       include 'COMMON.CHAIN'
9580       include 'COMMON.DERIV'
9581       include 'COMMON.INTERACT'
9582       include 'COMMON.CONTACTS'
9583       include 'COMMON.TORSION'
9584       include 'COMMON.VAR'
9585       include 'COMMON.GEO'
9586       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9587       double precision ggg1(3),ggg2(3)
9588 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9589 C                                                                              C
9590 C                            Parallel chains                                   C
9591 C                                                                              C
9592 C          o             o                   o             o                   C
9593 C         /l\           / \             \   / \           / \   /              C
9594 C        /   \         /   \             \ /   \         /   \ /               C
9595 C       j| o |l1       | o |              o| o |         | o |o                C
9596 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9597 C      \i/   \         /   \ /             /   \         /   \                 C
9598 C       o    k1             o                                                  C
9599 C         (I)          (II)                (III)          (IV)                 C
9600 C                                                                              C
9601 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9602 C                                                                              C
9603 C                            Antiparallel chains                               C
9604 C                                                                              C
9605 C          o             o                   o             o                   C
9606 C         /j\           / \             \   / \           / \   /              C
9607 C        /   \         /   \             \ /   \         /   \ /               C
9608 C      j1| o |l        | o |              o| o |         | o |o                C
9609 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9610 C      \i/   \         /   \ /             /   \         /   \                 C
9611 C       o     k1            o                                                  C
9612 C         (I)          (II)                (III)          (IV)                 C
9613 C                                                                              C
9614 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9615 C                                                                              C
9616 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9617 C                                                                              C
9618 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9619 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9620 cd        eello5=0.0d0
9621 cd        return
9622 cd      endif
9623 cd      write (iout,*)
9624 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9625 cd     &   ' and',k,l
9626       itk=itype2loc(itype(k))
9627       itl=itype2loc(itype(l))
9628       itj=itype2loc(itype(j))
9629       eello5_1=0.0d0
9630       eello5_2=0.0d0
9631       eello5_3=0.0d0
9632       eello5_4=0.0d0
9633 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9634 cd     &   eel5_3_num,eel5_4_num)
9635       do iii=1,2
9636         do kkk=1,5
9637           do lll=1,3
9638             derx(lll,kkk,iii)=0.0d0
9639           enddo
9640         enddo
9641       enddo
9642 cd      eij=facont_hb(jj,i)
9643 cd      ekl=facont_hb(kk,k)
9644 cd      ekont=eij*ekl
9645 cd      write (iout,*)'Contacts have occurred for peptide groups',
9646 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9647 cd      goto 1111
9648 C Contribution from the graph I.
9649 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9650 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9651       call transpose2(EUg(1,1,k),auxmat(1,1))
9652       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9653       vv(1)=pizda(1,1)-pizda(2,2)
9654       vv(2)=pizda(1,2)+pizda(2,1)
9655       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9656      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9657 C Explicit gradient in virtual-dihedral angles.
9658       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9659      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9660      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9661       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9662       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9663       vv(1)=pizda(1,1)-pizda(2,2)
9664       vv(2)=pizda(1,2)+pizda(2,1)
9665       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9666      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9667      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9668       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9669       vv(1)=pizda(1,1)-pizda(2,2)
9670       vv(2)=pizda(1,2)+pizda(2,1)
9671       if (l.eq.j+1) then
9672         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9673      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9674      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9675       else
9676         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9677      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9678      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9679       endif
9680 C Cartesian gradient
9681       do iii=1,2
9682         do kkk=1,5
9683           do lll=1,3
9684             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9685      &        pizda(1,1))
9686             vv(1)=pizda(1,1)-pizda(2,2)
9687             vv(2)=pizda(1,2)+pizda(2,1)
9688             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9689      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9690      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9691           enddo
9692         enddo
9693       enddo
9694 c      goto 1112
9695 c1111  continue
9696 C Contribution from graph II
9697       call transpose2(EE(1,1,k),auxmat(1,1))
9698       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9699       vv(1)=pizda(1,1)+pizda(2,2)
9700       vv(2)=pizda(2,1)-pizda(1,2)
9701       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9702      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9703 C Explicit gradient in virtual-dihedral angles.
9704       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9705      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9706       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9707       vv(1)=pizda(1,1)+pizda(2,2)
9708       vv(2)=pizda(2,1)-pizda(1,2)
9709       if (l.eq.j+1) then
9710         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9711      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9712      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9713       else
9714         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9715      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9716      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9717       endif
9718 C Cartesian gradient
9719       do iii=1,2
9720         do kkk=1,5
9721           do lll=1,3
9722             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9723      &        pizda(1,1))
9724             vv(1)=pizda(1,1)+pizda(2,2)
9725             vv(2)=pizda(2,1)-pizda(1,2)
9726             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9727      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9728      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9729           enddo
9730         enddo
9731       enddo
9732 cd      goto 1112
9733 cd1111  continue
9734       if (l.eq.j+1) then
9735 cd        goto 1110
9736 C Parallel orientation
9737 C Contribution from graph III
9738         call transpose2(EUg(1,1,l),auxmat(1,1))
9739         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9740         vv(1)=pizda(1,1)-pizda(2,2)
9741         vv(2)=pizda(1,2)+pizda(2,1)
9742         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9743      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9744 C Explicit gradient in virtual-dihedral angles.
9745         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9746      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9747      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9748         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9749         vv(1)=pizda(1,1)-pizda(2,2)
9750         vv(2)=pizda(1,2)+pizda(2,1)
9751         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9752      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9753      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9754         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9755         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9756         vv(1)=pizda(1,1)-pizda(2,2)
9757         vv(2)=pizda(1,2)+pizda(2,1)
9758         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9759      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9760      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9761 C Cartesian gradient
9762         do iii=1,2
9763           do kkk=1,5
9764             do lll=1,3
9765               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9766      &          pizda(1,1))
9767               vv(1)=pizda(1,1)-pizda(2,2)
9768               vv(2)=pizda(1,2)+pizda(2,1)
9769               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9770      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9771      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9772             enddo
9773           enddo
9774         enddo
9775 cd        goto 1112
9776 C Contribution from graph IV
9777 cd1110    continue
9778         call transpose2(EE(1,1,l),auxmat(1,1))
9779         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9780         vv(1)=pizda(1,1)+pizda(2,2)
9781         vv(2)=pizda(2,1)-pizda(1,2)
9782         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9783      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9784 C Explicit gradient in virtual-dihedral angles.
9785         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9786      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9787         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9788         vv(1)=pizda(1,1)+pizda(2,2)
9789         vv(2)=pizda(2,1)-pizda(1,2)
9790         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9791      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9792      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9793 C Cartesian gradient
9794         do iii=1,2
9795           do kkk=1,5
9796             do lll=1,3
9797               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9798      &          pizda(1,1))
9799               vv(1)=pizda(1,1)+pizda(2,2)
9800               vv(2)=pizda(2,1)-pizda(1,2)
9801               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9802      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9803      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9804             enddo
9805           enddo
9806         enddo
9807       else
9808 C Antiparallel orientation
9809 C Contribution from graph III
9810 c        goto 1110
9811         call transpose2(EUg(1,1,j),auxmat(1,1))
9812         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9813         vv(1)=pizda(1,1)-pizda(2,2)
9814         vv(2)=pizda(1,2)+pizda(2,1)
9815         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9816      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9817 C Explicit gradient in virtual-dihedral angles.
9818         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9819      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9820      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9821         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9822         vv(1)=pizda(1,1)-pizda(2,2)
9823         vv(2)=pizda(1,2)+pizda(2,1)
9824         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9825      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9826      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9827         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9828         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9829         vv(1)=pizda(1,1)-pizda(2,2)
9830         vv(2)=pizda(1,2)+pizda(2,1)
9831         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9832      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9833      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9834 C Cartesian gradient
9835         do iii=1,2
9836           do kkk=1,5
9837             do lll=1,3
9838               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9839      &          pizda(1,1))
9840               vv(1)=pizda(1,1)-pizda(2,2)
9841               vv(2)=pizda(1,2)+pizda(2,1)
9842               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9843      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9844      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9845             enddo
9846           enddo
9847         enddo
9848 cd        goto 1112
9849 C Contribution from graph IV
9850 1110    continue
9851         call transpose2(EE(1,1,j),auxmat(1,1))
9852         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9853         vv(1)=pizda(1,1)+pizda(2,2)
9854         vv(2)=pizda(2,1)-pizda(1,2)
9855         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9856      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9857 C Explicit gradient in virtual-dihedral angles.
9858         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9859      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9860         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9861         vv(1)=pizda(1,1)+pizda(2,2)
9862         vv(2)=pizda(2,1)-pizda(1,2)
9863         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9864      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9865      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9866 C Cartesian gradient
9867         do iii=1,2
9868           do kkk=1,5
9869             do lll=1,3
9870               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9871      &          pizda(1,1))
9872               vv(1)=pizda(1,1)+pizda(2,2)
9873               vv(2)=pizda(2,1)-pizda(1,2)
9874               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9875      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9876      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9877             enddo
9878           enddo
9879         enddo
9880       endif
9881 1112  continue
9882       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9883 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9884 cd        write (2,*) 'ijkl',i,j,k,l
9885 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9886 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9887 cd      endif
9888 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9889 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9890 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9891 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9892       if (j.lt.nres-1) then
9893         j1=j+1
9894         j2=j-1
9895       else
9896         j1=j-1
9897         j2=j-2
9898       endif
9899       if (l.lt.nres-1) then
9900         l1=l+1
9901         l2=l-1
9902       else
9903         l1=l-1
9904         l2=l-2
9905       endif
9906 cd      eij=1.0d0
9907 cd      ekl=1.0d0
9908 cd      ekont=1.0d0
9909 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9910 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9911 C        summed up outside the subrouine as for the other subroutines
9912 C        handling long-range interactions. The old code is commented out
9913 C        with "cgrad" to keep track of changes.
9914       do ll=1,3
9915 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9916 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9917         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9918         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9919 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9920 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9921 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9922 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9923 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9924 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9925 c     &   gradcorr5ij,
9926 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9927 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9928 cgrad        ghalf=0.5d0*ggg1(ll)
9929 cd        ghalf=0.0d0
9930         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9931         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9932         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9933         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9934         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9935         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9936 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9937 cgrad        ghalf=0.5d0*ggg2(ll)
9938 cd        ghalf=0.0d0
9939         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9940         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9941         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9942         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9943         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9944         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
9945       enddo
9946 cd      goto 1112
9947 cgrad      do m=i+1,j-1
9948 cgrad        do ll=1,3
9949 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
9950 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
9951 cgrad        enddo
9952 cgrad      enddo
9953 cgrad      do m=k+1,l-1
9954 cgrad        do ll=1,3
9955 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
9956 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
9957 cgrad        enddo
9958 cgrad      enddo
9959 c1112  continue
9960 cgrad      do m=i+2,j2
9961 cgrad        do ll=1,3
9962 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
9963 cgrad        enddo
9964 cgrad      enddo
9965 cgrad      do m=k+2,l2
9966 cgrad        do ll=1,3
9967 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
9968 cgrad        enddo
9969 cgrad      enddo
9970 cd      do iii=1,nres-3
9971 cd        write (2,*) iii,g_corr5_loc(iii)
9972 cd      enddo
9973       eello5=ekont*eel5
9974 cd      write (2,*) 'ekont',ekont
9975 cd      write (iout,*) 'eello5',ekont*eel5
9976       return
9977       end
9978 c--------------------------------------------------------------------------
9979       double precision function eello6(i,j,k,l,jj,kk)
9980       implicit real*8 (a-h,o-z)
9981       include 'DIMENSIONS'
9982       include 'COMMON.IOUNITS'
9983       include 'COMMON.CHAIN'
9984       include 'COMMON.DERIV'
9985       include 'COMMON.INTERACT'
9986       include 'COMMON.CONTACTS'
9987       include 'COMMON.TORSION'
9988       include 'COMMON.VAR'
9989       include 'COMMON.GEO'
9990       include 'COMMON.FFIELD'
9991       double precision ggg1(3),ggg2(3)
9992 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
9993 cd        eello6=0.0d0
9994 cd        return
9995 cd      endif
9996 cd      write (iout,*)
9997 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
9998 cd     &   ' and',k,l
9999       eello6_1=0.0d0
10000       eello6_2=0.0d0
10001       eello6_3=0.0d0
10002       eello6_4=0.0d0
10003       eello6_5=0.0d0
10004       eello6_6=0.0d0
10005 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10006 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10007       do iii=1,2
10008         do kkk=1,5
10009           do lll=1,3
10010             derx(lll,kkk,iii)=0.0d0
10011           enddo
10012         enddo
10013       enddo
10014 cd      eij=facont_hb(jj,i)
10015 cd      ekl=facont_hb(kk,k)
10016 cd      ekont=eij*ekl
10017 cd      eij=1.0d0
10018 cd      ekl=1.0d0
10019 cd      ekont=1.0d0
10020       if (l.eq.j+1) then
10021         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10022         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10023         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10024         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10025         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10026         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10027       else
10028         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10029         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10030         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10031         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10032         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10033           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10034         else
10035           eello6_5=0.0d0
10036         endif
10037         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10038       endif
10039 C If turn contributions are considered, they will be handled separately.
10040       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10041 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10042 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10043 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10044 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10045 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10046 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10047 cd      goto 1112
10048       if (j.lt.nres-1) then
10049         j1=j+1
10050         j2=j-1
10051       else
10052         j1=j-1
10053         j2=j-2
10054       endif
10055       if (l.lt.nres-1) then
10056         l1=l+1
10057         l2=l-1
10058       else
10059         l1=l-1
10060         l2=l-2
10061       endif
10062       do ll=1,3
10063 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10064 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10065 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10066 cgrad        ghalf=0.5d0*ggg1(ll)
10067 cd        ghalf=0.0d0
10068         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10069         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10070         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10071         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10072         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10073         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10074         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10075         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10076 cgrad        ghalf=0.5d0*ggg2(ll)
10077 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10078 cd        ghalf=0.0d0
10079         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10080         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10081         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10082         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10083         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10084         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10085       enddo
10086 cd      goto 1112
10087 cgrad      do m=i+1,j-1
10088 cgrad        do ll=1,3
10089 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10090 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10091 cgrad        enddo
10092 cgrad      enddo
10093 cgrad      do m=k+1,l-1
10094 cgrad        do ll=1,3
10095 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10096 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10097 cgrad        enddo
10098 cgrad      enddo
10099 cgrad1112  continue
10100 cgrad      do m=i+2,j2
10101 cgrad        do ll=1,3
10102 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10103 cgrad        enddo
10104 cgrad      enddo
10105 cgrad      do m=k+2,l2
10106 cgrad        do ll=1,3
10107 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10108 cgrad        enddo
10109 cgrad      enddo
10110 cd      do iii=1,nres-3
10111 cd        write (2,*) iii,g_corr6_loc(iii)
10112 cd      enddo
10113       eello6=ekont*eel6
10114 cd      write (2,*) 'ekont',ekont
10115 cd      write (iout,*) 'eello6',ekont*eel6
10116       return
10117       end
10118 c--------------------------------------------------------------------------
10119       double precision function eello6_graph1(i,j,k,l,imat,swap)
10120       implicit real*8 (a-h,o-z)
10121       include 'DIMENSIONS'
10122       include 'COMMON.IOUNITS'
10123       include 'COMMON.CHAIN'
10124       include 'COMMON.DERIV'
10125       include 'COMMON.INTERACT'
10126       include 'COMMON.CONTACTS'
10127       include 'COMMON.TORSION'
10128       include 'COMMON.VAR'
10129       include 'COMMON.GEO'
10130       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10131       logical swap
10132       logical lprn
10133       common /kutas/ lprn
10134 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10135 C                                                                              C
10136 C      Parallel       Antiparallel                                             C
10137 C                                                                              C
10138 C          o             o                                                     C
10139 C         /l\           /j\                                                    C
10140 C        /   \         /   \                                                   C
10141 C       /| o |         | o |\                                                  C
10142 C     \ j|/k\|  /   \  |/k\|l /                                                C
10143 C      \ /   \ /     \ /   \ /                                                 C
10144 C       o     o       o     o                                                  C
10145 C       i             i                                                        C
10146 C                                                                              C
10147 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10148       itk=itype2loc(itype(k))
10149       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10150       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10151       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10152       call transpose2(EUgC(1,1,k),auxmat(1,1))
10153       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10154       vv1(1)=pizda1(1,1)-pizda1(2,2)
10155       vv1(2)=pizda1(1,2)+pizda1(2,1)
10156       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10157       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10158       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10159       s5=scalar2(vv(1),Dtobr2(1,i))
10160 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10161       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10162       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10163      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10164      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10165      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10166      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10167      & +scalar2(vv(1),Dtobr2der(1,i)))
10168       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10169       vv1(1)=pizda1(1,1)-pizda1(2,2)
10170       vv1(2)=pizda1(1,2)+pizda1(2,1)
10171       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10172       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10173       if (l.eq.j+1) then
10174         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10175      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10176      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10177      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10178      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10179       else
10180         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10181      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10182      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10183      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10184      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10185       endif
10186       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10187       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10188       vv1(1)=pizda1(1,1)-pizda1(2,2)
10189       vv1(2)=pizda1(1,2)+pizda1(2,1)
10190       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10191      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10192      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10193      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10194       do iii=1,2
10195         if (swap) then
10196           ind=3-iii
10197         else
10198           ind=iii
10199         endif
10200         do kkk=1,5
10201           do lll=1,3
10202             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10203             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10204             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10205             call transpose2(EUgC(1,1,k),auxmat(1,1))
10206             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10207      &        pizda1(1,1))
10208             vv1(1)=pizda1(1,1)-pizda1(2,2)
10209             vv1(2)=pizda1(1,2)+pizda1(2,1)
10210             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10211             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10212      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10213             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10214      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10215             s5=scalar2(vv(1),Dtobr2(1,i))
10216             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10217           enddo
10218         enddo
10219       enddo
10220       return
10221       end
10222 c----------------------------------------------------------------------------
10223       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10224       implicit real*8 (a-h,o-z)
10225       include 'DIMENSIONS'
10226       include 'COMMON.IOUNITS'
10227       include 'COMMON.CHAIN'
10228       include 'COMMON.DERIV'
10229       include 'COMMON.INTERACT'
10230       include 'COMMON.CONTACTS'
10231       include 'COMMON.TORSION'
10232       include 'COMMON.VAR'
10233       include 'COMMON.GEO'
10234       logical swap
10235       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10236      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10237       logical lprn
10238       common /kutas/ lprn
10239 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10240 C                                                                              C
10241 C      Parallel       Antiparallel                                             C
10242 C                                                                              C
10243 C          o             o                                                     C
10244 C     \   /l\           /j\   /                                                C
10245 C      \ /   \         /   \ /                                                 C
10246 C       o| o |         | o |o                                                  C
10247 C     \ j|/k\|      \  |/k\|l                                                  C
10248 C      \ /   \       \ /   \                                                   C
10249 C       o             o                                                        C
10250 C       i             i                                                        C
10251 C                                                                              C
10252 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10253 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10254 C AL 7/4/01 s1 would occur in the sixth-order moment,
10255 C           but not in a cluster cumulant
10256 #ifdef MOMENT
10257       s1=dip(1,jj,i)*dip(1,kk,k)
10258 #endif
10259       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10260       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10261       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10262       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10263       call transpose2(EUg(1,1,k),auxmat(1,1))
10264       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10265       vv(1)=pizda(1,1)-pizda(2,2)
10266       vv(2)=pizda(1,2)+pizda(2,1)
10267       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10268 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10269 #ifdef MOMENT
10270       eello6_graph2=-(s1+s2+s3+s4)
10271 #else
10272       eello6_graph2=-(s2+s3+s4)
10273 #endif
10274 c      eello6_graph2=-s3
10275 C Derivatives in gamma(i-1)
10276       if (i.gt.1) then
10277 #ifdef MOMENT
10278         s1=dipderg(1,jj,i)*dip(1,kk,k)
10279 #endif
10280         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10281         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10282         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10283         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10284 #ifdef MOMENT
10285         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10286 #else
10287         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10288 #endif
10289 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10290       endif
10291 C Derivatives in gamma(k-1)
10292 #ifdef MOMENT
10293       s1=dip(1,jj,i)*dipderg(1,kk,k)
10294 #endif
10295       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10296       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10297       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10298       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10299       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10300       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10301       vv(1)=pizda(1,1)-pizda(2,2)
10302       vv(2)=pizda(1,2)+pizda(2,1)
10303       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10304 #ifdef MOMENT
10305       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10306 #else
10307       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10308 #endif
10309 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10310 C Derivatives in gamma(j-1) or gamma(l-1)
10311       if (j.gt.1) then
10312 #ifdef MOMENT
10313         s1=dipderg(3,jj,i)*dip(1,kk,k)
10314 #endif
10315         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10316         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10317         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10318         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10319         vv(1)=pizda(1,1)-pizda(2,2)
10320         vv(2)=pizda(1,2)+pizda(2,1)
10321         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10322 #ifdef MOMENT
10323         if (swap) then
10324           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10325         else
10326           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10327         endif
10328 #endif
10329         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10330 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10331       endif
10332 C Derivatives in gamma(l-1) or gamma(j-1)
10333       if (l.gt.1) then
10334 #ifdef MOMENT
10335         s1=dip(1,jj,i)*dipderg(3,kk,k)
10336 #endif
10337         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10338         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10339         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10340         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10341         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10342         vv(1)=pizda(1,1)-pizda(2,2)
10343         vv(2)=pizda(1,2)+pizda(2,1)
10344         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10345 #ifdef MOMENT
10346         if (swap) then
10347           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10348         else
10349           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10350         endif
10351 #endif
10352         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10353 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10354       endif
10355 C Cartesian derivatives.
10356       if (lprn) then
10357         write (2,*) 'In eello6_graph2'
10358         do iii=1,2
10359           write (2,*) 'iii=',iii
10360           do kkk=1,5
10361             write (2,*) 'kkk=',kkk
10362             do jjj=1,2
10363               write (2,'(3(2f10.5),5x)')
10364      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10365             enddo
10366           enddo
10367         enddo
10368       endif
10369       do iii=1,2
10370         do kkk=1,5
10371           do lll=1,3
10372 #ifdef MOMENT
10373             if (iii.eq.1) then
10374               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10375             else
10376               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10377             endif
10378 #endif
10379             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10380      &        auxvec(1))
10381             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10382             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10383      &        auxvec(1))
10384             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10385             call transpose2(EUg(1,1,k),auxmat(1,1))
10386             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10387      &        pizda(1,1))
10388             vv(1)=pizda(1,1)-pizda(2,2)
10389             vv(2)=pizda(1,2)+pizda(2,1)
10390             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10391 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10392 #ifdef MOMENT
10393             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10394 #else
10395             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10396 #endif
10397             if (swap) then
10398               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10399             else
10400               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10401             endif
10402           enddo
10403         enddo
10404       enddo
10405       return
10406       end
10407 c----------------------------------------------------------------------------
10408       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10409       implicit real*8 (a-h,o-z)
10410       include 'DIMENSIONS'
10411       include 'COMMON.IOUNITS'
10412       include 'COMMON.CHAIN'
10413       include 'COMMON.DERIV'
10414       include 'COMMON.INTERACT'
10415       include 'COMMON.CONTACTS'
10416       include 'COMMON.TORSION'
10417       include 'COMMON.VAR'
10418       include 'COMMON.GEO'
10419       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10420       logical swap
10421 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10422 C                                                                              C
10423 C      Parallel       Antiparallel                                             C
10424 C                                                                              C
10425 C          o             o                                                     C
10426 C         /l\   /   \   /j\                                                    C
10427 C        /   \ /     \ /   \                                                   C
10428 C       /| o |o       o| o |\                                                  C
10429 C       j|/k\|  /      |/k\|l /                                                C
10430 C        /   \ /       /   \ /                                                 C
10431 C       /     o       /     o                                                  C
10432 C       i             i                                                        C
10433 C                                                                              C
10434 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10435 C
10436 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10437 C           energy moment and not to the cluster cumulant.
10438       iti=itortyp(itype(i))
10439       if (j.lt.nres-1) then
10440         itj1=itype2loc(itype(j+1))
10441       else
10442         itj1=nloctyp
10443       endif
10444       itk=itype2loc(itype(k))
10445       itk1=itype2loc(itype(k+1))
10446       if (l.lt.nres-1) then
10447         itl1=itype2loc(itype(l+1))
10448       else
10449         itl1=nloctyp
10450       endif
10451 #ifdef MOMENT
10452       s1=dip(4,jj,i)*dip(4,kk,k)
10453 #endif
10454       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10455       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10456       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10457       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10458       call transpose2(EE(1,1,k),auxmat(1,1))
10459       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10460       vv(1)=pizda(1,1)+pizda(2,2)
10461       vv(2)=pizda(2,1)-pizda(1,2)
10462       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10463 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10464 cd     & "sum",-(s2+s3+s4)
10465 #ifdef MOMENT
10466       eello6_graph3=-(s1+s2+s3+s4)
10467 #else
10468       eello6_graph3=-(s2+s3+s4)
10469 #endif
10470 c      eello6_graph3=-s4
10471 C Derivatives in gamma(k-1)
10472       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10473       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10474       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10475       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10476 C Derivatives in gamma(l-1)
10477       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10478       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10479       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10480       vv(1)=pizda(1,1)+pizda(2,2)
10481       vv(2)=pizda(2,1)-pizda(1,2)
10482       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10483       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10484 C Cartesian derivatives.
10485       do iii=1,2
10486         do kkk=1,5
10487           do lll=1,3
10488 #ifdef MOMENT
10489             if (iii.eq.1) then
10490               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10491             else
10492               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10493             endif
10494 #endif
10495             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10496      &        auxvec(1))
10497             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10498             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10499      &        auxvec(1))
10500             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10501             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10502      &        pizda(1,1))
10503             vv(1)=pizda(1,1)+pizda(2,2)
10504             vv(2)=pizda(2,1)-pizda(1,2)
10505             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10506 #ifdef MOMENT
10507             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10508 #else
10509             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10510 #endif
10511             if (swap) then
10512               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10513             else
10514               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10515             endif
10516 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10517           enddo
10518         enddo
10519       enddo
10520       return
10521       end
10522 c----------------------------------------------------------------------------
10523       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10524       implicit real*8 (a-h,o-z)
10525       include 'DIMENSIONS'
10526       include 'COMMON.IOUNITS'
10527       include 'COMMON.CHAIN'
10528       include 'COMMON.DERIV'
10529       include 'COMMON.INTERACT'
10530       include 'COMMON.CONTACTS'
10531       include 'COMMON.TORSION'
10532       include 'COMMON.VAR'
10533       include 'COMMON.GEO'
10534       include 'COMMON.FFIELD'
10535       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10536      & auxvec1(2),auxmat1(2,2)
10537       logical swap
10538 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10539 C                                                                              C
10540 C      Parallel       Antiparallel                                             C
10541 C                                                                              C
10542 C          o             o                                                     C
10543 C         /l\   /   \   /j\                                                    C
10544 C        /   \ /     \ /   \                                                   C
10545 C       /| o |o       o| o |\                                                  C
10546 C     \ j|/k\|      \  |/k\|l                                                  C
10547 C      \ /   \       \ /   \                                                   C
10548 C       o     \       o     \                                                  C
10549 C       i             i                                                        C
10550 C                                                                              C
10551 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10552 C
10553 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10554 C           energy moment and not to the cluster cumulant.
10555 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10556       iti=itype2loc(itype(i))
10557       itj=itype2loc(itype(j))
10558       if (j.lt.nres-1) then
10559         itj1=itype2loc(itype(j+1))
10560       else
10561         itj1=nloctyp
10562       endif
10563       itk=itype2loc(itype(k))
10564       if (k.lt.nres-1) then
10565         itk1=itype2loc(itype(k+1))
10566       else
10567         itk1=nloctyp
10568       endif
10569       itl=itype2loc(itype(l))
10570       if (l.lt.nres-1) then
10571         itl1=itype2loc(itype(l+1))
10572       else
10573         itl1=nloctyp
10574       endif
10575 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10576 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10577 cd     & ' itl',itl,' itl1',itl1
10578 #ifdef MOMENT
10579       if (imat.eq.1) then
10580         s1=dip(3,jj,i)*dip(3,kk,k)
10581       else
10582         s1=dip(2,jj,j)*dip(2,kk,l)
10583       endif
10584 #endif
10585       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10586       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10587       if (j.eq.l+1) then
10588         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10589         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10590       else
10591         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10592         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10593       endif
10594       call transpose2(EUg(1,1,k),auxmat(1,1))
10595       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10596       vv(1)=pizda(1,1)-pizda(2,2)
10597       vv(2)=pizda(2,1)+pizda(1,2)
10598       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10599 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10600 #ifdef MOMENT
10601       eello6_graph4=-(s1+s2+s3+s4)
10602 #else
10603       eello6_graph4=-(s2+s3+s4)
10604 #endif
10605 C Derivatives in gamma(i-1)
10606       if (i.gt.1) then
10607 #ifdef MOMENT
10608         if (imat.eq.1) then
10609           s1=dipderg(2,jj,i)*dip(3,kk,k)
10610         else
10611           s1=dipderg(4,jj,j)*dip(2,kk,l)
10612         endif
10613 #endif
10614         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10615         if (j.eq.l+1) then
10616           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10617           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10618         else
10619           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10620           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10621         endif
10622         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10623         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10624 cd          write (2,*) 'turn6 derivatives'
10625 #ifdef MOMENT
10626           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10627 #else
10628           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10629 #endif
10630         else
10631 #ifdef MOMENT
10632           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10633 #else
10634           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10635 #endif
10636         endif
10637       endif
10638 C Derivatives in gamma(k-1)
10639 #ifdef MOMENT
10640       if (imat.eq.1) then
10641         s1=dip(3,jj,i)*dipderg(2,kk,k)
10642       else
10643         s1=dip(2,jj,j)*dipderg(4,kk,l)
10644       endif
10645 #endif
10646       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10647       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10648       if (j.eq.l+1) then
10649         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10650         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10651       else
10652         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10653         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10654       endif
10655       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10656       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10657       vv(1)=pizda(1,1)-pizda(2,2)
10658       vv(2)=pizda(2,1)+pizda(1,2)
10659       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10660       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10661 #ifdef MOMENT
10662         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10663 #else
10664         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10665 #endif
10666       else
10667 #ifdef MOMENT
10668         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10669 #else
10670         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10671 #endif
10672       endif
10673 C Derivatives in gamma(j-1) or gamma(l-1)
10674       if (l.eq.j+1 .and. l.gt.1) then
10675         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10676         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10677         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10678         vv(1)=pizda(1,1)-pizda(2,2)
10679         vv(2)=pizda(2,1)+pizda(1,2)
10680         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10681         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10682       else if (j.gt.1) then
10683         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10684         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10685         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10686         vv(1)=pizda(1,1)-pizda(2,2)
10687         vv(2)=pizda(2,1)+pizda(1,2)
10688         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10689         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10690           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10691         else
10692           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10693         endif
10694       endif
10695 C Cartesian derivatives.
10696       do iii=1,2
10697         do kkk=1,5
10698           do lll=1,3
10699 #ifdef MOMENT
10700             if (iii.eq.1) then
10701               if (imat.eq.1) then
10702                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10703               else
10704                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10705               endif
10706             else
10707               if (imat.eq.1) then
10708                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10709               else
10710                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10711               endif
10712             endif
10713 #endif
10714             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10715      &        auxvec(1))
10716             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10717             if (j.eq.l+1) then
10718               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10719      &          b1(1,j+1),auxvec(1))
10720               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10721             else
10722               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10723      &          b1(1,l+1),auxvec(1))
10724               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10725             endif
10726             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10727      &        pizda(1,1))
10728             vv(1)=pizda(1,1)-pizda(2,2)
10729             vv(2)=pizda(2,1)+pizda(1,2)
10730             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10731             if (swap) then
10732               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10733 #ifdef MOMENT
10734                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10735      &             -(s1+s2+s4)
10736 #else
10737                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10738      &             -(s2+s4)
10739 #endif
10740                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10741               else
10742 #ifdef MOMENT
10743                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10744 #else
10745                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10746 #endif
10747                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10748               endif
10749             else
10750 #ifdef MOMENT
10751               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10752 #else
10753               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10754 #endif
10755               if (l.eq.j+1) then
10756                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10757               else
10758                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10759               endif
10760             endif
10761           enddo
10762         enddo
10763       enddo
10764       return
10765       end
10766 c----------------------------------------------------------------------------
10767       double precision function eello_turn6(i,jj,kk)
10768       implicit real*8 (a-h,o-z)
10769       include 'DIMENSIONS'
10770       include 'COMMON.IOUNITS'
10771       include 'COMMON.CHAIN'
10772       include 'COMMON.DERIV'
10773       include 'COMMON.INTERACT'
10774       include 'COMMON.CONTACTS'
10775       include 'COMMON.TORSION'
10776       include 'COMMON.VAR'
10777       include 'COMMON.GEO'
10778       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10779      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10780      &  ggg1(3),ggg2(3)
10781       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10782      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10783 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10784 C           the respective energy moment and not to the cluster cumulant.
10785       s1=0.0d0
10786       s8=0.0d0
10787       s13=0.0d0
10788 c
10789       eello_turn6=0.0d0
10790       j=i+4
10791       k=i+1
10792       l=i+3
10793       iti=itype2loc(itype(i))
10794       itk=itype2loc(itype(k))
10795       itk1=itype2loc(itype(k+1))
10796       itl=itype2loc(itype(l))
10797       itj=itype2loc(itype(j))
10798 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10799 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10800 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10801 cd        eello6=0.0d0
10802 cd        return
10803 cd      endif
10804 cd      write (iout,*)
10805 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10806 cd     &   ' and',k,l
10807 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10808       do iii=1,2
10809         do kkk=1,5
10810           do lll=1,3
10811             derx_turn(lll,kkk,iii)=0.0d0
10812           enddo
10813         enddo
10814       enddo
10815 cd      eij=1.0d0
10816 cd      ekl=1.0d0
10817 cd      ekont=1.0d0
10818       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10819 cd      eello6_5=0.0d0
10820 cd      write (2,*) 'eello6_5',eello6_5
10821 #ifdef MOMENT
10822       call transpose2(AEA(1,1,1),auxmat(1,1))
10823       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10824       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10825       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10826 #endif
10827       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10828       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10829       s2 = scalar2(b1(1,k),vtemp1(1))
10830 #ifdef MOMENT
10831       call transpose2(AEA(1,1,2),atemp(1,1))
10832       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10833       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10834       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10835 #endif
10836       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10837       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10838       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10839 #ifdef MOMENT
10840       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10841       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10842       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10843       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10844       ss13 = scalar2(b1(1,k),vtemp4(1))
10845       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10846 #endif
10847 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10848 c      s1=0.0d0
10849 c      s2=0.0d0
10850 c      s8=0.0d0
10851 c      s12=0.0d0
10852 c      s13=0.0d0
10853       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10854 C Derivatives in gamma(i+2)
10855       s1d =0.0d0
10856       s8d =0.0d0
10857 #ifdef MOMENT
10858       call transpose2(AEA(1,1,1),auxmatd(1,1))
10859       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10860       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10861       call transpose2(AEAderg(1,1,2),atempd(1,1))
10862       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10863       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10864 #endif
10865       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10866       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10867       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10868 c      s1d=0.0d0
10869 c      s2d=0.0d0
10870 c      s8d=0.0d0
10871 c      s12d=0.0d0
10872 c      s13d=0.0d0
10873       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10874 C Derivatives in gamma(i+3)
10875 #ifdef MOMENT
10876       call transpose2(AEA(1,1,1),auxmatd(1,1))
10877       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10878       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10879       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10880 #endif
10881       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10882       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10883       s2d = scalar2(b1(1,k),vtemp1d(1))
10884 #ifdef MOMENT
10885       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10886       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10887 #endif
10888       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10889 #ifdef MOMENT
10890       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10891       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10892       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10893 #endif
10894 c      s1d=0.0d0
10895 c      s2d=0.0d0
10896 c      s8d=0.0d0
10897 c      s12d=0.0d0
10898 c      s13d=0.0d0
10899 #ifdef MOMENT
10900       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10901      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10902 #else
10903       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10904      &               -0.5d0*ekont*(s2d+s12d)
10905 #endif
10906 C Derivatives in gamma(i+4)
10907       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10908       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10909       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10910 #ifdef MOMENT
10911       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10912       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10913       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10914 #endif
10915 c      s1d=0.0d0
10916 c      s2d=0.0d0
10917 c      s8d=0.0d0
10918 C      s12d=0.0d0
10919 c      s13d=0.0d0
10920 #ifdef MOMENT
10921       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10922 #else
10923       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10924 #endif
10925 C Derivatives in gamma(i+5)
10926 #ifdef MOMENT
10927       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10928       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10929       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10930 #endif
10931       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10932       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10933       s2d = scalar2(b1(1,k),vtemp1d(1))
10934 #ifdef MOMENT
10935       call transpose2(AEA(1,1,2),atempd(1,1))
10936       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10937       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10938 #endif
10939       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10940       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10941 #ifdef MOMENT
10942       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10943       ss13d = scalar2(b1(1,k),vtemp4d(1))
10944       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
10945 #endif
10946 c      s1d=0.0d0
10947 c      s2d=0.0d0
10948 c      s8d=0.0d0
10949 c      s12d=0.0d0
10950 c      s13d=0.0d0
10951 #ifdef MOMENT
10952       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10953      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10954 #else
10955       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
10956      &               -0.5d0*ekont*(s2d+s12d)
10957 #endif
10958 C Cartesian derivatives
10959       do iii=1,2
10960         do kkk=1,5
10961           do lll=1,3
10962 #ifdef MOMENT
10963             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
10964             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10965             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10966 #endif
10967             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10968             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
10969      &          vtemp1d(1))
10970             s2d = scalar2(b1(1,k),vtemp1d(1))
10971 #ifdef MOMENT
10972             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
10973             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10974             s8d = -(atempd(1,1)+atempd(2,2))*
10975      &           scalar2(cc(1,1,l),vtemp2(1))
10976 #endif
10977             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
10978      &           auxmatd(1,1))
10979             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10980             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10981 c      s1d=0.0d0
10982 c      s2d=0.0d0
10983 c      s8d=0.0d0
10984 c      s12d=0.0d0
10985 c      s13d=0.0d0
10986 #ifdef MOMENT
10987             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10988      &        - 0.5d0*(s1d+s2d)
10989 #else
10990             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
10991      &        - 0.5d0*s2d
10992 #endif
10993 #ifdef MOMENT
10994             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10995      &        - 0.5d0*(s8d+s12d)
10996 #else
10997             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
10998      &        - 0.5d0*s12d
10999 #endif
11000           enddo
11001         enddo
11002       enddo
11003 #ifdef MOMENT
11004       do kkk=1,5
11005         do lll=1,3
11006           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11007      &      achuj_tempd(1,1))
11008           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11009           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11010           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11011           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11012           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11013      &      vtemp4d(1))
11014           ss13d = scalar2(b1(1,k),vtemp4d(1))
11015           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11016           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11017         enddo
11018       enddo
11019 #endif
11020 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11021 cd     &  16*eel_turn6_num
11022 cd      goto 1112
11023       if (j.lt.nres-1) then
11024         j1=j+1
11025         j2=j-1
11026       else
11027         j1=j-1
11028         j2=j-2
11029       endif
11030       if (l.lt.nres-1) then
11031         l1=l+1
11032         l2=l-1
11033       else
11034         l1=l-1
11035         l2=l-2
11036       endif
11037       do ll=1,3
11038 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11039 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11040 cgrad        ghalf=0.5d0*ggg1(ll)
11041 cd        ghalf=0.0d0
11042         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11043         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11044         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11045      &    +ekont*derx_turn(ll,2,1)
11046         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11047         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11048      &    +ekont*derx_turn(ll,4,1)
11049         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11050         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11051         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11052 cgrad        ghalf=0.5d0*ggg2(ll)
11053 cd        ghalf=0.0d0
11054         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11055      &    +ekont*derx_turn(ll,2,2)
11056         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11057         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11058      &    +ekont*derx_turn(ll,4,2)
11059         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11060         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11061         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11062       enddo
11063 cd      goto 1112
11064 cgrad      do m=i+1,j-1
11065 cgrad        do ll=1,3
11066 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11067 cgrad        enddo
11068 cgrad      enddo
11069 cgrad      do m=k+1,l-1
11070 cgrad        do ll=1,3
11071 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11072 cgrad        enddo
11073 cgrad      enddo
11074 cgrad1112  continue
11075 cgrad      do m=i+2,j2
11076 cgrad        do ll=1,3
11077 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11078 cgrad        enddo
11079 cgrad      enddo
11080 cgrad      do m=k+2,l2
11081 cgrad        do ll=1,3
11082 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11083 cgrad        enddo
11084 cgrad      enddo
11085 cd      do iii=1,nres-3
11086 cd        write (2,*) iii,g_corr6_loc(iii)
11087 cd      enddo
11088       eello_turn6=ekont*eel_turn6
11089 cd      write (2,*) 'ekont',ekont
11090 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11091       return
11092       end
11093
11094 C-----------------------------------------------------------------------------
11095       double precision function scalar(u,v)
11096 !DIR$ INLINEALWAYS scalar
11097 #ifndef OSF
11098 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11099 #endif
11100       implicit none
11101       double precision u(3),v(3)
11102 cd      double precision sc
11103 cd      integer i
11104 cd      sc=0.0d0
11105 cd      do i=1,3
11106 cd        sc=sc+u(i)*v(i)
11107 cd      enddo
11108 cd      scalar=sc
11109
11110       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11111       return
11112       end
11113 crc-------------------------------------------------
11114       SUBROUTINE MATVEC2(A1,V1,V2)
11115 !DIR$ INLINEALWAYS MATVEC2
11116 #ifndef OSF
11117 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11118 #endif
11119       implicit real*8 (a-h,o-z)
11120       include 'DIMENSIONS'
11121       DIMENSION A1(2,2),V1(2),V2(2)
11122 c      DO 1 I=1,2
11123 c        VI=0.0
11124 c        DO 3 K=1,2
11125 c    3     VI=VI+A1(I,K)*V1(K)
11126 c        Vaux(I)=VI
11127 c    1 CONTINUE
11128
11129       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11130       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11131
11132       v2(1)=vaux1
11133       v2(2)=vaux2
11134       END
11135 C---------------------------------------
11136       SUBROUTINE MATMAT2(A1,A2,A3)
11137 #ifndef OSF
11138 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11139 #endif
11140       implicit real*8 (a-h,o-z)
11141       include 'DIMENSIONS'
11142       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11143 c      DIMENSION AI3(2,2)
11144 c        DO  J=1,2
11145 c          A3IJ=0.0
11146 c          DO K=1,2
11147 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11148 c          enddo
11149 c          A3(I,J)=A3IJ
11150 c       enddo
11151 c      enddo
11152
11153       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11154       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11155       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11156       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11157
11158       A3(1,1)=AI3_11
11159       A3(2,1)=AI3_21
11160       A3(1,2)=AI3_12
11161       A3(2,2)=AI3_22
11162       END
11163
11164 c-------------------------------------------------------------------------
11165       double precision function scalar2(u,v)
11166 !DIR$ INLINEALWAYS scalar2
11167       implicit none
11168       double precision u(2),v(2)
11169       double precision sc
11170       integer i
11171       scalar2=u(1)*v(1)+u(2)*v(2)
11172       return
11173       end
11174
11175 C-----------------------------------------------------------------------------
11176
11177       subroutine transpose2(a,at)
11178 !DIR$ INLINEALWAYS transpose2
11179 #ifndef OSF
11180 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11181 #endif
11182       implicit none
11183       double precision a(2,2),at(2,2)
11184       at(1,1)=a(1,1)
11185       at(1,2)=a(2,1)
11186       at(2,1)=a(1,2)
11187       at(2,2)=a(2,2)
11188       return
11189       end
11190 c--------------------------------------------------------------------------
11191       subroutine transpose(n,a,at)
11192       implicit none
11193       integer n,i,j
11194       double precision a(n,n),at(n,n)
11195       do i=1,n
11196         do j=1,n
11197           at(j,i)=a(i,j)
11198         enddo
11199       enddo
11200       return
11201       end
11202 C---------------------------------------------------------------------------
11203       subroutine prodmat3(a1,a2,kk,transp,prod)
11204 !DIR$ INLINEALWAYS prodmat3
11205 #ifndef OSF
11206 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11207 #endif
11208       implicit none
11209       integer i,j
11210       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11211       logical transp
11212 crc      double precision auxmat(2,2),prod_(2,2)
11213
11214       if (transp) then
11215 crc        call transpose2(kk(1,1),auxmat(1,1))
11216 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11217 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11218
11219            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11220      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11221            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11222      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11223            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11224      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11225            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11226      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11227
11228       else
11229 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11230 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11231
11232            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11233      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11234            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11235      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11236            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11237      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11238            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11239      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11240
11241       endif
11242 c      call transpose2(a2(1,1),a2t(1,1))
11243
11244 crc      print *,transp
11245 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11246 crc      print *,((prod(i,j),i=1,2),j=1,2)
11247
11248       return
11249       end
11250 CCC----------------------------------------------
11251       subroutine Eliptransfer(eliptran)
11252       implicit real*8 (a-h,o-z)
11253       include 'DIMENSIONS'
11254       include 'COMMON.GEO'
11255       include 'COMMON.VAR'
11256       include 'COMMON.LOCAL'
11257       include 'COMMON.CHAIN'
11258       include 'COMMON.DERIV'
11259       include 'COMMON.NAMES'
11260       include 'COMMON.INTERACT'
11261       include 'COMMON.IOUNITS'
11262       include 'COMMON.CALC'
11263       include 'COMMON.CONTROL'
11264       include 'COMMON.SPLITELE'
11265       include 'COMMON.SBRIDGE'
11266 C this is done by Adasko
11267 C      print *,"wchodze"
11268 C structure of box:
11269 C      water
11270 C--bordliptop-- buffore starts
11271 C--bufliptop--- here true lipid starts
11272 C      lipid
11273 C--buflipbot--- lipid ends buffore starts
11274 C--bordlipbot--buffore ends
11275       eliptran=0.0
11276       do i=ilip_start,ilip_end
11277 C       do i=1,1
11278         if (itype(i).eq.ntyp1) cycle
11279
11280         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11281         if (positi.le.0.0) positi=positi+boxzsize
11282 C        print *,i
11283 C first for peptide groups
11284 c for each residue check if it is in lipid or lipid water border area
11285        if ((positi.gt.bordlipbot)
11286      &.and.(positi.lt.bordliptop)) then
11287 C the energy transfer exist
11288         if (positi.lt.buflipbot) then
11289 C what fraction I am in
11290          fracinbuf=1.0d0-
11291      &        ((positi-bordlipbot)/lipbufthick)
11292 C lipbufthick is thickenes of lipid buffore
11293          sslip=sscalelip(fracinbuf)
11294          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11295          eliptran=eliptran+sslip*pepliptran
11296          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11297          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11298 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11299
11300 C        print *,"doing sccale for lower part"
11301 C         print *,i,sslip,fracinbuf,ssgradlip
11302         elseif (positi.gt.bufliptop) then
11303          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11304          sslip=sscalelip(fracinbuf)
11305          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11306          eliptran=eliptran+sslip*pepliptran
11307          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11308          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11309 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11310 C          print *, "doing sscalefor top part"
11311 C         print *,i,sslip,fracinbuf,ssgradlip
11312         else
11313          eliptran=eliptran+pepliptran
11314 C         print *,"I am in true lipid"
11315         endif
11316 C       else
11317 C       eliptran=elpitran+0.0 ! I am in water
11318        endif
11319        enddo
11320 C       print *, "nic nie bylo w lipidzie?"
11321 C now multiply all by the peptide group transfer factor
11322 C       eliptran=eliptran*pepliptran
11323 C now the same for side chains
11324 CV       do i=1,1
11325        do i=ilip_start,ilip_end
11326         if (itype(i).eq.ntyp1) cycle
11327         positi=(mod(c(3,i+nres),boxzsize))
11328         if (positi.le.0) positi=positi+boxzsize
11329 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11330 c for each residue check if it is in lipid or lipid water border area
11331 C       respos=mod(c(3,i+nres),boxzsize)
11332 C       print *,positi,bordlipbot,buflipbot
11333        if ((positi.gt.bordlipbot)
11334      & .and.(positi.lt.bordliptop)) then
11335 C the energy transfer exist
11336         if (positi.lt.buflipbot) then
11337          fracinbuf=1.0d0-
11338      &     ((positi-bordlipbot)/lipbufthick)
11339 C lipbufthick is thickenes of lipid buffore
11340          sslip=sscalelip(fracinbuf)
11341          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11342          eliptran=eliptran+sslip*liptranene(itype(i))
11343          gliptranx(3,i)=gliptranx(3,i)
11344      &+ssgradlip*liptranene(itype(i))
11345          gliptranc(3,i-1)= gliptranc(3,i-1)
11346      &+ssgradlip*liptranene(itype(i))
11347 C         print *,"doing sccale for lower part"
11348         elseif (positi.gt.bufliptop) then
11349          fracinbuf=1.0d0-
11350      &((bordliptop-positi)/lipbufthick)
11351          sslip=sscalelip(fracinbuf)
11352          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11353          eliptran=eliptran+sslip*liptranene(itype(i))
11354          gliptranx(3,i)=gliptranx(3,i)
11355      &+ssgradlip*liptranene(itype(i))
11356          gliptranc(3,i-1)= gliptranc(3,i-1)
11357      &+ssgradlip*liptranene(itype(i))
11358 C          print *, "doing sscalefor top part",sslip,fracinbuf
11359         else
11360          eliptran=eliptran+liptranene(itype(i))
11361 C         print *,"I am in true lipid"
11362         endif
11363         endif ! if in lipid or buffor
11364 C       else
11365 C       eliptran=elpitran+0.0 ! I am in water
11366        enddo
11367        return
11368        end
11369 C---------------------------------------------------------
11370 C AFM soubroutine for constant force
11371        subroutine AFMforce(Eafmforce)
11372        implicit real*8 (a-h,o-z)
11373       include 'DIMENSIONS'
11374       include 'COMMON.GEO'
11375       include 'COMMON.VAR'
11376       include 'COMMON.LOCAL'
11377       include 'COMMON.CHAIN'
11378       include 'COMMON.DERIV'
11379       include 'COMMON.NAMES'
11380       include 'COMMON.INTERACT'
11381       include 'COMMON.IOUNITS'
11382       include 'COMMON.CALC'
11383       include 'COMMON.CONTROL'
11384       include 'COMMON.SPLITELE'
11385       include 'COMMON.SBRIDGE'
11386       real*8 diffafm(3)
11387       dist=0.0d0
11388       Eafmforce=0.0d0
11389       do i=1,3
11390       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11391       dist=dist+diffafm(i)**2
11392       enddo
11393       dist=dsqrt(dist)
11394       Eafmforce=-forceAFMconst*(dist-distafminit)
11395       do i=1,3
11396       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11397       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11398       enddo
11399 C      print *,'AFM',Eafmforce
11400       return
11401       end
11402 C---------------------------------------------------------
11403 C AFM subroutine with pseudoconstant velocity
11404        subroutine AFMvel(Eafmforce)
11405        implicit real*8 (a-h,o-z)
11406       include 'DIMENSIONS'
11407       include 'COMMON.GEO'
11408       include 'COMMON.VAR'
11409       include 'COMMON.LOCAL'
11410       include 'COMMON.CHAIN'
11411       include 'COMMON.DERIV'
11412       include 'COMMON.NAMES'
11413       include 'COMMON.INTERACT'
11414       include 'COMMON.IOUNITS'
11415       include 'COMMON.CALC'
11416       include 'COMMON.CONTROL'
11417       include 'COMMON.SPLITELE'
11418       include 'COMMON.SBRIDGE'
11419       real*8 diffafm(3)
11420 C Only for check grad COMMENT if not used for checkgrad
11421 C      totT=3.0d0
11422 C--------------------------------------------------------
11423 C      print *,"wchodze"
11424       dist=0.0d0
11425       Eafmforce=0.0d0
11426       do i=1,3
11427       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11428       dist=dist+diffafm(i)**2
11429       enddo
11430       dist=dsqrt(dist)
11431       Eafmforce=0.5d0*forceAFMconst
11432      & *(distafminit+totTafm*velAFMconst-dist)**2
11433 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11434       do i=1,3
11435       gradafm(i,afmend-1)=-forceAFMconst*
11436      &(distafminit+totTafm*velAFMconst-dist)
11437      &*diffafm(i)/dist
11438       gradafm(i,afmbeg-1)=forceAFMconst*
11439      &(distafminit+totTafm*velAFMconst-dist)
11440      &*diffafm(i)/dist
11441       enddo
11442 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11443       return
11444       end
11445 C-----------------------------------------------------------
11446 C first for shielding is setting of function of side-chains
11447        subroutine set_shield_fac
11448       implicit real*8 (a-h,o-z)
11449       include 'DIMENSIONS'
11450       include 'COMMON.CHAIN'
11451       include 'COMMON.DERIV'
11452       include 'COMMON.IOUNITS'
11453       include 'COMMON.SHIELD'
11454       include 'COMMON.INTERACT'
11455 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11456       double precision div77_81/0.974996043d0/,
11457      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11458
11459 C the vector between center of side_chain and peptide group
11460        double precision pep_side(3),long,side_calf(3),
11461      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11462      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11463 C the line belowe needs to be changed for FGPROC>1
11464       do i=1,nres-1
11465       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11466       ishield_list(i)=0
11467 Cif there two consequtive dummy atoms there is no peptide group between them
11468 C the line below has to be changed for FGPROC>1
11469       VolumeTotal=0.0
11470       do k=1,nres
11471        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11472        dist_pep_side=0.0
11473        dist_side_calf=0.0
11474        do j=1,3
11475 C first lets set vector conecting the ithe side-chain with kth side-chain
11476       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11477 C      pep_side(j)=2.0d0
11478 C and vector conecting the side-chain with its proper calfa
11479       side_calf(j)=c(j,k+nres)-c(j,k)
11480 C      side_calf(j)=2.0d0
11481       pept_group(j)=c(j,i)-c(j,i+1)
11482 C lets have their lenght
11483       dist_pep_side=pep_side(j)**2+dist_pep_side
11484       dist_side_calf=dist_side_calf+side_calf(j)**2
11485       dist_pept_group=dist_pept_group+pept_group(j)**2
11486       enddo
11487        dist_pep_side=dsqrt(dist_pep_side)
11488        dist_pept_group=dsqrt(dist_pept_group)
11489        dist_side_calf=dsqrt(dist_side_calf)
11490       do j=1,3
11491         pep_side_norm(j)=pep_side(j)/dist_pep_side
11492         side_calf_norm(j)=dist_side_calf
11493       enddo
11494 C now sscale fraction
11495        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11496 C       print *,buff_shield,"buff"
11497 C now sscale
11498         if (sh_frac_dist.le.0.0) cycle
11499 C If we reach here it means that this side chain reaches the shielding sphere
11500 C Lets add him to the list for gradient
11501         ishield_list(i)=ishield_list(i)+1
11502 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11503 C this list is essential otherwise problem would be O3
11504         shield_list(ishield_list(i),i)=k
11505 C Lets have the sscale value
11506         if (sh_frac_dist.gt.1.0) then
11507          scale_fac_dist=1.0d0
11508          do j=1,3
11509          sh_frac_dist_grad(j)=0.0d0
11510          enddo
11511         else
11512          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11513      &                   *(2.0*sh_frac_dist-3.0d0)
11514          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11515      &                  /dist_pep_side/buff_shield*0.5
11516 C remember for the final gradient multiply sh_frac_dist_grad(j)
11517 C for side_chain by factor -2 !
11518          do j=1,3
11519          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11520 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11521 C     &                    sh_frac_dist_grad(j)
11522          enddo
11523         endif
11524 C        if ((i.eq.3).and.(k.eq.2)) then
11525 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11526 C     & ,"TU"
11527 C        endif
11528
11529 C this is what is now we have the distance scaling now volume...
11530       short=short_r_sidechain(itype(k))
11531       long=long_r_sidechain(itype(k))
11532       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11533 C now costhet_grad
11534 C       costhet=0.0d0
11535        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11536 C       costhet_fac=0.0d0
11537        do j=1,3
11538          costhet_grad(j)=costhet_fac*pep_side(j)
11539        enddo
11540 C remember for the final gradient multiply costhet_grad(j)
11541 C for side_chain by factor -2 !
11542 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11543 C pep_side0pept_group is vector multiplication
11544       pep_side0pept_group=0.0
11545       do j=1,3
11546       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11547       enddo
11548       cosalfa=(pep_side0pept_group/
11549      & (dist_pep_side*dist_side_calf))
11550       fac_alfa_sin=1.0-cosalfa**2
11551       fac_alfa_sin=dsqrt(fac_alfa_sin)
11552       rkprim=fac_alfa_sin*(long-short)+short
11553 C now costhet_grad
11554        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11555        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11556
11557        do j=1,3
11558          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11559      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11560      &*(long-short)/fac_alfa_sin*cosalfa/
11561      &((dist_pep_side*dist_side_calf))*
11562      &((side_calf(j))-cosalfa*
11563      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11564
11565         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11566      &*(long-short)/fac_alfa_sin*cosalfa
11567      &/((dist_pep_side*dist_side_calf))*
11568      &(pep_side(j)-
11569      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11570        enddo
11571
11572       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11573      &                    /VSolvSphere_div
11574      &                    *wshield
11575 C now the gradient...
11576 C grad_shield is gradient of Calfa for peptide groups
11577 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11578 C     &               costhet,cosphi
11579 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11580 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11581       do j=1,3
11582       grad_shield(j,i)=grad_shield(j,i)
11583 C gradient po skalowaniu
11584      &                +(sh_frac_dist_grad(j)
11585 C  gradient po costhet
11586      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11587      &-scale_fac_dist*(cosphi_grad_long(j))
11588      &/(1.0-cosphi) )*div77_81
11589      &*VofOverlap
11590 C grad_shield_side is Cbeta sidechain gradient
11591       grad_shield_side(j,ishield_list(i),i)=
11592      &        (sh_frac_dist_grad(j)*(-2.0d0)
11593      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11594      &       +scale_fac_dist*(cosphi_grad_long(j))
11595      &        *2.0d0/(1.0-cosphi))
11596      &        *div77_81*VofOverlap
11597
11598        grad_shield_loc(j,ishield_list(i),i)=
11599      &   scale_fac_dist*cosphi_grad_loc(j)
11600      &        *2.0d0/(1.0-cosphi)
11601      &        *div77_81*VofOverlap
11602       enddo
11603       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11604       enddo
11605       fac_shield(i)=VolumeTotal*div77_81+div4_81
11606 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11607       enddo
11608       return
11609       end
11610 C--------------------------------------------------------------------------
11611       double precision function tschebyshev(m,n,x,y)
11612       implicit none
11613       include "DIMENSIONS"
11614       integer i,m,n
11615       double precision x(n),y,yy(0:maxvar),aux
11616 c Tschebyshev polynomial. Note that the first term is omitted
11617 c m=0: the constant term is included
11618 c m=1: the constant term is not included
11619       yy(0)=1.0d0
11620       yy(1)=y
11621       do i=2,n
11622         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11623       enddo
11624       aux=0.0d0
11625       do i=m,n
11626         aux=aux+x(i)*yy(i)
11627       enddo
11628       tschebyshev=aux
11629       return
11630       end
11631 C--------------------------------------------------------------------------
11632       double precision function gradtschebyshev(m,n,x,y)
11633       implicit none
11634       include "DIMENSIONS"
11635       integer i,m,n
11636       double precision x(n+1),y,yy(0:maxvar),aux
11637 c Tschebyshev polynomial. Note that the first term is omitted
11638 c m=0: the constant term is included
11639 c m=1: the constant term is not included
11640       yy(0)=1.0d0
11641       yy(1)=2.0d0*y
11642       do i=2,n
11643         yy(i)=2*y*yy(i-1)-yy(i-2)
11644       enddo
11645       aux=0.0d0
11646       do i=m,n
11647         aux=aux+x(i+1)*yy(i)*(i+1)
11648 C        print *, x(i+1),yy(i),i
11649       enddo
11650       gradtschebyshev=aux
11651       return
11652       end
11653 C------------------------------------------------------------------------
11654 C first for shielding is setting of function of side-chains
11655        subroutine set_shield_fac2
11656       implicit real*8 (a-h,o-z)
11657       include 'DIMENSIONS'
11658       include 'COMMON.CHAIN'
11659       include 'COMMON.DERIV'
11660       include 'COMMON.IOUNITS'
11661       include 'COMMON.SHIELD'
11662       include 'COMMON.INTERACT'
11663 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11664       double precision div77_81/0.974996043d0/,
11665      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11666
11667 C the vector between center of side_chain and peptide group
11668        double precision pep_side(3),long,side_calf(3),
11669      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11670      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11671 C the line belowe needs to be changed for FGPROC>1
11672       do i=1,nres-1
11673       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11674       ishield_list(i)=0
11675 Cif there two consequtive dummy atoms there is no peptide group between them
11676 C the line below has to be changed for FGPROC>1
11677       VolumeTotal=0.0
11678       do k=1,nres
11679        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11680        dist_pep_side=0.0
11681        dist_side_calf=0.0
11682        do j=1,3
11683 C first lets set vector conecting the ithe side-chain with kth side-chain
11684       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11685 C      pep_side(j)=2.0d0
11686 C and vector conecting the side-chain with its proper calfa
11687       side_calf(j)=c(j,k+nres)-c(j,k)
11688 C      side_calf(j)=2.0d0
11689       pept_group(j)=c(j,i)-c(j,i+1)
11690 C lets have their lenght
11691       dist_pep_side=pep_side(j)**2+dist_pep_side
11692       dist_side_calf=dist_side_calf+side_calf(j)**2
11693       dist_pept_group=dist_pept_group+pept_group(j)**2
11694       enddo
11695        dist_pep_side=dsqrt(dist_pep_side)
11696        dist_pept_group=dsqrt(dist_pept_group)
11697        dist_side_calf=dsqrt(dist_side_calf)
11698       do j=1,3
11699         pep_side_norm(j)=pep_side(j)/dist_pep_side
11700         side_calf_norm(j)=dist_side_calf
11701       enddo
11702 C now sscale fraction
11703        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11704 C       print *,buff_shield,"buff"
11705 C now sscale
11706         if (sh_frac_dist.le.0.0) cycle
11707 C If we reach here it means that this side chain reaches the shielding sphere
11708 C Lets add him to the list for gradient
11709         ishield_list(i)=ishield_list(i)+1
11710 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11711 C this list is essential otherwise problem would be O3
11712         shield_list(ishield_list(i),i)=k
11713 C Lets have the sscale value
11714         if (sh_frac_dist.gt.1.0) then
11715          scale_fac_dist=1.0d0
11716          do j=1,3
11717          sh_frac_dist_grad(j)=0.0d0
11718          enddo
11719         else
11720          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11721      &                   *(2.0d0*sh_frac_dist-3.0d0)
11722          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11723      &                  /dist_pep_side/buff_shield*0.5d0
11724 C remember for the final gradient multiply sh_frac_dist_grad(j)
11725 C for side_chain by factor -2 !
11726          do j=1,3
11727          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11728 C         sh_frac_dist_grad(j)=0.0d0
11729 C         scale_fac_dist=1.0d0
11730 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11731 C     &                    sh_frac_dist_grad(j)
11732          enddo
11733         endif
11734 C this is what is now we have the distance scaling now volume...
11735       short=short_r_sidechain(itype(k))
11736       long=long_r_sidechain(itype(k))
11737       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11738       sinthet=short/dist_pep_side*costhet
11739 C now costhet_grad
11740 C       costhet=0.6d0
11741 C       sinthet=0.8
11742        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11743 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11744 C     &             -short/dist_pep_side**2/costhet)
11745 C       costhet_fac=0.0d0
11746        do j=1,3
11747          costhet_grad(j)=costhet_fac*pep_side(j)
11748        enddo
11749 C remember for the final gradient multiply costhet_grad(j)
11750 C for side_chain by factor -2 !
11751 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11752 C pep_side0pept_group is vector multiplication
11753       pep_side0pept_group=0.0d0
11754       do j=1,3
11755       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11756       enddo
11757       cosalfa=(pep_side0pept_group/
11758      & (dist_pep_side*dist_side_calf))
11759       fac_alfa_sin=1.0d0-cosalfa**2
11760       fac_alfa_sin=dsqrt(fac_alfa_sin)
11761       rkprim=fac_alfa_sin*(long-short)+short
11762 C      rkprim=short
11763
11764 C now costhet_grad
11765        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11766 C       cosphi=0.6
11767        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11768        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11769      &      dist_pep_side**2)
11770 C       sinphi=0.8
11771        do j=1,3
11772          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11773      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11774      &*(long-short)/fac_alfa_sin*cosalfa/
11775      &((dist_pep_side*dist_side_calf))*
11776      &((side_calf(j))-cosalfa*
11777      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11778 C       cosphi_grad_long(j)=0.0d0
11779         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11780      &*(long-short)/fac_alfa_sin*cosalfa
11781      &/((dist_pep_side*dist_side_calf))*
11782      &(pep_side(j)-
11783      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11784 C       cosphi_grad_loc(j)=0.0d0
11785        enddo
11786 C      print *,sinphi,sinthet
11787 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
11788 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
11789       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11790      &                    /VSolvSphere_div
11791 C     &                    *wshield
11792 C now the gradient...
11793       do j=1,3
11794       grad_shield(j,i)=grad_shield(j,i)
11795 C gradient po skalowaniu
11796      &                +(sh_frac_dist_grad(j)*VofOverlap
11797 C  gradient po costhet
11798      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11799      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11800      &       sinphi/sinthet*costhet*costhet_grad(j)
11801      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11802      & )*wshield
11803 C grad_shield_side is Cbeta sidechain gradient
11804       grad_shield_side(j,ishield_list(i),i)=
11805      &        (sh_frac_dist_grad(j)*(-2.0d0)
11806      &        *VofOverlap
11807      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11808      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11809      &       sinphi/sinthet*costhet*costhet_grad(j)
11810      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11811      &       )*wshield
11812
11813        grad_shield_loc(j,ishield_list(i),i)=
11814      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11815      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11816      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11817      &        ))
11818      &        *wshield
11819       enddo
11820 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
11821 c     & scale_fac_dist
11822       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11823       enddo
11824       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11825 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
11826 c     &  " wshield",wshield
11827 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
11828       enddo
11829       return
11830       end
11831 C-----------------------------------------------------------------------
11832 C-----------------------------------------------------------
11833 C This subroutine is to mimic the histone like structure but as well can be
11834 C utilizet to nanostructures (infinit) small modification has to be used to
11835 C make it finite (z gradient at the ends has to be changes as well as the x,y
11836 C gradient has to be modified at the ends
11837 C The energy function is Kihara potential
11838 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11839 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11840 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11841 C simple Kihara potential
11842       subroutine calctube(Etube)
11843        implicit real*8 (a-h,o-z)
11844       include 'DIMENSIONS'
11845       include 'COMMON.GEO'
11846       include 'COMMON.VAR'
11847       include 'COMMON.LOCAL'
11848       include 'COMMON.CHAIN'
11849       include 'COMMON.DERIV'
11850       include 'COMMON.NAMES'
11851       include 'COMMON.INTERACT'
11852       include 'COMMON.IOUNITS'
11853       include 'COMMON.CALC'
11854       include 'COMMON.CONTROL'
11855       include 'COMMON.SPLITELE'
11856       include 'COMMON.SBRIDGE'
11857       double precision tub_r,vectube(3),enetube(maxres*2)
11858       Etube=0.0d0
11859       do i=1,2*nres
11860         enetube(i)=0.0d0
11861       enddo
11862 C first we calculate the distance from tube center
11863 C first sugare-phosphate group for NARES this would be peptide group
11864 C for UNRES
11865       do i=1,nres
11866 C lets ommit dummy atoms for now
11867        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11868 C now calculate distance from center of tube and direction vectors
11869       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11870           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11871       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
11872           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11873       vectube(1)=vectube(1)-tubecenter(1)
11874       vectube(2)=vectube(2)-tubecenter(2)
11875
11876 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11877 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11878
11879 C as the tube is infinity we do not calculate the Z-vector use of Z
11880 C as chosen axis
11881       vectube(3)=0.0d0
11882 C now calculte the distance
11883        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11884 C now normalize vector
11885       vectube(1)=vectube(1)/tub_r
11886       vectube(2)=vectube(2)/tub_r
11887 C calculte rdiffrence between r and r0
11888       rdiff=tub_r-tubeR0
11889 C and its 6 power
11890       rdiff6=rdiff**6.0d0
11891 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11892        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11893 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
11894 C       print *,rdiff,rdiff6,pep_aa_tube
11895 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11896 C now we calculate gradient
11897        fac=(-12.0d0*pep_aa_tube/rdiff6+
11898      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
11899 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11900 C     &rdiff,fac
11901
11902 C now direction of gg_tube vector
11903         do j=1,3
11904         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11905         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11906         enddo
11907         enddo
11908 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11909         do i=1,nres
11910 C Lets not jump over memory as we use many times iti
11911          iti=itype(i)
11912 C lets ommit dummy atoms for now
11913          if ((iti.eq.ntyp1)
11914 C in UNRES uncomment the line below as GLY has no side-chain...
11915 C      .or.(iti.eq.10)
11916      &   ) cycle
11917           vectube(1)=c(1,i+nres)
11918           vectube(1)=mod(vectube(1),boxxsize)
11919           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11920           vectube(2)=c(2,i+nres)
11921           vectube(2)=mod(vectube(2),boxxsize)
11922           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11923
11924       vectube(1)=vectube(1)-tubecenter(1)
11925       vectube(2)=vectube(2)-tubecenter(2)
11926
11927 C as the tube is infinity we do not calculate the Z-vector use of Z
11928 C as chosen axis
11929       vectube(3)=0.0d0
11930 C now calculte the distance
11931        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11932 C now normalize vector
11933       vectube(1)=vectube(1)/tub_r
11934       vectube(2)=vectube(2)/tub_r
11935 C calculte rdiffrence between r and r0
11936       rdiff=tub_r-tubeR0
11937 C and its 6 power
11938       rdiff6=rdiff**6.0d0
11939 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11940        sc_aa_tube=sc_aa_tube_par(iti)
11941        sc_bb_tube=sc_bb_tube_par(iti)
11942        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
11943 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11944 C now we calculate gradient
11945        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
11946      &       6.0d0*sc_bb_tube/rdiff6/rdiff
11947 C now direction of gg_tube vector
11948          do j=1,3
11949           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
11950           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
11951          enddo
11952         enddo
11953         do i=1,2*nres
11954           Etube=Etube+enetube(i)
11955         enddo
11956 C        print *,"ETUBE", etube
11957         return
11958         end
11959 C TO DO 1) add to total energy
11960 C       2) add to gradient summation
11961 C       3) add reading parameters (AND of course oppening of PARAM file)
11962 C       4) add reading the center of tube
11963 C       5) add COMMONs
11964 C       6) add to zerograd
11965
11966 C-----------------------------------------------------------------------
11967 C-----------------------------------------------------------
11968 C This subroutine is to mimic the histone like structure but as well can be
11969 C utilizet to nanostructures (infinit) small modification has to be used to
11970 C make it finite (z gradient at the ends has to be changes as well as the x,y
11971 C gradient has to be modified at the ends
11972 C The energy function is Kihara potential
11973 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11974 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11975 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11976 C simple Kihara potential
11977       subroutine calctube2(Etube)
11978        implicit real*8 (a-h,o-z)
11979       include 'DIMENSIONS'
11980       include 'COMMON.GEO'
11981       include 'COMMON.VAR'
11982       include 'COMMON.LOCAL'
11983       include 'COMMON.CHAIN'
11984       include 'COMMON.DERIV'
11985       include 'COMMON.NAMES'
11986       include 'COMMON.INTERACT'
11987       include 'COMMON.IOUNITS'
11988       include 'COMMON.CALC'
11989       include 'COMMON.CONTROL'
11990       include 'COMMON.SPLITELE'
11991       include 'COMMON.SBRIDGE'
11992       double precision tub_r,vectube(3),enetube(maxres*2)
11993       Etube=0.0d0
11994       do i=1,2*nres
11995         enetube(i)=0.0d0
11996       enddo
11997 C first we calculate the distance from tube center
11998 C first sugare-phosphate group for NARES this would be peptide group
11999 C for UNRES
12000       do i=1,nres
12001 C lets ommit dummy atoms for now
12002        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12003 C now calculate distance from center of tube and direction vectors
12004       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12005           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12006       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12007           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12008       vectube(1)=vectube(1)-tubecenter(1)
12009       vectube(2)=vectube(2)-tubecenter(2)
12010
12011 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12012 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12013
12014 C as the tube is infinity we do not calculate the Z-vector use of Z
12015 C as chosen axis
12016       vectube(3)=0.0d0
12017 C now calculte the distance
12018        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12019 C now normalize vector
12020       vectube(1)=vectube(1)/tub_r
12021       vectube(2)=vectube(2)/tub_r
12022 C calculte rdiffrence between r and r0
12023       rdiff=tub_r-tubeR0
12024 C and its 6 power
12025       rdiff6=rdiff**6.0d0
12026 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12027        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12028 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12029 C       print *,rdiff,rdiff6,pep_aa_tube
12030 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12031 C now we calculate gradient
12032        fac=(-12.0d0*pep_aa_tube/rdiff6+
12033      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12034 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12035 C     &rdiff,fac
12036
12037 C now direction of gg_tube vector
12038         do j=1,3
12039         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12040         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12041         enddo
12042         enddo
12043 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12044         do i=1,nres
12045 C Lets not jump over memory as we use many times iti
12046          iti=itype(i)
12047 C lets ommit dummy atoms for now
12048          if ((iti.eq.ntyp1)
12049 C in UNRES uncomment the line below as GLY has no side-chain...
12050      &      .or.(iti.eq.10)
12051      &   ) cycle
12052           vectube(1)=c(1,i+nres)
12053           vectube(1)=mod(vectube(1),boxxsize)
12054           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12055           vectube(2)=c(2,i+nres)
12056           vectube(2)=mod(vectube(2),boxxsize)
12057           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12058
12059       vectube(1)=vectube(1)-tubecenter(1)
12060       vectube(2)=vectube(2)-tubecenter(2)
12061 C THIS FRAGMENT MAKES TUBE FINITE
12062         positi=(mod(c(3,i+nres),boxzsize))
12063         if (positi.le.0) positi=positi+boxzsize
12064 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12065 c for each residue check if it is in lipid or lipid water border area
12066 C       respos=mod(c(3,i+nres),boxzsize)
12067        print *,positi,bordtubebot,buftubebot,bordtubetop
12068        if ((positi.gt.bordtubebot)
12069      & .and.(positi.lt.bordtubetop)) then
12070 C the energy transfer exist
12071         if (positi.lt.buftubebot) then
12072          fracinbuf=1.0d0-
12073      &     ((positi-bordtubebot)/tubebufthick)
12074 C lipbufthick is thickenes of lipid buffore
12075          sstube=sscalelip(fracinbuf)
12076          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12077          print *,ssgradtube, sstube,tubetranene(itype(i))
12078          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12079          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12080      &+ssgradtube*tubetranene(itype(i))
12081          gg_tube(3,i-1)= gg_tube(3,i-1)
12082      &+ssgradtube*tubetranene(itype(i))
12083 C         print *,"doing sccale for lower part"
12084         elseif (positi.gt.buftubetop) then
12085          fracinbuf=1.0d0-
12086      &((bordtubetop-positi)/tubebufthick)
12087          sstube=sscalelip(fracinbuf)
12088          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12089          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12090 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12091 C     &+ssgradtube*tubetranene(itype(i))
12092 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12093 C     &+ssgradtube*tubetranene(itype(i))
12094 C          print *, "doing sscalefor top part",sslip,fracinbuf
12095         else
12096          sstube=1.0d0
12097          ssgradtube=0.0d0
12098          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12099 C         print *,"I am in true lipid"
12100         endif
12101         else
12102 C          sstube=0.0d0
12103 C          ssgradtube=0.0d0
12104         cycle
12105         endif ! if in lipid or buffor
12106 CEND OF FINITE FRAGMENT
12107 C as the tube is infinity we do not calculate the Z-vector use of Z
12108 C as chosen axis
12109       vectube(3)=0.0d0
12110 C now calculte the distance
12111        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12112 C now normalize vector
12113       vectube(1)=vectube(1)/tub_r
12114       vectube(2)=vectube(2)/tub_r
12115 C calculte rdiffrence between r and r0
12116       rdiff=tub_r-tubeR0
12117 C and its 6 power
12118       rdiff6=rdiff**6.0d0
12119 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12120        sc_aa_tube=sc_aa_tube_par(iti)
12121        sc_bb_tube=sc_bb_tube_par(iti)
12122        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12123      &                 *sstube+enetube(i+nres)
12124 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12125 C now we calculate gradient
12126        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12127      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12128 C now direction of gg_tube vector
12129          do j=1,3
12130           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12131           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12132          enddo
12133          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12134      &+ssgradtube*enetube(i+nres)/sstube
12135          gg_tube(3,i-1)= gg_tube(3,i-1)
12136      &+ssgradtube*enetube(i+nres)/sstube
12137
12138         enddo
12139         do i=1,2*nres
12140           Etube=Etube+enetube(i)
12141         enddo
12142 C        print *,"ETUBE", etube
12143         return
12144         end
12145 C TO DO 1) add to total energy
12146 C       2) add to gradient summation
12147 C       3) add reading parameters (AND of course oppening of PARAM file)
12148 C       4) add reading the center of tube
12149 C       5) add COMMONs
12150 C       6) add to zerograd
12151 c----------------------------------------------------------------------------
12152       subroutine e_saxs(Esaxs_constr)
12153       implicit none
12154       include 'DIMENSIONS'
12155 #ifdef MPI
12156       include "mpif.h"
12157       include "COMMON.SETUP"
12158       integer IERR
12159 #endif
12160       include 'COMMON.SBRIDGE'
12161       include 'COMMON.CHAIN'
12162       include 'COMMON.GEO'
12163       include 'COMMON.DERIV'
12164       include 'COMMON.LOCAL'
12165       include 'COMMON.INTERACT'
12166       include 'COMMON.VAR'
12167       include 'COMMON.IOUNITS'
12168       include 'COMMON.MD'
12169       include 'COMMON.CONTROL'
12170       include 'COMMON.NAMES'
12171       include 'COMMON.TIME1'
12172       include 'COMMON.FFIELD'
12173 c
12174       double precision Esaxs_constr
12175       integer i,iint,j,k,l
12176       double precision PgradC(maxSAXS,3,maxres),
12177      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12178 #ifdef MPI
12179       double precision PgradC_(maxSAXS,3,maxres),
12180      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12181 #endif
12182       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12183      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12184      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12185      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12186       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12187       double precision dist,mygauss,mygaussder
12188       external dist
12189       integer llicz,lllicz
12190       double precision time01
12191 c  SAXS restraint penalty function
12192 #ifdef DEBUG
12193       write(iout,*) "------- SAXS penalty function start -------"
12194       write (iout,*) "nsaxs",nsaxs
12195       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12196       write (iout,*) "Psaxs"
12197       do i=1,nsaxs
12198         write (iout,'(i5,e15.5)') i, Psaxs(i)
12199       enddo
12200 #endif
12201 #ifdef TIMING
12202       time01=MPI_Wtime()
12203 #endif
12204       Esaxs_constr = 0.0d0
12205       do k=1,nsaxs
12206         Pcalc(k)=0.0d0
12207         do j=1,nres
12208           do l=1,3
12209             PgradC(k,l,j)=0.0d0
12210             PgradX(k,l,j)=0.0d0
12211           enddo
12212         enddo
12213       enddo
12214 c      lllicz=0
12215       do i=iatsc_s,iatsc_e
12216        if (itype(i).eq.ntyp1) cycle
12217        do iint=1,nint_gr(i)
12218          do j=istart(i,iint),iend(i,iint)
12219            if (itype(j).eq.ntyp1) cycle
12220 #ifdef ALLSAXS
12221            dijCACA=dist(i,j)
12222            dijCASC=dist(i,j+nres)
12223            dijSCCA=dist(i+nres,j)
12224            dijSCSC=dist(i+nres,j+nres)
12225            sigma2CACA=2.0d0/(pstok**2)
12226            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12227            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12228            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12229            do k=1,nsaxs
12230              dk = distsaxs(k)
12231              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12232              if (itype(j).ne.10) then
12233              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12234              else
12235              endif
12236              expCASC = 0.0d0
12237              if (itype(i).ne.10) then
12238              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12239              else
12240              expSCCA = 0.0d0
12241              endif
12242              if (itype(i).ne.10 .and. itype(j).ne.10) then
12243              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12244              else
12245              expSCSC = 0.0d0
12246              endif
12247              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12248 #ifdef DEBUG
12249              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12250 #endif
12251              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12252              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12253              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12254              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12255              do l=1,3
12256 c CA CA
12257                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12258                PgradC(k,l,i) = PgradC(k,l,i)-aux
12259                PgradC(k,l,j) = PgradC(k,l,j)+aux
12260 c CA SC
12261                if (itype(j).ne.10) then
12262                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12263                PgradC(k,l,i) = PgradC(k,l,i)-aux
12264                PgradC(k,l,j) = PgradC(k,l,j)+aux
12265                PgradX(k,l,j) = PgradX(k,l,j)+aux
12266                endif
12267 c SC CA
12268                if (itype(i).ne.10) then
12269                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12270                PgradX(k,l,i) = PgradX(k,l,i)-aux
12271                PgradC(k,l,i) = PgradC(k,l,i)-aux
12272                PgradC(k,l,j) = PgradC(k,l,j)+aux
12273                endif
12274 c SC SC
12275                if (itype(i).ne.10 .and. itype(j).ne.10) then
12276                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12277                PgradC(k,l,i) = PgradC(k,l,i)-aux
12278                PgradC(k,l,j) = PgradC(k,l,j)+aux
12279                PgradX(k,l,i) = PgradX(k,l,i)-aux
12280                PgradX(k,l,j) = PgradX(k,l,j)+aux
12281                endif
12282              enddo ! l
12283            enddo ! k
12284 #else
12285            dijCACA=dist(i,j)
12286            sigma2CACA=scal_rad**2*0.25d0/
12287      &        (restok(itype(j))**2+restok(itype(i))**2)
12288 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12289 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12290 #ifdef MYGAUSS
12291            sigmaCACA=dsqrt(sigma2CACA)
12292            threesig=3.0d0/sigmaCACA
12293 c           llicz=0
12294            do k=1,nsaxs
12295              dk = distsaxs(k)
12296              if (dabs(dijCACA-dk).ge.threesig) cycle
12297 c             llicz=llicz+1
12298 c             lllicz=lllicz+1
12299              aux = sigmaCACA*(dijCACA-dk)
12300              expCACA = mygauss(aux)
12301 c             if (expcaca.eq.0.0d0) cycle
12302              Pcalc(k) = Pcalc(k)+expCACA
12303              CACAgrad = -sigmaCACA*mygaussder(aux)
12304 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12305              do l=1,3
12306                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12307                PgradC(k,l,i) = PgradC(k,l,i)-aux
12308                PgradC(k,l,j) = PgradC(k,l,j)+aux
12309              enddo ! l
12310            enddo ! k
12311 c           write (iout,*) "i",i," j",j," llicz",llicz
12312 #else
12313            IF (saxs_cutoff.eq.0) THEN
12314            do k=1,nsaxs
12315              dk = distsaxs(k)
12316              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12317              Pcalc(k) = Pcalc(k)+expCACA
12318              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12319              do l=1,3
12320                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12321                PgradC(k,l,i) = PgradC(k,l,i)-aux
12322                PgradC(k,l,j) = PgradC(k,l,j)+aux
12323              enddo ! l
12324            enddo ! k
12325            ELSE
12326            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12327            do k=1,nsaxs
12328              dk = distsaxs(k)
12329 c             write (2,*) "ijk",i,j,k
12330              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12331              if (sss2.eq.0.0d0) cycle
12332              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12333              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12334      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12335      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
12336      &           sss2,ssgrad2
12337              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12338              Pcalc(k) = Pcalc(k)+expCACA
12339 #ifdef DEBUG
12340              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12341 #endif
12342              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12343      &             ssgrad2*expCACA/sss2
12344              do l=1,3
12345 c CA CA
12346                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12347                PgradC(k,l,i) = PgradC(k,l,i)+aux
12348                PgradC(k,l,j) = PgradC(k,l,j)-aux
12349              enddo ! l
12350            enddo ! k
12351            ENDIF
12352 #endif
12353 #endif
12354          enddo ! j
12355        enddo ! iint
12356       enddo ! i
12357 c#ifdef TIMING
12358 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
12359 c#endif
12360 c      write (iout,*) "lllicz",lllicz
12361 c#ifdef TIMING
12362 c      time01=MPI_Wtime()
12363 c#endif
12364 #ifdef MPI
12365       if (nfgtasks.gt.1) then
12366        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12367      &    MPI_SUM,FG_COMM,IERR)
12368 c        if (fg_rank.eq.king) then
12369           do k=1,nsaxs
12370             Pcalc(k) = Pcalc_(k)
12371           enddo
12372 c        endif
12373 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12374 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12375 c        if (fg_rank.eq.king) then
12376 c          do i=1,nres
12377 c            do l=1,3
12378 c              do k=1,nsaxs
12379 c                PgradC(k,l,i) = PgradC_(k,l,i)
12380 c              enddo
12381 c            enddo
12382 c          enddo
12383 c        endif
12384 #ifdef ALLSAXS
12385 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12386 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12387 c        if (fg_rank.eq.king) then
12388 c          do i=1,nres
12389 c            do l=1,3
12390 c              do k=1,nsaxs
12391 c                PgradX(k,l,i) = PgradX_(k,l,i)
12392 c              enddo
12393 c            enddo
12394 c          enddo
12395 c        endif
12396 #endif
12397       endif
12398 #endif
12399       Cnorm = 0.0d0
12400       do k=1,nsaxs
12401         Cnorm = Cnorm + Pcalc(k)
12402       enddo
12403 #ifdef MPI
12404       if (fg_rank.eq.king) then
12405 #endif
12406       Esaxs_constr = dlog(Cnorm)-wsaxs0
12407       do k=1,nsaxs
12408         if (Pcalc(k).gt.0.0d0)
12409      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12410 #ifdef DEBUG
12411         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12412 #endif
12413       enddo
12414 #ifdef DEBUG
12415       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12416 #endif
12417 #ifdef MPI
12418       endif
12419 #endif
12420       gsaxsC=0.0d0
12421       gsaxsX=0.0d0
12422       do i=nnt,nct
12423         do l=1,3
12424           auxC=0.0d0
12425           auxC1=0.0d0
12426           auxX=0.0d0
12427           auxX1=0.d0
12428           do k=1,nsaxs
12429             if (Pcalc(k).gt.0)
12430      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12431             auxC1 = auxC1+PgradC(k,l,i)
12432 #ifdef ALLSAXS
12433             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12434             auxX1 = auxX1+PgradX(k,l,i)
12435 #endif
12436           enddo
12437           gsaxsC(l,i) = auxC - auxC1/Cnorm
12438 #ifdef ALLSAXS
12439           gsaxsX(l,i) = auxX - auxX1/Cnorm
12440 #endif
12441 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12442 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
12443 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12444 c     *     " gradX",wsaxs*gsaxsX(l,i)
12445         enddo
12446       enddo
12447 #ifdef TIMING
12448       time_SAXS=time_SAXS+MPI_Wtime()-time01
12449 #endif
12450 #ifdef DEBUG
12451       write (iout,*) "gsaxsc"
12452       do i=nnt,nct
12453         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
12454       enddo
12455 #endif
12456 #ifdef MPI
12457 c      endif
12458 #endif
12459       return
12460       end
12461 c----------------------------------------------------------------------------
12462       subroutine e_saxsC(Esaxs_constr)
12463       implicit none
12464       include 'DIMENSIONS'
12465 #ifdef MPI
12466       include "mpif.h"
12467       include "COMMON.SETUP"
12468       integer IERR
12469 #endif
12470       include 'COMMON.SBRIDGE'
12471       include 'COMMON.CHAIN'
12472       include 'COMMON.GEO'
12473       include 'COMMON.DERIV'
12474       include 'COMMON.LOCAL'
12475       include 'COMMON.INTERACT'
12476       include 'COMMON.VAR'
12477       include 'COMMON.IOUNITS'
12478       include 'COMMON.MD'
12479       include 'COMMON.CONTROL'
12480       include 'COMMON.NAMES'
12481       include 'COMMON.TIME1'
12482       include 'COMMON.FFIELD'
12483 c
12484       double precision Esaxs_constr
12485       integer i,iint,j,k,l
12486       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
12487 #ifdef MPI
12488       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
12489 #endif
12490       double precision dk,dijCASPH,dijSCSPH,
12491      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
12492      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
12493      & auxX,auxX1,Cnorm
12494 c  SAXS restraint penalty function
12495 #ifdef DEBUG
12496       write(iout,*) "------- SAXS penalty function start -------"
12497       write (iout,*) "nsaxs",nsaxs
12498
12499       do i=nnt,nct
12500         print *,MyRank,"C",i,(C(j,i),j=1,3)
12501       enddo
12502       do i=nnt,nct
12503         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
12504       enddo
12505 #endif
12506       Esaxs_constr = 0.0d0
12507       logPtot=0.0d0
12508       do j=isaxs_start,isaxs_end
12509         Pcalc=0.0d0
12510         do i=1,nres
12511           do l=1,3
12512             PgradC(l,i)=0.0d0
12513             PgradX(l,i)=0.0d0
12514           enddo
12515         enddo
12516         do i=nnt,nct
12517           if (itype(i).eq.ntyp1) cycle
12518           dijCASPH=0.0d0
12519           dijSCSPH=0.0d0
12520           do l=1,3
12521             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
12522           enddo
12523           if (itype(i).ne.10) then
12524           do l=1,3
12525             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
12526           enddo
12527           endif
12528           sigma2CA=2.0d0/pstok**2
12529           sigma2SC=4.0d0/restok(itype(i))**2
12530           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
12531           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
12532           Pcalc = Pcalc+expCASPH+expSCSPH
12533 #ifdef DEBUG
12534           write(*,*) "processor i j Pcalc",
12535      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
12536 #endif
12537           CASPHgrad = sigma2CA*expCASPH
12538           SCSPHgrad = sigma2SC*expSCSPH
12539           do l=1,3
12540             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
12541             PgradX(l,i) = PgradX(l,i) + aux
12542             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
12543           enddo ! l
12544         enddo ! i
12545         do i=nnt,nct
12546           do l=1,3
12547             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
12548             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
12549           enddo
12550         enddo
12551         logPtot = logPtot - dlog(Pcalc)
12552 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
12553 c     &    " logPtot",logPtot
12554       enddo ! j
12555 #ifdef MPI
12556       if (nfgtasks.gt.1) then
12557 c        write (iout,*) "logPtot before reduction",logPtot
12558         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
12559      &    MPI_SUM,king,FG_COMM,IERR)
12560         logPtot = logPtot_
12561 c        write (iout,*) "logPtot after reduction",logPtot
12562         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
12563      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12564         if (fg_rank.eq.king) then
12565           do i=1,nres
12566             do l=1,3
12567               gsaxsC(l,i) = gsaxsC_(l,i)
12568             enddo
12569           enddo
12570         endif
12571         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
12572      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12573         if (fg_rank.eq.king) then
12574           do i=1,nres
12575             do l=1,3
12576               gsaxsX(l,i) = gsaxsX_(l,i)
12577             enddo
12578           enddo
12579         endif
12580       endif
12581 #endif
12582       Esaxs_constr = logPtot
12583       return
12584       end
12585 c----------------------------------------------------------------------------
12586       double precision function sscale2(r,r_cut,r0,rlamb)
12587       implicit none
12588       double precision r,gamm,r_cut,r0,rlamb,rr
12589       rr = dabs(r-r0)
12590 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
12591 c      write (2,*) "rr",rr
12592       if(rr.lt.r_cut-rlamb) then
12593         sscale2=1.0d0
12594       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
12595         gamm=(rr-(r_cut-rlamb))/rlamb
12596         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12597       else
12598         sscale2=0d0
12599       endif
12600       return
12601       end
12602 C-----------------------------------------------------------------------
12603       double precision function sscalgrad2(r,r_cut,r0,rlamb)
12604       implicit none
12605       double precision r,gamm,r_cut,r0,rlamb,rr
12606       rr = dabs(r-r0)
12607       if(rr.lt.r_cut-rlamb) then
12608         sscalgrad2=0.0d0
12609       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
12610         gamm=(rr-(r_cut-rlamb))/rlamb
12611         if (r.ge.r0) then
12612           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
12613         else
12614           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
12615         endif
12616       else
12617         sscalgrad2=0.0d0
12618       endif
12619       return
12620       end