source/unres/src_MD-M-SAXS/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            gtEE(k,l,i-2)=0.0d0
2983           enddo
2984         enddo
2985 #endif
2986         b1tilde(1,i-2)= b1(1,i-2)
2987         b1tilde(2,i-2)=-b1(2,i-2)
2988         b2tilde(1,i-2)= b2(1,i-2)
2989         b2tilde(2,i-2)=-b2(2,i-2)
2990 c
2991         Ctilde(1,1,i-2)= CC(1,1,i-2)
2992         Ctilde(1,2,i-2)= CC(1,2,i-2)
2993         Ctilde(2,1,i-2)=-CC(2,1,i-2)
2994         Ctilde(2,2,i-2)=-CC(2,2,i-2)
2995 c
2996         Dtilde(1,1,i-2)= DD(1,1,i-2)
2997         Dtilde(1,2,i-2)= DD(1,2,i-2)
2998         Dtilde(2,1,i-2)=-DD(2,1,i-2)
2999         Dtilde(2,2,i-2)=-DD(2,2,i-2)
3000 #ifdef DEBUG
3001         write(iout,*) "i",i," iti",iti
3002         write(iout,*)  'b1=',(b1(k,i-2),k=1,2)
3003         write(iout,*)  'b2=',(b2(k,i-2),k=1,2)
3004 #endif
3005       enddo
3006 #ifdef PARMAT
3007       do i=ivec_start+2,ivec_end+2
3008 #else
3009       do i=3,nres+1
3010 #endif
3011         if (i .lt. nres+1) then
3012           sin1=dsin(phi(i))
3013           cos1=dcos(phi(i))
3014           sintab(i-2)=sin1
3015           costab(i-2)=cos1
3016           obrot(1,i-2)=cos1
3017           obrot(2,i-2)=sin1
3018           sin2=dsin(2*phi(i))
3019           cos2=dcos(2*phi(i))
3020           sintab2(i-2)=sin2
3021           costab2(i-2)=cos2
3022           obrot2(1,i-2)=cos2
3023           obrot2(2,i-2)=sin2
3024           Ug(1,1,i-2)=-cos1
3025           Ug(1,2,i-2)=-sin1
3026           Ug(2,1,i-2)=-sin1
3027           Ug(2,2,i-2)= cos1
3028           Ug2(1,1,i-2)=-cos2
3029           Ug2(1,2,i-2)=-sin2
3030           Ug2(2,1,i-2)=-sin2
3031           Ug2(2,2,i-2)= cos2
3032         else
3033           costab(i-2)=1.0d0
3034           sintab(i-2)=0.0d0
3035           obrot(1,i-2)=1.0d0
3036           obrot(2,i-2)=0.0d0
3037           obrot2(1,i-2)=0.0d0
3038           obrot2(2,i-2)=0.0d0
3039           Ug(1,1,i-2)=1.0d0
3040           Ug(1,2,i-2)=0.0d0
3041           Ug(2,1,i-2)=0.0d0
3042           Ug(2,2,i-2)=1.0d0
3043           Ug2(1,1,i-2)=0.0d0
3044           Ug2(1,2,i-2)=0.0d0
3045           Ug2(2,1,i-2)=0.0d0
3046           Ug2(2,2,i-2)=0.0d0
3047         endif
3048         if (i .gt. 3 .and. i .lt. nres+1) then
3049           obrot_der(1,i-2)=-sin1
3050           obrot_der(2,i-2)= cos1
3051           Ugder(1,1,i-2)= sin1
3052           Ugder(1,2,i-2)=-cos1
3053           Ugder(2,1,i-2)=-cos1
3054           Ugder(2,2,i-2)=-sin1
3055           dwacos2=cos2+cos2
3056           dwasin2=sin2+sin2
3057           obrot2_der(1,i-2)=-dwasin2
3058           obrot2_der(2,i-2)= dwacos2
3059           Ug2der(1,1,i-2)= dwasin2
3060           Ug2der(1,2,i-2)=-dwacos2
3061           Ug2der(2,1,i-2)=-dwacos2
3062           Ug2der(2,2,i-2)=-dwasin2
3063         else
3064           obrot_der(1,i-2)=0.0d0
3065           obrot_der(2,i-2)=0.0d0
3066           Ugder(1,1,i-2)=0.0d0
3067           Ugder(1,2,i-2)=0.0d0
3068           Ugder(2,1,i-2)=0.0d0
3069           Ugder(2,2,i-2)=0.0d0
3070           obrot2_der(1,i-2)=0.0d0
3071           obrot2_der(2,i-2)=0.0d0
3072           Ug2der(1,1,i-2)=0.0d0
3073           Ug2der(1,2,i-2)=0.0d0
3074           Ug2der(2,1,i-2)=0.0d0
3075           Ug2der(2,2,i-2)=0.0d0
3076         endif
3077 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
3078         if (i.gt. nnt+2 .and. i.lt.nct+2) then
3079           iti = itype2loc(itype(i-2))
3080         else
3081           iti=nloctyp
3082         endif
3083 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3084         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3085           iti1 = itype2loc(itype(i-1))
3086         else
3087           iti1=nloctyp
3088         endif
3089 cd        write (iout,*) '*******i',i,' iti1',iti
3090 cd        write (iout,*) 'b1',b1(:,iti)
3091 cd        write (iout,*) 'b2',b2(:,iti)
3092 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
3093 c        if (i .gt. iatel_s+2) then
3094         if (i .gt. nnt+2) then
3095           call matvec2(Ug(1,1,i-2),b2(1,i-2),Ub2(1,i-2))
3096 #ifdef NEWCORR
3097           call matvec2(Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2))
3098 c          write (iout,*) Ug(1,1,i-2),gtb2(1,i-2),gUb2(1,i-2),"chuj"
3099 #endif
3100 c          write(iout,*) "co jest kurwa", iti, EE(1,1,i),EE(2,1,i),
3101 c     &    EE(1,2,iti),EE(2,2,i)
3102           call matmat2(EE(1,1,i-2),Ug(1,1,i-2),EUg(1,1,i-2))
3103           call matmat2(gtEE(1,1,i-2),Ug(1,1,i-2),gtEUg(1,1,i-2))
3104 c          write(iout,*) "Macierz EUG",
3105 c     &    eug(1,1,i-2),eug(1,2,i-2),eug(2,1,i-2),
3106 c     &    eug(2,2,i-2)
3107           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3108      &    then
3109           call matmat2(CC(1,1,i-2),Ug(1,1,i-2),CUg(1,1,i-2))
3110           call matmat2(DD(1,1,i-2),Ug(1,1,i-2),DUg(1,1,i-2))
3111           call matmat2(Dtilde(1,1,i-2),Ug2(1,1,i-2),DtUg2(1,1,i-2))
3112           call matvec2(Ctilde(1,1,i-1),obrot(1,i-2),Ctobr(1,i-2))
3113           call matvec2(Dtilde(1,1,i-2),obrot2(1,i-2),Dtobr2(1,i-2))
3114           endif
3115         else
3116           do k=1,2
3117             Ub2(k,i-2)=0.0d0
3118             Ctobr(k,i-2)=0.0d0
3119             Dtobr2(k,i-2)=0.0d0
3120             do l=1,2
3121               EUg(l,k,i-2)=0.0d0
3122               CUg(l,k,i-2)=0.0d0
3123               DUg(l,k,i-2)=0.0d0
3124               DtUg2(l,k,i-2)=0.0d0
3125             enddo
3126           enddo
3127         endif
3128         call matvec2(Ugder(1,1,i-2),b2(1,i-2),Ub2der(1,i-2))
3129         call matmat2(EE(1,1,i-2),Ugder(1,1,i-2),EUgder(1,1,i-2))
3130         do k=1,2
3131           muder(k,i-2)=Ub2der(k,i-2)
3132         enddo
3133 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
3134         if (i.gt. nnt+1 .and. i.lt.nct+1) then
3135           if (itype(i-1).le.ntyp) then
3136             iti1 = itype2loc(itype(i-1))
3137           else
3138             iti1=nloctyp
3139           endif
3140         else
3141           iti1=nloctyp
3142         endif
3143         do k=1,2
3144           mu(k,i-2)=Ub2(k,i-2)+b1(k,i-1)
3145 c          mu(k,i-2)=b1(k,i-1)
3146 c          mu(k,i-2)=Ub2(k,i-2)
3147         enddo
3148 #ifdef MUOUT
3149         write (iout,'(2hmu,i3,3f8.1,12f10.5)') i-2,rad2deg*theta(i-1),
3150      &     rad2deg*theta(i),rad2deg*phi(i),mu(1,i-2),mu(2,i-2),
3151      &       -b2(1,i-2),b2(2,i-2),b1(1,i-2),b1(2,i-2),
3152      &       dsqrt(b2(1,i-1)**2+b2(2,i-1)**2)
3153      &      +dsqrt(b1(1,i-1)**2+b1(2,i-1)**2),
3154      &      ((ee(l,k,i-2),l=1,2),k=1,2)
3155 #endif
3156 cd        write (iout,*) 'mu1',mu1(:,i-2)
3157 cd        write (iout,*) 'mu2',mu2(:,i-2)
3158 cd        write (iout,*) 'mu',i-2,mu(:,i-2)
3159         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3160      &  then
3161         call matmat2(CC(1,1,i-1),Ugder(1,1,i-2),CUgder(1,1,i-2))
3162         call matmat2(DD(1,1,i-2),Ugder(1,1,i-2),DUgder(1,1,i-2))
3163         call matmat2(Dtilde(1,1,i-2),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
3164         call matvec2(Ctilde(1,1,i-1),obrot_der(1,i-2),Ctobrder(1,i-2))
3165         call matvec2(Dtilde(1,1,i-2),obrot2_der(1,i-2),Dtobr2der(1,i-2))
3166 C Vectors and matrices dependent on a single virtual-bond dihedral.
3167         call matvec2(DD(1,1,i-2),b1tilde(1,i-1),auxvec(1))
3168         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
3169         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
3170         call matvec2(CC(1,1,i-1),Ub2(1,i-2),CUgb2(1,i-2))
3171         call matvec2(CC(1,1,i-1),Ub2der(1,i-2),CUgb2der(1,i-2))
3172         call matmat2(EUg(1,1,i-2),CC(1,1,i-1),EUgC(1,1,i-2))
3173         call matmat2(EUgder(1,1,i-2),CC(1,1,i-1),EUgCder(1,1,i-2))
3174         call matmat2(EUg(1,1,i-2),DD(1,1,i-1),EUgD(1,1,i-2))
3175         call matmat2(EUgder(1,1,i-2),DD(1,1,i-1),EUgDder(1,1,i-2))
3176         endif
3177       enddo
3178 C Matrices dependent on two consecutive virtual-bond dihedrals.
3179 C The order of matrices is from left to right.
3180       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
3181      &then
3182 c      do i=max0(ivec_start,2),ivec_end
3183       do i=2,nres-1
3184         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
3185         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
3186         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
3187         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
3188         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
3189         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
3190         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
3191         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
3192       enddo
3193       endif
3194 #if defined(MPI) && defined(PARMAT)
3195 #ifdef DEBUG
3196 c      if (fg_rank.eq.0) then
3197         write (iout,*) "Arrays UG and UGDER before GATHER"
3198         do i=1,nres-1
3199           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3200      &     ((ug(l,k,i),l=1,2),k=1,2),
3201      &     ((ugder(l,k,i),l=1,2),k=1,2)
3202         enddo
3203         write (iout,*) "Arrays UG2 and UG2DER"
3204         do i=1,nres-1
3205           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3206      &     ((ug2(l,k,i),l=1,2),k=1,2),
3207      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3208         enddo
3209         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3210         do i=1,nres-1
3211           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3212      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3213      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3214         enddo
3215         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3216         do i=1,nres-1
3217           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3218      &     costab(i),sintab(i),costab2(i),sintab2(i)
3219         enddo
3220         write (iout,*) "Array MUDER"
3221         do i=1,nres-1
3222           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3223         enddo
3224 c      endif
3225 #endif
3226       if (nfgtasks.gt.1) then
3227         time00=MPI_Wtime()
3228 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
3229 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
3230 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
3231 #ifdef MATGATHER
3232         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
3233      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3234      &   FG_COMM1,IERR)
3235         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
3236      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3237      &   FG_COMM1,IERR)
3238         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
3239      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3240      &   FG_COMM1,IERR)
3241         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
3242      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3243      &   FG_COMM1,IERR)
3244         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
3245      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3246      &   FG_COMM1,IERR)
3247         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
3248      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3249      &   FG_COMM1,IERR)
3250         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
3251      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
3252      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3253         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
3254      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
3255      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3256         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
3257      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
3258      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3259         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
3260      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
3261      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
3262         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3263      &  then
3264         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
3265      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3266      &   FG_COMM1,IERR)
3267         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
3268      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3269      &   FG_COMM1,IERR)
3270         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
3271      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3272      &   FG_COMM1,IERR)
3273        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
3274      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3275      &   FG_COMM1,IERR)
3276         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
3277      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3278      &   FG_COMM1,IERR)
3279         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
3280      &   ivec_count(fg_rank1),
3281      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3282      &   FG_COMM1,IERR)
3283         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
3284      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3285      &   FG_COMM1,IERR)
3286         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
3287      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
3288      &   FG_COMM1,IERR)
3289         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
3290      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3291      &   FG_COMM1,IERR)
3292         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
3293      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3294      &   FG_COMM1,IERR)
3295         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
3296      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3297      &   FG_COMM1,IERR)
3298         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
3299      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3300      &   FG_COMM1,IERR)
3301         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
3302      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3303      &   FG_COMM1,IERR)
3304         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
3305      &   ivec_count(fg_rank1),
3306      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3307      &   FG_COMM1,IERR)
3308         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
3309      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3310      &   FG_COMM1,IERR)
3311        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
3312      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3313      &   FG_COMM1,IERR)
3314         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
3315      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3316      &   FG_COMM1,IERR)
3317        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
3318      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3319      &   FG_COMM1,IERR)
3320         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
3321      &   ivec_count(fg_rank1),
3322      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3323      &   FG_COMM1,IERR)
3324         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
3325      &   ivec_count(fg_rank1),
3326      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
3327      &   FG_COMM1,IERR)
3328         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
3329      &   ivec_count(fg_rank1),
3330      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3331      &   MPI_MAT2,FG_COMM1,IERR)
3332         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
3333      &   ivec_count(fg_rank1),
3334      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
3335      &   MPI_MAT2,FG_COMM1,IERR)
3336         endif
3337 #else
3338 c Passes matrix info through the ring
3339       isend=fg_rank1
3340       irecv=fg_rank1-1
3341       if (irecv.lt.0) irecv=nfgtasks1-1
3342       iprev=irecv
3343       inext=fg_rank1+1
3344       if (inext.ge.nfgtasks1) inext=0
3345       do i=1,nfgtasks1-1
3346 c        write (iout,*) "isend",isend," irecv",irecv
3347 c        call flush(iout)
3348         lensend=lentyp(isend)
3349         lenrecv=lentyp(irecv)
3350 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
3351 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
3352 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
3353 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
3354 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
3355 c        write (iout,*) "Gather ROTAT1"
3356 c        call flush(iout)
3357 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
3358 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
3359 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3360 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
3361 c        write (iout,*) "Gather ROTAT2"
3362 c        call flush(iout)
3363         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
3364      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
3365      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
3366      &   iprev,4400+irecv,FG_COMM,status,IERR)
3367 c        write (iout,*) "Gather ROTAT_OLD"
3368 c        call flush(iout)
3369         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
3370      &   MPI_PRECOMP11(lensend),inext,5500+isend,
3371      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
3372      &   iprev,5500+irecv,FG_COMM,status,IERR)
3373 c        write (iout,*) "Gather PRECOMP11"
3374 c        call flush(iout)
3375         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
3376      &   MPI_PRECOMP12(lensend),inext,6600+isend,
3377      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
3378      &   iprev,6600+irecv,FG_COMM,status,IERR)
3379 c        write (iout,*) "Gather PRECOMP12"
3380 c        call flush(iout)
3381         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
3382      &  then
3383         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
3384      &   MPI_ROTAT2(lensend),inext,7700+isend,
3385      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
3386      &   iprev,7700+irecv,FG_COMM,status,IERR)
3387 c        write (iout,*) "Gather PRECOMP21"
3388 c        call flush(iout)
3389         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
3390      &   MPI_PRECOMP22(lensend),inext,8800+isend,
3391      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
3392      &   iprev,8800+irecv,FG_COMM,status,IERR)
3393 c        write (iout,*) "Gather PRECOMP22"
3394 c        call flush(iout)
3395         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
3396      &   MPI_PRECOMP23(lensend),inext,9900+isend,
3397      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
3398      &   MPI_PRECOMP23(lenrecv),
3399      &   iprev,9900+irecv,FG_COMM,status,IERR)
3400 c        write (iout,*) "Gather PRECOMP23"
3401 c        call flush(iout)
3402         endif
3403         isend=irecv
3404         irecv=irecv-1
3405         if (irecv.lt.0) irecv=nfgtasks1-1
3406       enddo
3407 #endif
3408         time_gather=time_gather+MPI_Wtime()-time00
3409       endif
3410 #ifdef DEBUG
3411 c      if (fg_rank.eq.0) then
3412         write (iout,*) "Arrays UG and UGDER"
3413         do i=1,nres-1
3414           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3415      &     ((ug(l,k,i),l=1,2),k=1,2),
3416      &     ((ugder(l,k,i),l=1,2),k=1,2)
3417         enddo
3418         write (iout,*) "Arrays UG2 and UG2DER"
3419         do i=1,nres-1
3420           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3421      &     ((ug2(l,k,i),l=1,2),k=1,2),
3422      &     ((ug2der(l,k,i),l=1,2),k=1,2)
3423         enddo
3424         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
3425         do i=1,nres-1
3426           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3427      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
3428      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
3429         enddo
3430         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
3431         do i=1,nres-1
3432           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
3433      &     costab(i),sintab(i),costab2(i),sintab2(i)
3434         enddo
3435         write (iout,*) "Array MUDER"
3436         do i=1,nres-1
3437           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
3438         enddo
3439 c      endif
3440 #endif
3441 #endif
3442 cd      do i=1,nres
3443 cd        iti = itype2loc(itype(i))
3444 cd        write (iout,*) i
3445 cd        do j=1,2
3446 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
3447 cd     &  (EE(j,k,i),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
3448 cd        enddo
3449 cd      enddo
3450       return
3451       end
3452 C--------------------------------------------------------------------------
3453       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
3454 C
3455 C This subroutine calculates the average interaction energy and its gradient
3456 C in the virtual-bond vectors between non-adjacent peptide groups, based on
3457 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
3458 C The potential depends both on the distance of peptide-group centers and on
3459 C the orientation of the CA-CA virtual bonds.
3460 C
3461       implicit real*8 (a-h,o-z)
3462 #ifdef MPI
3463       include 'mpif.h'
3464 #endif
3465       include 'DIMENSIONS'
3466       include 'COMMON.CONTROL'
3467       include 'COMMON.SETUP'
3468       include 'COMMON.IOUNITS'
3469       include 'COMMON.GEO'
3470       include 'COMMON.VAR'
3471       include 'COMMON.LOCAL'
3472       include 'COMMON.CHAIN'
3473       include 'COMMON.DERIV'
3474       include 'COMMON.INTERACT'
3475       include 'COMMON.CONTACTS'
3476       include 'COMMON.TORSION'
3477       include 'COMMON.VECTORS'
3478       include 'COMMON.FFIELD'
3479       include 'COMMON.TIME1'
3480       include 'COMMON.SPLITELE'
3481       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3482      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3483       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3484      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij(4)
3485       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3486      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3487      &    num_conti,j1,j2
3488 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3489 #ifdef MOMENT
3490       double precision scal_el /1.0d0/
3491 #else
3492       double precision scal_el /0.5d0/
3493 #endif
3494 C 12/13/98
3495 C 13-go grudnia roku pamietnego...
3496       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3497      &                   0.0d0,1.0d0,0.0d0,
3498      &                   0.0d0,0.0d0,1.0d0/
3499 cd      write(iout,*) 'In EELEC'
3500 cd      do i=1,nloctyp
3501 cd        write(iout,*) 'Type',i
3502 cd        write(iout,*) 'B1',B1(:,i)
3503 cd        write(iout,*) 'B2',B2(:,i)
3504 cd        write(iout,*) 'CC',CC(:,:,i)
3505 cd        write(iout,*) 'DD',DD(:,:,i)
3506 cd        write(iout,*) 'EE',EE(:,:,i)
3507 cd      enddo
3508 cd      call check_vecgrad
3509 cd      stop
3510       if (icheckgrad.eq.1) then
3511         do i=1,nres-1
3512           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
3513           do k=1,3
3514             dc_norm(k,i)=dc(k,i)*fac
3515           enddo
3516 c          write (iout,*) 'i',i,' fac',fac
3517         enddo
3518       endif
3519       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3520      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
3521      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
3522 c        call vec_and_deriv
3523 #ifdef TIMING
3524         time01=MPI_Wtime()
3525 #endif
3526         call set_matrices
3527 #ifdef TIMING
3528         time_mat=time_mat+MPI_Wtime()-time01
3529 #endif
3530       endif
3531 cd      do i=1,nres-1
3532 cd        write (iout,*) 'i=',i
3533 cd        do k=1,3
3534 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
3535 cd        enddo
3536 cd        do k=1,3
3537 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
3538 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
3539 cd        enddo
3540 cd      enddo
3541       t_eelecij=0.0d0
3542       ees=0.0D0
3543       evdw1=0.0D0
3544       eel_loc=0.0d0
3545       eello_turn3=0.0d0
3546       eello_turn4=0.0d0
3547       ind=0
3548       do i=1,nres
3549         num_cont_hb(i)=0
3550       enddo
3551 cd      print '(a)','Enter EELEC'
3552 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
3553       do i=1,nres
3554         gel_loc_loc(i)=0.0d0
3555         gcorr_loc(i)=0.0d0
3556       enddo
3557 c
3558 c
3559 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
3560 C
3561 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
3562 C
3563 C 14/01/2014 TURN3,TUNR4 does no go under periodic boundry condition
3564       do i=iturn3_start,iturn3_end
3565 c        if (i.le.1) cycle
3566 C        write(iout,*) "tu jest i",i
3567         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3568 C changes suggested by Ana to avoid out of bounds
3569 C Adam: Unnecessary: handled by iturn3_end and iturn3_start
3570 c     & .or.((i+4).gt.nres)
3571 c     & .or.((i-1).le.0)
3572 C end of changes by Ana
3573      &  .or. itype(i+2).eq.ntyp1
3574      &  .or. itype(i+3).eq.ntyp1) cycle
3575 C Adam: Instructions below will switch off existing interactions
3576 c        if(i.gt.1)then
3577 c          if(itype(i-1).eq.ntyp1)cycle
3578 c        end if
3579 c        if(i.LT.nres-3)then
3580 c          if (itype(i+4).eq.ntyp1) cycle
3581 c        end if
3582         dxi=dc(1,i)
3583         dyi=dc(2,i)
3584         dzi=dc(3,i)
3585         dx_normi=dc_norm(1,i)
3586         dy_normi=dc_norm(2,i)
3587         dz_normi=dc_norm(3,i)
3588         xmedi=c(1,i)+0.5d0*dxi
3589         ymedi=c(2,i)+0.5d0*dyi
3590         zmedi=c(3,i)+0.5d0*dzi
3591           xmedi=mod(xmedi,boxxsize)
3592           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3593           ymedi=mod(ymedi,boxysize)
3594           if (ymedi.lt.0) ymedi=ymedi+boxysize
3595           zmedi=mod(zmedi,boxzsize)
3596           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3597         num_conti=0
3598         call eelecij(i,i+2,ees,evdw1,eel_loc)
3599         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
3600         num_cont_hb(i)=num_conti
3601       enddo
3602       do i=iturn4_start,iturn4_end
3603         if (i.lt.1) cycle
3604         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3605 C changes suggested by Ana to avoid out of bounds
3606 c     & .or.((i+5).gt.nres)
3607 c     & .or.((i-1).le.0)
3608 C end of changes suggested by Ana
3609      &    .or. itype(i+3).eq.ntyp1
3610      &    .or. itype(i+4).eq.ntyp1
3611 c     &    .or. itype(i+5).eq.ntyp1
3612 c     &    .or. itype(i).eq.ntyp1
3613 c     &    .or. itype(i-1).eq.ntyp1
3614      &                             ) cycle
3615         dxi=dc(1,i)
3616         dyi=dc(2,i)
3617         dzi=dc(3,i)
3618         dx_normi=dc_norm(1,i)
3619         dy_normi=dc_norm(2,i)
3620         dz_normi=dc_norm(3,i)
3621         xmedi=c(1,i)+0.5d0*dxi
3622         ymedi=c(2,i)+0.5d0*dyi
3623         zmedi=c(3,i)+0.5d0*dzi
3624 C Return atom into box, boxxsize is size of box in x dimension
3625 c  194   continue
3626 c        if (xmedi.gt.((0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3627 c        if (xmedi.lt.((-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3628 C Condition for being inside the proper box
3629 c        if ((xmedi.gt.((0.5d0)*boxxsize)).or.
3630 c     &       (xmedi.lt.((-0.5d0)*boxxsize))) then
3631 c        go to 194
3632 c        endif
3633 c  195   continue
3634 c        if (ymedi.gt.((0.5d0)*boxysize)) ymedi=ymedi-boxysize
3635 c        if (ymedi.lt.((-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3636 C Condition for being inside the proper box
3637 c        if ((ymedi.gt.((0.5d0)*boxysize)).or.
3638 c     &       (ymedi.lt.((-0.5d0)*boxysize))) then
3639 c        go to 195
3640 c        endif
3641 c  196   continue
3642 c        if (zmedi.gt.((0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3643 c        if (zmedi.lt.((-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3644 C Condition for being inside the proper box
3645 c        if ((zmedi.gt.((0.5d0)*boxzsize)).or.
3646 c     &       (zmedi.lt.((-0.5d0)*boxzsize))) then
3647 c        go to 196
3648 c        endif
3649           xmedi=mod(xmedi,boxxsize)
3650           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3651           ymedi=mod(ymedi,boxysize)
3652           if (ymedi.lt.0) ymedi=ymedi+boxysize
3653           zmedi=mod(zmedi,boxzsize)
3654           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3655
3656         num_conti=num_cont_hb(i)
3657 c        write(iout,*) "JESTEM W PETLI"
3658         call eelecij(i,i+3,ees,evdw1,eel_loc)
3659         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
3660      &   call eturn4(i,eello_turn4)
3661         num_cont_hb(i)=num_conti
3662       enddo   ! i
3663 C Loop over all neighbouring boxes
3664 C      do xshift=-1,1
3665 C      do yshift=-1,1
3666 C      do zshift=-1,1
3667 c
3668 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
3669 c
3670 CTU KURWA
3671       do i=iatel_s,iatel_e
3672 C        do i=75,75
3673 c        if (i.le.1) cycle
3674         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
3675 C changes suggested by Ana to avoid out of bounds
3676 c     & .or.((i+2).gt.nres)
3677 c     & .or.((i-1).le.0)
3678 C end of changes by Ana
3679 c     &  .or. itype(i+2).eq.ntyp1
3680 c     &  .or. itype(i-1).eq.ntyp1
3681      &                ) cycle
3682         dxi=dc(1,i)
3683         dyi=dc(2,i)
3684         dzi=dc(3,i)
3685         dx_normi=dc_norm(1,i)
3686         dy_normi=dc_norm(2,i)
3687         dz_normi=dc_norm(3,i)
3688         xmedi=c(1,i)+0.5d0*dxi
3689         ymedi=c(2,i)+0.5d0*dyi
3690         zmedi=c(3,i)+0.5d0*dzi
3691           xmedi=mod(xmedi,boxxsize)
3692           if (xmedi.lt.0) xmedi=xmedi+boxxsize
3693           ymedi=mod(ymedi,boxysize)
3694           if (ymedi.lt.0) ymedi=ymedi+boxysize
3695           zmedi=mod(zmedi,boxzsize)
3696           if (zmedi.lt.0) zmedi=zmedi+boxzsize
3697 C          xmedi=xmedi+xshift*boxxsize
3698 C          ymedi=ymedi+yshift*boxysize
3699 C          zmedi=zmedi+zshift*boxzsize
3700
3701 C Return tom into box, boxxsize is size of box in x dimension
3702 c  164   continue
3703 c        if (xmedi.gt.((xshift+0.5d0)*boxxsize)) xmedi=xmedi-boxxsize
3704 c        if (xmedi.lt.((xshift-0.5d0)*boxxsize)) xmedi=xmedi+boxxsize
3705 C Condition for being inside the proper box
3706 c        if ((xmedi.gt.((xshift+0.5d0)*boxxsize)).or.
3707 c     &       (xmedi.lt.((xshift-0.5d0)*boxxsize))) then
3708 c        go to 164
3709 c        endif
3710 c  165   continue
3711 c        if (ymedi.gt.((yshift+0.5d0)*boxysize)) ymedi=ymedi-boxysize
3712 c        if (ymedi.lt.((yshift-0.5d0)*boxysize)) ymedi=ymedi+boxysize
3713 C Condition for being inside the proper box
3714 c        if ((ymedi.gt.((yshift+0.5d0)*boxysize)).or.
3715 c     &       (ymedi.lt.((yshift-0.5d0)*boxysize))) then
3716 c        go to 165
3717 c        endif
3718 c  166   continue
3719 c        if (zmedi.gt.((zshift+0.5d0)*boxzsize)) zmedi=zmedi-boxzsize
3720 c        if (zmedi.lt.((zshift-0.5d0)*boxzsize)) zmedi=zmedi+boxzsize
3721 cC Condition for being inside the proper box
3722 c        if ((zmedi.gt.((zshift+0.5d0)*boxzsize)).or.
3723 c     &       (zmedi.lt.((zshift-0.5d0)*boxzsize))) then
3724 c        go to 166
3725 c        endif
3726
3727 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
3728         num_conti=num_cont_hb(i)
3729 C I TU KURWA
3730         do j=ielstart(i),ielend(i)
3731 C          do j=16,17
3732 C          write (iout,*) i,j
3733 C         if (j.le.1) cycle
3734           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1
3735 C changes suggested by Ana to avoid out of bounds
3736 c     & .or.((j+2).gt.nres)
3737 c     & .or.((j-1).le.0)
3738 C end of changes by Ana
3739 c     & .or.itype(j+2).eq.ntyp1
3740 c     & .or.itype(j-1).eq.ntyp1
3741      &) cycle
3742           call eelecij(i,j,ees,evdw1,eel_loc)
3743         enddo ! j
3744         num_cont_hb(i)=num_conti
3745       enddo   ! i
3746 C     enddo   ! zshift
3747 C      enddo   ! yshift
3748 C      enddo   ! xshift
3749
3750 c      write (iout,*) "Number of loop steps in EELEC:",ind
3751 cd      do i=1,nres
3752 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
3753 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
3754 cd      enddo
3755 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
3756 ccc      eel_loc=eel_loc+eello_turn3
3757 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
3758       return
3759       end
3760 C-------------------------------------------------------------------------------
3761       subroutine eelecij(i,j,ees,evdw1,eel_loc)
3762       implicit real*8 (a-h,o-z)
3763       include 'DIMENSIONS'
3764 #ifdef MPI
3765       include "mpif.h"
3766 #endif
3767       include 'COMMON.CONTROL'
3768       include 'COMMON.IOUNITS'
3769       include 'COMMON.GEO'
3770       include 'COMMON.VAR'
3771       include 'COMMON.LOCAL'
3772       include 'COMMON.CHAIN'
3773       include 'COMMON.DERIV'
3774       include 'COMMON.INTERACT'
3775       include 'COMMON.CONTACTS'
3776       include 'COMMON.TORSION'
3777       include 'COMMON.VECTORS'
3778       include 'COMMON.FFIELD'
3779       include 'COMMON.TIME1'
3780       include 'COMMON.SPLITELE'
3781       include 'COMMON.SHIELD'
3782       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
3783      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
3784       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
3785      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4),gmuij1(4),gmuji1(4),
3786      &    gmuij2(4),gmuji2(4)
3787       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3788      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3789      &    num_conti,j1,j2
3790 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
3791 #ifdef MOMENT
3792       double precision scal_el /1.0d0/
3793 #else
3794       double precision scal_el /0.5d0/
3795 #endif
3796 C 12/13/98
3797 C 13-go grudnia roku pamietnego...
3798       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
3799      &                   0.0d0,1.0d0,0.0d0,
3800      &                   0.0d0,0.0d0,1.0d0/
3801        integer xshift,yshift,zshift
3802 c          time00=MPI_Wtime()
3803 cd      write (iout,*) "eelecij",i,j
3804 c          ind=ind+1
3805           iteli=itel(i)
3806           itelj=itel(j)
3807           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
3808           aaa=app(iteli,itelj)
3809           bbb=bpp(iteli,itelj)
3810           ael6i=ael6(iteli,itelj)
3811           ael3i=ael3(iteli,itelj)
3812           dxj=dc(1,j)
3813           dyj=dc(2,j)
3814           dzj=dc(3,j)
3815           dx_normj=dc_norm(1,j)
3816           dy_normj=dc_norm(2,j)
3817           dz_normj=dc_norm(3,j)
3818 C          xj=c(1,j)+0.5D0*dxj-xmedi
3819 C          yj=c(2,j)+0.5D0*dyj-ymedi
3820 C          zj=c(3,j)+0.5D0*dzj-zmedi
3821           xj=c(1,j)+0.5D0*dxj
3822           yj=c(2,j)+0.5D0*dyj
3823           zj=c(3,j)+0.5D0*dzj
3824           xj=mod(xj,boxxsize)
3825           if (xj.lt.0) xj=xj+boxxsize
3826           yj=mod(yj,boxysize)
3827           if (yj.lt.0) yj=yj+boxysize
3828           zj=mod(zj,boxzsize)
3829           if (zj.lt.0) zj=zj+boxzsize
3830           if ((zj.lt.0).or.(xj.lt.0).or.(yj.lt.0)) write (*,*) "CHUJ"
3831       dist_init=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3832       xj_safe=xj
3833       yj_safe=yj
3834       zj_safe=zj
3835       isubchap=0
3836       do xshift=-1,1
3837       do yshift=-1,1
3838       do zshift=-1,1
3839           xj=xj_safe+xshift*boxxsize
3840           yj=yj_safe+yshift*boxysize
3841           zj=zj_safe+zshift*boxzsize
3842           dist_temp=(xj-xmedi)**2+(yj-ymedi)**2+(zj-zmedi)**2
3843           if(dist_temp.lt.dist_init) then
3844             dist_init=dist_temp
3845             xj_temp=xj
3846             yj_temp=yj
3847             zj_temp=zj
3848             isubchap=1
3849           endif
3850        enddo
3851        enddo
3852        enddo
3853        if (isubchap.eq.1) then
3854           xj=xj_temp-xmedi
3855           yj=yj_temp-ymedi
3856           zj=zj_temp-zmedi
3857        else
3858           xj=xj_safe-xmedi
3859           yj=yj_safe-ymedi
3860           zj=zj_safe-zmedi
3861        endif
3862 C        if ((i+3).lt.j) then !this condition keeps for turn3 and turn4 not subject to PBC
3863 c  174   continue
3864 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
3865 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
3866 C Condition for being inside the proper box
3867 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
3868 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
3869 c        go to 174
3870 c        endif
3871 c  175   continue
3872 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
3873 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
3874 C Condition for being inside the proper box
3875 c        if ((yj.gt.((0.5d0)*boxysize)).or.
3876 c     &       (yj.lt.((-0.5d0)*boxysize))) then
3877 c        go to 175
3878 c        endif
3879 c  176   continue
3880 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
3881 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
3882 C Condition for being inside the proper box
3883 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
3884 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
3885 c        go to 176
3886 c        endif
3887 C        endif !endPBC condintion
3888 C        xj=xj-xmedi
3889 C        yj=yj-ymedi
3890 C        zj=zj-zmedi
3891           rij=xj*xj+yj*yj+zj*zj
3892
3893             sss=sscale(sqrt(rij))
3894             sssgrad=sscagrad(sqrt(rij))
3895 c            if (sss.gt.0.0d0) then
3896           rrmij=1.0D0/rij
3897           rij=dsqrt(rij)
3898           rmij=1.0D0/rij
3899           r3ij=rrmij*rmij
3900           r6ij=r3ij*r3ij
3901           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
3902           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
3903           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
3904           fac=cosa-3.0D0*cosb*cosg
3905           ev1=aaa*r6ij*r6ij
3906 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
3907           if (j.eq.i+2) ev1=scal_el*ev1
3908           ev2=bbb*r6ij
3909           fac3=ael6i*r6ij
3910           fac4=ael3i*r3ij
3911           evdwij=(ev1+ev2)
3912           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
3913           el2=fac4*fac
3914 C MARYSIA
3915 C          eesij=(el1+el2)
3916 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
3917           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
3918           if (shield_mode.gt.0) then
3919 C          fac_shield(i)=0.4
3920 C          fac_shield(j)=0.6
3921           el1=el1*fac_shield(i)**2*fac_shield(j)**2
3922           el2=el2*fac_shield(i)**2*fac_shield(j)**2
3923           eesij=(el1+el2)
3924           ees=ees+eesij
3925           else
3926           fac_shield(i)=1.0
3927           fac_shield(j)=1.0
3928           eesij=(el1+el2)
3929           ees=ees+eesij
3930           endif
3931           evdw1=evdw1+evdwij*sss
3932 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
3933 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
3934 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
3935 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
3936
3937           if (energy_dec) then
3938               write (iout,'(a6,2i5,0pf7.3,2i5,3e11.3)')
3939      &'evdw1',i,j,evdwij
3940      &,iteli,itelj,aaa,evdw1,sss
3941               write (iout,'(a6,2i5,0pf7.3,2f8.3)') 'ees',i,j,eesij,
3942      &fac_shield(i),fac_shield(j)
3943           endif
3944
3945 C
3946 C Calculate contributions to the Cartesian gradient.
3947 C
3948 #ifdef SPLITELE
3949           facvdw=-6*rrmij*(ev1+evdwij)*sss
3950           facel=-3*rrmij*(el1+eesij)
3951           fac1=fac
3952           erij(1)=xj*rmij
3953           erij(2)=yj*rmij
3954           erij(3)=zj*rmij
3955
3956 *
3957 * Radial derivatives. First process both termini of the fragment (i,j)
3958 *
3959           ggg(1)=facel*xj
3960           ggg(2)=facel*yj
3961           ggg(3)=facel*zj
3962           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
3963      &  (shield_mode.gt.0)) then
3964 C          print *,i,j
3965           do ilist=1,ishield_list(i)
3966            iresshield=shield_list(ilist,i)
3967            do k=1,3
3968            rlocshield=grad_shield_side(k,ilist,i)*eesij/fac_shield(i)
3969      &      *2.0
3970            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3971      &              rlocshield
3972      & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)*2.0
3973             gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
3974 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
3975 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3976 C             if (iresshield.gt.i) then
3977 C               do ishi=i+1,iresshield-1
3978 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
3979 C     & +grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3980 C
3981 C              enddo
3982 C             else
3983 C               do ishi=iresshield,i
3984 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
3985 C     & -grad_shield_loc(k,ilist,i)*eesij/fac_shield(i)
3986 C
3987 C               enddo
3988 C              endif
3989            enddo
3990           enddo
3991           do ilist=1,ishield_list(j)
3992            iresshield=shield_list(ilist,j)
3993            do k=1,3
3994            rlocshield=grad_shield_side(k,ilist,j)*eesij/fac_shield(j)
3995      &     *2.0
3996            gshieldx(k,iresshield)=gshieldx(k,iresshield)+
3997      &              rlocshield
3998      & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)*2.0
3999            gshieldc(k,iresshield-1)=gshieldc(k,iresshield-1)+rlocshield
4000
4001 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4002 C           gshieldc_loc(k,iresshield)=gshieldc_loc(k,iresshield)
4003 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4004 C             if (iresshield.gt.j) then
4005 C               do ishi=j+1,iresshield-1
4006 C                gshieldc(k,ishi)=gshieldc(k,ishi)+rlocshield
4007 C     & +grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4008 C
4009 C               enddo
4010 C            else
4011 C               do ishi=iresshield,j
4012 C                gshieldc(k,ishi)=gshieldc(k,ishi)-rlocshield
4013 C     & -grad_shield_loc(k,ilist,j)*eesij/fac_shield(j)
4014 C               enddo
4015 C              endif
4016            enddo
4017           enddo
4018
4019           do k=1,3
4020             gshieldc(k,i)=gshieldc(k,i)+
4021      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4022             gshieldc(k,j)=gshieldc(k,j)+
4023      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4024             gshieldc(k,i-1)=gshieldc(k,i-1)+
4025      &              grad_shield(k,i)*eesij/fac_shield(i)*2.0
4026             gshieldc(k,j-1)=gshieldc(k,j-1)+
4027      &              grad_shield(k,j)*eesij/fac_shield(j)*2.0
4028
4029            enddo
4030            endif
4031 c          do k=1,3
4032 c            ghalf=0.5D0*ggg(k)
4033 c            gelc(k,i)=gelc(k,i)+ghalf
4034 c            gelc(k,j)=gelc(k,j)+ghalf
4035 c          enddo
4036 c 9/28/08 AL Gradient compotents will be summed only at the end
4037 C           print *,"before", gelc_long(1,i), gelc_long(1,j)
4038           do k=1,3
4039             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4040 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4041             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4042 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4043 C            gelc_long(k,i-1)=gelc_long(k,i-1)
4044 C     &                    +grad_shield(k,i)*eesij/fac_shield(i)
4045 C            gelc_long(k,j-1)=gelc_long(k,j-1)
4046 C     &                    +grad_shield(k,j)*eesij/fac_shield(j)
4047           enddo
4048 C           print *,"bafter", gelc_long(1,i), gelc_long(1,j)
4049
4050 *
4051 * Loop over residues i+1 thru j-1.
4052 *
4053 cgrad          do k=i+1,j-1
4054 cgrad            do l=1,3
4055 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4056 cgrad            enddo
4057 cgrad          enddo
4058           if (sss.gt.0.0) then
4059           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4060           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4061           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4062           else
4063           ggg(1)=0.0
4064           ggg(2)=0.0
4065           ggg(3)=0.0
4066           endif
4067 c          do k=1,3
4068 c            ghalf=0.5D0*ggg(k)
4069 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
4070 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
4071 c          enddo
4072 c 9/28/08 AL Gradient compotents will be summed only at the end
4073           do k=1,3
4074             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4075             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4076           enddo
4077 *
4078 * Loop over residues i+1 thru j-1.
4079 *
4080 cgrad          do k=i+1,j-1
4081 cgrad            do l=1,3
4082 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
4083 cgrad            enddo
4084 cgrad          enddo
4085 #else
4086 C MARYSIA
4087           facvdw=(ev1+evdwij)*sss
4088           facel=(el1+eesij)
4089           fac1=fac
4090           fac=-3*rrmij*(facvdw+facvdw+facel)
4091           erij(1)=xj*rmij
4092           erij(2)=yj*rmij
4093           erij(3)=zj*rmij
4094 *
4095 * Radial derivatives. First process both termini of the fragment (i,j)
4096 *
4097           ggg(1)=fac*xj
4098 C+eesij*grad_shield(1,i)+eesij*grad_shield(1,j)
4099           ggg(2)=fac*yj
4100 C+eesij*grad_shield(2,i)+eesij*grad_shield(2,j)
4101           ggg(3)=fac*zj
4102 C+eesij*grad_shield(3,i)+eesij*grad_shield(3,j)
4103 c          do k=1,3
4104 c            ghalf=0.5D0*ggg(k)
4105 c            gelc(k,i)=gelc(k,i)+ghalf
4106 c            gelc(k,j)=gelc(k,j)+ghalf
4107 c          enddo
4108 c 9/28/08 AL Gradient compotents will be summed only at the end
4109           do k=1,3
4110             gelc_long(k,j)=gelc(k,j)+ggg(k)
4111             gelc_long(k,i)=gelc(k,i)-ggg(k)
4112           enddo
4113 *
4114 * Loop over residues i+1 thru j-1.
4115 *
4116 cgrad          do k=i+1,j-1
4117 cgrad            do l=1,3
4118 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4119 cgrad            enddo
4120 cgrad          enddo
4121 c 9/28/08 AL Gradient compotents will be summed only at the end
4122           ggg(1)=facvdw*xj+sssgrad*rmij*evdwij*xj
4123           ggg(2)=facvdw*yj+sssgrad*rmij*evdwij*yj
4124           ggg(3)=facvdw*zj+sssgrad*rmij*evdwij*zj
4125           do k=1,3
4126             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
4127             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
4128           enddo
4129 #endif
4130 *
4131 * Angular part
4132 *
4133           ecosa=2.0D0*fac3*fac1+fac4
4134           fac4=-3.0D0*fac4
4135           fac3=-6.0D0*fac3
4136           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
4137           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
4138           do k=1,3
4139             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4140             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4141           enddo
4142 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
4143 cd   &          (dcosg(k),k=1,3)
4144           do k=1,3
4145             ggg(k)=(ecosb*dcosb(k)+ecosg*dcosg(k))*
4146      &      fac_shield(i)**2*fac_shield(j)**2
4147           enddo
4148 c          do k=1,3
4149 c            ghalf=0.5D0*ggg(k)
4150 c            gelc(k,i)=gelc(k,i)+ghalf
4151 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4152 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4153 c            gelc(k,j)=gelc(k,j)+ghalf
4154 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4155 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4156 c          enddo
4157 cgrad          do k=i+1,j-1
4158 cgrad            do l=1,3
4159 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
4160 cgrad            enddo
4161 cgrad          enddo
4162 C                     print *,"before22", gelc_long(1,i), gelc_long(1,j)
4163           do k=1,3
4164             gelc(k,i)=gelc(k,i)
4165      &           +((ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
4166      &           + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1))
4167      &           *fac_shield(i)**2*fac_shield(j)**2
4168             gelc(k,j)=gelc(k,j)
4169      &           +((ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
4170      &           + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1))
4171      &           *fac_shield(i)**2*fac_shield(j)**2
4172             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
4173             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
4174           enddo
4175 C           print *,"before33", gelc_long(1,i), gelc_long(1,j)
4176
4177 C MARYSIA
4178 c          endif !sscale
4179           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
4180      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
4181      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4182 C
4183 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
4184 C   energy of a peptide unit is assumed in the form of a second-order
4185 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
4186 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
4187 C   are computed for EVERY pair of non-contiguous peptide groups.
4188 C
4189
4190           if (j.lt.nres-1) then
4191             j1=j+1
4192             j2=j-1
4193           else
4194             j1=j-1
4195             j2=j-2
4196           endif
4197           kkk=0
4198           lll=0
4199           do k=1,2
4200             do l=1,2
4201               kkk=kkk+1
4202               muij(kkk)=mu(k,i)*mu(l,j)
4203 c              write(iout,*) 'mumu=', mu(k,i),mu(l,j),i,j,k,l
4204 #ifdef NEWCORR
4205              gmuij1(kkk)=gtb1(k,i+1)*mu(l,j)
4206 c             write(iout,*) 'k=',k,i,gtb1(k,i+1),gtb1(k,i+1)*mu(l,j)
4207              gmuij2(kkk)=gUb2(k,i)*mu(l,j)
4208              gmuji1(kkk)=mu(k,i)*gtb1(l,j+1)
4209 c             write(iout,*) 'l=',l,j,gtb1(l,j+1),gtb1(l,j+1)*mu(k,i)
4210              gmuji2(kkk)=mu(k,i)*gUb2(l,j)
4211 #endif
4212             enddo
4213           enddo
4214 #ifdef DEBUG
4215           write (iout,*) 'EELEC: i',i,' j',j
4216           write (iout,*) 'j',j,' j1',j1,' j2',j2
4217           write(iout,*) 'muij',muij
4218 #endif
4219           ury=scalar(uy(1,i),erij)
4220           urz=scalar(uz(1,i),erij)
4221           vry=scalar(uy(1,j),erij)
4222           vrz=scalar(uz(1,j),erij)
4223           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
4224           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
4225           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
4226           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
4227           fac=dsqrt(-ael6i)*r3ij
4228 #ifdef DEBUG
4229           write (iout,*) "ury",ury," urz",urz," vry",vry," vrz",vrz
4230           write (iout,*) "uyvy",scalar(uy(1,i),uy(1,j)),
4231      &      "uyvz",scalar(uy(1,i),uz(1,j)),
4232      &      "uzvy",scalar(uz(1,i),uy(1,j)),
4233      &      "uzvz",scalar(uz(1,i),uz(1,j))
4234           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4235           write (iout,*) "fac",fac
4236 #endif
4237           a22=a22*fac
4238           a23=a23*fac
4239           a32=a32*fac
4240           a33=a33*fac
4241 #ifdef DEBUG
4242           write (iout,*) "a22",a22," a23",a23," a32",a32," a33",a33
4243 #endif
4244 #undef DEBUG
4245 cd          write (iout,'(4i5,4f10.5)')
4246 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
4247 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
4248 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
4249 cd     &      uy(:,j),uz(:,j)
4250 cd          write (iout,'(4f10.5)')
4251 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
4252 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
4253 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
4254 cd           write (iout,'(9f10.5/)')
4255 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
4256 C Derivatives of the elements of A in virtual-bond vectors
4257           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
4258           do k=1,3
4259             uryg(k,1)=scalar(erder(1,k),uy(1,i))
4260             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
4261             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
4262             urzg(k,1)=scalar(erder(1,k),uz(1,i))
4263             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
4264             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
4265             vryg(k,1)=scalar(erder(1,k),uy(1,j))
4266             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
4267             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
4268             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
4269             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
4270             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
4271           enddo
4272 C Compute radial contributions to the gradient
4273           facr=-3.0d0*rrmij
4274           a22der=a22*facr
4275           a23der=a23*facr
4276           a32der=a32*facr
4277           a33der=a33*facr
4278           agg(1,1)=a22der*xj
4279           agg(2,1)=a22der*yj
4280           agg(3,1)=a22der*zj
4281           agg(1,2)=a23der*xj
4282           agg(2,2)=a23der*yj
4283           agg(3,2)=a23der*zj
4284           agg(1,3)=a32der*xj
4285           agg(2,3)=a32der*yj
4286           agg(3,3)=a32der*zj
4287           agg(1,4)=a33der*xj
4288           agg(2,4)=a33der*yj
4289           agg(3,4)=a33der*zj
4290 C Add the contributions coming from er
4291           fac3=-3.0d0*fac
4292           do k=1,3
4293             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
4294             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
4295             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
4296             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
4297           enddo
4298           do k=1,3
4299 C Derivatives in DC(i)
4300 cgrad            ghalf1=0.5d0*agg(k,1)
4301 cgrad            ghalf2=0.5d0*agg(k,2)
4302 cgrad            ghalf3=0.5d0*agg(k,3)
4303 cgrad            ghalf4=0.5d0*agg(k,4)
4304             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
4305      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
4306             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
4307      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
4308             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
4309      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
4310             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
4311      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
4312 C Derivatives in DC(i+1)
4313             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
4314      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
4315             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
4316      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
4317             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
4318      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
4319             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
4320      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
4321 C Derivatives in DC(j)
4322             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
4323      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
4324             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
4325      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
4326             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
4327      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
4328             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
4329      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
4330 C Derivatives in DC(j+1) or DC(nres-1)
4331             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
4332      &      -3.0d0*vryg(k,3)*ury)
4333             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
4334      &      -3.0d0*vrzg(k,3)*ury)
4335             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
4336      &      -3.0d0*vryg(k,3)*urz)
4337             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
4338      &      -3.0d0*vrzg(k,3)*urz)
4339 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
4340 cgrad              do l=1,4
4341 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
4342 cgrad              enddo
4343 cgrad            endif
4344           enddo
4345           acipa(1,1)=a22
4346           acipa(1,2)=a23
4347           acipa(2,1)=a32
4348           acipa(2,2)=a33
4349           a22=-a22
4350           a23=-a23
4351           do l=1,2
4352             do k=1,3
4353               agg(k,l)=-agg(k,l)
4354               aggi(k,l)=-aggi(k,l)
4355               aggi1(k,l)=-aggi1(k,l)
4356               aggj(k,l)=-aggj(k,l)
4357               aggj1(k,l)=-aggj1(k,l)
4358             enddo
4359           enddo
4360           if (j.lt.nres-1) then
4361             a22=-a22
4362             a32=-a32
4363             do l=1,3,2
4364               do k=1,3
4365                 agg(k,l)=-agg(k,l)
4366                 aggi(k,l)=-aggi(k,l)
4367                 aggi1(k,l)=-aggi1(k,l)
4368                 aggj(k,l)=-aggj(k,l)
4369                 aggj1(k,l)=-aggj1(k,l)
4370               enddo
4371             enddo
4372           else
4373             a22=-a22
4374             a23=-a23
4375             a32=-a32
4376             a33=-a33
4377             do l=1,4
4378               do k=1,3
4379                 agg(k,l)=-agg(k,l)
4380                 aggi(k,l)=-aggi(k,l)
4381                 aggi1(k,l)=-aggi1(k,l)
4382                 aggj(k,l)=-aggj(k,l)
4383                 aggj1(k,l)=-aggj1(k,l)
4384               enddo
4385             enddo
4386           endif
4387           ENDIF ! WCORR
4388           IF (wel_loc.gt.0.0d0) THEN
4389 C Contribution to the local-electrostatic energy coming from the i-j pair
4390           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
4391      &     +a33*muij(4)
4392 #ifdef DEBUG
4393           write (iout,*) "muij",muij," a22",a22," a23",a23," a32",a32,
4394      &     " a33",a33
4395           write (iout,*) "ij",i,j," eel_loc_ij",eel_loc_ij,
4396      &     " wel_loc",wel_loc
4397 #endif
4398           if (shield_mode.eq.0) then
4399            fac_shield(i)=1.0
4400            fac_shield(j)=1.0
4401 C          else
4402 C           fac_shield(i)=0.4
4403 C           fac_shield(j)=0.6
4404           endif
4405           eel_loc_ij=eel_loc_ij
4406      &    *fac_shield(i)*fac_shield(j)
4407 c          if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4408 c     &            'eelloc',i,j,eel_loc_ij
4409 C Now derivative over eel_loc
4410           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4411      &  (shield_mode.gt.0)) then
4412 C          print *,i,j
4413
4414           do ilist=1,ishield_list(i)
4415            iresshield=shield_list(ilist,i)
4416            do k=1,3
4417            rlocshield=grad_shield_side(k,ilist,i)*eel_loc_ij
4418      &                                          /fac_shield(i)
4419 C     &      *2.0
4420            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4421      &              rlocshield
4422      & +grad_shield_loc(k,ilist,i)*eel_loc_ij/fac_shield(i)
4423             gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4424      &      +rlocshield
4425            enddo
4426           enddo
4427           do ilist=1,ishield_list(j)
4428            iresshield=shield_list(ilist,j)
4429            do k=1,3
4430            rlocshield=grad_shield_side(k,ilist,j)*eel_loc_ij
4431      &                                       /fac_shield(j)
4432 C     &     *2.0
4433            gshieldx_ll(k,iresshield)=gshieldx_ll(k,iresshield)+
4434      &              rlocshield
4435      & +grad_shield_loc(k,ilist,j)*eel_loc_ij/fac_shield(j)
4436            gshieldc_ll(k,iresshield-1)=gshieldc_ll(k,iresshield-1)
4437      &             +rlocshield
4438
4439            enddo
4440           enddo
4441
4442           do k=1,3
4443             gshieldc_ll(k,i)=gshieldc_ll(k,i)+
4444      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4445             gshieldc_ll(k,j)=gshieldc_ll(k,j)+
4446      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4447             gshieldc_ll(k,i-1)=gshieldc_ll(k,i-1)+
4448      &              grad_shield(k,i)*eel_loc_ij/fac_shield(i)
4449             gshieldc_ll(k,j-1)=gshieldc_ll(k,j-1)+
4450      &              grad_shield(k,j)*eel_loc_ij/fac_shield(j)
4451            enddo
4452            endif
4453
4454
4455 c          write (iout,*) 'i',i,' j',j,itype(i),itype(j),
4456 c     &                     ' eel_loc_ij',eel_loc_ij
4457 C          write(iout,*) 'muije=',i,j,muij(1),muij(2),muij(3),muij(4)
4458 C Calculate patrial derivative for theta angle
4459 #ifdef NEWCORR
4460          geel_loc_ij=(a22*gmuij1(1)
4461      &     +a23*gmuij1(2)
4462      &     +a32*gmuij1(3)
4463      &     +a33*gmuij1(4))
4464      &    *fac_shield(i)*fac_shield(j)
4465 c         write(iout,*) "derivative over thatai"
4466 c         write(iout,*) a22*gmuij1(1), a23*gmuij1(2) ,a32*gmuij1(3),
4467 c     &   a33*gmuij1(4)
4468          gloc(nphi+i,icg)=gloc(nphi+i,icg)+
4469      &      geel_loc_ij*wel_loc
4470 c         write(iout,*) "derivative over thatai-1"
4471 c         write(iout,*) a22*gmuij2(1), a23*gmuij2(2) ,a32*gmuij2(3),
4472 c     &   a33*gmuij2(4)
4473          geel_loc_ij=
4474      &     a22*gmuij2(1)
4475      &     +a23*gmuij2(2)
4476      &     +a32*gmuij2(3)
4477      &     +a33*gmuij2(4)
4478          gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
4479      &      geel_loc_ij*wel_loc
4480      &    *fac_shield(i)*fac_shield(j)
4481
4482 c  Derivative over j residue
4483          geel_loc_ji=a22*gmuji1(1)
4484      &     +a23*gmuji1(2)
4485      &     +a32*gmuji1(3)
4486      &     +a33*gmuji1(4)
4487 c         write(iout,*) "derivative over thataj"
4488 c         write(iout,*) a22*gmuji1(1), a23*gmuji1(2) ,a32*gmuji1(3),
4489 c     &   a33*gmuji1(4)
4490
4491         gloc(nphi+j,icg)=gloc(nphi+j,icg)+
4492      &      geel_loc_ji*wel_loc
4493      &    *fac_shield(i)*fac_shield(j)
4494
4495          geel_loc_ji=
4496      &     +a22*gmuji2(1)
4497      &     +a23*gmuji2(2)
4498      &     +a32*gmuji2(3)
4499      &     +a33*gmuji2(4)
4500 c         write(iout,*) "derivative over thataj-1"
4501 c         write(iout,*) a22*gmuji2(1), a23*gmuji2(2) ,a32*gmuji2(3),
4502 c     &   a33*gmuji2(4)
4503          gloc(nphi+j-1,icg)=gloc(nphi+j-1,icg)+
4504      &      geel_loc_ji*wel_loc
4505      &    *fac_shield(i)*fac_shield(j)
4506 #endif
4507 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
4508
4509           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4510      &            'eelloc',i,j,eel_loc_ij
4511 c           if (eel_loc_ij.ne.0)
4512 c     &      write (iout,'(a4,2i4,8f9.5)')'chuj',
4513 c     &     i,j,a22,muij(1),a23,muij(2),a32,muij(3),a33,muij(4)
4514
4515           eel_loc=eel_loc+eel_loc_ij
4516 C Partial derivatives in virtual-bond dihedral angles gamma
4517           if (i.gt.1)
4518      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
4519      &            (a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
4520      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j))
4521      &    *fac_shield(i)*fac_shield(j)
4522
4523           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
4524      &           (a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
4525      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j))
4526      &    *fac_shield(i)*fac_shield(j)
4527 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
4528           do l=1,3
4529             ggg(l)=(agg(l,1)*muij(1)+
4530      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4))
4531      &    *fac_shield(i)*fac_shield(j)
4532             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
4533             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
4534 cgrad            ghalf=0.5d0*ggg(l)
4535 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
4536 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
4537           enddo
4538 cgrad          do k=i+1,j2
4539 cgrad            do l=1,3
4540 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
4541 cgrad            enddo
4542 cgrad          enddo
4543 C Remaining derivatives of eello
4544           do l=1,3
4545             gel_loc(l,i)=gel_loc(l,i)+(aggi(l,1)*muij(1)+
4546      &        aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4))
4547      &    *fac_shield(i)*fac_shield(j)
4548
4549             gel_loc(l,i+1)=gel_loc(l,i+1)+(aggi1(l,1)*muij(1)+
4550      &     aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4))
4551      &    *fac_shield(i)*fac_shield(j)
4552
4553             gel_loc(l,j)=gel_loc(l,j)+(aggj(l,1)*muij(1)+
4554      &       aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4))
4555      &    *fac_shield(i)*fac_shield(j)
4556
4557             gel_loc(l,j1)=gel_loc(l,j1)+(aggj1(l,1)*muij(1)+
4558      &     aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4))
4559      &    *fac_shield(i)*fac_shield(j)
4560
4561           enddo
4562           ENDIF
4563 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
4564 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
4565           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
4566      &       .and. num_conti.le.maxconts) then
4567 c            write (iout,*) i,j," entered corr"
4568 C
4569 C Calculate the contact function. The ith column of the array JCONT will
4570 C contain the numbers of atoms that make contacts with the atom I (of numbers
4571 C greater than I). The arrays FACONT and GACONT will contain the values of
4572 C the contact function and its derivative.
4573 c           r0ij=1.02D0*rpp(iteli,itelj)
4574 c           r0ij=1.11D0*rpp(iteli,itelj)
4575             r0ij=2.20D0*rpp(iteli,itelj)
4576 c           r0ij=1.55D0*rpp(iteli,itelj)
4577             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
4578             if (fcont.gt.0.0D0) then
4579               num_conti=num_conti+1
4580               if (num_conti.gt.maxconts) then
4581                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
4582      &                         ' will skip next contacts for this conf.'
4583               else
4584                 jcont_hb(num_conti,i)=j
4585 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
4586 cd     &           " jcont_hb",jcont_hb(num_conti,i)
4587                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
4588      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
4589 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
4590 C  terms.
4591                 d_cont(num_conti,i)=rij
4592 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
4593 C     --- Electrostatic-interaction matrix ---
4594                 a_chuj(1,1,num_conti,i)=a22
4595                 a_chuj(1,2,num_conti,i)=a23
4596                 a_chuj(2,1,num_conti,i)=a32
4597                 a_chuj(2,2,num_conti,i)=a33
4598 C     --- Gradient of rij
4599                 do kkk=1,3
4600                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
4601                 enddo
4602                 kkll=0
4603                 do k=1,2
4604                   do l=1,2
4605                     kkll=kkll+1
4606                     do m=1,3
4607                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
4608                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
4609                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
4610                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
4611                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
4612                     enddo
4613                   enddo
4614                 enddo
4615                 ENDIF
4616                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
4617 C Calculate contact energies
4618                 cosa4=4.0D0*cosa
4619                 wij=cosa-3.0D0*cosb*cosg
4620                 cosbg1=cosb+cosg
4621                 cosbg2=cosb-cosg
4622 c               fac3=dsqrt(-ael6i)/r0ij**3
4623                 fac3=dsqrt(-ael6i)*r3ij
4624 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
4625                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
4626                 if (ees0tmp.gt.0) then
4627                   ees0pij=dsqrt(ees0tmp)
4628                 else
4629                   ees0pij=0
4630                 endif
4631 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
4632                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
4633                 if (ees0tmp.gt.0) then
4634                   ees0mij=dsqrt(ees0tmp)
4635                 else
4636                   ees0mij=0
4637                 endif
4638 c               ees0mij=0.0D0
4639                 if (shield_mode.eq.0) then
4640                 fac_shield(i)=1.0d0
4641                 fac_shield(j)=1.0d0
4642                 else
4643                 ees0plist(num_conti,i)=j
4644 C                fac_shield(i)=0.4d0
4645 C                fac_shield(j)=0.6d0
4646                 endif
4647                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
4648      &          *fac_shield(i)*fac_shield(j)
4649                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
4650      &          *fac_shield(i)*fac_shield(j)
4651 C Diagnostics. Comment out or remove after debugging!
4652 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
4653 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
4654 c               ees0m(num_conti,i)=0.0D0
4655 C End diagnostics.
4656 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
4657 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
4658 C Angular derivatives of the contact function
4659                 ees0pij1=fac3/ees0pij
4660                 ees0mij1=fac3/ees0mij
4661                 fac3p=-3.0D0*fac3*rrmij
4662                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
4663                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
4664 c               ees0mij1=0.0D0
4665                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
4666                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
4667                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
4668                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
4669                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
4670                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
4671                 ecosap=ecosa1+ecosa2
4672                 ecosbp=ecosb1+ecosb2
4673                 ecosgp=ecosg1+ecosg2
4674                 ecosam=ecosa1-ecosa2
4675                 ecosbm=ecosb1-ecosb2
4676                 ecosgm=ecosg1-ecosg2
4677 C Diagnostics
4678 c               ecosap=ecosa1
4679 c               ecosbp=ecosb1
4680 c               ecosgp=ecosg1
4681 c               ecosam=0.0D0
4682 c               ecosbm=0.0D0
4683 c               ecosgm=0.0D0
4684 C End diagnostics
4685                 facont_hb(num_conti,i)=fcont
4686                 fprimcont=fprimcont/rij
4687 cd              facont_hb(num_conti,i)=1.0D0
4688 C Following line is for diagnostics.
4689 cd              fprimcont=0.0D0
4690                 do k=1,3
4691                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
4692                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
4693                 enddo
4694                 do k=1,3
4695                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
4696                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
4697                 enddo
4698                 gggp(1)=gggp(1)+ees0pijp*xj
4699                 gggp(2)=gggp(2)+ees0pijp*yj
4700                 gggp(3)=gggp(3)+ees0pijp*zj
4701                 gggm(1)=gggm(1)+ees0mijp*xj
4702                 gggm(2)=gggm(2)+ees0mijp*yj
4703                 gggm(3)=gggm(3)+ees0mijp*zj
4704 C Derivatives due to the contact function
4705                 gacont_hbr(1,num_conti,i)=fprimcont*xj
4706                 gacont_hbr(2,num_conti,i)=fprimcont*yj
4707                 gacont_hbr(3,num_conti,i)=fprimcont*zj
4708                 do k=1,3
4709 c
4710 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
4711 c          following the change of gradient-summation algorithm.
4712 c
4713 cgrad                  ghalfp=0.5D0*gggp(k)
4714 cgrad                  ghalfm=0.5D0*gggm(k)
4715                   gacontp_hb1(k,num_conti,i)=!ghalfp
4716      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
4717      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4718      &          *fac_shield(i)*fac_shield(j)
4719
4720                   gacontp_hb2(k,num_conti,i)=!ghalfp
4721      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
4722      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4723      &          *fac_shield(i)*fac_shield(j)
4724
4725                   gacontp_hb3(k,num_conti,i)=gggp(k)
4726      &          *fac_shield(i)*fac_shield(j)
4727
4728                   gacontm_hb1(k,num_conti,i)=!ghalfm
4729      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
4730      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
4731      &          *fac_shield(i)*fac_shield(j)
4732
4733                   gacontm_hb2(k,num_conti,i)=!ghalfm
4734      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
4735      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
4736      &          *fac_shield(i)*fac_shield(j)
4737
4738                   gacontm_hb3(k,num_conti,i)=gggm(k)
4739      &          *fac_shield(i)*fac_shield(j)
4740
4741                 enddo
4742 C Diagnostics. Comment out or remove after debugging!
4743 cdiag           do k=1,3
4744 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
4745 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
4746 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
4747 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
4748 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
4749 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
4750 cdiag           enddo
4751               ENDIF ! wcorr
4752               endif  ! num_conti.le.maxconts
4753             endif  ! fcont.gt.0
4754           endif    ! j.gt.i+1
4755           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
4756             do k=1,4
4757               do l=1,3
4758                 ghalf=0.5d0*agg(l,k)
4759                 aggi(l,k)=aggi(l,k)+ghalf
4760                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
4761                 aggj(l,k)=aggj(l,k)+ghalf
4762               enddo
4763             enddo
4764             if (j.eq.nres-1 .and. i.lt.j-2) then
4765               do k=1,4
4766                 do l=1,3
4767                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
4768                 enddo
4769               enddo
4770             endif
4771           endif
4772 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
4773       return
4774       end
4775 C-----------------------------------------------------------------------------
4776       subroutine eturn3(i,eello_turn3)
4777 C Third- and fourth-order contributions from turns
4778       implicit real*8 (a-h,o-z)
4779       include 'DIMENSIONS'
4780       include 'COMMON.IOUNITS'
4781       include 'COMMON.GEO'
4782       include 'COMMON.VAR'
4783       include 'COMMON.LOCAL'
4784       include 'COMMON.CHAIN'
4785       include 'COMMON.DERIV'
4786       include 'COMMON.INTERACT'
4787       include 'COMMON.CONTACTS'
4788       include 'COMMON.TORSION'
4789       include 'COMMON.VECTORS'
4790       include 'COMMON.FFIELD'
4791       include 'COMMON.CONTROL'
4792       include 'COMMON.SHIELD'
4793       dimension ggg(3)
4794       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4795      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4796      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),gpizda1(2,2),
4797      &  gpizda2(2,2),auxgmat1(2,2),auxgmatt1(2,2),
4798      &  auxgmat2(2,2),auxgmatt2(2,2)
4799       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4800      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4801       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4802      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4803      &    num_conti,j1,j2
4804       j=i+2
4805 c      write (iout,*) "eturn3",i,j,j1,j2
4806       a_temp(1,1)=a22
4807       a_temp(1,2)=a23
4808       a_temp(2,1)=a32
4809       a_temp(2,2)=a33
4810 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4811 C
4812 C               Third-order contributions
4813 C
4814 C                 (i+2)o----(i+3)
4815 C                      | |
4816 C                      | |
4817 C                 (i+1)o----i
4818 C
4819 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4820 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
4821         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
4822 c auxalary matices for theta gradient
4823 c auxalary matrix for i+1 and constant i+2
4824         call matmat2(gtEUg(1,1,i+1),EUg(1,1,i+2),auxgmat1(1,1))
4825 c auxalary matrix for i+2 and constant i+1
4826         call matmat2(EUg(1,1,i+1),gtEUg(1,1,i+2),auxgmat2(1,1))
4827         call transpose2(auxmat(1,1),auxmat1(1,1))
4828         call transpose2(auxgmat1(1,1),auxgmatt1(1,1))
4829         call transpose2(auxgmat2(1,1),auxgmatt2(1,1))
4830         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4831         call matmat2(a_temp(1,1),auxgmatt1(1,1),gpizda1(1,1))
4832         call matmat2(a_temp(1,1),auxgmatt2(1,1),gpizda2(1,1))
4833         if (shield_mode.eq.0) then
4834         fac_shield(i)=1.0
4835         fac_shield(j)=1.0
4836 C        else
4837 C        fac_shield(i)=0.4
4838 C        fac_shield(j)=0.6
4839         endif
4840         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
4841      &  *fac_shield(i)*fac_shield(j)
4842         eello_t3=0.5d0*(pizda(1,1)+pizda(2,2))
4843      &  *fac_shield(i)*fac_shield(j)
4844         if (energy_dec) write (iout,'(6heturn3,2i5,0pf7.3)') i,i+2,
4845      &    eello_t3
4846 C#ifdef NEWCORR
4847 C Derivatives in theta
4848         gloc(nphi+i,icg)=gloc(nphi+i,icg)
4849      &  +0.5d0*(gpizda1(1,1)+gpizda1(2,2))*wturn3
4850      &   *fac_shield(i)*fac_shield(j)
4851         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)
4852      &  +0.5d0*(gpizda2(1,1)+gpizda2(2,2))*wturn3
4853      &   *fac_shield(i)*fac_shield(j)
4854 C#endif
4855
4856 C Derivatives in shield mode
4857           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
4858      &  (shield_mode.gt.0)) then
4859 C          print *,i,j
4860
4861           do ilist=1,ishield_list(i)
4862            iresshield=shield_list(ilist,i)
4863            do k=1,3
4864            rlocshield=grad_shield_side(k,ilist,i)*eello_t3/fac_shield(i)
4865 C     &      *2.0
4866            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4867      &              rlocshield
4868      & +grad_shield_loc(k,ilist,i)*eello_t3/fac_shield(i)
4869             gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4870      &      +rlocshield
4871            enddo
4872           enddo
4873           do ilist=1,ishield_list(j)
4874            iresshield=shield_list(ilist,j)
4875            do k=1,3
4876            rlocshield=grad_shield_side(k,ilist,j)*eello_t3/fac_shield(j)
4877 C     &     *2.0
4878            gshieldx_t3(k,iresshield)=gshieldx_t3(k,iresshield)+
4879      &              rlocshield
4880      & +grad_shield_loc(k,ilist,j)*eello_t3/fac_shield(j)
4881            gshieldc_t3(k,iresshield-1)=gshieldc_t3(k,iresshield-1)
4882      &             +rlocshield
4883
4884            enddo
4885           enddo
4886
4887           do k=1,3
4888             gshieldc_t3(k,i)=gshieldc_t3(k,i)+
4889      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4890             gshieldc_t3(k,j)=gshieldc_t3(k,j)+
4891      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4892             gshieldc_t3(k,i-1)=gshieldc_t3(k,i-1)+
4893      &              grad_shield(k,i)*eello_t3/fac_shield(i)
4894             gshieldc_t3(k,j-1)=gshieldc_t3(k,j-1)+
4895      &              grad_shield(k,j)*eello_t3/fac_shield(j)
4896            enddo
4897            endif
4898
4899 C        if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
4900 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
4901 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
4902 cd     &    ' eello_turn3_num',4*eello_turn3_num
4903 C Derivatives in gamma(i)
4904         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
4905         call transpose2(auxmat2(1,1),auxmat3(1,1))
4906         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4907         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
4908      &   *fac_shield(i)*fac_shield(j)
4909 C Derivatives in gamma(i+1)
4910         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
4911         call transpose2(auxmat2(1,1),auxmat3(1,1))
4912         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
4913         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
4914      &    +0.5d0*(pizda(1,1)+pizda(2,2))
4915      &   *fac_shield(i)*fac_shield(j)
4916 C Cartesian derivatives
4917         do l=1,3
4918 c            ghalf1=0.5d0*agg(l,1)
4919 c            ghalf2=0.5d0*agg(l,2)
4920 c            ghalf3=0.5d0*agg(l,3)
4921 c            ghalf4=0.5d0*agg(l,4)
4922           a_temp(1,1)=aggi(l,1)!+ghalf1
4923           a_temp(1,2)=aggi(l,2)!+ghalf2
4924           a_temp(2,1)=aggi(l,3)!+ghalf3
4925           a_temp(2,2)=aggi(l,4)!+ghalf4
4926           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4927           gcorr3_turn(l,i)=gcorr3_turn(l,i)
4928      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4929      &   *fac_shield(i)*fac_shield(j)
4930
4931           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
4932           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
4933           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
4934           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
4935           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4936           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
4937      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4938      &   *fac_shield(i)*fac_shield(j)
4939           a_temp(1,1)=aggj(l,1)!+ghalf1
4940           a_temp(1,2)=aggj(l,2)!+ghalf2
4941           a_temp(2,1)=aggj(l,3)!+ghalf3
4942           a_temp(2,2)=aggj(l,4)!+ghalf4
4943           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4944           gcorr3_turn(l,j)=gcorr3_turn(l,j)
4945      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4946      &   *fac_shield(i)*fac_shield(j)
4947           a_temp(1,1)=aggj1(l,1)
4948           a_temp(1,2)=aggj1(l,2)
4949           a_temp(2,1)=aggj1(l,3)
4950           a_temp(2,2)=aggj1(l,4)
4951           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
4952           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
4953      &      +0.5d0*(pizda(1,1)+pizda(2,2))
4954      &   *fac_shield(i)*fac_shield(j)
4955         enddo
4956       return
4957       end
4958 C-------------------------------------------------------------------------------
4959       subroutine eturn4(i,eello_turn4)
4960 C Third- and fourth-order contributions from turns
4961       implicit real*8 (a-h,o-z)
4962       include 'DIMENSIONS'
4963       include 'COMMON.IOUNITS'
4964       include 'COMMON.GEO'
4965       include 'COMMON.VAR'
4966       include 'COMMON.LOCAL'
4967       include 'COMMON.CHAIN'
4968       include 'COMMON.DERIV'
4969       include 'COMMON.INTERACT'
4970       include 'COMMON.CONTACTS'
4971       include 'COMMON.TORSION'
4972       include 'COMMON.VECTORS'
4973       include 'COMMON.FFIELD'
4974       include 'COMMON.CONTROL'
4975       include 'COMMON.SHIELD'
4976       dimension ggg(3)
4977       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
4978      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
4979      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2),auxgvec(2),
4980      &  auxgEvec1(2),auxgEvec2(2),auxgEvec3(2),
4981      &  gte1t(2,2),gte2t(2,2),gte3t(2,2),
4982      &  gte1a(2,2),gtae3(2,2),gtae3e2(2,2), ae3gte2(2,2),
4983      &  gtEpizda1(2,2),gtEpizda2(2,2),gtEpizda3(2,2)
4984       double precision agg(3,4),aggi(3,4),aggi1(3,4),
4985      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
4986       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
4987      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
4988      &    num_conti,j1,j2
4989       j=i+3
4990 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
4991 C
4992 C               Fourth-order contributions
4993 C
4994 C                 (i+3)o----(i+4)
4995 C                     /  |
4996 C               (i+2)o   |
4997 C                     \  |
4998 C                 (i+1)o----i
4999 C
5000 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
5001 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
5002 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
5003 c        write(iout,*)"WCHODZE W PROGRAM"
5004         a_temp(1,1)=a22
5005         a_temp(1,2)=a23
5006         a_temp(2,1)=a32
5007         a_temp(2,2)=a33
5008         iti1=itype2loc(itype(i+1))
5009         iti2=itype2loc(itype(i+2))
5010         iti3=itype2loc(itype(i+3))
5011 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
5012         call transpose2(EUg(1,1,i+1),e1t(1,1))
5013         call transpose2(Eug(1,1,i+2),e2t(1,1))
5014         call transpose2(Eug(1,1,i+3),e3t(1,1))
5015 C Ematrix derivative in theta
5016         call transpose2(gtEUg(1,1,i+1),gte1t(1,1))
5017         call transpose2(gtEug(1,1,i+2),gte2t(1,1))
5018         call transpose2(gtEug(1,1,i+3),gte3t(1,1))
5019         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5020 c       eta1 in derivative theta
5021         call matmat2(gte1t(1,1),a_temp(1,1),gte1a(1,1))
5022         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5023 c       auxgvec is derivative of Ub2 so i+3 theta
5024         call matvec2(e1a(1,1),gUb2(1,i+3),auxgvec(1))
5025 c       auxalary matrix of E i+1
5026         call matvec2(gte1a(1,1),Ub2(1,i+3),auxgEvec1(1))
5027 c        s1=0.0
5028 c        gs1=0.0
5029         s1=scalar2(b1(1,i+2),auxvec(1))
5030 c derivative of theta i+2 with constant i+3
5031         gs23=scalar2(gtb1(1,i+2),auxvec(1))
5032 c derivative of theta i+2 with constant i+2
5033         gs32=scalar2(b1(1,i+2),auxgvec(1))
5034 c derivative of E matix in theta of i+1
5035         gsE13=scalar2(b1(1,i+2),auxgEvec1(1))
5036
5037         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5038 c       ea31 in derivative theta
5039         call matmat2(a_temp(1,1),gte3t(1,1),gtae3(1,1))
5040         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5041 c auxilary matrix auxgvec of Ub2 with constant E matirx
5042         call matvec2(ae3(1,1),gUb2(1,i+2),auxgvec(1))
5043 c auxilary matrix auxgEvec1 of E matix with Ub2 constant
5044         call matvec2(gtae3(1,1),Ub2(1,i+2),auxgEvec3(1))
5045
5046 c        s2=0.0
5047 c        gs2=0.0
5048         s2=scalar2(b1(1,i+1),auxvec(1))
5049 c derivative of theta i+1 with constant i+3
5050         gs13=scalar2(gtb1(1,i+1),auxvec(1))
5051 c derivative of theta i+2 with constant i+1
5052         gs21=scalar2(b1(1,i+1),auxgvec(1))
5053 c derivative of theta i+3 with constant i+1
5054         gsE31=scalar2(b1(1,i+1),auxgEvec3(1))
5055 c        write(iout,*) gs1,gs2,'i=',i,auxgvec(1),gUb2(1,i+2),gtb1(1,i+2),
5056 c     &  gtb1(1,i+1)
5057         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5058 c two derivatives over diffetent matrices
5059 c gtae3e2 is derivative over i+3
5060         call matmat2(gtae3(1,1),e2t(1,1),gtae3e2(1,1))
5061 c ae3gte2 is derivative over i+2
5062         call matmat2(ae3(1,1),gte2t(1,1),ae3gte2(1,1))
5063         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5064 c three possible derivative over theta E matices
5065 c i+1
5066         call matmat2(ae3e2(1,1),gte1t(1,1),gtEpizda1(1,1))
5067 c i+2
5068         call matmat2(ae3gte2(1,1),e1t(1,1),gtEpizda2(1,1))
5069 c i+3
5070         call matmat2(gtae3e2(1,1),e1t(1,1),gtEpizda3(1,1))
5071         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5072
5073         gsEE1=0.5d0*(gtEpizda1(1,1)+gtEpizda1(2,2))
5074         gsEE2=0.5d0*(gtEpizda2(1,1)+gtEpizda2(2,2))
5075         gsEE3=0.5d0*(gtEpizda3(1,1)+gtEpizda3(2,2))
5076         if (shield_mode.eq.0) then
5077         fac_shield(i)=1.0
5078         fac_shield(j)=1.0
5079 C        else
5080 C        fac_shield(i)=0.6
5081 C        fac_shield(j)=0.4
5082         endif
5083         eello_turn4=eello_turn4-(s1+s2+s3)
5084      &  *fac_shield(i)*fac_shield(j)
5085         eello_t4=-(s1+s2+s3)
5086      &  *fac_shield(i)*fac_shield(j)
5087 c             write(iout,*)'chujOWO', auxvec(1),b1(1,iti2)
5088         if (energy_dec) write (iout,'(a6,2i5,0pf7.3,3f7.3)')
5089      &      'eturn4',i,j,-(s1+s2+s3),s1,s2,s3
5090 C Now derivative over shield:
5091           if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
5092      &  (shield_mode.gt.0)) then
5093 C          print *,i,j
5094
5095           do ilist=1,ishield_list(i)
5096            iresshield=shield_list(ilist,i)
5097            do k=1,3
5098            rlocshield=grad_shield_side(k,ilist,i)*eello_t4/fac_shield(i)
5099 C     &      *2.0
5100            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5101      &              rlocshield
5102      & +grad_shield_loc(k,ilist,i)*eello_t4/fac_shield(i)
5103             gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5104      &      +rlocshield
5105            enddo
5106           enddo
5107           do ilist=1,ishield_list(j)
5108            iresshield=shield_list(ilist,j)
5109            do k=1,3
5110            rlocshield=grad_shield_side(k,ilist,j)*eello_t4/fac_shield(j)
5111 C     &     *2.0
5112            gshieldx_t4(k,iresshield)=gshieldx_t4(k,iresshield)+
5113      &              rlocshield
5114      & +grad_shield_loc(k,ilist,j)*eello_t4/fac_shield(j)
5115            gshieldc_t4(k,iresshield-1)=gshieldc_t4(k,iresshield-1)
5116      &             +rlocshield
5117
5118            enddo
5119           enddo
5120
5121           do k=1,3
5122             gshieldc_t4(k,i)=gshieldc_t4(k,i)+
5123      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5124             gshieldc_t4(k,j)=gshieldc_t4(k,j)+
5125      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5126             gshieldc_t4(k,i-1)=gshieldc_t4(k,i-1)+
5127      &              grad_shield(k,i)*eello_t4/fac_shield(i)
5128             gshieldc_t4(k,j-1)=gshieldc_t4(k,j-1)+
5129      &              grad_shield(k,j)*eello_t4/fac_shield(j)
5130            enddo
5131            endif
5132
5133
5134
5135
5136
5137
5138 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5139 cd     &    ' eello_turn4_num',8*eello_turn4_num
5140 #ifdef NEWCORR
5141         gloc(nphi+i,icg)=gloc(nphi+i,icg)
5142      &                  -(gs13+gsE13+gsEE1)*wturn4
5143      &  *fac_shield(i)*fac_shield(j)
5144         gloc(nphi+i+1,icg)= gloc(nphi+i+1,icg)
5145      &                    -(gs23+gs21+gsEE2)*wturn4
5146      &  *fac_shield(i)*fac_shield(j)
5147
5148         gloc(nphi+i+2,icg)= gloc(nphi+i+2,icg)
5149      &                    -(gs32+gsE31+gsEE3)*wturn4
5150      &  *fac_shield(i)*fac_shield(j)
5151
5152 c         gloc(nphi+i+1,icg)=gloc(nphi+i+1,icg)-
5153 c     &   gs2
5154 #endif
5155         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
5156      &      'eturn4',i,j,-(s1+s2+s3)
5157 c        write (iout,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
5158 c     &    ' eello_turn4_num',8*eello_turn4_num
5159 C Derivatives in gamma(i)
5160         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
5161         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
5162         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
5163         s1=scalar2(b1(1,i+2),auxvec(1))
5164         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
5165         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5166         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
5167      &  *fac_shield(i)*fac_shield(j)
5168 C Derivatives in gamma(i+1)
5169         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
5170         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
5171         s2=scalar2(b1(1,i+1),auxvec(1))
5172         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
5173         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
5174         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5175         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
5176      &  *fac_shield(i)*fac_shield(j)
5177 C Derivatives in gamma(i+2)
5178         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
5179         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
5180         s1=scalar2(b1(1,i+2),auxvec(1))
5181         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
5182         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
5183         s2=scalar2(b1(1,i+1),auxvec(1))
5184         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
5185         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
5186         s3=0.5d0*(pizda(1,1)+pizda(2,2))
5187         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
5188      &  *fac_shield(i)*fac_shield(j)
5189 C Cartesian derivatives
5190 C Derivatives of this turn contributions in DC(i+2)
5191         if (j.lt.nres-1) then
5192           do l=1,3
5193             a_temp(1,1)=agg(l,1)
5194             a_temp(1,2)=agg(l,2)
5195             a_temp(2,1)=agg(l,3)
5196             a_temp(2,2)=agg(l,4)
5197             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5198             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5199             s1=scalar2(b1(1,i+2),auxvec(1))
5200             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5201             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5202             s2=scalar2(b1(1,i+1),auxvec(1))
5203             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5204             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5205             s3=0.5d0*(pizda(1,1)+pizda(2,2))
5206             ggg(l)=-(s1+s2+s3)
5207             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
5208      &  *fac_shield(i)*fac_shield(j)
5209           enddo
5210         endif
5211 C Remaining derivatives of this turn contribution
5212         do l=1,3
5213           a_temp(1,1)=aggi(l,1)
5214           a_temp(1,2)=aggi(l,2)
5215           a_temp(2,1)=aggi(l,3)
5216           a_temp(2,2)=aggi(l,4)
5217           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5218           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5219           s1=scalar2(b1(1,i+2),auxvec(1))
5220           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5221           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5222           s2=scalar2(b1(1,i+1),auxvec(1))
5223           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5224           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5225           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5226           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
5227      &  *fac_shield(i)*fac_shield(j)
5228           a_temp(1,1)=aggi1(l,1)
5229           a_temp(1,2)=aggi1(l,2)
5230           a_temp(2,1)=aggi1(l,3)
5231           a_temp(2,2)=aggi1(l,4)
5232           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5233           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5234           s1=scalar2(b1(1,i+2),auxvec(1))
5235           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5236           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5237           s2=scalar2(b1(1,i+1),auxvec(1))
5238           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5239           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5240           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5241           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
5242      &  *fac_shield(i)*fac_shield(j)
5243           a_temp(1,1)=aggj(l,1)
5244           a_temp(1,2)=aggj(l,2)
5245           a_temp(2,1)=aggj(l,3)
5246           a_temp(2,2)=aggj(l,4)
5247           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5248           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5249           s1=scalar2(b1(1,i+2),auxvec(1))
5250           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5251           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5252           s2=scalar2(b1(1,i+1),auxvec(1))
5253           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5254           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5255           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5256           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
5257      &  *fac_shield(i)*fac_shield(j)
5258           a_temp(1,1)=aggj1(l,1)
5259           a_temp(1,2)=aggj1(l,2)
5260           a_temp(2,1)=aggj1(l,3)
5261           a_temp(2,2)=aggj1(l,4)
5262           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
5263           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
5264           s1=scalar2(b1(1,i+2),auxvec(1))
5265           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
5266           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
5267           s2=scalar2(b1(1,i+1),auxvec(1))
5268           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
5269           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
5270           s3=0.5d0*(pizda(1,1)+pizda(2,2))
5271 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
5272           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
5273      &  *fac_shield(i)*fac_shield(j)
5274         enddo
5275       return
5276       end
5277 C-----------------------------------------------------------------------------
5278       subroutine vecpr(u,v,w)
5279       implicit real*8(a-h,o-z)
5280       dimension u(3),v(3),w(3)
5281       w(1)=u(2)*v(3)-u(3)*v(2)
5282       w(2)=-u(1)*v(3)+u(3)*v(1)
5283       w(3)=u(1)*v(2)-u(2)*v(1)
5284       return
5285       end
5286 C-----------------------------------------------------------------------------
5287       subroutine unormderiv(u,ugrad,unorm,ungrad)
5288 C This subroutine computes the derivatives of a normalized vector u, given
5289 C the derivatives computed without normalization conditions, ugrad. Returns
5290 C ungrad.
5291       implicit none
5292       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
5293       double precision vec(3)
5294       double precision scalar
5295       integer i,j
5296 c      write (2,*) 'ugrad',ugrad
5297 c      write (2,*) 'u',u
5298       do i=1,3
5299         vec(i)=scalar(ugrad(1,i),u(1))
5300       enddo
5301 c      write (2,*) 'vec',vec
5302       do i=1,3
5303         do j=1,3
5304           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
5305         enddo
5306       enddo
5307 c      write (2,*) 'ungrad',ungrad
5308       return
5309       end
5310 C-----------------------------------------------------------------------------
5311       subroutine escp_soft_sphere(evdw2,evdw2_14)
5312 C
5313 C This subroutine calculates the excluded-volume interaction energy between
5314 C peptide-group centers and side chains and its gradient in virtual-bond and
5315 C side-chain vectors.
5316 C
5317       implicit real*8 (a-h,o-z)
5318       include 'DIMENSIONS'
5319       include 'COMMON.GEO'
5320       include 'COMMON.VAR'
5321       include 'COMMON.LOCAL'
5322       include 'COMMON.CHAIN'
5323       include 'COMMON.DERIV'
5324       include 'COMMON.INTERACT'
5325       include 'COMMON.FFIELD'
5326       include 'COMMON.IOUNITS'
5327       include 'COMMON.CONTROL'
5328       dimension ggg(3)
5329       integer xshift,yshift,zshift
5330       evdw2=0.0D0
5331       evdw2_14=0.0d0
5332       r0_scp=4.5d0
5333 cd    print '(a)','Enter ESCP'
5334 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5335 C      do xshift=-1,1
5336 C      do yshift=-1,1
5337 C      do zshift=-1,1
5338       do i=iatscp_s,iatscp_e
5339         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5340         iteli=itel(i)
5341         xi=0.5D0*(c(1,i)+c(1,i+1))
5342         yi=0.5D0*(c(2,i)+c(2,i+1))
5343         zi=0.5D0*(c(3,i)+c(3,i+1))
5344 C Return atom into box, boxxsize is size of box in x dimension
5345 c  134   continue
5346 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5347 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5348 C Condition for being inside the proper box
5349 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5350 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5351 c        go to 134
5352 c        endif
5353 c  135   continue
5354 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5355 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5356 C Condition for being inside the proper box
5357 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5358 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5359 c        go to 135
5360 c c       endif
5361 c  136   continue
5362 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5363 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5364 cC Condition for being inside the proper box
5365 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5366 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5367 c        go to 136
5368 c        endif
5369           xi=mod(xi,boxxsize)
5370           if (xi.lt.0) xi=xi+boxxsize
5371           yi=mod(yi,boxysize)
5372           if (yi.lt.0) yi=yi+boxysize
5373           zi=mod(zi,boxzsize)
5374           if (zi.lt.0) zi=zi+boxzsize
5375 C          xi=xi+xshift*boxxsize
5376 C          yi=yi+yshift*boxysize
5377 C          zi=zi+zshift*boxzsize
5378         do iint=1,nscp_gr(i)
5379
5380         do j=iscpstart(i,iint),iscpend(i,iint)
5381           if (itype(j).eq.ntyp1) cycle
5382           itypj=iabs(itype(j))
5383 C Uncomment following three lines for SC-p interactions
5384 c         xj=c(1,nres+j)-xi
5385 c         yj=c(2,nres+j)-yi
5386 c         zj=c(3,nres+j)-zi
5387 C Uncomment following three lines for Ca-p interactions
5388           xj=c(1,j)
5389           yj=c(2,j)
5390           zj=c(3,j)
5391 c  174   continue
5392 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5393 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5394 C Condition for being inside the proper box
5395 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5396 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5397 c        go to 174
5398 c        endif
5399 c  175   continue
5400 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5401 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5402 cC Condition for being inside the proper box
5403 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5404 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5405 c        go to 175
5406 c        endif
5407 c  176   continue
5408 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5409 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5410 C Condition for being inside the proper box
5411 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5412 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5413 c        go to 176
5414           xj=mod(xj,boxxsize)
5415           if (xj.lt.0) xj=xj+boxxsize
5416           yj=mod(yj,boxysize)
5417           if (yj.lt.0) yj=yj+boxysize
5418           zj=mod(zj,boxzsize)
5419           if (zj.lt.0) zj=zj+boxzsize
5420       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5421       xj_safe=xj
5422       yj_safe=yj
5423       zj_safe=zj
5424       subchap=0
5425       do xshift=-1,1
5426       do yshift=-1,1
5427       do zshift=-1,1
5428           xj=xj_safe+xshift*boxxsize
5429           yj=yj_safe+yshift*boxysize
5430           zj=zj_safe+zshift*boxzsize
5431           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5432           if(dist_temp.lt.dist_init) then
5433             dist_init=dist_temp
5434             xj_temp=xj
5435             yj_temp=yj
5436             zj_temp=zj
5437             subchap=1
5438           endif
5439        enddo
5440        enddo
5441        enddo
5442        if (subchap.eq.1) then
5443           xj=xj_temp-xi
5444           yj=yj_temp-yi
5445           zj=zj_temp-zi
5446        else
5447           xj=xj_safe-xi
5448           yj=yj_safe-yi
5449           zj=zj_safe-zi
5450        endif
5451 c c       endif
5452 C          xj=xj-xi
5453 C          yj=yj-yi
5454 C          zj=zj-zi
5455           rij=xj*xj+yj*yj+zj*zj
5456
5457           r0ij=r0_scp
5458           r0ijsq=r0ij*r0ij
5459           if (rij.lt.r0ijsq) then
5460             evdwij=0.25d0*(rij-r0ijsq)**2
5461             fac=rij-r0ijsq
5462           else
5463             evdwij=0.0d0
5464             fac=0.0d0
5465           endif
5466           evdw2=evdw2+evdwij
5467 C
5468 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5469 C
5470           ggg(1)=xj*fac
5471           ggg(2)=yj*fac
5472           ggg(3)=zj*fac
5473 cgrad          if (j.lt.i) then
5474 cd          write (iout,*) 'j<i'
5475 C Uncomment following three lines for SC-p interactions
5476 c           do k=1,3
5477 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5478 c           enddo
5479 cgrad          else
5480 cd          write (iout,*) 'j>i'
5481 cgrad            do k=1,3
5482 cgrad              ggg(k)=-ggg(k)
5483 C Uncomment following line for SC-p interactions
5484 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5485 cgrad            enddo
5486 cgrad          endif
5487 cgrad          do k=1,3
5488 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5489 cgrad          enddo
5490 cgrad          kstart=min0(i+1,j)
5491 cgrad          kend=max0(i-1,j-1)
5492 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5493 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5494 cgrad          do k=kstart,kend
5495 cgrad            do l=1,3
5496 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5497 cgrad            enddo
5498 cgrad          enddo
5499           do k=1,3
5500             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5501             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5502           enddo
5503         enddo
5504
5505         enddo ! iint
5506       enddo ! i
5507 C      enddo !zshift
5508 C      enddo !yshift
5509 C      enddo !xshift
5510       return
5511       end
5512 C-----------------------------------------------------------------------------
5513       subroutine escp(evdw2,evdw2_14)
5514 C
5515 C This subroutine calculates the excluded-volume interaction energy between
5516 C peptide-group centers and side chains and its gradient in virtual-bond and
5517 C side-chain vectors.
5518 C
5519       implicit real*8 (a-h,o-z)
5520       include 'DIMENSIONS'
5521       include 'COMMON.GEO'
5522       include 'COMMON.VAR'
5523       include 'COMMON.LOCAL'
5524       include 'COMMON.CHAIN'
5525       include 'COMMON.DERIV'
5526       include 'COMMON.INTERACT'
5527       include 'COMMON.FFIELD'
5528       include 'COMMON.IOUNITS'
5529       include 'COMMON.CONTROL'
5530       include 'COMMON.SPLITELE'
5531       integer xshift,yshift,zshift
5532       dimension ggg(3)
5533       evdw2=0.0D0
5534       evdw2_14=0.0d0
5535 c        print *,boxxsize,boxysize,boxzsize,'wymiary pudla'
5536 cd    print '(a)','Enter ESCP'
5537 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
5538 C      do xshift=-1,1
5539 C      do yshift=-1,1
5540 C      do zshift=-1,1
5541       if (energy_dec) write (iout,*) "escp:",r_cut,rlamb
5542       do i=iatscp_s,iatscp_e
5543         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5544         iteli=itel(i)
5545         xi=0.5D0*(c(1,i)+c(1,i+1))
5546         yi=0.5D0*(c(2,i)+c(2,i+1))
5547         zi=0.5D0*(c(3,i)+c(3,i+1))
5548           xi=mod(xi,boxxsize)
5549           if (xi.lt.0) xi=xi+boxxsize
5550           yi=mod(yi,boxysize)
5551           if (yi.lt.0) yi=yi+boxysize
5552           zi=mod(zi,boxzsize)
5553           if (zi.lt.0) zi=zi+boxzsize
5554 c          xi=xi+xshift*boxxsize
5555 c          yi=yi+yshift*boxysize
5556 c          zi=zi+zshift*boxzsize
5557 c        print *,xi,yi,zi,'polozenie i'
5558 C Return atom into box, boxxsize is size of box in x dimension
5559 c  134   continue
5560 c        if (xi.gt.((xshift+0.5d0)*boxxsize)) xi=xi-boxxsize
5561 c        if (xi.lt.((xshift-0.5d0)*boxxsize)) xi=xi+boxxsize
5562 C Condition for being inside the proper box
5563 c        if ((xi.gt.((xshift+0.5d0)*boxxsize)).or.
5564 c     &       (xi.lt.((xshift-0.5d0)*boxxsize))) then
5565 c        go to 134
5566 c        endif
5567 c  135   continue
5568 c          print *,xi,boxxsize,"pierwszy"
5569
5570 c        if (yi.gt.((yshift+0.5d0)*boxysize)) yi=yi-boxysize
5571 c        if (yi.lt.((yshift-0.5d0)*boxysize)) yi=yi+boxysize
5572 C Condition for being inside the proper box
5573 c        if ((yi.gt.((yshift+0.5d0)*boxysize)).or.
5574 c     &       (yi.lt.((yshift-0.5d0)*boxysize))) then
5575 c        go to 135
5576 c        endif
5577 c  136   continue
5578 c        if (zi.gt.((zshift+0.5d0)*boxzsize)) zi=zi-boxzsize
5579 c        if (zi.lt.((zshift-0.5d0)*boxzsize)) zi=zi+boxzsize
5580 C Condition for being inside the proper box
5581 c        if ((zi.gt.((zshift+0.5d0)*boxzsize)).or.
5582 c     &       (zi.lt.((zshift-0.5d0)*boxzsize))) then
5583 c        go to 136
5584 c        endif
5585         do iint=1,nscp_gr(i)
5586
5587         do j=iscpstart(i,iint),iscpend(i,iint)
5588           itypj=iabs(itype(j))
5589           if (itypj.eq.ntyp1) cycle
5590 C Uncomment following three lines for SC-p interactions
5591 c         xj=c(1,nres+j)-xi
5592 c         yj=c(2,nres+j)-yi
5593 c         zj=c(3,nres+j)-zi
5594 C Uncomment following three lines for Ca-p interactions
5595           xj=c(1,j)
5596           yj=c(2,j)
5597           zj=c(3,j)
5598           xj=mod(xj,boxxsize)
5599           if (xj.lt.0) xj=xj+boxxsize
5600           yj=mod(yj,boxysize)
5601           if (yj.lt.0) yj=yj+boxysize
5602           zj=mod(zj,boxzsize)
5603           if (zj.lt.0) zj=zj+boxzsize
5604 c  174   continue
5605 c        if (xj.gt.((0.5d0)*boxxsize)) xj=xj-boxxsize
5606 c        if (xj.lt.((-0.5d0)*boxxsize)) xj=xj+boxxsize
5607 C Condition for being inside the proper box
5608 c        if ((xj.gt.((0.5d0)*boxxsize)).or.
5609 c     &       (xj.lt.((-0.5d0)*boxxsize))) then
5610 c        go to 174
5611 c        endif
5612 c  175   continue
5613 c        if (yj.gt.((0.5d0)*boxysize)) yj=yj-boxysize
5614 c        if (yj.lt.((-0.5d0)*boxysize)) yj=yj+boxysize
5615 cC Condition for being inside the proper box
5616 c        if ((yj.gt.((0.5d0)*boxysize)).or.
5617 c     &       (yj.lt.((-0.5d0)*boxysize))) then
5618 c        go to 175
5619 c        endif
5620 c  176   continue
5621 c        if (zj.gt.((0.5d0)*boxzsize)) zj=zj-boxzsize
5622 c        if (zj.lt.((-0.5d0)*boxzsize)) zj=zj+boxzsize
5623 C Condition for being inside the proper box
5624 c        if ((zj.gt.((0.5d0)*boxzsize)).or.
5625 c     &       (zj.lt.((-0.5d0)*boxzsize))) then
5626 c        go to 176
5627 c        endif
5628 CHERE IS THE CALCULATION WHICH MIRROR IMAGE IS THE CLOSEST ONE
5629       dist_init=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5630       xj_safe=xj
5631       yj_safe=yj
5632       zj_safe=zj
5633       subchap=0
5634       do xshift=-1,1
5635       do yshift=-1,1
5636       do zshift=-1,1
5637           xj=xj_safe+xshift*boxxsize
5638           yj=yj_safe+yshift*boxysize
5639           zj=zj_safe+zshift*boxzsize
5640           dist_temp=(xj-xi)**2+(yj-yi)**2+(zj-zi)**2
5641           if(dist_temp.lt.dist_init) then
5642             dist_init=dist_temp
5643             xj_temp=xj
5644             yj_temp=yj
5645             zj_temp=zj
5646             subchap=1
5647           endif
5648        enddo
5649        enddo
5650        enddo
5651        if (subchap.eq.1) then
5652           xj=xj_temp-xi
5653           yj=yj_temp-yi
5654           zj=zj_temp-zi
5655        else
5656           xj=xj_safe-xi
5657           yj=yj_safe-yi
5658           zj=zj_safe-zi
5659        endif
5660 c          print *,xj,yj,zj,'polozenie j'
5661           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
5662 c          print *,rrij
5663           sss=sscale(1.0d0/(dsqrt(rrij)))
5664 c          print *,r_cut,1.0d0/dsqrt(rrij),sss,'tu patrz'
5665 c          if (sss.eq.0) print *,'czasem jest OK'
5666           if (sss.le.0.0d0) cycle
5667           sssgrad=sscagrad(1.0d0/(dsqrt(rrij)))
5668           fac=rrij**expon2
5669           e1=fac*fac*aad(itypj,iteli)
5670           e2=fac*bad(itypj,iteli)
5671           if (iabs(j-i) .le. 2) then
5672             e1=scal14*e1
5673             e2=scal14*e2
5674             evdw2_14=evdw2_14+(e1+e2)*sss
5675           endif
5676           evdwij=e1+e2
5677           evdw2=evdw2+evdwij*sss
5678           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
5679      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
5680      &       bad(itypj,iteli)
5681 C
5682 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
5683 C
5684           fac=-(evdwij+e1)*rrij*sss
5685           fac=fac+(evdwij)*sssgrad*dsqrt(rrij)/expon
5686           ggg(1)=xj*fac
5687           ggg(2)=yj*fac
5688           ggg(3)=zj*fac
5689 cgrad          if (j.lt.i) then
5690 cd          write (iout,*) 'j<i'
5691 C Uncomment following three lines for SC-p interactions
5692 c           do k=1,3
5693 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5694 c           enddo
5695 cgrad          else
5696 cd          write (iout,*) 'j>i'
5697 cgrad            do k=1,3
5698 cgrad              ggg(k)=-ggg(k)
5699 C Uncomment following line for SC-p interactions
5700 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
5701 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
5702 cgrad            enddo
5703 cgrad          endif
5704 cgrad          do k=1,3
5705 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
5706 cgrad          enddo
5707 cgrad          kstart=min0(i+1,j)
5708 cgrad          kend=max0(i-1,j-1)
5709 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
5710 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
5711 cgrad          do k=kstart,kend
5712 cgrad            do l=1,3
5713 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
5714 cgrad            enddo
5715 cgrad          enddo
5716           do k=1,3
5717             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
5718             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
5719           enddo
5720 c        endif !endif for sscale cutoff
5721         enddo ! j
5722
5723         enddo ! iint
5724       enddo ! i
5725 c      enddo !zshift
5726 c      enddo !yshift
5727 c      enddo !xshift
5728       do i=1,nct
5729         do j=1,3
5730           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
5731           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
5732           gradx_scp(j,i)=expon*gradx_scp(j,i)
5733         enddo
5734       enddo
5735 C******************************************************************************
5736 C
5737 C                              N O T E !!!
5738 C
5739 C To save time the factor EXPON has been extracted from ALL components
5740 C of GVDWC and GRADX. Remember to multiply them by this factor before further
5741 C use!
5742 C
5743 C******************************************************************************
5744       return
5745       end
5746 C--------------------------------------------------------------------------
5747       subroutine edis(ehpb)
5748 C
5749 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
5750 C
5751       implicit real*8 (a-h,o-z)
5752       include 'DIMENSIONS'
5753       include 'COMMON.SBRIDGE'
5754       include 'COMMON.CHAIN'
5755       include 'COMMON.DERIV'
5756       include 'COMMON.VAR'
5757       include 'COMMON.INTERACT'
5758       include 'COMMON.IOUNITS'
5759       include 'COMMON.CONTROL'
5760       dimension ggg(3),ggg_peak(3,1000)
5761       ehpb=0.0D0
5762       do i=1,3
5763        ggg(i)=0.0d0
5764       enddo
5765 c 8/21/18 AL: added explicit restraints on reference coords
5766 c      write (iout,*) "restr_on_coord",restr_on_coord
5767       if (restr_on_coord) then
5768
5769       do i=nnt,nct
5770         ecoor=0.0d0
5771         if (itype(i).eq.ntyp1) cycle
5772         do j=1,3
5773           ecoor=ecoor+(c(j,i)-cref(j,i))**2
5774           ghpbc(j,i)=ghpbc(j,i)+bfac(i)*(c(j,i)-cref(j,i))
5775         enddo
5776         if (itype(i).ne.10) then
5777           do j=1,3
5778             ecoor=ecoor+(c(j,i+nres)-cref(j,i+nres))**2
5779             ghpbx(j,i)=ghpbx(j,i)+bfac(i)*(c(j,i+nres)-cref(j,i+nres))
5780           enddo
5781         endif
5782         if (energy_dec) write (iout,*)
5783      &     "i",i," bfac",bfac(i)," ecoor",ecoor
5784         ehpb=ehpb+0.5d0*bfac(i)*ecoor
5785       enddo
5786
5787       endif
5788 C      write (iout,*) ,"link_end",link_end,constr_dist
5789 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
5790 c      write(iout,*)'link_start=',link_start,' link_end=',link_end,
5791 c     &  " constr_dist",constr_dist," link_start_peak",link_start_peak,
5792 c     &  " link_end_peak",link_end_peak
5793       if (link_end.eq.0.and.link_end_peak.eq.0) return
5794       do i=link_start_peak,link_end_peak
5795         ehpb_peak=0.0d0
5796 c        print *,"i",i," link_end_peak",link_end_peak," ipeak",
5797 c     &   ipeak(1,i),ipeak(2,i)
5798         do ip=ipeak(1,i),ipeak(2,i)
5799           ii=ihpb_peak(ip)
5800           jj=jhpb_peak(ip)
5801           dd=dist(ii,jj)
5802           iip=ip-ipeak(1,i)+1
5803 C iii and jjj point to the residues for which the distance is assigned.
5804 c          if (ii.gt.nres) then
5805 c            iii=ii-nres
5806 c            jjj=jj-nres
5807 c          else
5808 c            iii=ii
5809 c            jjj=jj
5810 c          endif
5811           if (ii.gt.nres) then
5812             iii=ii-nres
5813           else
5814             iii=ii
5815           endif
5816           if (jj.gt.nres) then
5817             jjj=jj-nres
5818           else
5819             jjj=jj
5820           endif
5821           aux=rlornmr1(dd,dhpb_peak(ip),dhpb1_peak(ip),forcon_peak(ip))
5822           aux=dexp(-scal_peak*aux)
5823           ehpb_peak=ehpb_peak+aux
5824           fac=rlornmr1prim(dd,dhpb_peak(ip),dhpb1_peak(ip),
5825      &      forcon_peak(ip))*aux/dd
5826           do j=1,3
5827             ggg_peak(j,iip)=fac*(c(j,jj)-c(j,ii))
5828           enddo
5829           if (energy_dec) write (iout,'(a6,3i5,6f10.3,i5)')
5830      &      "edisL",i,ii,jj,dd,dhpb_peak(ip),dhpb1_peak(ip),
5831      &      forcon_peak(ip),fordepth_peak(ip),ehpb_peak
5832         enddo
5833 c        write (iout,*) "ehpb_peak",ehpb_peak," scal_peak",scal_peak
5834         ehpb=ehpb-fordepth_peak(ipeak(1,i))*dlog(ehpb_peak)/scal_peak
5835         do ip=ipeak(1,i),ipeak(2,i)
5836           iip=ip-ipeak(1,i)+1
5837           do j=1,3
5838             ggg(j)=ggg_peak(j,iip)/ehpb_peak
5839           enddo
5840           ii=ihpb_peak(ip)
5841           jj=jhpb_peak(ip)
5842 C iii and jjj point to the residues for which the distance is assigned.
5843 c          if (ii.gt.nres) then
5844 c            iii=ii-nres
5845 c            jjj=jj-nres
5846 c          else
5847 c            iii=ii
5848 c            jjj=jj
5849 c          endif
5850           if (ii.gt.nres) then
5851             iii=ii-nres
5852           else
5853             iii=ii
5854           endif
5855           if (jj.gt.nres) then
5856             jjj=jj-nres
5857           else
5858             jjj=jj
5859           endif
5860           if (iii.lt.ii) then
5861             do j=1,3
5862               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5863             enddo
5864           endif
5865           if (jjj.lt.jj) then
5866             do j=1,3
5867               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5868             enddo
5869           endif
5870           do k=1,3
5871             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5872             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5873           enddo
5874         enddo
5875       enddo
5876       do i=link_start,link_end
5877 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
5878 C CA-CA distance used in regularization of structure.
5879         ii=ihpb(i)
5880         jj=jhpb(i)
5881 C iii and jjj point to the residues for which the distance is assigned.
5882         if (ii.gt.nres) then
5883           iii=ii-nres
5884         else
5885           iii=ii
5886         endif
5887         if (jj.gt.nres) then
5888           jjj=jj-nres
5889         else
5890           jjj=jj
5891         endif
5892 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
5893 c     &    dhpb(i),dhpb1(i),forcon(i)
5894 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
5895 C    distance and angle dependent SS bond potential.
5896 C        if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5897 C     & iabs(itype(jjj)).eq.1) then
5898 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
5899 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
5900         if (.not.dyn_ss .and. i.le.nss) then
5901 C 15/02/13 CC dynamic SSbond - additional check
5902           if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
5903      &        iabs(itype(jjj)).eq.1) then
5904            call ssbond_ene(iii,jjj,eij)
5905            ehpb=ehpb+2*eij
5906          endif
5907 cd          write (iout,*) "eij",eij
5908 cd   &   ' waga=',waga,' fac=',fac
5909 !        else if (ii.gt.nres .and. jj.gt.nres) then
5910         else
5911 C Calculate the distance between the two points and its difference from the
5912 C target distance.
5913           dd=dist(ii,jj)
5914           if (irestr_type(i).eq.11) then
5915             ehpb=ehpb+fordepth(i)!**4.0d0
5916      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
5917             fac=fordepth(i)!**4.0d0
5918      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
5919             if (energy_dec) write (iout,'(a6,2i5,6f10.3,i5)')
5920      &        "edisL",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5921      &        ehpb,irestr_type(i)
5922           else if (irestr_type(i).eq.10) then
5923 c AL 6//19/2018 cross-link restraints
5924             xdis = 0.5d0*(dd/forcon(i))**2
5925             expdis = dexp(-xdis)
5926 c            aux=(dhpb(i)+dhpb1(i)*xdis)*expdis+fordepth(i)
5927             aux=(dhpb(i)+dhpb1(i)*xdis*xdis)*expdis+fordepth(i)
5928 c            write (iout,*)"HERE: xdis",xdis," expdis",expdis," aux",aux,
5929 c     &          " wboltzd",wboltzd
5930             ehpb=ehpb-wboltzd*xlscore(i)*dlog(aux)
5931 c            fac=-wboltzd*(dhpb1(i)*(1.0d0-xdis)-dhpb(i))
5932             fac=-wboltzd*xlscore(i)*(dhpb1(i)*(2.0d0-xdis)*xdis-dhpb(i))
5933      &           *expdis/(aux*forcon(i)**2)
5934             if (energy_dec) write(iout,'(a6,2i5,6f10.3,i5)')
5935      &        "edisX",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),fordepth(i),
5936      &        -wboltzd*xlscore(i)*dlog(aux),irestr_type(i)
5937           else if (irestr_type(i).eq.2) then
5938 c Quartic restraints
5939             ehpb=ehpb+forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
5940             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5941      &      "edisQ",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5942      &      forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i)),irestr_type(i)
5943             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
5944           else
5945 c Quadratic restraints
5946             rdis=dd-dhpb(i)
5947 C Get the force constant corresponding to this distance.
5948             waga=forcon(i)
5949 C Calculate the contribution to energy.
5950             ehpb=ehpb+0.5d0*waga*rdis*rdis
5951             if (energy_dec) write(iout,'(a6,2i5,5f10.3,i5)')
5952      &      "edisS",ii,jj,dd,dhpb(i),dhpb1(i),forcon(i),
5953      &       0.5d0*waga*rdis*rdis,irestr_type(i)
5954 C
5955 C Evaluate gradient.
5956 C
5957             fac=waga*rdis/dd
5958           endif
5959 c Calculate Cartesian gradient
5960           do j=1,3
5961             ggg(j)=fac*(c(j,jj)-c(j,ii))
5962           enddo
5963 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
5964 C If this is a SC-SC distance, we need to calculate the contributions to the
5965 C Cartesian gradient in the SC vectors (ghpbx).
5966           if (iii.lt.ii) then
5967             do j=1,3
5968               ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
5969             enddo
5970           endif
5971           if (jjj.lt.jj) then
5972             do j=1,3
5973               ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
5974             enddo
5975           endif
5976           do k=1,3
5977             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
5978             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
5979           enddo
5980         endif
5981       enddo
5982       return
5983       end
5984 C--------------------------------------------------------------------------
5985       subroutine ssbond_ene(i,j,eij)
5986 C
5987 C Calculate the distance and angle dependent SS-bond potential energy
5988 C using a free-energy function derived based on RHF/6-31G** ab initio
5989 C calculations of diethyl disulfide.
5990 C
5991 C A. Liwo and U. Kozlowska, 11/24/03
5992 C
5993       implicit real*8 (a-h,o-z)
5994       include 'DIMENSIONS'
5995       include 'COMMON.SBRIDGE'
5996       include 'COMMON.CHAIN'
5997       include 'COMMON.DERIV'
5998       include 'COMMON.LOCAL'
5999       include 'COMMON.INTERACT'
6000       include 'COMMON.VAR'
6001       include 'COMMON.IOUNITS'
6002       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
6003       itypi=iabs(itype(i))
6004       xi=c(1,nres+i)
6005       yi=c(2,nres+i)
6006       zi=c(3,nres+i)
6007       dxi=dc_norm(1,nres+i)
6008       dyi=dc_norm(2,nres+i)
6009       dzi=dc_norm(3,nres+i)
6010 c      dsci_inv=dsc_inv(itypi)
6011       dsci_inv=vbld_inv(nres+i)
6012       itypj=iabs(itype(j))
6013 c      dscj_inv=dsc_inv(itypj)
6014       dscj_inv=vbld_inv(nres+j)
6015       xj=c(1,nres+j)-xi
6016       yj=c(2,nres+j)-yi
6017       zj=c(3,nres+j)-zi
6018       dxj=dc_norm(1,nres+j)
6019       dyj=dc_norm(2,nres+j)
6020       dzj=dc_norm(3,nres+j)
6021       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
6022       rij=dsqrt(rrij)
6023       erij(1)=xj*rij
6024       erij(2)=yj*rij
6025       erij(3)=zj*rij
6026       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
6027       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
6028       om12=dxi*dxj+dyi*dyj+dzi*dzj
6029       do k=1,3
6030         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
6031         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
6032       enddo
6033       rij=1.0d0/rij
6034       deltad=rij-d0cm
6035       deltat1=1.0d0-om1
6036       deltat2=1.0d0+om2
6037       deltat12=om2-om1+2.0d0
6038       cosphi=om12-om1*om2
6039       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
6040      &  +akct*deltad*deltat12
6041      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
6042 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
6043 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
6044 c     &  " deltat12",deltat12," eij",eij
6045       ed=2*akcm*deltad+akct*deltat12
6046       pom1=akct*deltad
6047       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
6048       eom1=-2*akth*deltat1-pom1-om2*pom2
6049       eom2= 2*akth*deltat2+pom1-om1*pom2
6050       eom12=pom2
6051       do k=1,3
6052         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
6053         ghpbx(k,i)=ghpbx(k,i)-ggk
6054      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
6055      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
6056         ghpbx(k,j)=ghpbx(k,j)+ggk
6057      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
6058      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
6059         ghpbc(k,i)=ghpbc(k,i)-ggk
6060         ghpbc(k,j)=ghpbc(k,j)+ggk
6061       enddo
6062 C
6063 C Calculate the components of the gradient in DC and X
6064 C
6065 cgrad      do k=i,j-1
6066 cgrad        do l=1,3
6067 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
6068 cgrad        enddo
6069 cgrad      enddo
6070       return
6071       end
6072 C--------------------------------------------------------------------------
6073       subroutine ebond(estr)
6074 c
6075 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
6076 c
6077       implicit real*8 (a-h,o-z)
6078       include 'DIMENSIONS'
6079       include 'COMMON.LOCAL'
6080       include 'COMMON.GEO'
6081       include 'COMMON.INTERACT'
6082       include 'COMMON.DERIV'
6083       include 'COMMON.VAR'
6084       include 'COMMON.CHAIN'
6085       include 'COMMON.IOUNITS'
6086       include 'COMMON.NAMES'
6087       include 'COMMON.FFIELD'
6088       include 'COMMON.CONTROL'
6089       include 'COMMON.SETUP'
6090       double precision u(3),ud(3)
6091       estr=0.0d0
6092       estr1=0.0d0
6093       do i=ibondp_start,ibondp_end
6094         if (itype(i-1).eq.ntyp1 .and. itype(i).eq.ntyp1) cycle
6095 c          estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
6096 c          do j=1,3
6097 c          gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
6098 c     &      *dc(j,i-1)/vbld(i)
6099 c          enddo
6100 c          if (energy_dec) write(iout,*)
6101 c     &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
6102 c        else
6103 C       Checking if it involves dummy (NH3+ or COO-) group
6104          if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
6105 C YES   vbldpDUM is the equlibrium length of spring for Dummy atom
6106         diff = vbld(i)-vbldpDUM
6107         if (energy_dec) write(iout,*) "dum_bond",i,diff
6108          else
6109 C NO    vbldp0 is the equlibrium lenght of spring for peptide group
6110         diff = vbld(i)-vbldp0
6111          endif
6112         if (energy_dec)    write (iout,'(a7,i5,4f7.3)')
6113      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
6114         estr=estr+diff*diff
6115         do j=1,3
6116           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
6117         enddo
6118 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
6119 c        endif
6120       enddo
6121
6122       estr=0.5d0*AKP*estr+estr1
6123 c
6124 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
6125 c
6126       do i=ibond_start,ibond_end
6127         iti=iabs(itype(i))
6128         if (iti.ne.10 .and. iti.ne.ntyp1) then
6129           nbi=nbondterm(iti)
6130           if (nbi.eq.1) then
6131             diff=vbld(i+nres)-vbldsc0(1,iti)
6132             if (energy_dec)  write (iout,*)
6133      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
6134      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
6135             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
6136             do j=1,3
6137               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
6138             enddo
6139           else
6140             do j=1,nbi
6141               diff=vbld(i+nres)-vbldsc0(j,iti)
6142               ud(j)=aksc(j,iti)*diff
6143               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
6144             enddo
6145             uprod=u(1)
6146             do j=2,nbi
6147               uprod=uprod*u(j)
6148             enddo
6149             usum=0.0d0
6150             usumsqder=0.0d0
6151             do j=1,nbi
6152               uprod1=1.0d0
6153               uprod2=1.0d0
6154               do k=1,nbi
6155                 if (k.ne.j) then
6156                   uprod1=uprod1*u(k)
6157                   uprod2=uprod2*u(k)*u(k)
6158                 endif
6159               enddo
6160               usum=usum+uprod1
6161               usumsqder=usumsqder+ud(j)*uprod2
6162             enddo
6163             estr=estr+uprod/usum
6164             do j=1,3
6165              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
6166             enddo
6167           endif
6168         endif
6169       enddo
6170       return
6171       end
6172 #ifdef CRYST_THETA
6173 C--------------------------------------------------------------------------
6174       subroutine ebend(etheta)
6175 C
6176 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6177 C angles gamma and its derivatives in consecutive thetas and gammas.
6178 C
6179       implicit real*8 (a-h,o-z)
6180       include 'DIMENSIONS'
6181       include 'COMMON.LOCAL'
6182       include 'COMMON.GEO'
6183       include 'COMMON.INTERACT'
6184       include 'COMMON.DERIV'
6185       include 'COMMON.VAR'
6186       include 'COMMON.CHAIN'
6187       include 'COMMON.IOUNITS'
6188       include 'COMMON.NAMES'
6189       include 'COMMON.FFIELD'
6190       include 'COMMON.CONTROL'
6191       include 'COMMON.TORCNSTR'
6192       common /calcthet/ term1,term2,termm,diffak,ratak,
6193      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6194      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6195       double precision y(2),z(2)
6196       delta=0.02d0*pi
6197 c      time11=dexp(-2*time)
6198 c      time12=1.0d0
6199       etheta=0.0D0
6200 c     write (*,'(a,i2)') 'EBEND ICG=',icg
6201       do i=ithet_start,ithet_end
6202         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6203      &  .or.itype(i).eq.ntyp1) cycle
6204 C Zero the energy function and its derivative at 0 or pi.
6205         call splinthet(theta(i),0.5d0*delta,ss,ssd)
6206         it=itype(i-1)
6207         ichir1=isign(1,itype(i-2))
6208         ichir2=isign(1,itype(i))
6209          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
6210          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
6211          if (itype(i-1).eq.10) then
6212           itype1=isign(10,itype(i-2))
6213           ichir11=isign(1,itype(i-2))
6214           ichir12=isign(1,itype(i-2))
6215           itype2=isign(10,itype(i))
6216           ichir21=isign(1,itype(i))
6217           ichir22=isign(1,itype(i))
6218          endif
6219
6220         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6221 #ifdef OSF
6222           phii=phi(i)
6223           if (phii.ne.phii) phii=150.0
6224 #else
6225           phii=phi(i)
6226 #endif
6227           y(1)=dcos(phii)
6228           y(2)=dsin(phii)
6229         else
6230           y(1)=0.0D0
6231           y(2)=0.0D0
6232         endif
6233         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6234 #ifdef OSF
6235           phii1=phi(i+1)
6236           if (phii1.ne.phii1) phii1=150.0
6237           phii1=pinorm(phii1)
6238           z(1)=cos(phii1)
6239 #else
6240           phii1=phi(i+1)
6241 #endif
6242           z(1)=dcos(phii1)
6243           z(2)=dsin(phii1)
6244         else
6245           z(1)=0.0D0
6246           z(2)=0.0D0
6247         endif
6248 C Calculate the "mean" value of theta from the part of the distribution
6249 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
6250 C In following comments this theta will be referred to as t_c.
6251         thet_pred_mean=0.0d0
6252         do k=1,2
6253             athetk=athet(k,it,ichir1,ichir2)
6254             bthetk=bthet(k,it,ichir1,ichir2)
6255           if (it.eq.10) then
6256              athetk=athet(k,itype1,ichir11,ichir12)
6257              bthetk=bthet(k,itype2,ichir21,ichir22)
6258           endif
6259          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
6260 c         write(iout,*) 'chuj tu', y(k),z(k)
6261         enddo
6262         dthett=thet_pred_mean*ssd
6263         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
6264 C Derivatives of the "mean" values in gamma1 and gamma2.
6265         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
6266      &+athet(2,it,ichir1,ichir2)*y(1))*ss
6267          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
6268      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
6269          if (it.eq.10) then
6270       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
6271      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
6272         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
6273      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
6274          endif
6275         if (theta(i).gt.pi-delta) then
6276           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
6277      &         E_tc0)
6278           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
6279           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6280           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
6281      &        E_theta)
6282           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
6283      &        E_tc)
6284         else if (theta(i).lt.delta) then
6285           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
6286           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
6287           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
6288      &        E_theta)
6289           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
6290           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
6291      &        E_tc)
6292         else
6293           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
6294      &        E_theta,E_tc)
6295         endif
6296         etheta=etheta+ethetai
6297         if (energy_dec) write (iout,'(a6,i5,0pf7.3,f7.3,i5)')
6298      &      'ebend',i,ethetai,theta(i),itype(i)
6299         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
6300         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
6301         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)+gloc(nphi+i-2,icg)
6302       enddo
6303
6304 C Ufff.... We've done all this!!!
6305       return
6306       end
6307 C---------------------------------------------------------------------------
6308       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
6309      &     E_tc)
6310       implicit real*8 (a-h,o-z)
6311       include 'DIMENSIONS'
6312       include 'COMMON.LOCAL'
6313       include 'COMMON.IOUNITS'
6314       common /calcthet/ term1,term2,termm,diffak,ratak,
6315      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6316      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6317 C Calculate the contributions to both Gaussian lobes.
6318 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
6319 C The "polynomial part" of the "standard deviation" of this part of
6320 C the distributioni.
6321 ccc        write (iout,*) thetai,thet_pred_mean
6322         sig=polthet(3,it)
6323         do j=2,0,-1
6324           sig=sig*thet_pred_mean+polthet(j,it)
6325         enddo
6326 C Derivative of the "interior part" of the "standard deviation of the"
6327 C gamma-dependent Gaussian lobe in t_c.
6328         sigtc=3*polthet(3,it)
6329         do j=2,1,-1
6330           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
6331         enddo
6332         sigtc=sig*sigtc
6333 C Set the parameters of both Gaussian lobes of the distribution.
6334 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
6335         fac=sig*sig+sigc0(it)
6336         sigcsq=fac+fac
6337         sigc=1.0D0/sigcsq
6338 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
6339         sigsqtc=-4.0D0*sigcsq*sigtc
6340 c       print *,i,sig,sigtc,sigsqtc
6341 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
6342         sigtc=-sigtc/(fac*fac)
6343 C Following variable is sigma(t_c)**(-2)
6344         sigcsq=sigcsq*sigcsq
6345         sig0i=sig0(it)
6346         sig0inv=1.0D0/sig0i**2
6347         delthec=thetai-thet_pred_mean
6348         delthe0=thetai-theta0i
6349         term1=-0.5D0*sigcsq*delthec*delthec
6350         term2=-0.5D0*sig0inv*delthe0*delthe0
6351 C        write (iout,*)'term1',term1,term2,sigcsq,delthec,sig0inv,delthe0
6352 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
6353 C NaNs in taking the logarithm. We extract the largest exponent which is added
6354 C to the energy (this being the log of the distribution) at the end of energy
6355 C term evaluation for this virtual-bond angle.
6356         if (term1.gt.term2) then
6357           termm=term1
6358           term2=dexp(term2-termm)
6359           term1=1.0d0
6360         else
6361           termm=term2
6362           term1=dexp(term1-termm)
6363           term2=1.0d0
6364         endif
6365 C The ratio between the gamma-independent and gamma-dependent lobes of
6366 C the distribution is a Gaussian function of thet_pred_mean too.
6367         diffak=gthet(2,it)-thet_pred_mean
6368         ratak=diffak/gthet(3,it)**2
6369         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
6370 C Let's differentiate it in thet_pred_mean NOW.
6371         aktc=ak*ratak
6372 C Now put together the distribution terms to make complete distribution.
6373         termexp=term1+ak*term2
6374         termpre=sigc+ak*sig0i
6375 C Contribution of the bending energy from this theta is just the -log of
6376 C the sum of the contributions from the two lobes and the pre-exponential
6377 C factor. Simple enough, isn't it?
6378         ethetai=(-dlog(termexp)-termm+dlog(termpre))
6379 C       write (iout,*) 'termexp',termexp,termm,termpre,i
6380 C NOW the derivatives!!!
6381 C 6/6/97 Take into account the deformation.
6382         E_theta=(delthec*sigcsq*term1
6383      &       +ak*delthe0*sig0inv*term2)/termexp
6384         E_tc=((sigtc+aktc*sig0i)/termpre
6385      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
6386      &       aktc*term2)/termexp)
6387       return
6388       end
6389 c-----------------------------------------------------------------------------
6390       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
6391       implicit real*8 (a-h,o-z)
6392       include 'DIMENSIONS'
6393       include 'COMMON.LOCAL'
6394       include 'COMMON.IOUNITS'
6395       common /calcthet/ term1,term2,termm,diffak,ratak,
6396      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
6397      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
6398       delthec=thetai-thet_pred_mean
6399       delthe0=thetai-theta0i
6400 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
6401       t3 = thetai-thet_pred_mean
6402       t6 = t3**2
6403       t9 = term1
6404       t12 = t3*sigcsq
6405       t14 = t12+t6*sigsqtc
6406       t16 = 1.0d0
6407       t21 = thetai-theta0i
6408       t23 = t21**2
6409       t26 = term2
6410       t27 = t21*t26
6411       t32 = termexp
6412       t40 = t32**2
6413       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
6414      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
6415      & *(-t12*t9-ak*sig0inv*t27)
6416       return
6417       end
6418 #else
6419 C--------------------------------------------------------------------------
6420       subroutine ebend(etheta)
6421 C
6422 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
6423 C angles gamma and its derivatives in consecutive thetas and gammas.
6424 C ab initio-derived potentials from
6425 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
6426 C
6427       implicit real*8 (a-h,o-z)
6428       include 'DIMENSIONS'
6429       include 'COMMON.LOCAL'
6430       include 'COMMON.GEO'
6431       include 'COMMON.INTERACT'
6432       include 'COMMON.DERIV'
6433       include 'COMMON.VAR'
6434       include 'COMMON.CHAIN'
6435       include 'COMMON.IOUNITS'
6436       include 'COMMON.NAMES'
6437       include 'COMMON.FFIELD'
6438       include 'COMMON.CONTROL'
6439       include 'COMMON.TORCNSTR'
6440       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
6441      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
6442      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
6443      & sinph1ph2(maxdouble,maxdouble)
6444       logical lprn /.false./, lprn1 /.false./
6445       etheta=0.0D0
6446       do i=ithet_start,ithet_end
6447 c        print *,i,itype(i-1),itype(i),itype(i-2)
6448         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
6449      &  .or.itype(i).eq.ntyp1) cycle
6450 C        print *,i,theta(i)
6451         if (iabs(itype(i+1)).eq.20) iblock=2
6452         if (iabs(itype(i+1)).ne.20) iblock=1
6453         dethetai=0.0d0
6454         dephii=0.0d0
6455         dephii1=0.0d0
6456         theti2=0.5d0*theta(i)
6457         ityp2=ithetyp((itype(i-1)))
6458         do k=1,nntheterm
6459           coskt(k)=dcos(k*theti2)
6460           sinkt(k)=dsin(k*theti2)
6461         enddo
6462 C        print *,ethetai
6463         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
6464 #ifdef OSF
6465           phii=phi(i)
6466           if (phii.ne.phii) phii=150.0
6467 #else
6468           phii=phi(i)
6469 #endif
6470           ityp1=ithetyp((itype(i-2)))
6471 C propagation of chirality for glycine type
6472           do k=1,nsingle
6473             cosph1(k)=dcos(k*phii)
6474             sinph1(k)=dsin(k*phii)
6475           enddo
6476         else
6477           phii=0.0d0
6478           do k=1,nsingle
6479           ityp1=ithetyp((itype(i-2)))
6480             cosph1(k)=0.0d0
6481             sinph1(k)=0.0d0
6482           enddo
6483         endif
6484         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
6485 #ifdef OSF
6486           phii1=phi(i+1)
6487           if (phii1.ne.phii1) phii1=150.0
6488           phii1=pinorm(phii1)
6489 #else
6490           phii1=phi(i+1)
6491 #endif
6492           ityp3=ithetyp((itype(i)))
6493           do k=1,nsingle
6494             cosph2(k)=dcos(k*phii1)
6495             sinph2(k)=dsin(k*phii1)
6496           enddo
6497         else
6498           phii1=0.0d0
6499           ityp3=ithetyp((itype(i)))
6500           do k=1,nsingle
6501             cosph2(k)=0.0d0
6502             sinph2(k)=0.0d0
6503           enddo
6504         endif
6505         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
6506         do k=1,ndouble
6507           do l=1,k-1
6508             ccl=cosph1(l)*cosph2(k-l)
6509             ssl=sinph1(l)*sinph2(k-l)
6510             scl=sinph1(l)*cosph2(k-l)
6511             csl=cosph1(l)*sinph2(k-l)
6512             cosph1ph2(l,k)=ccl-ssl
6513             cosph1ph2(k,l)=ccl+ssl
6514             sinph1ph2(l,k)=scl+csl
6515             sinph1ph2(k,l)=scl-csl
6516           enddo
6517         enddo
6518         if (lprn) then
6519         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
6520      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
6521         write (iout,*) "coskt and sinkt"
6522         do k=1,nntheterm
6523           write (iout,*) k,coskt(k),sinkt(k)
6524         enddo
6525         endif
6526         do k=1,ntheterm
6527           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
6528           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
6529      &      *coskt(k)
6530           if (lprn)
6531      &    write (iout,*) "k",k,"
6532      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
6533      &     " ethetai",ethetai
6534         enddo
6535         if (lprn) then
6536         write (iout,*) "cosph and sinph"
6537         do k=1,nsingle
6538           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6539         enddo
6540         write (iout,*) "cosph1ph2 and sinph2ph2"
6541         do k=2,ndouble
6542           do l=1,k-1
6543             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
6544      &         sinph1ph2(l,k),sinph1ph2(k,l)
6545           enddo
6546         enddo
6547         write(iout,*) "ethetai",ethetai
6548         endif
6549 C       print *,ethetai
6550         do m=1,ntheterm2
6551           do k=1,nsingle
6552             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
6553      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
6554      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
6555      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
6556             ethetai=ethetai+sinkt(m)*aux
6557             dethetai=dethetai+0.5d0*m*aux*coskt(m)
6558             dephii=dephii+k*sinkt(m)*(
6559      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
6560      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
6561             dephii1=dephii1+k*sinkt(m)*(
6562      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
6563      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
6564             if (lprn)
6565      &      write (iout,*) "m",m," k",k," bbthet",
6566      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
6567      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
6568      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
6569      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
6570 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6571           enddo
6572         enddo
6573 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
6574 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
6575 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
6576 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
6577         if (lprn)
6578      &  write(iout,*) "ethetai",ethetai
6579 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
6580         do m=1,ntheterm3
6581           do k=2,ndouble
6582             do l=1,k-1
6583               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6584      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
6585      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6586      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
6587               ethetai=ethetai+sinkt(m)*aux
6588               dethetai=dethetai+0.5d0*m*coskt(m)*aux
6589               dephii=dephii+l*sinkt(m)*(
6590      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
6591      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6592      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
6593      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6594               dephii1=dephii1+(k-l)*sinkt(m)*(
6595      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
6596      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
6597      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
6598      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
6599               if (lprn) then
6600               write (iout,*) "m",m," k",k," l",l," ffthet",
6601      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6602      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
6603      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
6604      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
6605      &            " ethetai",ethetai
6606               write (iout,*) cosph1ph2(l,k)*sinkt(m),
6607      &            cosph1ph2(k,l)*sinkt(m),
6608      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
6609               endif
6610             enddo
6611           enddo
6612         enddo
6613 10      continue
6614 c        lprn1=.true.
6615 C        print *,ethetai
6616         if (lprn1)
6617      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
6618      &   i,theta(i)*rad2deg,phii*rad2deg,
6619      &   phii1*rad2deg,ethetai
6620 c        lprn1=.false.
6621         etheta=etheta+ethetai
6622         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
6623         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
6624         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
6625       enddo
6626
6627       return
6628       end
6629 #endif
6630 #ifdef CRYST_SC
6631 c-----------------------------------------------------------------------------
6632       subroutine esc(escloc)
6633 C Calculate the local energy of a side chain and its derivatives in the
6634 C corresponding virtual-bond valence angles THETA and the spherical angles
6635 C ALPHA and OMEGA.
6636       implicit real*8 (a-h,o-z)
6637       include 'DIMENSIONS'
6638       include 'COMMON.GEO'
6639       include 'COMMON.LOCAL'
6640       include 'COMMON.VAR'
6641       include 'COMMON.INTERACT'
6642       include 'COMMON.DERIV'
6643       include 'COMMON.CHAIN'
6644       include 'COMMON.IOUNITS'
6645       include 'COMMON.NAMES'
6646       include 'COMMON.FFIELD'
6647       include 'COMMON.CONTROL'
6648       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
6649      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
6650       common /sccalc/ time11,time12,time112,theti,it,nlobit
6651       delta=0.02d0*pi
6652       escloc=0.0D0
6653 c     write (iout,'(a)') 'ESC'
6654       do i=loc_start,loc_end
6655         it=itype(i)
6656         if (it.eq.ntyp1) cycle
6657         if (it.eq.10) goto 1
6658         nlobit=nlob(iabs(it))
6659 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
6660 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
6661         theti=theta(i+1)-pipol
6662         x(1)=dtan(theti)
6663         x(2)=alph(i)
6664         x(3)=omeg(i)
6665
6666         if (x(2).gt.pi-delta) then
6667           xtemp(1)=x(1)
6668           xtemp(2)=pi-delta
6669           xtemp(3)=x(3)
6670           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6671           xtemp(2)=pi
6672           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6673           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
6674      &        escloci,dersc(2))
6675           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6676      &        ddersc0(1),dersc(1))
6677           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
6678      &        ddersc0(3),dersc(3))
6679           xtemp(2)=pi-delta
6680           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6681           xtemp(2)=pi
6682           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6683           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
6684      &            dersc0(2),esclocbi,dersc02)
6685           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
6686      &            dersc12,dersc01)
6687           call splinthet(x(2),0.5d0*delta,ss,ssd)
6688           dersc0(1)=dersc01
6689           dersc0(2)=dersc02
6690           dersc0(3)=0.0d0
6691           do k=1,3
6692             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6693           enddo
6694           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6695 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6696 c    &             esclocbi,ss,ssd
6697           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6698 c         escloci=esclocbi
6699 c         write (iout,*) escloci
6700         else if (x(2).lt.delta) then
6701           xtemp(1)=x(1)
6702           xtemp(2)=delta
6703           xtemp(3)=x(3)
6704           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
6705           xtemp(2)=0.0d0
6706           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
6707           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
6708      &        escloci,dersc(2))
6709           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6710      &        ddersc0(1),dersc(1))
6711           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
6712      &        ddersc0(3),dersc(3))
6713           xtemp(2)=delta
6714           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
6715           xtemp(2)=0.0d0
6716           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
6717           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
6718      &            dersc0(2),esclocbi,dersc02)
6719           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
6720      &            dersc12,dersc01)
6721           dersc0(1)=dersc01
6722           dersc0(2)=dersc02
6723           dersc0(3)=0.0d0
6724           call splinthet(x(2),0.5d0*delta,ss,ssd)
6725           do k=1,3
6726             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
6727           enddo
6728           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
6729 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
6730 c    &             esclocbi,ss,ssd
6731           escloci=ss*escloci+(1.0d0-ss)*esclocbi
6732 c         write (iout,*) escloci
6733         else
6734           call enesc(x,escloci,dersc,ddummy,.false.)
6735         endif
6736
6737         escloc=escloc+escloci
6738         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
6739      &     'escloc',i,escloci
6740 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
6741
6742         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
6743      &   wscloc*dersc(1)
6744         gloc(ialph(i,1),icg)=wscloc*dersc(2)
6745         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
6746     1   continue
6747       enddo
6748       return
6749       end
6750 C---------------------------------------------------------------------------
6751       subroutine enesc(x,escloci,dersc,ddersc,mixed)
6752       implicit real*8 (a-h,o-z)
6753       include 'DIMENSIONS'
6754       include 'COMMON.GEO'
6755       include 'COMMON.LOCAL'
6756       include 'COMMON.IOUNITS'
6757       common /sccalc/ time11,time12,time112,theti,it,nlobit
6758       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
6759       double precision contr(maxlob,-1:1)
6760       logical mixed
6761 c       write (iout,*) 'it=',it,' nlobit=',nlobit
6762         escloc_i=0.0D0
6763         do j=1,3
6764           dersc(j)=0.0D0
6765           if (mixed) ddersc(j)=0.0d0
6766         enddo
6767         x3=x(3)
6768
6769 C Because of periodicity of the dependence of the SC energy in omega we have
6770 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
6771 C To avoid underflows, first compute & store the exponents.
6772
6773         do iii=-1,1
6774
6775           x(3)=x3+iii*dwapi
6776
6777           do j=1,nlobit
6778             do k=1,3
6779               z(k)=x(k)-censc(k,j,it)
6780             enddo
6781             do k=1,3
6782               Axk=0.0D0
6783               do l=1,3
6784                 Axk=Axk+gaussc(l,k,j,it)*z(l)
6785               enddo
6786               Ax(k,j,iii)=Axk
6787             enddo
6788             expfac=0.0D0
6789             do k=1,3
6790               expfac=expfac+Ax(k,j,iii)*z(k)
6791             enddo
6792             contr(j,iii)=expfac
6793           enddo ! j
6794
6795         enddo ! iii
6796
6797         x(3)=x3
6798 C As in the case of ebend, we want to avoid underflows in exponentiation and
6799 C subsequent NaNs and INFs in energy calculation.
6800 C Find the largest exponent
6801         emin=contr(1,-1)
6802         do iii=-1,1
6803           do j=1,nlobit
6804             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
6805           enddo
6806         enddo
6807         emin=0.5D0*emin
6808 cd      print *,'it=',it,' emin=',emin
6809
6810 C Compute the contribution to SC energy and derivatives
6811         do iii=-1,1
6812
6813           do j=1,nlobit
6814 #ifdef OSF
6815             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
6816             if(adexp.ne.adexp) adexp=1.0
6817             expfac=dexp(adexp)
6818 #else
6819             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
6820 #endif
6821 cd          print *,'j=',j,' expfac=',expfac
6822             escloc_i=escloc_i+expfac
6823             do k=1,3
6824               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
6825             enddo
6826             if (mixed) then
6827               do k=1,3,2
6828                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
6829      &            +gaussc(k,2,j,it))*expfac
6830               enddo
6831             endif
6832           enddo
6833
6834         enddo ! iii
6835
6836         dersc(1)=dersc(1)/cos(theti)**2
6837         ddersc(1)=ddersc(1)/cos(theti)**2
6838         ddersc(3)=ddersc(3)
6839
6840         escloci=-(dlog(escloc_i)-emin)
6841         do j=1,3
6842           dersc(j)=dersc(j)/escloc_i
6843         enddo
6844         if (mixed) then
6845           do j=1,3,2
6846             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
6847           enddo
6848         endif
6849       return
6850       end
6851 C------------------------------------------------------------------------------
6852       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
6853       implicit real*8 (a-h,o-z)
6854       include 'DIMENSIONS'
6855       include 'COMMON.GEO'
6856       include 'COMMON.LOCAL'
6857       include 'COMMON.IOUNITS'
6858       common /sccalc/ time11,time12,time112,theti,it,nlobit
6859       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
6860       double precision contr(maxlob)
6861       logical mixed
6862
6863       escloc_i=0.0D0
6864
6865       do j=1,3
6866         dersc(j)=0.0D0
6867       enddo
6868
6869       do j=1,nlobit
6870         do k=1,2
6871           z(k)=x(k)-censc(k,j,it)
6872         enddo
6873         z(3)=dwapi
6874         do k=1,3
6875           Axk=0.0D0
6876           do l=1,3
6877             Axk=Axk+gaussc(l,k,j,it)*z(l)
6878           enddo
6879           Ax(k,j)=Axk
6880         enddo
6881         expfac=0.0D0
6882         do k=1,3
6883           expfac=expfac+Ax(k,j)*z(k)
6884         enddo
6885         contr(j)=expfac
6886       enddo ! j
6887
6888 C As in the case of ebend, we want to avoid underflows in exponentiation and
6889 C subsequent NaNs and INFs in energy calculation.
6890 C Find the largest exponent
6891       emin=contr(1)
6892       do j=1,nlobit
6893         if (emin.gt.contr(j)) emin=contr(j)
6894       enddo
6895       emin=0.5D0*emin
6896
6897 C Compute the contribution to SC energy and derivatives
6898
6899       dersc12=0.0d0
6900       do j=1,nlobit
6901         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
6902         escloc_i=escloc_i+expfac
6903         do k=1,2
6904           dersc(k)=dersc(k)+Ax(k,j)*expfac
6905         enddo
6906         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
6907      &            +gaussc(1,2,j,it))*expfac
6908         dersc(3)=0.0d0
6909       enddo
6910
6911       dersc(1)=dersc(1)/cos(theti)**2
6912       dersc12=dersc12/cos(theti)**2
6913       escloci=-(dlog(escloc_i)-emin)
6914       do j=1,2
6915         dersc(j)=dersc(j)/escloc_i
6916       enddo
6917       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
6918       return
6919       end
6920 #else
6921 c----------------------------------------------------------------------------------
6922       subroutine esc(escloc)
6923 C Calculate the local energy of a side chain and its derivatives in the
6924 C corresponding virtual-bond valence angles THETA and the spherical angles
6925 C ALPHA and OMEGA derived from AM1 all-atom calculations.
6926 C added by Urszula Kozlowska. 07/11/2007
6927 C
6928       implicit real*8 (a-h,o-z)
6929       include 'DIMENSIONS'
6930       include 'COMMON.GEO'
6931       include 'COMMON.LOCAL'
6932       include 'COMMON.VAR'
6933       include 'COMMON.SCROT'
6934       include 'COMMON.INTERACT'
6935       include 'COMMON.DERIV'
6936       include 'COMMON.CHAIN'
6937       include 'COMMON.IOUNITS'
6938       include 'COMMON.NAMES'
6939       include 'COMMON.FFIELD'
6940       include 'COMMON.CONTROL'
6941       include 'COMMON.VECTORS'
6942       double precision x_prime(3),y_prime(3),z_prime(3)
6943      &    , sumene,dsc_i,dp2_i,x(65),
6944      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
6945      &    de_dxx,de_dyy,de_dzz,de_dt
6946       double precision s1_t,s1_6_t,s2_t,s2_6_t
6947       double precision
6948      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
6949      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
6950      & dt_dCi(3),dt_dCi1(3)
6951       common /sccalc/ time11,time12,time112,theti,it,nlobit
6952       delta=0.02d0*pi
6953       escloc=0.0D0
6954       do i=loc_start,loc_end
6955         if (itype(i).eq.ntyp1) cycle
6956         costtab(i+1) =dcos(theta(i+1))
6957         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
6958         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
6959         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
6960         cosfac2=0.5d0/(1.0d0+costtab(i+1))
6961         cosfac=dsqrt(cosfac2)
6962         sinfac2=0.5d0/(1.0d0-costtab(i+1))
6963         sinfac=dsqrt(sinfac2)
6964         it=iabs(itype(i))
6965         if (it.eq.10) goto 1
6966 c
6967 C  Compute the axes of tghe local cartesian coordinates system; store in
6968 c   x_prime, y_prime and z_prime
6969 c
6970         do j=1,3
6971           x_prime(j) = 0.00
6972           y_prime(j) = 0.00
6973           z_prime(j) = 0.00
6974         enddo
6975 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
6976 C     &   dc_norm(3,i+nres)
6977         do j = 1,3
6978           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
6979           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
6980         enddo
6981         do j = 1,3
6982           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
6983         enddo
6984 c       write (2,*) "i",i
6985 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
6986 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
6987 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
6988 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
6989 c      & " xy",scalar(x_prime(1),y_prime(1)),
6990 c      & " xz",scalar(x_prime(1),z_prime(1)),
6991 c      & " yy",scalar(y_prime(1),y_prime(1)),
6992 c      & " yz",scalar(y_prime(1),z_prime(1)),
6993 c      & " zz",scalar(z_prime(1),z_prime(1))
6994 c
6995 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
6996 C to local coordinate system. Store in xx, yy, zz.
6997 c
6998         xx=0.0d0
6999         yy=0.0d0
7000         zz=0.0d0
7001         do j = 1,3
7002           xx = xx + x_prime(j)*dc_norm(j,i+nres)
7003           yy = yy + y_prime(j)*dc_norm(j,i+nres)
7004           zz = zz + z_prime(j)*dc_norm(j,i+nres)
7005         enddo
7006
7007         xxtab(i)=xx
7008         yytab(i)=yy
7009         zztab(i)=zz
7010 C
7011 C Compute the energy of the ith side cbain
7012 C
7013 c        write (2,*) "xx",xx," yy",yy," zz",zz
7014         it=iabs(itype(i))
7015         do j = 1,65
7016           x(j) = sc_parmin(j,it)
7017         enddo
7018 #ifdef CHECK_COORD
7019 Cc diagnostics - remove later
7020         xx1 = dcos(alph(2))
7021         yy1 = dsin(alph(2))*dcos(omeg(2))
7022         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
7023         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
7024      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
7025      &    xx1,yy1,zz1
7026 C,"  --- ", xx_w,yy_w,zz_w
7027 c end diagnostics
7028 #endif
7029         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7030      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7031      &   + x(10)*yy*zz
7032         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7033      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7034      & + x(20)*yy*zz
7035         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7036      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7037      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7038      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7039      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7040      &  +x(40)*xx*yy*zz
7041         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7042      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7043      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7044      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7045      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7046      &  +x(60)*xx*yy*zz
7047         dsc_i   = 0.743d0+x(61)
7048         dp2_i   = 1.9d0+x(62)
7049         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7050      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
7051         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7052      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
7053         s1=(1+x(63))/(0.1d0 + dscp1)
7054         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7055         s2=(1+x(65))/(0.1d0 + dscp2)
7056         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7057         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
7058      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
7059 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
7060 c     &   sumene4,
7061 c     &   dscp1,dscp2,sumene
7062 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7063         escloc = escloc + sumene
7064 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
7065 c     & ,zz,xx,yy
7066 c#define DEBUG
7067 #ifdef DEBUG
7068 C
7069 C This section to check the numerical derivatives of the energy of ith side
7070 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
7071 C #define DEBUG in the code to turn it on.
7072 C
7073         write (2,*) "sumene               =",sumene
7074         aincr=1.0d-7
7075         xxsave=xx
7076         xx=xx+aincr
7077         write (2,*) xx,yy,zz
7078         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7079         de_dxx_num=(sumenep-sumene)/aincr
7080         xx=xxsave
7081         write (2,*) "xx+ sumene from enesc=",sumenep
7082         yysave=yy
7083         yy=yy+aincr
7084         write (2,*) xx,yy,zz
7085         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7086         de_dyy_num=(sumenep-sumene)/aincr
7087         yy=yysave
7088         write (2,*) "yy+ sumene from enesc=",sumenep
7089         zzsave=zz
7090         zz=zz+aincr
7091         write (2,*) xx,yy,zz
7092         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7093         de_dzz_num=(sumenep-sumene)/aincr
7094         zz=zzsave
7095         write (2,*) "zz+ sumene from enesc=",sumenep
7096         costsave=cost2tab(i+1)
7097         sintsave=sint2tab(i+1)
7098         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
7099         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
7100         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
7101         de_dt_num=(sumenep-sumene)/aincr
7102         write (2,*) " t+ sumene from enesc=",sumenep
7103         cost2tab(i+1)=costsave
7104         sint2tab(i+1)=sintsave
7105 C End of diagnostics section.
7106 #endif
7107 C
7108 C Compute the gradient of esc
7109 C
7110 c        zz=zz*dsign(1.0,dfloat(itype(i)))
7111         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
7112         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
7113         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
7114         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
7115         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
7116         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
7117         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
7118         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
7119         pom1=(sumene3*sint2tab(i+1)+sumene1)
7120      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
7121         pom2=(sumene4*cost2tab(i+1)+sumene2)
7122      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
7123         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
7124         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
7125      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
7126      &  +x(40)*yy*zz
7127         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
7128         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
7129      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
7130      &  +x(60)*yy*zz
7131         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
7132      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
7133      &        +(pom1+pom2)*pom_dx
7134 #ifdef DEBUG
7135         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
7136 #endif
7137 C
7138         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
7139         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
7140      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
7141      &  +x(40)*xx*zz
7142         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
7143         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
7144      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
7145      &  +x(59)*zz**2 +x(60)*xx*zz
7146         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
7147      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
7148      &        +(pom1-pom2)*pom_dy
7149 #ifdef DEBUG
7150         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
7151 #endif
7152 C
7153         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
7154      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
7155      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
7156      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
7157      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
7158      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
7159      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
7160      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
7161 #ifdef DEBUG
7162         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
7163 #endif
7164 C
7165         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
7166      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
7167      &  +pom1*pom_dt1+pom2*pom_dt2
7168 #ifdef DEBUG
7169         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
7170 #endif
7171 c#undef DEBUG
7172 c
7173 C
7174        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
7175        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
7176        cosfac2xx=cosfac2*xx
7177        sinfac2yy=sinfac2*yy
7178        do k = 1,3
7179          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
7180      &      vbld_inv(i+1)
7181          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
7182      &      vbld_inv(i)
7183          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
7184          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
7185 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
7186 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
7187 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
7188 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
7189          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
7190          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
7191          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
7192          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
7193          dZZ_Ci1(k)=0.0d0
7194          dZZ_Ci(k)=0.0d0
7195          do j=1,3
7196            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
7197      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7198            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
7199      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
7200          enddo
7201
7202          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
7203          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
7204          dZZ_XYZ(k)=vbld_inv(i+nres)*
7205      &   (z_prime(k)-zz*dC_norm(k,i+nres))
7206 c
7207          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
7208          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
7209        enddo
7210
7211        do k=1,3
7212          dXX_Ctab(k,i)=dXX_Ci(k)
7213          dXX_C1tab(k,i)=dXX_Ci1(k)
7214          dYY_Ctab(k,i)=dYY_Ci(k)
7215          dYY_C1tab(k,i)=dYY_Ci1(k)
7216          dZZ_Ctab(k,i)=dZZ_Ci(k)
7217          dZZ_C1tab(k,i)=dZZ_Ci1(k)
7218          dXX_XYZtab(k,i)=dXX_XYZ(k)
7219          dYY_XYZtab(k,i)=dYY_XYZ(k)
7220          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
7221        enddo
7222
7223        do k = 1,3
7224 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
7225 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
7226 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
7227 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
7228 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
7229 c     &    dt_dci(k)
7230 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
7231 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
7232          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
7233      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
7234          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
7235      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
7236          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
7237      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
7238        enddo
7239 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
7240 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
7241
7242 C to check gradient call subroutine check_grad
7243
7244     1 continue
7245       enddo
7246       return
7247       end
7248 c------------------------------------------------------------------------------
7249       double precision function enesc(x,xx,yy,zz,cost2,sint2)
7250       implicit none
7251       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
7252      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
7253       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
7254      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
7255      &   + x(10)*yy*zz
7256       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
7257      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
7258      & + x(20)*yy*zz
7259       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
7260      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
7261      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
7262      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
7263      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
7264      &  +x(40)*xx*yy*zz
7265       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
7266      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
7267      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
7268      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
7269      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
7270      &  +x(60)*xx*yy*zz
7271       dsc_i   = 0.743d0+x(61)
7272       dp2_i   = 1.9d0+x(62)
7273       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7274      &          *(xx*cost2+yy*sint2))
7275       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
7276      &          *(xx*cost2-yy*sint2))
7277       s1=(1+x(63))/(0.1d0 + dscp1)
7278       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
7279       s2=(1+x(65))/(0.1d0 + dscp2)
7280       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
7281       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
7282      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
7283       enesc=sumene
7284       return
7285       end
7286 #endif
7287 c------------------------------------------------------------------------------
7288       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
7289 C
7290 C This procedure calculates two-body contact function g(rij) and its derivative:
7291 C
7292 C           eps0ij                                     !       x < -1
7293 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
7294 C            0                                         !       x > 1
7295 C
7296 C where x=(rij-r0ij)/delta
7297 C
7298 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
7299 C
7300       implicit none
7301       double precision rij,r0ij,eps0ij,fcont,fprimcont
7302       double precision x,x2,x4,delta
7303 c     delta=0.02D0*r0ij
7304 c      delta=0.2D0*r0ij
7305       x=(rij-r0ij)/delta
7306       if (x.lt.-1.0D0) then
7307         fcont=eps0ij
7308         fprimcont=0.0D0
7309       else if (x.le.1.0D0) then
7310         x2=x*x
7311         x4=x2*x2
7312         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
7313         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
7314       else
7315         fcont=0.0D0
7316         fprimcont=0.0D0
7317       endif
7318       return
7319       end
7320 c------------------------------------------------------------------------------
7321       subroutine splinthet(theti,delta,ss,ssder)
7322       implicit real*8 (a-h,o-z)
7323       include 'DIMENSIONS'
7324       include 'COMMON.VAR'
7325       include 'COMMON.GEO'
7326       thetup=pi-delta
7327       thetlow=delta
7328       if (theti.gt.pipol) then
7329         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
7330       else
7331         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
7332         ssder=-ssder
7333       endif
7334       return
7335       end
7336 c------------------------------------------------------------------------------
7337       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
7338       implicit none
7339       double precision x,x0,delta,f0,f1,fprim0,f,fprim
7340       double precision ksi,ksi2,ksi3,a1,a2,a3
7341       a1=fprim0*delta/(f1-f0)
7342       a2=3.0d0-2.0d0*a1
7343       a3=a1-2.0d0
7344       ksi=(x-x0)/delta
7345       ksi2=ksi*ksi
7346       ksi3=ksi2*ksi
7347       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
7348       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
7349       return
7350       end
7351 c------------------------------------------------------------------------------
7352       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
7353       implicit none
7354       double precision x,x0,delta,f0x,f1x,fprim0x,fx
7355       double precision ksi,ksi2,ksi3,a1,a2,a3
7356       ksi=(x-x0)/delta
7357       ksi2=ksi*ksi
7358       ksi3=ksi2*ksi
7359       a1=fprim0x*delta
7360       a2=3*(f1x-f0x)-2*fprim0x*delta
7361       a3=fprim0x*delta-2*(f1x-f0x)
7362       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
7363       return
7364       end
7365 C-----------------------------------------------------------------------------
7366 #ifdef CRYST_TOR
7367 C-----------------------------------------------------------------------------
7368       subroutine etor(etors)
7369       implicit real*8 (a-h,o-z)
7370       include 'DIMENSIONS'
7371       include 'COMMON.VAR'
7372       include 'COMMON.GEO'
7373       include 'COMMON.LOCAL'
7374       include 'COMMON.TORSION'
7375       include 'COMMON.INTERACT'
7376       include 'COMMON.DERIV'
7377       include 'COMMON.CHAIN'
7378       include 'COMMON.NAMES'
7379       include 'COMMON.IOUNITS'
7380       include 'COMMON.FFIELD'
7381       include 'COMMON.TORCNSTR'
7382       include 'COMMON.CONTROL'
7383       logical lprn
7384 C Set lprn=.true. for debugging
7385       lprn=.false.
7386 c      lprn=.true.
7387       etors=0.0D0
7388       do i=iphi_start,iphi_end
7389       etors_ii=0.0D0
7390         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7391      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7392         itori=itortyp(itype(i-2))
7393         itori1=itortyp(itype(i-1))
7394         phii=phi(i)
7395         gloci=0.0D0
7396 C Proline-Proline pair is a special case...
7397         if (itori.eq.3 .and. itori1.eq.3) then
7398           if (phii.gt.-dwapi3) then
7399             cosphi=dcos(3*phii)
7400             fac=1.0D0/(1.0D0-cosphi)
7401             etorsi=v1(1,3,3)*fac
7402             etorsi=etorsi+etorsi
7403             etors=etors+etorsi-v1(1,3,3)
7404             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
7405             gloci=gloci-3*fac*etorsi*dsin(3*phii)
7406           endif
7407           do j=1,3
7408             v1ij=v1(j+1,itori,itori1)
7409             v2ij=v2(j+1,itori,itori1)
7410             cosphi=dcos(j*phii)
7411             sinphi=dsin(j*phii)
7412             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7413             if (energy_dec) etors_ii=etors_ii+
7414      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7415             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7416           enddo
7417         else
7418           do j=1,nterm_old
7419             v1ij=v1(j,itori,itori1)
7420             v2ij=v2(j,itori,itori1)
7421             cosphi=dcos(j*phii)
7422             sinphi=dsin(j*phii)
7423             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7424             if (energy_dec) etors_ii=etors_ii+
7425      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
7426             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7427           enddo
7428         endif
7429         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7430              'etor',i,etors_ii
7431         if (lprn)
7432      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7433      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7434      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
7435         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7436 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7437       enddo
7438       return
7439       end
7440 c------------------------------------------------------------------------------
7441       subroutine etor_d(etors_d)
7442       etors_d=0.0d0
7443       return
7444       end
7445 c----------------------------------------------------------------------------
7446 #else
7447       subroutine etor(etors)
7448       implicit real*8 (a-h,o-z)
7449       include 'DIMENSIONS'
7450       include 'COMMON.VAR'
7451       include 'COMMON.GEO'
7452       include 'COMMON.LOCAL'
7453       include 'COMMON.TORSION'
7454       include 'COMMON.INTERACT'
7455       include 'COMMON.DERIV'
7456       include 'COMMON.CHAIN'
7457       include 'COMMON.NAMES'
7458       include 'COMMON.IOUNITS'
7459       include 'COMMON.FFIELD'
7460       include 'COMMON.TORCNSTR'
7461       include 'COMMON.CONTROL'
7462       logical lprn
7463 C Set lprn=.true. for debugging
7464       lprn=.false.
7465 c     lprn=.true.
7466       etors=0.0D0
7467       do i=iphi_start,iphi_end
7468 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7469 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7470 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7471 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7472         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7473      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7474 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7475 C For introducing the NH3+ and COO- group please check the etor_d for reference
7476 C and guidance
7477         etors_ii=0.0D0
7478          if (iabs(itype(i)).eq.20) then
7479          iblock=2
7480          else
7481          iblock=1
7482          endif
7483         itori=itortyp(itype(i-2))
7484         itori1=itortyp(itype(i-1))
7485         phii=phi(i)
7486         gloci=0.0D0
7487 C Regular cosine and sine terms
7488         do j=1,nterm(itori,itori1,iblock)
7489           v1ij=v1(j,itori,itori1,iblock)
7490           v2ij=v2(j,itori,itori1,iblock)
7491           cosphi=dcos(j*phii)
7492           sinphi=dsin(j*phii)
7493           etors=etors+v1ij*cosphi+v2ij*sinphi
7494           if (energy_dec) etors_ii=etors_ii+
7495      &                v1ij*cosphi+v2ij*sinphi
7496           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7497         enddo
7498 C Lorentz terms
7499 C                         v1
7500 C  E = SUM ----------------------------------- - v1
7501 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
7502 C
7503         cosphi=dcos(0.5d0*phii)
7504         sinphi=dsin(0.5d0*phii)
7505         do j=1,nlor(itori,itori1,iblock)
7506           vl1ij=vlor1(j,itori,itori1)
7507           vl2ij=vlor2(j,itori,itori1)
7508           vl3ij=vlor3(j,itori,itori1)
7509           pom=vl2ij*cosphi+vl3ij*sinphi
7510           pom1=1.0d0/(pom*pom+1.0d0)
7511           etors=etors+vl1ij*pom1
7512           if (energy_dec) etors_ii=etors_ii+
7513      &                vl1ij*pom1
7514           pom=-pom*pom1*pom1
7515           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
7516         enddo
7517 C Subtract the constant term
7518         etors=etors-v0(itori,itori1,iblock)
7519           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
7520      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
7521         if (lprn)
7522      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7523      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
7524      &  (v1(j,itori,itori1,iblock),j=1,6),
7525      &  (v2(j,itori,itori1,iblock),j=1,6)
7526         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
7527 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
7528       enddo
7529       return
7530       end
7531 c----------------------------------------------------------------------------
7532       subroutine etor_d(etors_d)
7533 C 6/23/01 Compute double torsional energy
7534       implicit real*8 (a-h,o-z)
7535       include 'DIMENSIONS'
7536       include 'COMMON.VAR'
7537       include 'COMMON.GEO'
7538       include 'COMMON.LOCAL'
7539       include 'COMMON.TORSION'
7540       include 'COMMON.INTERACT'
7541       include 'COMMON.DERIV'
7542       include 'COMMON.CHAIN'
7543       include 'COMMON.NAMES'
7544       include 'COMMON.IOUNITS'
7545       include 'COMMON.FFIELD'
7546       include 'COMMON.TORCNSTR'
7547       logical lprn
7548 C Set lprn=.true. for debugging
7549       lprn=.false.
7550 c     lprn=.true.
7551       etors_d=0.0D0
7552 c      write(iout,*) "a tu??"
7553       do i=iphid_start,iphid_end
7554 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7555 C        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7556 C     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1)).or.
7557 C     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))  .or.
7558 C     &      ((itype(i).eq.ntyp1).and.(itype(i+1).eq.ntyp1))) cycle
7559          if ((itype(i-2).eq.ntyp1).or.itype(i-3).eq.ntyp1.or.
7560      &  (itype(i-1).eq.ntyp1).or.(itype(i).eq.ntyp1).or.
7561      &  (itype(i+1).eq.ntyp1)) cycle
7562 C In current verion the ALL DUMMY ATOM POTENTIALS ARE OFF
7563         itori=itortyp(itype(i-2))
7564         itori1=itortyp(itype(i-1))
7565         itori2=itortyp(itype(i))
7566         phii=phi(i)
7567         phii1=phi(i+1)
7568         gloci1=0.0D0
7569         gloci2=0.0D0
7570         iblock=1
7571         if (iabs(itype(i+1)).eq.20) iblock=2
7572 C Iblock=2 Proline type
7573 C ADASKO: WHEN PARAMETERS FOR THIS TYPE OF BLOCKING GROUP IS READY UNCOMMENT
7574 C CHECK WEATHER THERE IS NECCESITY FOR iblock=3 for COO-
7575 C        if (itype(i+1).eq.ntyp1) iblock=3
7576 C The problem of NH3+ group can be resolved by adding new parameters please note if there
7577 C IS or IS NOT need for this
7578 C IF Yes uncomment below and add to parmread.F appropriate changes and to v1cij and so on
7579 C        is (itype(i-3).eq.ntyp1) ntblock=2
7580 C        ntblock is N-terminal blocking group
7581
7582 C Regular cosine and sine terms
7583         do j=1,ntermd_1(itori,itori1,itori2,iblock)
7584 C Example of changes for NH3+ blocking group
7585 C       do j=1,ntermd_1(itori,itori1,itori2,iblock,ntblock)
7586 C          v1cij=v1c(1,j,itori,itori1,itori2,iblock,ntblock)
7587           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
7588           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
7589           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
7590           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
7591           cosphi1=dcos(j*phii)
7592           sinphi1=dsin(j*phii)
7593           cosphi2=dcos(j*phii1)
7594           sinphi2=dsin(j*phii1)
7595           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
7596      &     v2cij*cosphi2+v2sij*sinphi2
7597           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
7598           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
7599         enddo
7600         do k=2,ntermd_2(itori,itori1,itori2,iblock)
7601           do l=1,k-1
7602             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
7603             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
7604             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
7605             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
7606             cosphi1p2=dcos(l*phii+(k-l)*phii1)
7607             cosphi1m2=dcos(l*phii-(k-l)*phii1)
7608             sinphi1p2=dsin(l*phii+(k-l)*phii1)
7609             sinphi1m2=dsin(l*phii-(k-l)*phii1)
7610             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
7611      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
7612             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
7613      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
7614             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
7615      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
7616           enddo
7617         enddo
7618         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
7619         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
7620       enddo
7621       return
7622       end
7623 #endif
7624 C----------------------------------------------------------------------------------
7625 C The rigorous attempt to derive energy function
7626       subroutine etor_kcc(etors)
7627       implicit real*8 (a-h,o-z)
7628       include 'DIMENSIONS'
7629       include 'COMMON.VAR'
7630       include 'COMMON.GEO'
7631       include 'COMMON.LOCAL'
7632       include 'COMMON.TORSION'
7633       include 'COMMON.INTERACT'
7634       include 'COMMON.DERIV'
7635       include 'COMMON.CHAIN'
7636       include 'COMMON.NAMES'
7637       include 'COMMON.IOUNITS'
7638       include 'COMMON.FFIELD'
7639       include 'COMMON.TORCNSTR'
7640       include 'COMMON.CONTROL'
7641       double precision c1(0:maxval_kcc),c2(0:maxval_kcc)
7642       logical lprn
7643 c      double precision thybt1(maxtermkcc),thybt2(maxtermkcc)
7644 C Set lprn=.true. for debugging
7645       lprn=energy_dec
7646 c     lprn=.true.
7647 C      print *,"wchodze kcc"
7648       if (lprn) write (iout,*) "etor_kcc tor_mode",tor_mode
7649       etors=0.0D0
7650       do i=iphi_start,iphi_end
7651 C ANY TWO ARE DUMMY ATOMS in row CYCLE
7652 c        if (((itype(i-3).eq.ntyp1).and.(itype(i-2).eq.ntyp1)).or.
7653 c     &      ((itype(i-2).eq.ntyp1).and.(itype(i-1).eq.ntyp1))  .or.
7654 c     &      ((itype(i-1).eq.ntyp1).and.(itype(i).eq.ntyp1))) cycle
7655         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
7656      &      .or. itype(i).eq.ntyp1 .or. itype(i-3).eq.ntyp1) cycle
7657         itori=itortyp(itype(i-2))
7658         itori1=itortyp(itype(i-1))
7659         phii=phi(i)
7660         glocig=0.0D0
7661         glocit1=0.0d0
7662         glocit2=0.0d0
7663 C to avoid multiple devision by 2
7664 c        theti22=0.5d0*theta(i)
7665 C theta 12 is the theta_1 /2
7666 C theta 22 is theta_2 /2
7667 c        theti12=0.5d0*theta(i-1)
7668 C and appropriate sinus function
7669         sinthet1=dsin(theta(i-1))
7670         sinthet2=dsin(theta(i))
7671         costhet1=dcos(theta(i-1))
7672         costhet2=dcos(theta(i))
7673 C to speed up lets store its mutliplication
7674         sint1t2=sinthet2*sinthet1
7675         sint1t2n=1.0d0
7676 C \sum_{i=1}^n (sin(theta_1) * sin(theta_2))^n * (c_n* cos(n*gamma)
7677 C +d_n*sin(n*gamma)) *
7678 C \sum_{i=1}^m (1+a_m*Tb_m(cos(theta_1 /2))+b_m*Tb_m(cos(theta_2 /2)))
7679 C we have two sum 1) Non-Chebyshev which is with n and gamma
7680         nval=nterm_kcc_Tb(itori,itori1)
7681         c1(0)=0.0d0
7682         c2(0)=0.0d0
7683         c1(1)=1.0d0
7684         c2(1)=1.0d0
7685         do j=2,nval
7686           c1(j)=c1(j-1)*costhet1
7687           c2(j)=c2(j-1)*costhet2
7688         enddo
7689         etori=0.0d0
7690         do j=1,nterm_kcc(itori,itori1)
7691           cosphi=dcos(j*phii)
7692           sinphi=dsin(j*phii)
7693           sint1t2n1=sint1t2n
7694           sint1t2n=sint1t2n*sint1t2
7695           sumvalc=0.0d0
7696           gradvalct1=0.0d0
7697           gradvalct2=0.0d0
7698           do k=1,nval
7699             do l=1,nval
7700               sumvalc=sumvalc+v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7701               gradvalct1=gradvalct1+
7702      &           (k-1)*v1_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7703               gradvalct2=gradvalct2+
7704      &           (l-1)*v1_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7705             enddo
7706           enddo
7707           gradvalct1=-gradvalct1*sinthet1
7708           gradvalct2=-gradvalct2*sinthet2
7709           sumvals=0.0d0
7710           gradvalst1=0.0d0
7711           gradvalst2=0.0d0
7712           do k=1,nval
7713             do l=1,nval
7714               sumvals=sumvals+v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l)
7715               gradvalst1=gradvalst1+
7716      &           (k-1)*v2_kcc(l,k,j,itori1,itori)*c1(k-1)*c2(l)
7717               gradvalst2=gradvalst2+
7718      &           (l-1)*v2_kcc(l,k,j,itori1,itori)*c1(k)*c2(l-1)
7719             enddo
7720           enddo
7721           gradvalst1=-gradvalst1*sinthet1
7722           gradvalst2=-gradvalst2*sinthet2
7723           if (lprn) write (iout,*)j,"sumvalc",sumvalc," sumvals",sumvals
7724           etori=etori+sint1t2n*(sumvalc*cosphi+sumvals*sinphi)
7725 C glocig is the gradient local i site in gamma
7726           glocig=glocig+j*sint1t2n*(sumvals*cosphi-sumvalc*sinphi)
7727 C now gradient over theta_1
7728           glocit1=glocit1+sint1t2n*(gradvalct1*cosphi+gradvalst1*sinphi)
7729      &   +j*sint1t2n1*costhet1*sinthet2*(sumvalc*cosphi+sumvals*sinphi)
7730           glocit2=glocit2+sint1t2n*(gradvalct2*cosphi+gradvalst2*sinphi)
7731      &   +j*sint1t2n1*sinthet1*costhet2*(sumvalc*cosphi+sumvals*sinphi)
7732         enddo ! j
7733         etors=etors+etori
7734 C derivative over gamma
7735         gloc(i-3,icg)=gloc(i-3,icg)+wtor*glocig
7736 C derivative over theta1
7737         gloc(nphi+i-3,icg)=gloc(nphi+i-3,icg)+wtor*glocit1
7738 C now derivative over theta2
7739         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wtor*glocit2
7740         if (lprn) then
7741           write (iout,*) i-2,i-1,itype(i-2),itype(i-1),itori,itori1,
7742      &       theta(i-1)*rad2deg,theta(i)*rad2deg,phii*rad2deg,etori
7743           write (iout,*) "c1",(c1(k),k=0,nval),
7744      &    " c2",(c2(k),k=0,nval)
7745         endif
7746       enddo
7747       return
7748       end
7749 c---------------------------------------------------------------------------------------------
7750       subroutine etor_constr(edihcnstr)
7751       implicit real*8 (a-h,o-z)
7752       include 'DIMENSIONS'
7753       include 'COMMON.VAR'
7754       include 'COMMON.GEO'
7755       include 'COMMON.LOCAL'
7756       include 'COMMON.TORSION'
7757       include 'COMMON.INTERACT'
7758       include 'COMMON.DERIV'
7759       include 'COMMON.CHAIN'
7760       include 'COMMON.NAMES'
7761       include 'COMMON.IOUNITS'
7762       include 'COMMON.FFIELD'
7763       include 'COMMON.TORCNSTR'
7764       include 'COMMON.BOUNDS'
7765       include 'COMMON.CONTROL'
7766 ! 6/20/98 - dihedral angle constraints
7767       edihcnstr=0.0d0
7768 c      do i=1,ndih_constr
7769       if (raw_psipred) then
7770         do i=idihconstr_start,idihconstr_end
7771           itori=idih_constr(i)
7772           phii=phi(itori)
7773           gaudih_i=vpsipred(1,i)
7774           gauder_i=0.0d0
7775           do j=1,2
7776             s = sdihed(j,i)
7777             cos_i=(1.0d0-dcos(phii-phibound(j,i)))/s**2
7778             dexpcos_i=dexp(-cos_i*cos_i)
7779             gaudih_i=gaudih_i+vpsipred(j+1,i)*dexpcos_i
7780             gauder_i=gauder_i-2*vpsipred(j+1,i)*dsin(phii-phibound(j,i))
7781      &            *cos_i*dexpcos_i/s**2
7782           enddo
7783           edihcnstr=edihcnstr-wdihc*dlog(gaudih_i)
7784           gloc(itori-3,icg)=gloc(itori-3,icg)-wdihc*gauder_i/gaudih_i
7785           if (energy_dec)
7786      &     write (iout,'(2i5,f8.3,f8.5,2(f8.5,2f8.3),f10.5)')
7787      &     i,itori,phii*rad2deg,vpsipred(1,i),vpsipred(2,i),
7788      &     phibound(1,i)*rad2deg,sdihed(1,i)*rad2deg,vpsipred(3,i),
7789      &     phibound(2,i)*rad2deg,sdihed(2,i)*rad2deg,
7790      &     -wdihc*dlog(gaudih_i)
7791         enddo
7792       else
7793
7794       do i=idihconstr_start,idihconstr_end
7795         itori=idih_constr(i)
7796         phii=phi(itori)
7797         difi=pinorm(phii-phi0(i))
7798         if (difi.gt.drange(i)) then
7799           difi=difi-drange(i)
7800           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7801           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7802         else if (difi.lt.-drange(i)) then
7803           difi=difi+drange(i)
7804           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
7805           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
7806         else
7807           difi=0.0
7808         endif
7809       enddo
7810
7811       endif
7812
7813       return
7814       end
7815 c----------------------------------------------------------------------------
7816 C The rigorous attempt to derive energy function
7817       subroutine ebend_kcc(etheta)
7818
7819       implicit real*8 (a-h,o-z)
7820       include 'DIMENSIONS'
7821       include 'COMMON.VAR'
7822       include 'COMMON.GEO'
7823       include 'COMMON.LOCAL'
7824       include 'COMMON.TORSION'
7825       include 'COMMON.INTERACT'
7826       include 'COMMON.DERIV'
7827       include 'COMMON.CHAIN'
7828       include 'COMMON.NAMES'
7829       include 'COMMON.IOUNITS'
7830       include 'COMMON.FFIELD'
7831       include 'COMMON.TORCNSTR'
7832       include 'COMMON.CONTROL'
7833       logical lprn
7834       double precision thybt1(maxang_kcc)
7835 C Set lprn=.true. for debugging
7836       lprn=energy_dec
7837 c     lprn=.true.
7838 C      print *,"wchodze kcc"
7839       if (lprn) write (iout,*) "ebend_kcc tor_mode",tor_mode
7840       etheta=0.0D0
7841       do i=ithet_start,ithet_end
7842 c        print *,i,itype(i-1),itype(i),itype(i-2)
7843         if ((itype(i-1).eq.ntyp1).or.itype(i-2).eq.ntyp1
7844      &  .or.itype(i).eq.ntyp1) cycle
7845         iti=iabs(itortyp(itype(i-1)))
7846         sinthet=dsin(theta(i))
7847         costhet=dcos(theta(i))
7848         do j=1,nbend_kcc_Tb(iti)
7849           thybt1(j)=v1bend_chyb(j,iti)
7850         enddo
7851         sumth1thyb=v1bend_chyb(0,iti)+
7852      &    tschebyshev(1,nbend_kcc_Tb(iti),thybt1(1),costhet)
7853         if (lprn) write (iout,*) i-1,itype(i-1),iti,theta(i)*rad2deg,
7854      &    sumth1thyb
7855         ihelp=nbend_kcc_Tb(iti)-1
7856         gradthybt1=gradtschebyshev(0,ihelp,thybt1(1),costhet)
7857         etheta=etheta+sumth1thyb
7858 C        print *,sumth1thyb,gradthybt1,sinthet*(-0.5d0)
7859         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)-wang*gradthybt1*sinthet
7860       enddo
7861       return
7862       end
7863 c-------------------------------------------------------------------------------------
7864       subroutine etheta_constr(ethetacnstr)
7865
7866       implicit real*8 (a-h,o-z)
7867       include 'DIMENSIONS'
7868       include 'COMMON.VAR'
7869       include 'COMMON.GEO'
7870       include 'COMMON.LOCAL'
7871       include 'COMMON.TORSION'
7872       include 'COMMON.INTERACT'
7873       include 'COMMON.DERIV'
7874       include 'COMMON.CHAIN'
7875       include 'COMMON.NAMES'
7876       include 'COMMON.IOUNITS'
7877       include 'COMMON.FFIELD'
7878       include 'COMMON.TORCNSTR'
7879       include 'COMMON.CONTROL'
7880       ethetacnstr=0.0d0
7881 C      print *,ithetaconstr_start,ithetaconstr_end,"TU"
7882       do i=ithetaconstr_start,ithetaconstr_end
7883         itheta=itheta_constr(i)
7884         thetiii=theta(itheta)
7885         difi=pinorm(thetiii-theta_constr0(i))
7886         if (difi.gt.theta_drange(i)) then
7887           difi=difi-theta_drange(i)
7888           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7889           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7890      &    +for_thet_constr(i)*difi**3
7891         else if (difi.lt.-drange(i)) then
7892           difi=difi+drange(i)
7893           ethetacnstr=ethetacnstr+0.25d0*for_thet_constr(i)*difi**4
7894           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
7895      &    +for_thet_constr(i)*difi**3
7896         else
7897           difi=0.0
7898         endif
7899        if (energy_dec) then
7900         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
7901      &    i,itheta,rad2deg*thetiii,
7902      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
7903      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
7904      &    gloc(itheta+nphi-2,icg)
7905         endif
7906       enddo
7907       return
7908       end
7909 c------------------------------------------------------------------------------
7910       subroutine eback_sc_corr(esccor)
7911 c 7/21/2007 Correlations between the backbone-local and side-chain-local
7912 c        conformational states; temporarily implemented as differences
7913 c        between UNRES torsional potentials (dependent on three types of
7914 c        residues) and the torsional potentials dependent on all 20 types
7915 c        of residues computed from AM1  energy surfaces of terminally-blocked
7916 c        amino-acid residues.
7917       implicit real*8 (a-h,o-z)
7918       include 'DIMENSIONS'
7919       include 'COMMON.VAR'
7920       include 'COMMON.GEO'
7921       include 'COMMON.LOCAL'
7922       include 'COMMON.TORSION'
7923       include 'COMMON.SCCOR'
7924       include 'COMMON.INTERACT'
7925       include 'COMMON.DERIV'
7926       include 'COMMON.CHAIN'
7927       include 'COMMON.NAMES'
7928       include 'COMMON.IOUNITS'
7929       include 'COMMON.FFIELD'
7930       include 'COMMON.CONTROL'
7931       logical lprn
7932 C Set lprn=.true. for debugging
7933       lprn=.false.
7934 c      lprn=.true.
7935 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
7936       esccor=0.0D0
7937       do i=itau_start,itau_end
7938         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
7939         esccor_ii=0.0D0
7940         isccori=isccortyp(itype(i-2))
7941         isccori1=isccortyp(itype(i-1))
7942 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
7943         phii=phi(i)
7944         do intertyp=1,3 !intertyp
7945 cc Added 09 May 2012 (Adasko)
7946 cc  Intertyp means interaction type of backbone mainchain correlation:
7947 c   1 = SC...Ca...Ca...Ca
7948 c   2 = Ca...Ca...Ca...SC
7949 c   3 = SC...Ca...Ca...SCi
7950         gloci=0.0D0
7951         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
7952      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
7953      &      (itype(i-1).eq.ntyp1)))
7954      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
7955      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
7956      &     .or.(itype(i).eq.ntyp1)))
7957      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
7958      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
7959      &      (itype(i-3).eq.ntyp1)))) cycle
7960         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
7961         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
7962      & cycle
7963        do j=1,nterm_sccor(isccori,isccori1)
7964           v1ij=v1sccor(j,intertyp,isccori,isccori1)
7965           v2ij=v2sccor(j,intertyp,isccori,isccori1)
7966           cosphi=dcos(j*tauangle(intertyp,i))
7967           sinphi=dsin(j*tauangle(intertyp,i))
7968           esccor=esccor+v1ij*cosphi+v2ij*sinphi
7969           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
7970         enddo
7971 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
7972         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
7973         if (lprn)
7974      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
7975      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
7976      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
7977      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
7978         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
7979        enddo !intertyp
7980       enddo
7981
7982       return
7983       end
7984 c----------------------------------------------------------------------------
7985       subroutine multibody(ecorr)
7986 C This subroutine calculates multi-body contributions to energy following
7987 C the idea of Skolnick et al. If side chains I and J make a contact and
7988 C at the same time side chains I+1 and J+1 make a contact, an extra
7989 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
7990       implicit real*8 (a-h,o-z)
7991       include 'DIMENSIONS'
7992       include 'COMMON.IOUNITS'
7993       include 'COMMON.DERIV'
7994       include 'COMMON.INTERACT'
7995       include 'COMMON.CONTACTS'
7996       double precision gx(3),gx1(3)
7997       logical lprn
7998
7999 C Set lprn=.true. for debugging
8000       lprn=.false.
8001
8002       if (lprn) then
8003         write (iout,'(a)') 'Contact function values:'
8004         do i=nnt,nct-2
8005           write (iout,'(i2,20(1x,i2,f10.5))')
8006      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
8007         enddo
8008       endif
8009       ecorr=0.0D0
8010       do i=nnt,nct
8011         do j=1,3
8012           gradcorr(j,i)=0.0D0
8013           gradxorr(j,i)=0.0D0
8014         enddo
8015       enddo
8016       do i=nnt,nct-2
8017
8018         DO ISHIFT = 3,4
8019
8020         i1=i+ishift
8021         num_conti=num_cont(i)
8022         num_conti1=num_cont(i1)
8023         do jj=1,num_conti
8024           j=jcont(jj,i)
8025           do kk=1,num_conti1
8026             j1=jcont(kk,i1)
8027             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
8028 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8029 cd   &                   ' ishift=',ishift
8030 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
8031 C The system gains extra energy.
8032               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
8033             endif   ! j1==j+-ishift
8034           enddo     ! kk
8035         enddo       ! jj
8036
8037         ENDDO ! ISHIFT
8038
8039       enddo         ! i
8040       return
8041       end
8042 c------------------------------------------------------------------------------
8043       double precision function esccorr(i,j,k,l,jj,kk)
8044       implicit real*8 (a-h,o-z)
8045       include 'DIMENSIONS'
8046       include 'COMMON.IOUNITS'
8047       include 'COMMON.DERIV'
8048       include 'COMMON.INTERACT'
8049       include 'COMMON.CONTACTS'
8050       include 'COMMON.SHIELD'
8051       double precision gx(3),gx1(3)
8052       logical lprn
8053       lprn=.false.
8054       eij=facont(jj,i)
8055       ekl=facont(kk,k)
8056 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
8057 C Calculate the multi-body contribution to energy.
8058 C Calculate multi-body contributions to the gradient.
8059 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
8060 cd   & k,l,(gacont(m,kk,k),m=1,3)
8061       do m=1,3
8062         gx(m) =ekl*gacont(m,jj,i)
8063         gx1(m)=eij*gacont(m,kk,k)
8064         gradxorr(m,i)=gradxorr(m,i)-gx(m)
8065         gradxorr(m,j)=gradxorr(m,j)+gx(m)
8066         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
8067         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
8068       enddo
8069       do m=i,j-1
8070         do ll=1,3
8071           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
8072         enddo
8073       enddo
8074       do m=k,l-1
8075         do ll=1,3
8076           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
8077         enddo
8078       enddo
8079       esccorr=-eij*ekl
8080       return
8081       end
8082 c------------------------------------------------------------------------------
8083       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
8084 C This subroutine calculates multi-body contributions to hydrogen-bonding
8085       implicit real*8 (a-h,o-z)
8086       include 'DIMENSIONS'
8087       include 'COMMON.IOUNITS'
8088 #ifdef MPI
8089       include "mpif.h"
8090       parameter (max_cont=maxconts)
8091       parameter (max_dim=26)
8092       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8093       double precision zapas(max_dim,maxconts,max_fg_procs),
8094      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8095       common /przechowalnia/ zapas
8096       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8097      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8098 #endif
8099       include 'COMMON.SETUP'
8100       include 'COMMON.FFIELD'
8101       include 'COMMON.DERIV'
8102       include 'COMMON.INTERACT'
8103       include 'COMMON.CONTACTS'
8104       include 'COMMON.CONTROL'
8105       include 'COMMON.LOCAL'
8106       double precision gx(3),gx1(3),time00
8107       logical lprn,ldone
8108
8109 C Set lprn=.true. for debugging
8110       lprn=.false.
8111 #ifdef MPI
8112       n_corr=0
8113       n_corr1=0
8114       if (nfgtasks.le.1) goto 30
8115       if (lprn) then
8116         write (iout,'(a)') 'Contact function values before RECEIVE:'
8117         do i=nnt,nct-2
8118           write (iout,'(2i3,50(1x,i2,f5.2))')
8119      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8120      &    j=1,num_cont_hb(i))
8121         enddo
8122         call flush(iout)
8123       endif
8124       do i=1,ntask_cont_from
8125         ncont_recv(i)=0
8126       enddo
8127       do i=1,ntask_cont_to
8128         ncont_sent(i)=0
8129       enddo
8130 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8131 c     & ntask_cont_to
8132 C Make the list of contacts to send to send to other procesors
8133 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
8134 c      call flush(iout)
8135       do i=iturn3_start,iturn3_end
8136 c        write (iout,*) "make contact list turn3",i," num_cont",
8137 c     &    num_cont_hb(i)
8138         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
8139       enddo
8140       do i=iturn4_start,iturn4_end
8141 c        write (iout,*) "make contact list turn4",i," num_cont",
8142 c     &   num_cont_hb(i)
8143         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
8144       enddo
8145       do ii=1,nat_sent
8146         i=iat_sent(ii)
8147 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8148 c     &    num_cont_hb(i)
8149         do j=1,num_cont_hb(i)
8150         do k=1,4
8151           jjc=jcont_hb(j,i)
8152           iproc=iint_sent_local(k,jjc,ii)
8153 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8154           if (iproc.gt.0) then
8155             ncont_sent(iproc)=ncont_sent(iproc)+1
8156             nn=ncont_sent(iproc)
8157             zapas(1,nn,iproc)=i
8158             zapas(2,nn,iproc)=jjc
8159             zapas(3,nn,iproc)=facont_hb(j,i)
8160             zapas(4,nn,iproc)=ees0p(j,i)
8161             zapas(5,nn,iproc)=ees0m(j,i)
8162             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
8163             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
8164             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
8165             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
8166             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
8167             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
8168             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
8169             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
8170             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
8171             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
8172             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
8173             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
8174             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
8175             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
8176             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
8177             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
8178             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
8179             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
8180             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
8181             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
8182             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
8183           endif
8184         enddo
8185         enddo
8186       enddo
8187       if (lprn) then
8188       write (iout,*)
8189      &  "Numbers of contacts to be sent to other processors",
8190      &  (ncont_sent(i),i=1,ntask_cont_to)
8191       write (iout,*) "Contacts sent"
8192       do ii=1,ntask_cont_to
8193         nn=ncont_sent(ii)
8194         iproc=itask_cont_to(ii)
8195         write (iout,*) nn," contacts to processor",iproc,
8196      &   " of CONT_TO_COMM group"
8197         do i=1,nn
8198           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8199         enddo
8200       enddo
8201       call flush(iout)
8202       endif
8203       CorrelType=477
8204       CorrelID=fg_rank+1
8205       CorrelType1=478
8206       CorrelID1=nfgtasks+fg_rank+1
8207       ireq=0
8208 C Receive the numbers of needed contacts from other processors
8209       do ii=1,ntask_cont_from
8210         iproc=itask_cont_from(ii)
8211         ireq=ireq+1
8212         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8213      &    FG_COMM,req(ireq),IERR)
8214       enddo
8215 c      write (iout,*) "IRECV ended"
8216 c      call flush(iout)
8217 C Send the number of contacts needed by other processors
8218       do ii=1,ntask_cont_to
8219         iproc=itask_cont_to(ii)
8220         ireq=ireq+1
8221         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8222      &    FG_COMM,req(ireq),IERR)
8223       enddo
8224 c      write (iout,*) "ISEND ended"
8225 c      write (iout,*) "number of requests (nn)",ireq
8226 c      call flush(iout)
8227       if (ireq.gt.0)
8228      &  call MPI_Waitall(ireq,req,status_array,ierr)
8229 c      write (iout,*)
8230 c     &  "Numbers of contacts to be received from other processors",
8231 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8232 c      call flush(iout)
8233 C Receive contacts
8234       ireq=0
8235       do ii=1,ntask_cont_from
8236         iproc=itask_cont_from(ii)
8237         nn=ncont_recv(ii)
8238 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8239 c     &   " of CONT_TO_COMM group"
8240 c        call flush(iout)
8241         if (nn.gt.0) then
8242           ireq=ireq+1
8243           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8244      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8245 c          write (iout,*) "ireq,req",ireq,req(ireq)
8246         endif
8247       enddo
8248 C Send the contacts to processors that need them
8249       do ii=1,ntask_cont_to
8250         iproc=itask_cont_to(ii)
8251         nn=ncont_sent(ii)
8252 c        write (iout,*) nn," contacts to processor",iproc,
8253 c     &   " of CONT_TO_COMM group"
8254         if (nn.gt.0) then
8255           ireq=ireq+1
8256           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8257      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8258 c          write (iout,*) "ireq,req",ireq,req(ireq)
8259 c          do i=1,nn
8260 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8261 c          enddo
8262         endif
8263       enddo
8264 c      write (iout,*) "number of requests (contacts)",ireq
8265 c      write (iout,*) "req",(req(i),i=1,4)
8266 c      call flush(iout)
8267       if (ireq.gt.0)
8268      & call MPI_Waitall(ireq,req,status_array,ierr)
8269       do iii=1,ntask_cont_from
8270         iproc=itask_cont_from(iii)
8271         nn=ncont_recv(iii)
8272         if (lprn) then
8273         write (iout,*) "Received",nn," contacts from processor",iproc,
8274      &   " of CONT_FROM_COMM group"
8275         call flush(iout)
8276         do i=1,nn
8277           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
8278         enddo
8279         call flush(iout)
8280         endif
8281         do i=1,nn
8282           ii=zapas_recv(1,i,iii)
8283 c Flag the received contacts to prevent double-counting
8284           jj=-zapas_recv(2,i,iii)
8285 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8286 c          call flush(iout)
8287           nnn=num_cont_hb(ii)+1
8288           num_cont_hb(ii)=nnn
8289           jcont_hb(nnn,ii)=jj
8290           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
8291           ees0p(nnn,ii)=zapas_recv(4,i,iii)
8292           ees0m(nnn,ii)=zapas_recv(5,i,iii)
8293           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
8294           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
8295           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
8296           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
8297           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
8298           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
8299           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
8300           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
8301           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
8302           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
8303           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
8304           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
8305           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
8306           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
8307           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
8308           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
8309           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
8310           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
8311           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
8312           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
8313           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
8314         enddo
8315       enddo
8316       if (lprn) then
8317         write (iout,'(a)') 'Contact function values after receive:'
8318         do i=nnt,nct-2
8319           write (iout,'(2i3,50(1x,i3,f5.2))')
8320      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8321      &    j=1,num_cont_hb(i))
8322         enddo
8323         call flush(iout)
8324       endif
8325    30 continue
8326 #endif
8327       if (lprn) then
8328         write (iout,'(a)') 'Contact function values:'
8329         do i=nnt,nct-2
8330           write (iout,'(2i3,50(1x,i3,f5.2))')
8331      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8332      &    j=1,num_cont_hb(i))
8333         enddo
8334         call flush(iout)
8335       endif
8336       ecorr=0.0D0
8337 C Remove the loop below after debugging !!!
8338       do i=nnt,nct
8339         do j=1,3
8340           gradcorr(j,i)=0.0D0
8341           gradxorr(j,i)=0.0D0
8342         enddo
8343       enddo
8344 C Calculate the local-electrostatic correlation terms
8345       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
8346         i1=i+1
8347         num_conti=num_cont_hb(i)
8348         num_conti1=num_cont_hb(i+1)
8349         do jj=1,num_conti
8350           j=jcont_hb(jj,i)
8351           jp=iabs(j)
8352           do kk=1,num_conti1
8353             j1=jcont_hb(kk,i1)
8354             jp1=iabs(j1)
8355 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8356 c     &         ' jj=',jj,' kk=',kk
8357 c            call flush(iout)
8358             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8359      &          .or. j.lt.0 .and. j1.gt.0) .and.
8360      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8361 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8362 C The system gains extra energy.
8363               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
8364               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
8365      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
8366               n_corr=n_corr+1
8367             else if (j1.eq.j) then
8368 C Contacts I-J and I-(J+1) occur simultaneously.
8369 C The system loses extra energy.
8370 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
8371             endif
8372           enddo ! kk
8373           do kk=1,num_conti
8374             j1=jcont_hb(kk,i)
8375 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8376 c    &         ' jj=',jj,' kk=',kk
8377             if (j1.eq.j+1) then
8378 C Contacts I-J and (I+1)-J occur simultaneously.
8379 C The system loses extra energy.
8380 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
8381             endif ! j1==j+1
8382           enddo ! kk
8383         enddo ! jj
8384       enddo ! i
8385       return
8386       end
8387 c------------------------------------------------------------------------------
8388       subroutine add_hb_contact(ii,jj,itask)
8389       implicit real*8 (a-h,o-z)
8390       include "DIMENSIONS"
8391       include "COMMON.IOUNITS"
8392       integer max_cont
8393       integer max_dim
8394       parameter (max_cont=maxconts)
8395       parameter (max_dim=26)
8396       include "COMMON.CONTACTS"
8397       double precision zapas(max_dim,maxconts,max_fg_procs),
8398      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8399       common /przechowalnia/ zapas
8400       integer i,j,ii,jj,iproc,itask(4),nn
8401 c      write (iout,*) "itask",itask
8402       do i=1,2
8403         iproc=itask(i)
8404         if (iproc.gt.0) then
8405           do j=1,num_cont_hb(ii)
8406             jjc=jcont_hb(j,ii)
8407 c            write (iout,*) "i",ii," j",jj," jjc",jjc
8408             if (jjc.eq.jj) then
8409               ncont_sent(iproc)=ncont_sent(iproc)+1
8410               nn=ncont_sent(iproc)
8411               zapas(1,nn,iproc)=ii
8412               zapas(2,nn,iproc)=jjc
8413               zapas(3,nn,iproc)=facont_hb(j,ii)
8414               zapas(4,nn,iproc)=ees0p(j,ii)
8415               zapas(5,nn,iproc)=ees0m(j,ii)
8416               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
8417               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
8418               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
8419               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
8420               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
8421               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
8422               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
8423               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
8424               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
8425               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
8426               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
8427               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
8428               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
8429               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
8430               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
8431               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
8432               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
8433               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
8434               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
8435               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
8436               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
8437               exit
8438             endif
8439           enddo
8440         endif
8441       enddo
8442       return
8443       end
8444 c------------------------------------------------------------------------------
8445       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
8446      &  n_corr1)
8447 C This subroutine calculates multi-body contributions to hydrogen-bonding
8448       implicit real*8 (a-h,o-z)
8449       include 'DIMENSIONS'
8450       include 'COMMON.IOUNITS'
8451 #ifdef MPI
8452       include "mpif.h"
8453       parameter (max_cont=maxconts)
8454       parameter (max_dim=70)
8455       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
8456       double precision zapas(max_dim,maxconts,max_fg_procs),
8457      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8458       common /przechowalnia/ zapas
8459       integer status(MPI_STATUS_SIZE),req(maxconts*2),
8460      &  status_array(MPI_STATUS_SIZE,maxconts*2)
8461 #endif
8462       include 'COMMON.SETUP'
8463       include 'COMMON.FFIELD'
8464       include 'COMMON.DERIV'
8465       include 'COMMON.LOCAL'
8466       include 'COMMON.INTERACT'
8467       include 'COMMON.CONTACTS'
8468       include 'COMMON.CHAIN'
8469       include 'COMMON.CONTROL'
8470       include 'COMMON.SHIELD'
8471       double precision gx(3),gx1(3)
8472       integer num_cont_hb_old(maxres)
8473       logical lprn,ldone
8474       double precision eello4,eello5,eelo6,eello_turn6
8475       external eello4,eello5,eello6,eello_turn6
8476 C Set lprn=.true. for debugging
8477       lprn=.false.
8478       eturn6=0.0d0
8479 #ifdef MPI
8480       do i=1,nres
8481         num_cont_hb_old(i)=num_cont_hb(i)
8482       enddo
8483       n_corr=0
8484       n_corr1=0
8485       if (nfgtasks.le.1) goto 30
8486       if (lprn) then
8487         write (iout,'(a)') 'Contact function values before RECEIVE:'
8488         do i=nnt,nct-2
8489           write (iout,'(2i3,50(1x,i2,f5.2))')
8490      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
8491      &    j=1,num_cont_hb(i))
8492         enddo
8493       endif
8494       do i=1,ntask_cont_from
8495         ncont_recv(i)=0
8496       enddo
8497       do i=1,ntask_cont_to
8498         ncont_sent(i)=0
8499       enddo
8500 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
8501 c     & ntask_cont_to
8502 C Make the list of contacts to send to send to other procesors
8503       do i=iturn3_start,iturn3_end
8504 c        write (iout,*) "make contact list turn3",i," num_cont",
8505 c     &    num_cont_hb(i)
8506         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
8507       enddo
8508       do i=iturn4_start,iturn4_end
8509 c        write (iout,*) "make contact list turn4",i," num_cont",
8510 c     &   num_cont_hb(i)
8511         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
8512       enddo
8513       do ii=1,nat_sent
8514         i=iat_sent(ii)
8515 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
8516 c     &    num_cont_hb(i)
8517         do j=1,num_cont_hb(i)
8518         do k=1,4
8519           jjc=jcont_hb(j,i)
8520           iproc=iint_sent_local(k,jjc,ii)
8521 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
8522           if (iproc.ne.0) then
8523             ncont_sent(iproc)=ncont_sent(iproc)+1
8524             nn=ncont_sent(iproc)
8525             zapas(1,nn,iproc)=i
8526             zapas(2,nn,iproc)=jjc
8527             zapas(3,nn,iproc)=d_cont(j,i)
8528             ind=3
8529             do kk=1,3
8530               ind=ind+1
8531               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
8532             enddo
8533             do kk=1,2
8534               do ll=1,2
8535                 ind=ind+1
8536                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
8537               enddo
8538             enddo
8539             do jj=1,5
8540               do kk=1,3
8541                 do ll=1,2
8542                   do mm=1,2
8543                     ind=ind+1
8544                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
8545                   enddo
8546                 enddo
8547               enddo
8548             enddo
8549           endif
8550         enddo
8551         enddo
8552       enddo
8553       if (lprn) then
8554       write (iout,*)
8555      &  "Numbers of contacts to be sent to other processors",
8556      &  (ncont_sent(i),i=1,ntask_cont_to)
8557       write (iout,*) "Contacts sent"
8558       do ii=1,ntask_cont_to
8559         nn=ncont_sent(ii)
8560         iproc=itask_cont_to(ii)
8561         write (iout,*) nn," contacts to processor",iproc,
8562      &   " of CONT_TO_COMM group"
8563         do i=1,nn
8564           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
8565         enddo
8566       enddo
8567       call flush(iout)
8568       endif
8569       CorrelType=477
8570       CorrelID=fg_rank+1
8571       CorrelType1=478
8572       CorrelID1=nfgtasks+fg_rank+1
8573       ireq=0
8574 C Receive the numbers of needed contacts from other processors
8575       do ii=1,ntask_cont_from
8576         iproc=itask_cont_from(ii)
8577         ireq=ireq+1
8578         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
8579      &    FG_COMM,req(ireq),IERR)
8580       enddo
8581 c      write (iout,*) "IRECV ended"
8582 c      call flush(iout)
8583 C Send the number of contacts needed by other processors
8584       do ii=1,ntask_cont_to
8585         iproc=itask_cont_to(ii)
8586         ireq=ireq+1
8587         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
8588      &    FG_COMM,req(ireq),IERR)
8589       enddo
8590 c      write (iout,*) "ISEND ended"
8591 c      write (iout,*) "number of requests (nn)",ireq
8592 c      call flush(iout)
8593       if (ireq.gt.0)
8594      &  call MPI_Waitall(ireq,req,status_array,ierr)
8595 c      write (iout,*)
8596 c     &  "Numbers of contacts to be received from other processors",
8597 c     &  (ncont_recv(i),i=1,ntask_cont_from)
8598 c      call flush(iout)
8599 C Receive contacts
8600       ireq=0
8601       do ii=1,ntask_cont_from
8602         iproc=itask_cont_from(ii)
8603         nn=ncont_recv(ii)
8604 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
8605 c     &   " of CONT_TO_COMM group"
8606 c        call flush(iout)
8607         if (nn.gt.0) then
8608           ireq=ireq+1
8609           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
8610      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8611 c          write (iout,*) "ireq,req",ireq,req(ireq)
8612         endif
8613       enddo
8614 C Send the contacts to processors that need them
8615       do ii=1,ntask_cont_to
8616         iproc=itask_cont_to(ii)
8617         nn=ncont_sent(ii)
8618 c        write (iout,*) nn," contacts to processor",iproc,
8619 c     &   " of CONT_TO_COMM group"
8620         if (nn.gt.0) then
8621           ireq=ireq+1
8622           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
8623      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
8624 c          write (iout,*) "ireq,req",ireq,req(ireq)
8625 c          do i=1,nn
8626 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
8627 c          enddo
8628         endif
8629       enddo
8630 c      write (iout,*) "number of requests (contacts)",ireq
8631 c      write (iout,*) "req",(req(i),i=1,4)
8632 c      call flush(iout)
8633       if (ireq.gt.0)
8634      & call MPI_Waitall(ireq,req,status_array,ierr)
8635       do iii=1,ntask_cont_from
8636         iproc=itask_cont_from(iii)
8637         nn=ncont_recv(iii)
8638         if (lprn) then
8639         write (iout,*) "Received",nn," contacts from processor",iproc,
8640      &   " of CONT_FROM_COMM group"
8641         call flush(iout)
8642         do i=1,nn
8643           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
8644         enddo
8645         call flush(iout)
8646         endif
8647         do i=1,nn
8648           ii=zapas_recv(1,i,iii)
8649 c Flag the received contacts to prevent double-counting
8650           jj=-zapas_recv(2,i,iii)
8651 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
8652 c          call flush(iout)
8653           nnn=num_cont_hb(ii)+1
8654           num_cont_hb(ii)=nnn
8655           jcont_hb(nnn,ii)=jj
8656           d_cont(nnn,ii)=zapas_recv(3,i,iii)
8657           ind=3
8658           do kk=1,3
8659             ind=ind+1
8660             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
8661           enddo
8662           do kk=1,2
8663             do ll=1,2
8664               ind=ind+1
8665               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
8666             enddo
8667           enddo
8668           do jj=1,5
8669             do kk=1,3
8670               do ll=1,2
8671                 do mm=1,2
8672                   ind=ind+1
8673                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
8674                 enddo
8675               enddo
8676             enddo
8677           enddo
8678         enddo
8679       enddo
8680       if (lprn) then
8681         write (iout,'(a)') 'Contact function values after receive:'
8682         do i=nnt,nct-2
8683           write (iout,'(2i3,50(1x,i3,5f6.3))')
8684      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8685      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8686         enddo
8687         call flush(iout)
8688       endif
8689    30 continue
8690 #endif
8691       if (lprn) then
8692         write (iout,'(a)') 'Contact function values:'
8693         do i=nnt,nct-2
8694           write (iout,'(2i3,50(1x,i2,5f6.3))')
8695      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
8696      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
8697         enddo
8698       endif
8699       ecorr=0.0D0
8700       ecorr5=0.0d0
8701       ecorr6=0.0d0
8702 C Remove the loop below after debugging !!!
8703       do i=nnt,nct
8704         do j=1,3
8705           gradcorr(j,i)=0.0D0
8706           gradxorr(j,i)=0.0D0
8707         enddo
8708       enddo
8709 C Calculate the dipole-dipole interaction energies
8710       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
8711       do i=iatel_s,iatel_e+1
8712         num_conti=num_cont_hb(i)
8713         do jj=1,num_conti
8714           j=jcont_hb(jj,i)
8715 #ifdef MOMENT
8716           call dipole(i,j,jj)
8717 #endif
8718         enddo
8719       enddo
8720       endif
8721 C Calculate the local-electrostatic correlation terms
8722 c                write (iout,*) "gradcorr5 in eello5 before loop"
8723 c                do iii=1,nres
8724 c                  write (iout,'(i5,3f10.5)')
8725 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8726 c                enddo
8727       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
8728 c        write (iout,*) "corr loop i",i
8729         i1=i+1
8730         num_conti=num_cont_hb(i)
8731         num_conti1=num_cont_hb(i+1)
8732         do jj=1,num_conti
8733           j=jcont_hb(jj,i)
8734           jp=iabs(j)
8735           do kk=1,num_conti1
8736             j1=jcont_hb(kk,i1)
8737             jp1=iabs(j1)
8738 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
8739 c     &         ' jj=',jj,' kk=',kk
8740 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
8741             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
8742      &          .or. j.lt.0 .and. j1.gt.0) .and.
8743      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
8744 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
8745 C The system gains extra energy.
8746               n_corr=n_corr+1
8747               sqd1=dsqrt(d_cont(jj,i))
8748               sqd2=dsqrt(d_cont(kk,i1))
8749               sred_geom = sqd1*sqd2
8750               IF (sred_geom.lt.cutoff_corr) THEN
8751                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
8752      &            ekont,fprimcont)
8753 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
8754 cd     &         ' jj=',jj,' kk=',kk
8755                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
8756                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
8757                 do l=1,3
8758                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
8759                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
8760                 enddo
8761                 n_corr1=n_corr1+1
8762 cd               write (iout,*) 'sred_geom=',sred_geom,
8763 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
8764 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
8765 cd               write (iout,*) "g_contij",g_contij
8766 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
8767 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
8768                 call calc_eello(i,jp,i+1,jp1,jj,kk)
8769                 if (wcorr4.gt.0.0d0)
8770      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
8771 CC     &            *fac_shield(i)**2*fac_shield(j)**2
8772                   if (energy_dec.and.wcorr4.gt.0.0d0)
8773      1                 write (iout,'(a6,4i5,0pf7.3)')
8774      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
8775 c                write (iout,*) "gradcorr5 before eello5"
8776 c                do iii=1,nres
8777 c                  write (iout,'(i5,3f10.5)')
8778 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8779 c                enddo
8780                 if (wcorr5.gt.0.0d0)
8781      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
8782 c                write (iout,*) "gradcorr5 after eello5"
8783 c                do iii=1,nres
8784 c                  write (iout,'(i5,3f10.5)')
8785 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8786 c                enddo
8787                   if (energy_dec.and.wcorr5.gt.0.0d0)
8788      1                 write (iout,'(a6,4i5,0pf7.3)')
8789      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
8790 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
8791 cd                write(2,*)'ijkl',i,jp,i+1,jp1
8792                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
8793      &               .or. wturn6.eq.0.0d0))then
8794 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
8795                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
8796                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8797      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
8798 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
8799 cd     &            'ecorr6=',ecorr6
8800 cd                write (iout,'(4e15.5)') sred_geom,
8801 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
8802 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
8803 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
8804                 else if (wturn6.gt.0.0d0
8805      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
8806 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
8807                   eturn6=eturn6+eello_turn6(i,jj,kk)
8808                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
8809      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
8810 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
8811                 endif
8812               ENDIF
8813 1111          continue
8814             endif
8815           enddo ! kk
8816         enddo ! jj
8817       enddo ! i
8818       do i=1,nres
8819         num_cont_hb(i)=num_cont_hb_old(i)
8820       enddo
8821 c                write (iout,*) "gradcorr5 in eello5"
8822 c                do iii=1,nres
8823 c                  write (iout,'(i5,3f10.5)')
8824 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
8825 c                enddo
8826       return
8827       end
8828 c------------------------------------------------------------------------------
8829       subroutine add_hb_contact_eello(ii,jj,itask)
8830       implicit real*8 (a-h,o-z)
8831       include "DIMENSIONS"
8832       include "COMMON.IOUNITS"
8833       integer max_cont
8834       integer max_dim
8835       parameter (max_cont=maxconts)
8836       parameter (max_dim=70)
8837       include "COMMON.CONTACTS"
8838       double precision zapas(max_dim,maxconts,max_fg_procs),
8839      &  zapas_recv(max_dim,maxconts,max_fg_procs)
8840       common /przechowalnia/ zapas
8841       integer i,j,ii,jj,iproc,itask(4),nn
8842 c      write (iout,*) "itask",itask
8843       do i=1,2
8844         iproc=itask(i)
8845         if (iproc.gt.0) then
8846           do j=1,num_cont_hb(ii)
8847             jjc=jcont_hb(j,ii)
8848 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
8849             if (jjc.eq.jj) then
8850               ncont_sent(iproc)=ncont_sent(iproc)+1
8851               nn=ncont_sent(iproc)
8852               zapas(1,nn,iproc)=ii
8853               zapas(2,nn,iproc)=jjc
8854               zapas(3,nn,iproc)=d_cont(j,ii)
8855               ind=3
8856               do kk=1,3
8857                 ind=ind+1
8858                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
8859               enddo
8860               do kk=1,2
8861                 do ll=1,2
8862                   ind=ind+1
8863                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
8864                 enddo
8865               enddo
8866               do jj=1,5
8867                 do kk=1,3
8868                   do ll=1,2
8869                     do mm=1,2
8870                       ind=ind+1
8871                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
8872                     enddo
8873                   enddo
8874                 enddo
8875               enddo
8876               exit
8877             endif
8878           enddo
8879         endif
8880       enddo
8881       return
8882       end
8883 c------------------------------------------------------------------------------
8884       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
8885       implicit real*8 (a-h,o-z)
8886       include 'DIMENSIONS'
8887       include 'COMMON.IOUNITS'
8888       include 'COMMON.DERIV'
8889       include 'COMMON.INTERACT'
8890       include 'COMMON.CONTACTS'
8891       include 'COMMON.SHIELD'
8892       include 'COMMON.CONTROL'
8893       double precision gx(3),gx1(3)
8894       logical lprn
8895       lprn=.false.
8896 C      print *,"wchodze",fac_shield(i),shield_mode
8897       eij=facont_hb(jj,i)
8898       ekl=facont_hb(kk,k)
8899       ees0pij=ees0p(jj,i)
8900       ees0pkl=ees0p(kk,k)
8901       ees0mij=ees0m(jj,i)
8902       ees0mkl=ees0m(kk,k)
8903       ekont=eij*ekl
8904       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
8905 C*
8906 C     & fac_shield(i)**2*fac_shield(j)**2
8907 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
8908 C Following 4 lines for diagnostics.
8909 cd    ees0pkl=0.0D0
8910 cd    ees0pij=1.0D0
8911 cd    ees0mkl=0.0D0
8912 cd    ees0mij=1.0D0
8913 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
8914 c     & 'Contacts ',i,j,
8915 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
8916 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
8917 c     & 'gradcorr_long'
8918 C Calculate the multi-body contribution to energy.
8919 C      ecorr=ecorr+ekont*ees
8920 C Calculate multi-body contributions to the gradient.
8921       coeffpees0pij=coeffp*ees0pij
8922       coeffmees0mij=coeffm*ees0mij
8923       coeffpees0pkl=coeffp*ees0pkl
8924       coeffmees0mkl=coeffm*ees0mkl
8925       do ll=1,3
8926 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
8927         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
8928      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
8929      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
8930         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
8931      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
8932      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
8933 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
8934         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
8935      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
8936      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
8937         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
8938      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
8939      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
8940         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
8941      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
8942      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
8943         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
8944         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
8945         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
8946      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
8947      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
8948         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
8949         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
8950 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
8951       enddo
8952 c      write (iout,*)
8953 cgrad      do m=i+1,j-1
8954 cgrad        do ll=1,3
8955 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8956 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
8957 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
8958 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
8959 cgrad        enddo
8960 cgrad      enddo
8961 cgrad      do m=k+1,l-1
8962 cgrad        do ll=1,3
8963 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
8964 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
8965 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
8966 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
8967 cgrad        enddo
8968 cgrad      enddo
8969 c      write (iout,*) "ehbcorr",ekont*ees
8970 C      print *,ekont,ees,i,k
8971       ehbcorr=ekont*ees
8972 C now gradient over shielding
8973 C      return
8974       if (shield_mode.gt.0) then
8975        j=ees0plist(jj,i)
8976        l=ees0plist(kk,k)
8977 C        print *,i,j,fac_shield(i),fac_shield(j),
8978 C     &fac_shield(k),fac_shield(l)
8979         if ((fac_shield(i).gt.0).and.(fac_shield(j).gt.0).and.
8980      &      (fac_shield(k).gt.0).and.(fac_shield(l).gt.0)) then
8981           do ilist=1,ishield_list(i)
8982            iresshield=shield_list(ilist,i)
8983            do m=1,3
8984            rlocshield=grad_shield_side(m,ilist,i)*ehbcorr/fac_shield(i)
8985 C     &      *2.0
8986            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8987      &              rlocshield
8988      & +grad_shield_loc(m,ilist,i)*ehbcorr/fac_shield(i)
8989             gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
8990      &+rlocshield
8991            enddo
8992           enddo
8993           do ilist=1,ishield_list(j)
8994            iresshield=shield_list(ilist,j)
8995            do m=1,3
8996            rlocshield=grad_shield_side(m,ilist,j)*ehbcorr/fac_shield(j)
8997 C     &     *2.0
8998            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
8999      &              rlocshield
9000      & +grad_shield_loc(m,ilist,j)*ehbcorr/fac_shield(j)
9001            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9002      &     +rlocshield
9003            enddo
9004           enddo
9005
9006           do ilist=1,ishield_list(k)
9007            iresshield=shield_list(ilist,k)
9008            do m=1,3
9009            rlocshield=grad_shield_side(m,ilist,k)*ehbcorr/fac_shield(k)
9010 C     &     *2.0
9011            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9012      &              rlocshield
9013      & +grad_shield_loc(m,ilist,k)*ehbcorr/fac_shield(k)
9014            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9015      &     +rlocshield
9016            enddo
9017           enddo
9018           do ilist=1,ishield_list(l)
9019            iresshield=shield_list(ilist,l)
9020            do m=1,3
9021            rlocshield=grad_shield_side(m,ilist,l)*ehbcorr/fac_shield(l)
9022 C     &     *2.0
9023            gshieldx_ec(m,iresshield)=gshieldx_ec(m,iresshield)+
9024      &              rlocshield
9025      & +grad_shield_loc(m,ilist,l)*ehbcorr/fac_shield(l)
9026            gshieldc_ec(m,iresshield-1)=gshieldc_ec(m,iresshield-1)
9027      &     +rlocshield
9028            enddo
9029           enddo
9030 C          print *,gshieldx(m,iresshield)
9031           do m=1,3
9032             gshieldc_ec(m,i)=gshieldc_ec(m,i)+
9033      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9034             gshieldc_ec(m,j)=gshieldc_ec(m,j)+
9035      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9036             gshieldc_ec(m,i-1)=gshieldc_ec(m,i-1)+
9037      &              grad_shield(m,i)*ehbcorr/fac_shield(i)
9038             gshieldc_ec(m,j-1)=gshieldc_ec(m,j-1)+
9039      &              grad_shield(m,j)*ehbcorr/fac_shield(j)
9040
9041             gshieldc_ec(m,k)=gshieldc_ec(m,k)+
9042      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9043             gshieldc_ec(m,l)=gshieldc_ec(m,l)+
9044      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9045             gshieldc_ec(m,k-1)=gshieldc_ec(m,k-1)+
9046      &              grad_shield(m,k)*ehbcorr/fac_shield(k)
9047             gshieldc_ec(m,l-1)=gshieldc_ec(m,l-1)+
9048      &              grad_shield(m,l)*ehbcorr/fac_shield(l)
9049
9050            enddo
9051       endif
9052       endif
9053       return
9054       end
9055 #ifdef MOMENT
9056 C---------------------------------------------------------------------------
9057       subroutine dipole(i,j,jj)
9058       implicit real*8 (a-h,o-z)
9059       include 'DIMENSIONS'
9060       include 'COMMON.IOUNITS'
9061       include 'COMMON.CHAIN'
9062       include 'COMMON.FFIELD'
9063       include 'COMMON.DERIV'
9064       include 'COMMON.INTERACT'
9065       include 'COMMON.CONTACTS'
9066       include 'COMMON.TORSION'
9067       include 'COMMON.VAR'
9068       include 'COMMON.GEO'
9069       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
9070      &  auxmat(2,2)
9071       iti1 = itortyp(itype(i+1))
9072       if (j.lt.nres-1) then
9073         itj1 = itype2loc(itype(j+1))
9074       else
9075         itj1=nloctyp
9076       endif
9077       do iii=1,2
9078         dipi(iii,1)=Ub2(iii,i)
9079         dipderi(iii)=Ub2der(iii,i)
9080         dipi(iii,2)=b1(iii,i+1)
9081         dipj(iii,1)=Ub2(iii,j)
9082         dipderj(iii)=Ub2der(iii,j)
9083         dipj(iii,2)=b1(iii,j+1)
9084       enddo
9085       kkk=0
9086       do iii=1,2
9087         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
9088         do jjj=1,2
9089           kkk=kkk+1
9090           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9091         enddo
9092       enddo
9093       do kkk=1,5
9094         do lll=1,3
9095           mmm=0
9096           do iii=1,2
9097             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
9098      &        auxvec(1))
9099             do jjj=1,2
9100               mmm=mmm+1
9101               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
9102             enddo
9103           enddo
9104         enddo
9105       enddo
9106       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
9107       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
9108       do iii=1,2
9109         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
9110       enddo
9111       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
9112       do iii=1,2
9113         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
9114       enddo
9115       return
9116       end
9117 #endif
9118 C---------------------------------------------------------------------------
9119       subroutine calc_eello(i,j,k,l,jj,kk)
9120 C
9121 C This subroutine computes matrices and vectors needed to calculate
9122 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
9123 C
9124       implicit real*8 (a-h,o-z)
9125       include 'DIMENSIONS'
9126       include 'COMMON.IOUNITS'
9127       include 'COMMON.CHAIN'
9128       include 'COMMON.DERIV'
9129       include 'COMMON.INTERACT'
9130       include 'COMMON.CONTACTS'
9131       include 'COMMON.TORSION'
9132       include 'COMMON.VAR'
9133       include 'COMMON.GEO'
9134       include 'COMMON.FFIELD'
9135       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
9136      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
9137       logical lprn
9138       common /kutas/ lprn
9139 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
9140 cd     & ' jj=',jj,' kk=',kk
9141 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
9142 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
9143 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
9144       do iii=1,2
9145         do jjj=1,2
9146           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
9147           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
9148         enddo
9149       enddo
9150       call transpose2(aa1(1,1),aa1t(1,1))
9151       call transpose2(aa2(1,1),aa2t(1,1))
9152       do kkk=1,5
9153         do lll=1,3
9154           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
9155      &      aa1tder(1,1,lll,kkk))
9156           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
9157      &      aa2tder(1,1,lll,kkk))
9158         enddo
9159       enddo
9160       if (l.eq.j+1) then
9161 C parallel orientation of the two CA-CA-CA frames.
9162         if (i.gt.1) then
9163           iti=itype2loc(itype(i))
9164         else
9165           iti=nloctyp
9166         endif
9167         itk1=itype2loc(itype(k+1))
9168         itj=itype2loc(itype(j))
9169         if (l.lt.nres-1) then
9170           itl1=itype2loc(itype(l+1))
9171         else
9172           itl1=nloctyp
9173         endif
9174 C A1 kernel(j+1) A2T
9175 cd        do iii=1,2
9176 cd          write (iout,'(3f10.5,5x,3f10.5)')
9177 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
9178 cd        enddo
9179         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9180      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
9181      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9182 C Following matrices are needed only for 6-th order cumulants
9183         IF (wcorr6.gt.0.0d0) THEN
9184         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9185      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
9186      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9187         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9188      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
9189      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9190      &   ADtEAderx(1,1,1,1,1,1))
9191         lprn=.false.
9192         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9193      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
9194      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9195      &   ADtEA1derx(1,1,1,1,1,1))
9196         ENDIF
9197 C End 6-th order cumulants
9198 cd        lprn=.false.
9199 cd        if (lprn) then
9200 cd        write (2,*) 'In calc_eello6'
9201 cd        do iii=1,2
9202 cd          write (2,*) 'iii=',iii
9203 cd          do kkk=1,5
9204 cd            write (2,*) 'kkk=',kkk
9205 cd            do jjj=1,2
9206 cd              write (2,'(3(2f10.5),5x)')
9207 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
9208 cd            enddo
9209 cd          enddo
9210 cd        enddo
9211 cd        endif
9212         call transpose2(EUgder(1,1,k),auxmat(1,1))
9213         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9214         call transpose2(EUg(1,1,k),auxmat(1,1))
9215         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9216         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9217 C AL 4/16/16: Derivatives of the quantitied related to matrices C, D, and E
9218 c    in theta; to be sriten later.
9219 c#ifdef NEWCORR
9220 c        call transpose2(gtEE(1,1,k),auxmat(1,1))
9221 c        call matmat2(auxmat(1,1),AEA(1,1,1),EAEAdert(1,1,1,1))
9222 c        call transpose2(EUg(1,1,k),auxmat(1,1))
9223 c        call matmat2(auxmat(1,1),AEAdert(1,1,1),EAEAdert(1,1,2,1))
9224 c#endif
9225         do iii=1,2
9226           do kkk=1,5
9227             do lll=1,3
9228               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9229      &          EAEAderx(1,1,lll,kkk,iii,1))
9230             enddo
9231           enddo
9232         enddo
9233 C A1T kernel(i+1) A2
9234         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9235      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
9236      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9237 C Following matrices are needed only for 6-th order cumulants
9238         IF (wcorr6.gt.0.0d0) THEN
9239         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9240      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
9241      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9242         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9243      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
9244      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9245      &   ADtEAderx(1,1,1,1,1,2))
9246         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
9247      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
9248      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9249      &   ADtEA1derx(1,1,1,1,1,2))
9250         ENDIF
9251 C End 6-th order cumulants
9252         call transpose2(EUgder(1,1,l),auxmat(1,1))
9253         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
9254         call transpose2(EUg(1,1,l),auxmat(1,1))
9255         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9256         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9257         do iii=1,2
9258           do kkk=1,5
9259             do lll=1,3
9260               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9261      &          EAEAderx(1,1,lll,kkk,iii,2))
9262             enddo
9263           enddo
9264         enddo
9265 C AEAb1 and AEAb2
9266 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9267 C They are needed only when the fifth- or the sixth-order cumulants are
9268 C indluded.
9269         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
9270         call transpose2(AEA(1,1,1),auxmat(1,1))
9271         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9272         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9273         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9274         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9275         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9276         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9277         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9278         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9279         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9280         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9281         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9282         call transpose2(AEA(1,1,2),auxmat(1,1))
9283         call matvec2(auxmat(1,1),b1(1,j),AEAb1(1,1,2))
9284         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
9285         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
9286         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9287         call matvec2(auxmat(1,1),b1(1,j),AEAb1derg(1,1,2))
9288         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
9289         call matvec2(AEA(1,1,2),b1(1,l+1),AEAb1(1,2,2))
9290         call matvec2(AEAderg(1,1,2),b1(1,l+1),AEAb1derg(1,2,2))
9291         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
9292         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
9293         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
9294 C Calculate the Cartesian derivatives of the vectors.
9295         do iii=1,2
9296           do kkk=1,5
9297             do lll=1,3
9298               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9299               call matvec2(auxmat(1,1),b1(1,i),
9300      &          AEAb1derx(1,lll,kkk,iii,1,1))
9301               call matvec2(auxmat(1,1),Ub2(1,i),
9302      &          AEAb2derx(1,lll,kkk,iii,1,1))
9303               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9304      &          AEAb1derx(1,lll,kkk,iii,2,1))
9305               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9306      &          AEAb2derx(1,lll,kkk,iii,2,1))
9307               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9308               call matvec2(auxmat(1,1),b1(1,j),
9309      &          AEAb1derx(1,lll,kkk,iii,1,2))
9310               call matvec2(auxmat(1,1),Ub2(1,j),
9311      &          AEAb2derx(1,lll,kkk,iii,1,2))
9312               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
9313      &          AEAb1derx(1,lll,kkk,iii,2,2))
9314               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
9315      &          AEAb2derx(1,lll,kkk,iii,2,2))
9316             enddo
9317           enddo
9318         enddo
9319         ENDIF
9320 C End vectors
9321       else
9322 C Antiparallel orientation of the two CA-CA-CA frames.
9323         if (i.gt.1) then
9324           iti=itype2loc(itype(i))
9325         else
9326           iti=nloctyp
9327         endif
9328         itk1=itype2loc(itype(k+1))
9329         itl=itype2loc(itype(l))
9330         itj=itype2loc(itype(j))
9331         if (j.lt.nres-1) then
9332           itj1=itype2loc(itype(j+1))
9333         else
9334           itj1=nloctyp
9335         endif
9336 C A2 kernel(j-1)T A1T
9337         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9338      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
9339      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
9340 C Following matrices are needed only for 6-th order cumulants
9341         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9342      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9343         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9344      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
9345      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
9346         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9347      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
9348      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
9349      &   ADtEAderx(1,1,1,1,1,1))
9350         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
9351      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
9352      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
9353      &   ADtEA1derx(1,1,1,1,1,1))
9354         ENDIF
9355 C End 6-th order cumulants
9356         call transpose2(EUgder(1,1,k),auxmat(1,1))
9357         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
9358         call transpose2(EUg(1,1,k),auxmat(1,1))
9359         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
9360         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
9361         do iii=1,2
9362           do kkk=1,5
9363             do lll=1,3
9364               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9365      &          EAEAderx(1,1,lll,kkk,iii,1))
9366             enddo
9367           enddo
9368         enddo
9369 C A2T kernel(i+1)T A1
9370         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9371      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
9372      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
9373 C Following matrices are needed only for 6-th order cumulants
9374         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
9375      &     j.eq.i+4 .and. l.eq.i+3)) THEN
9376         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9377      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
9378      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
9379         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9380      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
9381      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
9382      &   ADtEAderx(1,1,1,1,1,2))
9383         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
9384      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
9385      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
9386      &   ADtEA1derx(1,1,1,1,1,2))
9387         ENDIF
9388 C End 6-th order cumulants
9389         call transpose2(EUgder(1,1,j),auxmat(1,1))
9390         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
9391         call transpose2(EUg(1,1,j),auxmat(1,1))
9392         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
9393         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
9394         do iii=1,2
9395           do kkk=1,5
9396             do lll=1,3
9397               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9398      &          EAEAderx(1,1,lll,kkk,iii,2))
9399             enddo
9400           enddo
9401         enddo
9402 C AEAb1 and AEAb2
9403 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
9404 C They are needed only when the fifth- or the sixth-order cumulants are
9405 C indluded.
9406         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
9407      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
9408         call transpose2(AEA(1,1,1),auxmat(1,1))
9409         call matvec2(auxmat(1,1),b1(1,i),AEAb1(1,1,1))
9410         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
9411         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
9412         call transpose2(AEAderg(1,1,1),auxmat(1,1))
9413         call matvec2(auxmat(1,1),b1(1,i),AEAb1derg(1,1,1))
9414         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
9415         call matvec2(AEA(1,1,1),b1(1,k+1),AEAb1(1,2,1))
9416         call matvec2(AEAderg(1,1,1),b1(1,k+1),AEAb1derg(1,2,1))
9417         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
9418         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
9419         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
9420         call transpose2(AEA(1,1,2),auxmat(1,1))
9421         call matvec2(auxmat(1,1),b1(1,j+1),AEAb1(1,1,2))
9422         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
9423         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
9424         call transpose2(AEAderg(1,1,2),auxmat(1,1))
9425         call matvec2(auxmat(1,1),b1(1,l),AEAb1(1,1,2))
9426         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
9427         call matvec2(AEA(1,1,2),b1(1,j+1),AEAb1(1,2,2))
9428         call matvec2(AEAderg(1,1,2),b1(1,j+1),AEAb1derg(1,2,2))
9429         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
9430         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
9431         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
9432 C Calculate the Cartesian derivatives of the vectors.
9433         do iii=1,2
9434           do kkk=1,5
9435             do lll=1,3
9436               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
9437               call matvec2(auxmat(1,1),b1(1,i),
9438      &          AEAb1derx(1,lll,kkk,iii,1,1))
9439               call matvec2(auxmat(1,1),Ub2(1,i),
9440      &          AEAb2derx(1,lll,kkk,iii,1,1))
9441               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
9442      &          AEAb1derx(1,lll,kkk,iii,2,1))
9443               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
9444      &          AEAb2derx(1,lll,kkk,iii,2,1))
9445               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
9446               call matvec2(auxmat(1,1),b1(1,l),
9447      &          AEAb1derx(1,lll,kkk,iii,1,2))
9448               call matvec2(auxmat(1,1),Ub2(1,l),
9449      &          AEAb2derx(1,lll,kkk,iii,1,2))
9450               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,j+1),
9451      &          AEAb1derx(1,lll,kkk,iii,2,2))
9452               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
9453      &          AEAb2derx(1,lll,kkk,iii,2,2))
9454             enddo
9455           enddo
9456         enddo
9457         ENDIF
9458 C End vectors
9459       endif
9460       return
9461       end
9462 C---------------------------------------------------------------------------
9463       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
9464      &  KK,KKderg,AKA,AKAderg,AKAderx)
9465       implicit none
9466       integer nderg
9467       logical transp
9468       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
9469      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
9470      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
9471       integer iii,kkk,lll
9472       integer jjj,mmm
9473       logical lprn
9474       common /kutas/ lprn
9475       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
9476       do iii=1,nderg
9477         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
9478      &    AKAderg(1,1,iii))
9479       enddo
9480 cd      if (lprn) write (2,*) 'In kernel'
9481       do kkk=1,5
9482 cd        if (lprn) write (2,*) 'kkk=',kkk
9483         do lll=1,3
9484           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
9485      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
9486 cd          if (lprn) then
9487 cd            write (2,*) 'lll=',lll
9488 cd            write (2,*) 'iii=1'
9489 cd            do jjj=1,2
9490 cd              write (2,'(3(2f10.5),5x)')
9491 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
9492 cd            enddo
9493 cd          endif
9494           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
9495      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
9496 cd          if (lprn) then
9497 cd            write (2,*) 'lll=',lll
9498 cd            write (2,*) 'iii=2'
9499 cd            do jjj=1,2
9500 cd              write (2,'(3(2f10.5),5x)')
9501 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
9502 cd            enddo
9503 cd          endif
9504         enddo
9505       enddo
9506       return
9507       end
9508 C---------------------------------------------------------------------------
9509       double precision function eello4(i,j,k,l,jj,kk)
9510       implicit real*8 (a-h,o-z)
9511       include 'DIMENSIONS'
9512       include 'COMMON.IOUNITS'
9513       include 'COMMON.CHAIN'
9514       include 'COMMON.DERIV'
9515       include 'COMMON.INTERACT'
9516       include 'COMMON.CONTACTS'
9517       include 'COMMON.TORSION'
9518       include 'COMMON.VAR'
9519       include 'COMMON.GEO'
9520       double precision pizda(2,2),ggg1(3),ggg2(3)
9521 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
9522 cd        eello4=0.0d0
9523 cd        return
9524 cd      endif
9525 cd      print *,'eello4:',i,j,k,l,jj,kk
9526 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
9527 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
9528 cold      eij=facont_hb(jj,i)
9529 cold      ekl=facont_hb(kk,k)
9530 cold      ekont=eij*ekl
9531       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
9532 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
9533       gcorr_loc(k-1)=gcorr_loc(k-1)
9534      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
9535       if (l.eq.j+1) then
9536         gcorr_loc(l-1)=gcorr_loc(l-1)
9537      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9538 C Al 4/16/16: Derivatives in theta, to be added later.
9539 c#ifdef NEWCORR
9540 c        gcorr_loc(nphi+l-1)=gcorr_loc(nphi+l-1)
9541 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9542 c#endif
9543       else
9544         gcorr_loc(j-1)=gcorr_loc(j-1)
9545      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
9546 c#ifdef NEWCORR
9547 c        gcorr_loc(nphi+j-1)=gcorr_loc(nphi+j-1)
9548 c     &     -ekont*(EAEAdert(1,1,2,1)+EAEAdert(2,2,2,1))
9549 c#endif
9550       endif
9551       do iii=1,2
9552         do kkk=1,5
9553           do lll=1,3
9554             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
9555      &                        -EAEAderx(2,2,lll,kkk,iii,1)
9556 cd            derx(lll,kkk,iii)=0.0d0
9557           enddo
9558         enddo
9559       enddo
9560 cd      gcorr_loc(l-1)=0.0d0
9561 cd      gcorr_loc(j-1)=0.0d0
9562 cd      gcorr_loc(k-1)=0.0d0
9563 cd      eel4=1.0d0
9564 cd      write (iout,*)'Contacts have occurred for peptide groups',
9565 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
9566 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
9567       if (j.lt.nres-1) then
9568         j1=j+1
9569         j2=j-1
9570       else
9571         j1=j-1
9572         j2=j-2
9573       endif
9574       if (l.lt.nres-1) then
9575         l1=l+1
9576         l2=l-1
9577       else
9578         l1=l-1
9579         l2=l-2
9580       endif
9581       do ll=1,3
9582 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
9583 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
9584         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
9585         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
9586 cgrad        ghalf=0.5d0*ggg1(ll)
9587         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
9588         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
9589         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
9590         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
9591         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
9592         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
9593 cgrad        ghalf=0.5d0*ggg2(ll)
9594         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
9595         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
9596         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
9597         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
9598         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
9599         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
9600       enddo
9601 cgrad      do m=i+1,j-1
9602 cgrad        do ll=1,3
9603 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
9604 cgrad        enddo
9605 cgrad      enddo
9606 cgrad      do m=k+1,l-1
9607 cgrad        do ll=1,3
9608 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
9609 cgrad        enddo
9610 cgrad      enddo
9611 cgrad      do m=i+2,j2
9612 cgrad        do ll=1,3
9613 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
9614 cgrad        enddo
9615 cgrad      enddo
9616 cgrad      do m=k+2,l2
9617 cgrad        do ll=1,3
9618 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
9619 cgrad        enddo
9620 cgrad      enddo
9621 cd      do iii=1,nres-3
9622 cd        write (2,*) iii,gcorr_loc(iii)
9623 cd      enddo
9624       eello4=ekont*eel4
9625 cd      write (2,*) 'ekont',ekont
9626 cd      write (iout,*) 'eello4',ekont*eel4
9627       return
9628       end
9629 C---------------------------------------------------------------------------
9630       double precision function eello5(i,j,k,l,jj,kk)
9631       implicit real*8 (a-h,o-z)
9632       include 'DIMENSIONS'
9633       include 'COMMON.IOUNITS'
9634       include 'COMMON.CHAIN'
9635       include 'COMMON.DERIV'
9636       include 'COMMON.INTERACT'
9637       include 'COMMON.CONTACTS'
9638       include 'COMMON.TORSION'
9639       include 'COMMON.VAR'
9640       include 'COMMON.GEO'
9641       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
9642       double precision ggg1(3),ggg2(3)
9643 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9644 C                                                                              C
9645 C                            Parallel chains                                   C
9646 C                                                                              C
9647 C          o             o                   o             o                   C
9648 C         /l\           / \             \   / \           / \   /              C
9649 C        /   \         /   \             \ /   \         /   \ /               C
9650 C       j| o |l1       | o |              o| o |         | o |o                C
9651 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9652 C      \i/   \         /   \ /             /   \         /   \                 C
9653 C       o    k1             o                                                  C
9654 C         (I)          (II)                (III)          (IV)                 C
9655 C                                                                              C
9656 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9657 C                                                                              C
9658 C                            Antiparallel chains                               C
9659 C                                                                              C
9660 C          o             o                   o             o                   C
9661 C         /j\           / \             \   / \           / \   /              C
9662 C        /   \         /   \             \ /   \         /   \ /               C
9663 C      j1| o |l        | o |              o| o |         | o |o                C
9664 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
9665 C      \i/   \         /   \ /             /   \         /   \                 C
9666 C       o     k1            o                                                  C
9667 C         (I)          (II)                (III)          (IV)                 C
9668 C                                                                              C
9669 C      eello5_1        eello5_2            eello5_3       eello5_4             C
9670 C                                                                              C
9671 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
9672 C                                                                              C
9673 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
9674 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
9675 cd        eello5=0.0d0
9676 cd        return
9677 cd      endif
9678 cd      write (iout,*)
9679 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
9680 cd     &   ' and',k,l
9681       itk=itype2loc(itype(k))
9682       itl=itype2loc(itype(l))
9683       itj=itype2loc(itype(j))
9684       eello5_1=0.0d0
9685       eello5_2=0.0d0
9686       eello5_3=0.0d0
9687       eello5_4=0.0d0
9688 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
9689 cd     &   eel5_3_num,eel5_4_num)
9690       do iii=1,2
9691         do kkk=1,5
9692           do lll=1,3
9693             derx(lll,kkk,iii)=0.0d0
9694           enddo
9695         enddo
9696       enddo
9697 cd      eij=facont_hb(jj,i)
9698 cd      ekl=facont_hb(kk,k)
9699 cd      ekont=eij*ekl
9700 cd      write (iout,*)'Contacts have occurred for peptide groups',
9701 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
9702 cd      goto 1111
9703 C Contribution from the graph I.
9704 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
9705 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
9706       call transpose2(EUg(1,1,k),auxmat(1,1))
9707       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
9708       vv(1)=pizda(1,1)-pizda(2,2)
9709       vv(2)=pizda(1,2)+pizda(2,1)
9710       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
9711      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9712 C Explicit gradient in virtual-dihedral angles.
9713       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
9714      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
9715      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
9716       call transpose2(EUgder(1,1,k),auxmat1(1,1))
9717       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
9718       vv(1)=pizda(1,1)-pizda(2,2)
9719       vv(2)=pizda(1,2)+pizda(2,1)
9720       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9721      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
9722      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9723       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
9724       vv(1)=pizda(1,1)-pizda(2,2)
9725       vv(2)=pizda(1,2)+pizda(2,1)
9726       if (l.eq.j+1) then
9727         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
9728      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9729      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9730       else
9731         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
9732      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
9733      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
9734       endif
9735 C Cartesian gradient
9736       do iii=1,2
9737         do kkk=1,5
9738           do lll=1,3
9739             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
9740      &        pizda(1,1))
9741             vv(1)=pizda(1,1)-pizda(2,2)
9742             vv(2)=pizda(1,2)+pizda(2,1)
9743             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9744      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
9745      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
9746           enddo
9747         enddo
9748       enddo
9749 c      goto 1112
9750 c1111  continue
9751 C Contribution from graph II
9752       call transpose2(EE(1,1,k),auxmat(1,1))
9753       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
9754       vv(1)=pizda(1,1)+pizda(2,2)
9755       vv(2)=pizda(2,1)-pizda(1,2)
9756       eello5_2=scalar2(AEAb1(1,2,1),b1(1,k))
9757      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
9758 C Explicit gradient in virtual-dihedral angles.
9759       g_corr5_loc(k-1)=g_corr5_loc(k-1)
9760      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
9761       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
9762       vv(1)=pizda(1,1)+pizda(2,2)
9763       vv(2)=pizda(2,1)-pizda(1,2)
9764       if (l.eq.j+1) then
9765         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9766      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9767      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9768       else
9769         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9770      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,k))
9771      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
9772       endif
9773 C Cartesian gradient
9774       do iii=1,2
9775         do kkk=1,5
9776           do lll=1,3
9777             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
9778      &        pizda(1,1))
9779             vv(1)=pizda(1,1)+pizda(2,2)
9780             vv(2)=pizda(2,1)-pizda(1,2)
9781             derx(lll,kkk,iii)=derx(lll,kkk,iii)
9782      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,k))
9783      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
9784           enddo
9785         enddo
9786       enddo
9787 cd      goto 1112
9788 cd1111  continue
9789       if (l.eq.j+1) then
9790 cd        goto 1110
9791 C Parallel orientation
9792 C Contribution from graph III
9793         call transpose2(EUg(1,1,l),auxmat(1,1))
9794         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9795         vv(1)=pizda(1,1)-pizda(2,2)
9796         vv(2)=pizda(1,2)+pizda(2,1)
9797         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
9798      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9799 C Explicit gradient in virtual-dihedral angles.
9800         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9801      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
9802      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
9803         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9804         vv(1)=pizda(1,1)-pizda(2,2)
9805         vv(2)=pizda(1,2)+pizda(2,1)
9806         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9807      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
9808      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9809         call transpose2(EUgder(1,1,l),auxmat1(1,1))
9810         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9811         vv(1)=pizda(1,1)-pizda(2,2)
9812         vv(2)=pizda(1,2)+pizda(2,1)
9813         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9814      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
9815      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
9816 C Cartesian gradient
9817         do iii=1,2
9818           do kkk=1,5
9819             do lll=1,3
9820               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9821      &          pizda(1,1))
9822               vv(1)=pizda(1,1)-pizda(2,2)
9823               vv(2)=pizda(1,2)+pizda(2,1)
9824               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9825      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
9826      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
9827             enddo
9828           enddo
9829         enddo
9830 cd        goto 1112
9831 C Contribution from graph IV
9832 cd1110    continue
9833         call transpose2(EE(1,1,l),auxmat(1,1))
9834         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9835         vv(1)=pizda(1,1)+pizda(2,2)
9836         vv(2)=pizda(2,1)-pizda(1,2)
9837         eello5_4=scalar2(AEAb1(1,2,2),b1(1,l))
9838      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
9839 C Explicit gradient in virtual-dihedral angles.
9840         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9841      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
9842         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9843         vv(1)=pizda(1,1)+pizda(2,2)
9844         vv(2)=pizda(2,1)-pizda(1,2)
9845         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9846      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,l))
9847      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
9848 C Cartesian gradient
9849         do iii=1,2
9850           do kkk=1,5
9851             do lll=1,3
9852               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9853      &          pizda(1,1))
9854               vv(1)=pizda(1,1)+pizda(2,2)
9855               vv(2)=pizda(2,1)-pizda(1,2)
9856               derx(lll,kkk,iii)=derx(lll,kkk,iii)
9857      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,l))
9858      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
9859             enddo
9860           enddo
9861         enddo
9862       else
9863 C Antiparallel orientation
9864 C Contribution from graph III
9865 c        goto 1110
9866         call transpose2(EUg(1,1,j),auxmat(1,1))
9867         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
9868         vv(1)=pizda(1,1)-pizda(2,2)
9869         vv(2)=pizda(1,2)+pizda(2,1)
9870         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
9871      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9872 C Explicit gradient in virtual-dihedral angles.
9873         g_corr5_loc(l-1)=g_corr5_loc(l-1)
9874      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
9875      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
9876         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
9877         vv(1)=pizda(1,1)-pizda(2,2)
9878         vv(2)=pizda(1,2)+pizda(2,1)
9879         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9880      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
9881      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9882         call transpose2(EUgder(1,1,j),auxmat1(1,1))
9883         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
9884         vv(1)=pizda(1,1)-pizda(2,2)
9885         vv(2)=pizda(1,2)+pizda(2,1)
9886         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9887      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
9888      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
9889 C Cartesian gradient
9890         do iii=1,2
9891           do kkk=1,5
9892             do lll=1,3
9893               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
9894      &          pizda(1,1))
9895               vv(1)=pizda(1,1)-pizda(2,2)
9896               vv(2)=pizda(1,2)+pizda(2,1)
9897               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9898      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
9899      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
9900             enddo
9901           enddo
9902         enddo
9903 cd        goto 1112
9904 C Contribution from graph IV
9905 1110    continue
9906         call transpose2(EE(1,1,j),auxmat(1,1))
9907         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
9908         vv(1)=pizda(1,1)+pizda(2,2)
9909         vv(2)=pizda(2,1)-pizda(1,2)
9910         eello5_4=scalar2(AEAb1(1,2,2),b1(1,j))
9911      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
9912 C Explicit gradient in virtual-dihedral angles.
9913         g_corr5_loc(j-1)=g_corr5_loc(j-1)
9914      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
9915         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
9916         vv(1)=pizda(1,1)+pizda(2,2)
9917         vv(2)=pizda(2,1)-pizda(1,2)
9918         g_corr5_loc(k-1)=g_corr5_loc(k-1)
9919      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,j))
9920      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
9921 C Cartesian gradient
9922         do iii=1,2
9923           do kkk=1,5
9924             do lll=1,3
9925               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
9926      &          pizda(1,1))
9927               vv(1)=pizda(1,1)+pizda(2,2)
9928               vv(2)=pizda(2,1)-pizda(1,2)
9929               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
9930      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,j))
9931      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
9932             enddo
9933           enddo
9934         enddo
9935       endif
9936 1112  continue
9937       eel5=eello5_1+eello5_2+eello5_3+eello5_4
9938 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
9939 cd        write (2,*) 'ijkl',i,j,k,l
9940 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
9941 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
9942 cd      endif
9943 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
9944 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
9945 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
9946 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
9947       if (j.lt.nres-1) then
9948         j1=j+1
9949         j2=j-1
9950       else
9951         j1=j-1
9952         j2=j-2
9953       endif
9954       if (l.lt.nres-1) then
9955         l1=l+1
9956         l2=l-1
9957       else
9958         l1=l-1
9959         l2=l-2
9960       endif
9961 cd      eij=1.0d0
9962 cd      ekl=1.0d0
9963 cd      ekont=1.0d0
9964 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
9965 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
9966 C        summed up outside the subrouine as for the other subroutines
9967 C        handling long-range interactions. The old code is commented out
9968 C        with "cgrad" to keep track of changes.
9969       do ll=1,3
9970 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
9971 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
9972         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
9973         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
9974 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
9975 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
9976 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
9977 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
9978 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
9979 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
9980 c     &   gradcorr5ij,
9981 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
9982 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
9983 cgrad        ghalf=0.5d0*ggg1(ll)
9984 cd        ghalf=0.0d0
9985         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
9986         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
9987         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
9988         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
9989         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
9990         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
9991 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
9992 cgrad        ghalf=0.5d0*ggg2(ll)
9993 cd        ghalf=0.0d0
9994         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
9995         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
9996         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
9997         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
9998         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
9999         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
10000       enddo
10001 cd      goto 1112
10002 cgrad      do m=i+1,j-1
10003 cgrad        do ll=1,3
10004 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
10005 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
10006 cgrad        enddo
10007 cgrad      enddo
10008 cgrad      do m=k+1,l-1
10009 cgrad        do ll=1,3
10010 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
10011 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
10012 cgrad        enddo
10013 cgrad      enddo
10014 c1112  continue
10015 cgrad      do m=i+2,j2
10016 cgrad        do ll=1,3
10017 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
10018 cgrad        enddo
10019 cgrad      enddo
10020 cgrad      do m=k+2,l2
10021 cgrad        do ll=1,3
10022 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
10023 cgrad        enddo
10024 cgrad      enddo
10025 cd      do iii=1,nres-3
10026 cd        write (2,*) iii,g_corr5_loc(iii)
10027 cd      enddo
10028       eello5=ekont*eel5
10029 cd      write (2,*) 'ekont',ekont
10030 cd      write (iout,*) 'eello5',ekont*eel5
10031       return
10032       end
10033 c--------------------------------------------------------------------------
10034       double precision function eello6(i,j,k,l,jj,kk)
10035       implicit real*8 (a-h,o-z)
10036       include 'DIMENSIONS'
10037       include 'COMMON.IOUNITS'
10038       include 'COMMON.CHAIN'
10039       include 'COMMON.DERIV'
10040       include 'COMMON.INTERACT'
10041       include 'COMMON.CONTACTS'
10042       include 'COMMON.TORSION'
10043       include 'COMMON.VAR'
10044       include 'COMMON.GEO'
10045       include 'COMMON.FFIELD'
10046       double precision ggg1(3),ggg2(3)
10047 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10048 cd        eello6=0.0d0
10049 cd        return
10050 cd      endif
10051 cd      write (iout,*)
10052 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10053 cd     &   ' and',k,l
10054       eello6_1=0.0d0
10055       eello6_2=0.0d0
10056       eello6_3=0.0d0
10057       eello6_4=0.0d0
10058       eello6_5=0.0d0
10059       eello6_6=0.0d0
10060 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
10061 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
10062       do iii=1,2
10063         do kkk=1,5
10064           do lll=1,3
10065             derx(lll,kkk,iii)=0.0d0
10066           enddo
10067         enddo
10068       enddo
10069 cd      eij=facont_hb(jj,i)
10070 cd      ekl=facont_hb(kk,k)
10071 cd      ekont=eij*ekl
10072 cd      eij=1.0d0
10073 cd      ekl=1.0d0
10074 cd      ekont=1.0d0
10075       if (l.eq.j+1) then
10076         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10077         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
10078         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
10079         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10080         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
10081         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
10082       else
10083         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
10084         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
10085         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
10086         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
10087         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
10088           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10089         else
10090           eello6_5=0.0d0
10091         endif
10092         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
10093       endif
10094 C If turn contributions are considered, they will be handled separately.
10095       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
10096 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
10097 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
10098 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
10099 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
10100 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
10101 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
10102 cd      goto 1112
10103       if (j.lt.nres-1) then
10104         j1=j+1
10105         j2=j-1
10106       else
10107         j1=j-1
10108         j2=j-2
10109       endif
10110       if (l.lt.nres-1) then
10111         l1=l+1
10112         l2=l-1
10113       else
10114         l1=l-1
10115         l2=l-2
10116       endif
10117       do ll=1,3
10118 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
10119 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
10120 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
10121 cgrad        ghalf=0.5d0*ggg1(ll)
10122 cd        ghalf=0.0d0
10123         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
10124         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
10125         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
10126         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
10127         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
10128         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
10129         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
10130         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
10131 cgrad        ghalf=0.5d0*ggg2(ll)
10132 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
10133 cd        ghalf=0.0d0
10134         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
10135         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
10136         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
10137         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
10138         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
10139         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
10140       enddo
10141 cd      goto 1112
10142 cgrad      do m=i+1,j-1
10143 cgrad        do ll=1,3
10144 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
10145 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
10146 cgrad        enddo
10147 cgrad      enddo
10148 cgrad      do m=k+1,l-1
10149 cgrad        do ll=1,3
10150 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
10151 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
10152 cgrad        enddo
10153 cgrad      enddo
10154 cgrad1112  continue
10155 cgrad      do m=i+2,j2
10156 cgrad        do ll=1,3
10157 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
10158 cgrad        enddo
10159 cgrad      enddo
10160 cgrad      do m=k+2,l2
10161 cgrad        do ll=1,3
10162 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
10163 cgrad        enddo
10164 cgrad      enddo
10165 cd      do iii=1,nres-3
10166 cd        write (2,*) iii,g_corr6_loc(iii)
10167 cd      enddo
10168       eello6=ekont*eel6
10169 cd      write (2,*) 'ekont',ekont
10170 cd      write (iout,*) 'eello6',ekont*eel6
10171       return
10172       end
10173 c--------------------------------------------------------------------------
10174       double precision function eello6_graph1(i,j,k,l,imat,swap)
10175       implicit real*8 (a-h,o-z)
10176       include 'DIMENSIONS'
10177       include 'COMMON.IOUNITS'
10178       include 'COMMON.CHAIN'
10179       include 'COMMON.DERIV'
10180       include 'COMMON.INTERACT'
10181       include 'COMMON.CONTACTS'
10182       include 'COMMON.TORSION'
10183       include 'COMMON.VAR'
10184       include 'COMMON.GEO'
10185       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
10186       logical swap
10187       logical lprn
10188       common /kutas/ lprn
10189 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10190 C                                                                              C
10191 C      Parallel       Antiparallel                                             C
10192 C                                                                              C
10193 C          o             o                                                     C
10194 C         /l\           /j\                                                    C
10195 C        /   \         /   \                                                   C
10196 C       /| o |         | o |\                                                  C
10197 C     \ j|/k\|  /   \  |/k\|l /                                                C
10198 C      \ /   \ /     \ /   \ /                                                 C
10199 C       o     o       o     o                                                  C
10200 C       i             i                                                        C
10201 C                                                                              C
10202 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10203       itk=itype2loc(itype(k))
10204       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
10205       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
10206       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
10207       call transpose2(EUgC(1,1,k),auxmat(1,1))
10208       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10209       vv1(1)=pizda1(1,1)-pizda1(2,2)
10210       vv1(2)=pizda1(1,2)+pizda1(2,1)
10211       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10212       vv(1)=AEAb1(1,2,imat)*b1(1,k)-AEAb1(2,2,imat)*b1(2,k)
10213       vv(2)=AEAb1(1,2,imat)*b1(2,k)+AEAb1(2,2,imat)*b1(1,k)
10214       s5=scalar2(vv(1),Dtobr2(1,i))
10215 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
10216       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
10217       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
10218      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
10219      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
10220      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
10221      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
10222      & +scalar2(vv(1),Dtobr2der(1,i)))
10223       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
10224       vv1(1)=pizda1(1,1)-pizda1(2,2)
10225       vv1(2)=pizda1(1,2)+pizda1(2,1)
10226       vv(1)=AEAb1derg(1,2,imat)*b1(1,k)-AEAb1derg(2,2,imat)*b1(2,k)
10227       vv(2)=AEAb1derg(1,2,imat)*b1(2,k)+AEAb1derg(2,2,imat)*b1(1,k)
10228       if (l.eq.j+1) then
10229         g_corr6_loc(l-1)=g_corr6_loc(l-1)
10230      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10231      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10232      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10233      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10234       else
10235         g_corr6_loc(j-1)=g_corr6_loc(j-1)
10236      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
10237      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
10238      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
10239      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
10240       endif
10241       call transpose2(EUgCder(1,1,k),auxmat(1,1))
10242       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
10243       vv1(1)=pizda1(1,1)-pizda1(2,2)
10244       vv1(2)=pizda1(1,2)+pizda1(2,1)
10245       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
10246      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
10247      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
10248      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
10249       do iii=1,2
10250         if (swap) then
10251           ind=3-iii
10252         else
10253           ind=iii
10254         endif
10255         do kkk=1,5
10256           do lll=1,3
10257             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
10258             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
10259             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
10260             call transpose2(EUgC(1,1,k),auxmat(1,1))
10261             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10262      &        pizda1(1,1))
10263             vv1(1)=pizda1(1,1)-pizda1(2,2)
10264             vv1(2)=pizda1(1,2)+pizda1(2,1)
10265             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
10266             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,k)
10267      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,k)
10268             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,k)
10269      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,k)
10270             s5=scalar2(vv(1),Dtobr2(1,i))
10271             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
10272           enddo
10273         enddo
10274       enddo
10275       return
10276       end
10277 c----------------------------------------------------------------------------
10278       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
10279       implicit real*8 (a-h,o-z)
10280       include 'DIMENSIONS'
10281       include 'COMMON.IOUNITS'
10282       include 'COMMON.CHAIN'
10283       include 'COMMON.DERIV'
10284       include 'COMMON.INTERACT'
10285       include 'COMMON.CONTACTS'
10286       include 'COMMON.TORSION'
10287       include 'COMMON.VAR'
10288       include 'COMMON.GEO'
10289       logical swap
10290       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10291      & auxvec1(2),auxvec2(2),auxmat1(2,2)
10292       logical lprn
10293       common /kutas/ lprn
10294 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10295 C                                                                              C
10296 C      Parallel       Antiparallel                                             C
10297 C                                                                              C
10298 C          o             o                                                     C
10299 C     \   /l\           /j\   /                                                C
10300 C      \ /   \         /   \ /                                                 C
10301 C       o| o |         | o |o                                                  C
10302 C     \ j|/k\|      \  |/k\|l                                                  C
10303 C      \ /   \       \ /   \                                                   C
10304 C       o             o                                                        C
10305 C       i             i                                                        C
10306 C                                                                              C
10307 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10308 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
10309 C AL 7/4/01 s1 would occur in the sixth-order moment,
10310 C           but not in a cluster cumulant
10311 #ifdef MOMENT
10312       s1=dip(1,jj,i)*dip(1,kk,k)
10313 #endif
10314       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
10315       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10316       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
10317       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
10318       call transpose2(EUg(1,1,k),auxmat(1,1))
10319       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
10320       vv(1)=pizda(1,1)-pizda(2,2)
10321       vv(2)=pizda(1,2)+pizda(2,1)
10322       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10323 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10324 #ifdef MOMENT
10325       eello6_graph2=-(s1+s2+s3+s4)
10326 #else
10327       eello6_graph2=-(s2+s3+s4)
10328 #endif
10329 c      eello6_graph2=-s3
10330 C Derivatives in gamma(i-1)
10331       if (i.gt.1) then
10332 #ifdef MOMENT
10333         s1=dipderg(1,jj,i)*dip(1,kk,k)
10334 #endif
10335         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10336         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
10337         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10338         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10339 #ifdef MOMENT
10340         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10341 #else
10342         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10343 #endif
10344 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
10345       endif
10346 C Derivatives in gamma(k-1)
10347 #ifdef MOMENT
10348       s1=dip(1,jj,i)*dipderg(1,kk,k)
10349 #endif
10350       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
10351       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10352       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
10353       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10354       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10355       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
10356       vv(1)=pizda(1,1)-pizda(2,2)
10357       vv(2)=pizda(1,2)+pizda(2,1)
10358       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10359 #ifdef MOMENT
10360       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10361 #else
10362       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10363 #endif
10364 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
10365 C Derivatives in gamma(j-1) or gamma(l-1)
10366       if (j.gt.1) then
10367 #ifdef MOMENT
10368         s1=dipderg(3,jj,i)*dip(1,kk,k)
10369 #endif
10370         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
10371         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10372         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
10373         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
10374         vv(1)=pizda(1,1)-pizda(2,2)
10375         vv(2)=pizda(1,2)+pizda(2,1)
10376         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10377 #ifdef MOMENT
10378         if (swap) then
10379           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10380         else
10381           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10382         endif
10383 #endif
10384         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
10385 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
10386       endif
10387 C Derivatives in gamma(l-1) or gamma(j-1)
10388       if (l.gt.1) then
10389 #ifdef MOMENT
10390         s1=dip(1,jj,i)*dipderg(3,kk,k)
10391 #endif
10392         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
10393         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
10394         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
10395         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
10396         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
10397         vv(1)=pizda(1,1)-pizda(2,2)
10398         vv(2)=pizda(1,2)+pizda(2,1)
10399         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10400 #ifdef MOMENT
10401         if (swap) then
10402           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
10403         else
10404           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
10405         endif
10406 #endif
10407         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
10408 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
10409       endif
10410 C Cartesian derivatives.
10411       if (lprn) then
10412         write (2,*) 'In eello6_graph2'
10413         do iii=1,2
10414           write (2,*) 'iii=',iii
10415           do kkk=1,5
10416             write (2,*) 'kkk=',kkk
10417             do jjj=1,2
10418               write (2,'(3(2f10.5),5x)')
10419      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
10420             enddo
10421           enddo
10422         enddo
10423       endif
10424       do iii=1,2
10425         do kkk=1,5
10426           do lll=1,3
10427 #ifdef MOMENT
10428             if (iii.eq.1) then
10429               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
10430             else
10431               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
10432             endif
10433 #endif
10434             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
10435      &        auxvec(1))
10436             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
10437             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
10438      &        auxvec(1))
10439             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
10440             call transpose2(EUg(1,1,k),auxmat(1,1))
10441             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
10442      &        pizda(1,1))
10443             vv(1)=pizda(1,1)-pizda(2,2)
10444             vv(2)=pizda(1,2)+pizda(2,1)
10445             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
10446 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
10447 #ifdef MOMENT
10448             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10449 #else
10450             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10451 #endif
10452             if (swap) then
10453               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10454             else
10455               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10456             endif
10457           enddo
10458         enddo
10459       enddo
10460       return
10461       end
10462 c----------------------------------------------------------------------------
10463       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
10464       implicit real*8 (a-h,o-z)
10465       include 'DIMENSIONS'
10466       include 'COMMON.IOUNITS'
10467       include 'COMMON.CHAIN'
10468       include 'COMMON.DERIV'
10469       include 'COMMON.INTERACT'
10470       include 'COMMON.CONTACTS'
10471       include 'COMMON.TORSION'
10472       include 'COMMON.VAR'
10473       include 'COMMON.GEO'
10474       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
10475       logical swap
10476 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10477 C                                                                              C
10478 C      Parallel       Antiparallel                                             C
10479 C                                                                              C
10480 C          o             o                                                     C
10481 C         /l\   /   \   /j\                                                    C
10482 C        /   \ /     \ /   \                                                   C
10483 C       /| o |o       o| o |\                                                  C
10484 C       j|/k\|  /      |/k\|l /                                                C
10485 C        /   \ /       /   \ /                                                 C
10486 C       /     o       /     o                                                  C
10487 C       i             i                                                        C
10488 C                                                                              C
10489 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10490 C
10491 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10492 C           energy moment and not to the cluster cumulant.
10493       iti=itortyp(itype(i))
10494       if (j.lt.nres-1) then
10495         itj1=itype2loc(itype(j+1))
10496       else
10497         itj1=nloctyp
10498       endif
10499       itk=itype2loc(itype(k))
10500       itk1=itype2loc(itype(k+1))
10501       if (l.lt.nres-1) then
10502         itl1=itype2loc(itype(l+1))
10503       else
10504         itl1=nloctyp
10505       endif
10506 #ifdef MOMENT
10507       s1=dip(4,jj,i)*dip(4,kk,k)
10508 #endif
10509       call matvec2(AECA(1,1,1),b1(1,k+1),auxvec(1))
10510       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10511       call matvec2(AECA(1,1,2),b1(1,l+1),auxvec(1))
10512       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10513       call transpose2(EE(1,1,k),auxmat(1,1))
10514       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
10515       vv(1)=pizda(1,1)+pizda(2,2)
10516       vv(2)=pizda(2,1)-pizda(1,2)
10517       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10518 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
10519 cd     & "sum",-(s2+s3+s4)
10520 #ifdef MOMENT
10521       eello6_graph3=-(s1+s2+s3+s4)
10522 #else
10523       eello6_graph3=-(s2+s3+s4)
10524 #endif
10525 c      eello6_graph3=-s4
10526 C Derivatives in gamma(k-1)
10527       call matvec2(AECAderg(1,1,2),b1(1,l+1),auxvec(1))
10528       s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10529       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
10530       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
10531 C Derivatives in gamma(l-1)
10532       call matvec2(AECAderg(1,1,1),b1(1,k+1),auxvec(1))
10533       s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10534       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
10535       vv(1)=pizda(1,1)+pizda(2,2)
10536       vv(2)=pizda(2,1)-pizda(1,2)
10537       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10538       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10539 C Cartesian derivatives.
10540       do iii=1,2
10541         do kkk=1,5
10542           do lll=1,3
10543 #ifdef MOMENT
10544             if (iii.eq.1) then
10545               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
10546             else
10547               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
10548             endif
10549 #endif
10550             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,k+1),
10551      &        auxvec(1))
10552             s2=0.5d0*scalar2(b1(1,k),auxvec(1))
10553             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,l+1),
10554      &        auxvec(1))
10555             s3=0.5d0*scalar2(b1(1,j+1),auxvec(1))
10556             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
10557      &        pizda(1,1))
10558             vv(1)=pizda(1,1)+pizda(2,2)
10559             vv(2)=pizda(2,1)-pizda(1,2)
10560             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
10561 #ifdef MOMENT
10562             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10563 #else
10564             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10565 #endif
10566             if (swap) then
10567               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10568             else
10569               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10570             endif
10571 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
10572           enddo
10573         enddo
10574       enddo
10575       return
10576       end
10577 c----------------------------------------------------------------------------
10578       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
10579       implicit real*8 (a-h,o-z)
10580       include 'DIMENSIONS'
10581       include 'COMMON.IOUNITS'
10582       include 'COMMON.CHAIN'
10583       include 'COMMON.DERIV'
10584       include 'COMMON.INTERACT'
10585       include 'COMMON.CONTACTS'
10586       include 'COMMON.TORSION'
10587       include 'COMMON.VAR'
10588       include 'COMMON.GEO'
10589       include 'COMMON.FFIELD'
10590       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
10591      & auxvec1(2),auxmat1(2,2)
10592       logical swap
10593 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10594 C                                                                              C
10595 C      Parallel       Antiparallel                                             C
10596 C                                                                              C
10597 C          o             o                                                     C
10598 C         /l\   /   \   /j\                                                    C
10599 C        /   \ /     \ /   \                                                   C
10600 C       /| o |o       o| o |\                                                  C
10601 C     \ j|/k\|      \  |/k\|l                                                  C
10602 C      \ /   \       \ /   \                                                   C
10603 C       o     \       o     \                                                  C
10604 C       i             i                                                        C
10605 C                                                                              C
10606 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
10607 C
10608 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
10609 C           energy moment and not to the cluster cumulant.
10610 cd      write (2,*) 'eello_graph4: wturn6',wturn6
10611       iti=itype2loc(itype(i))
10612       itj=itype2loc(itype(j))
10613       if (j.lt.nres-1) then
10614         itj1=itype2loc(itype(j+1))
10615       else
10616         itj1=nloctyp
10617       endif
10618       itk=itype2loc(itype(k))
10619       if (k.lt.nres-1) then
10620         itk1=itype2loc(itype(k+1))
10621       else
10622         itk1=nloctyp
10623       endif
10624       itl=itype2loc(itype(l))
10625       if (l.lt.nres-1) then
10626         itl1=itype2loc(itype(l+1))
10627       else
10628         itl1=nloctyp
10629       endif
10630 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
10631 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
10632 cd     & ' itl',itl,' itl1',itl1
10633 #ifdef MOMENT
10634       if (imat.eq.1) then
10635         s1=dip(3,jj,i)*dip(3,kk,k)
10636       else
10637         s1=dip(2,jj,j)*dip(2,kk,l)
10638       endif
10639 #endif
10640       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
10641       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10642       if (j.eq.l+1) then
10643         call matvec2(ADtEA1(1,1,3-imat),b1(1,j+1),auxvec1(1))
10644         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10645       else
10646         call matvec2(ADtEA1(1,1,3-imat),b1(1,l+1),auxvec1(1))
10647         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10648       endif
10649       call transpose2(EUg(1,1,k),auxmat(1,1))
10650       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
10651       vv(1)=pizda(1,1)-pizda(2,2)
10652       vv(2)=pizda(2,1)+pizda(1,2)
10653       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10654 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
10655 #ifdef MOMENT
10656       eello6_graph4=-(s1+s2+s3+s4)
10657 #else
10658       eello6_graph4=-(s2+s3+s4)
10659 #endif
10660 C Derivatives in gamma(i-1)
10661       if (i.gt.1) then
10662 #ifdef MOMENT
10663         if (imat.eq.1) then
10664           s1=dipderg(2,jj,i)*dip(3,kk,k)
10665         else
10666           s1=dipderg(4,jj,j)*dip(2,kk,l)
10667         endif
10668 #endif
10669         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
10670         if (j.eq.l+1) then
10671           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,j+1),auxvec1(1))
10672           s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10673         else
10674           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,l+1),auxvec1(1))
10675           s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10676         endif
10677         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
10678         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10679 cd          write (2,*) 'turn6 derivatives'
10680 #ifdef MOMENT
10681           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
10682 #else
10683           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
10684 #endif
10685         else
10686 #ifdef MOMENT
10687           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
10688 #else
10689           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
10690 #endif
10691         endif
10692       endif
10693 C Derivatives in gamma(k-1)
10694 #ifdef MOMENT
10695       if (imat.eq.1) then
10696         s1=dip(3,jj,i)*dipderg(2,kk,k)
10697       else
10698         s1=dip(2,jj,j)*dipderg(4,kk,l)
10699       endif
10700 #endif
10701       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
10702       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
10703       if (j.eq.l+1) then
10704         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,j+1),auxvec1(1))
10705         s3=-0.5d0*scalar2(b1(1,j),auxvec1(1))
10706       else
10707         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,l+1),auxvec1(1))
10708         s3=-0.5d0*scalar2(b1(1,l),auxvec1(1))
10709       endif
10710       call transpose2(EUgder(1,1,k),auxmat1(1,1))
10711       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
10712       vv(1)=pizda(1,1)-pizda(2,2)
10713       vv(2)=pizda(2,1)+pizda(1,2)
10714       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10715       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10716 #ifdef MOMENT
10717         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
10718 #else
10719         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
10720 #endif
10721       else
10722 #ifdef MOMENT
10723         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
10724 #else
10725         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
10726 #endif
10727       endif
10728 C Derivatives in gamma(j-1) or gamma(l-1)
10729       if (l.eq.j+1 .and. l.gt.1) then
10730         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10731         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10732         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10733         vv(1)=pizda(1,1)-pizda(2,2)
10734         vv(2)=pizda(2,1)+pizda(1,2)
10735         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10736         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
10737       else if (j.gt.1) then
10738         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
10739         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10740         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
10741         vv(1)=pizda(1,1)-pizda(2,2)
10742         vv(2)=pizda(2,1)+pizda(1,2)
10743         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10744         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10745           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
10746         else
10747           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
10748         endif
10749       endif
10750 C Cartesian derivatives.
10751       do iii=1,2
10752         do kkk=1,5
10753           do lll=1,3
10754 #ifdef MOMENT
10755             if (iii.eq.1) then
10756               if (imat.eq.1) then
10757                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
10758               else
10759                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
10760               endif
10761             else
10762               if (imat.eq.1) then
10763                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
10764               else
10765                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
10766               endif
10767             endif
10768 #endif
10769             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
10770      &        auxvec(1))
10771             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
10772             if (j.eq.l+1) then
10773               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10774      &          b1(1,j+1),auxvec(1))
10775               s3=-0.5d0*scalar2(b1(1,j),auxvec(1))
10776             else
10777               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
10778      &          b1(1,l+1),auxvec(1))
10779               s3=-0.5d0*scalar2(b1(1,l),auxvec(1))
10780             endif
10781             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
10782      &        pizda(1,1))
10783             vv(1)=pizda(1,1)-pizda(2,2)
10784             vv(2)=pizda(2,1)+pizda(1,2)
10785             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
10786             if (swap) then
10787               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
10788 #ifdef MOMENT
10789                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10790      &             -(s1+s2+s4)
10791 #else
10792                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
10793      &             -(s2+s4)
10794 #endif
10795                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
10796               else
10797 #ifdef MOMENT
10798                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
10799 #else
10800                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
10801 #endif
10802                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10803               endif
10804             else
10805 #ifdef MOMENT
10806               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
10807 #else
10808               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
10809 #endif
10810               if (l.eq.j+1) then
10811                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
10812               else
10813                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
10814               endif
10815             endif
10816           enddo
10817         enddo
10818       enddo
10819       return
10820       end
10821 c----------------------------------------------------------------------------
10822       double precision function eello_turn6(i,jj,kk)
10823       implicit real*8 (a-h,o-z)
10824       include 'DIMENSIONS'
10825       include 'COMMON.IOUNITS'
10826       include 'COMMON.CHAIN'
10827       include 'COMMON.DERIV'
10828       include 'COMMON.INTERACT'
10829       include 'COMMON.CONTACTS'
10830       include 'COMMON.TORSION'
10831       include 'COMMON.VAR'
10832       include 'COMMON.GEO'
10833       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
10834      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
10835      &  ggg1(3),ggg2(3)
10836       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
10837      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
10838 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
10839 C           the respective energy moment and not to the cluster cumulant.
10840       s1=0.0d0
10841       s8=0.0d0
10842       s13=0.0d0
10843 c
10844       eello_turn6=0.0d0
10845       j=i+4
10846       k=i+1
10847       l=i+3
10848       iti=itype2loc(itype(i))
10849       itk=itype2loc(itype(k))
10850       itk1=itype2loc(itype(k+1))
10851       itl=itype2loc(itype(l))
10852       itj=itype2loc(itype(j))
10853 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
10854 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
10855 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
10856 cd        eello6=0.0d0
10857 cd        return
10858 cd      endif
10859 cd      write (iout,*)
10860 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
10861 cd     &   ' and',k,l
10862 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
10863       do iii=1,2
10864         do kkk=1,5
10865           do lll=1,3
10866             derx_turn(lll,kkk,iii)=0.0d0
10867           enddo
10868         enddo
10869       enddo
10870 cd      eij=1.0d0
10871 cd      ekl=1.0d0
10872 cd      ekont=1.0d0
10873       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
10874 cd      eello6_5=0.0d0
10875 cd      write (2,*) 'eello6_5',eello6_5
10876 #ifdef MOMENT
10877       call transpose2(AEA(1,1,1),auxmat(1,1))
10878       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
10879       ss1=scalar2(Ub2(1,i+2),b1(1,l))
10880       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
10881 #endif
10882       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
10883       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
10884       s2 = scalar2(b1(1,k),vtemp1(1))
10885 #ifdef MOMENT
10886       call transpose2(AEA(1,1,2),atemp(1,1))
10887       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
10888       call matvec2(Ug2(1,1,i+2),dd(1,1,k+1),vtemp2(1))
10889       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10890 #endif
10891       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
10892       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
10893       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
10894 #ifdef MOMENT
10895       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
10896       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
10897       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
10898       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
10899       ss13 = scalar2(b1(1,k),vtemp4(1))
10900       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
10901 #endif
10902 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
10903 c      s1=0.0d0
10904 c      s2=0.0d0
10905 c      s8=0.0d0
10906 c      s12=0.0d0
10907 c      s13=0.0d0
10908       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
10909 C Derivatives in gamma(i+2)
10910       s1d =0.0d0
10911       s8d =0.0d0
10912 #ifdef MOMENT
10913       call transpose2(AEA(1,1,1),auxmatd(1,1))
10914       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10915       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10916       call transpose2(AEAderg(1,1,2),atempd(1,1))
10917       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
10918       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10919 #endif
10920       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
10921       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10922       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10923 c      s1d=0.0d0
10924 c      s2d=0.0d0
10925 c      s8d=0.0d0
10926 c      s12d=0.0d0
10927 c      s13d=0.0d0
10928       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
10929 C Derivatives in gamma(i+3)
10930 #ifdef MOMENT
10931       call transpose2(AEA(1,1,1),auxmatd(1,1))
10932       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10933       ss1d=scalar2(Ub2der(1,i+2),b1(1,l))
10934       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
10935 #endif
10936       call matvec2(EUgder(1,1,i+2),b1(1,l),vtemp1d(1))
10937       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
10938       s2d = scalar2(b1(1,k),vtemp1d(1))
10939 #ifdef MOMENT
10940       call matvec2(Ug2der(1,1,i+2),dd(1,1,k+1),vtemp2d(1))
10941       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,l),vtemp2d(1))
10942 #endif
10943       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
10944 #ifdef MOMENT
10945       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
10946       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
10947       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10948 #endif
10949 c      s1d=0.0d0
10950 c      s2d=0.0d0
10951 c      s8d=0.0d0
10952 c      s12d=0.0d0
10953 c      s13d=0.0d0
10954 #ifdef MOMENT
10955       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10956      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
10957 #else
10958       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
10959      &               -0.5d0*ekont*(s2d+s12d)
10960 #endif
10961 C Derivatives in gamma(i+4)
10962       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
10963       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
10964       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10965 #ifdef MOMENT
10966       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
10967       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
10968       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
10969 #endif
10970 c      s1d=0.0d0
10971 c      s2d=0.0d0
10972 c      s8d=0.0d0
10973 C      s12d=0.0d0
10974 c      s13d=0.0d0
10975 #ifdef MOMENT
10976       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
10977 #else
10978       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
10979 #endif
10980 C Derivatives in gamma(i+5)
10981 #ifdef MOMENT
10982       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
10983       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
10984       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
10985 #endif
10986       call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1d(1))
10987       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
10988       s2d = scalar2(b1(1,k),vtemp1d(1))
10989 #ifdef MOMENT
10990       call transpose2(AEA(1,1,2),atempd(1,1))
10991       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
10992       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,l),vtemp2(1))
10993 #endif
10994       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
10995       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
10996 #ifdef MOMENT
10997       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
10998       ss13d = scalar2(b1(1,k),vtemp4d(1))
10999       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11000 #endif
11001 c      s1d=0.0d0
11002 c      s2d=0.0d0
11003 c      s8d=0.0d0
11004 c      s12d=0.0d0
11005 c      s13d=0.0d0
11006 #ifdef MOMENT
11007       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11008      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
11009 #else
11010       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
11011      &               -0.5d0*ekont*(s2d+s12d)
11012 #endif
11013 C Cartesian derivatives
11014       do iii=1,2
11015         do kkk=1,5
11016           do lll=1,3
11017 #ifdef MOMENT
11018             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
11019             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
11020             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
11021 #endif
11022             call matvec2(EUg(1,1,i+2),b1(1,l),vtemp1(1))
11023             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
11024      &          vtemp1d(1))
11025             s2d = scalar2(b1(1,k),vtemp1d(1))
11026 #ifdef MOMENT
11027             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
11028             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
11029             s8d = -(atempd(1,1)+atempd(2,2))*
11030      &           scalar2(cc(1,1,l),vtemp2(1))
11031 #endif
11032             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
11033      &           auxmatd(1,1))
11034             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
11035             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
11036 c      s1d=0.0d0
11037 c      s2d=0.0d0
11038 c      s8d=0.0d0
11039 c      s12d=0.0d0
11040 c      s13d=0.0d0
11041 #ifdef MOMENT
11042             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11043      &        - 0.5d0*(s1d+s2d)
11044 #else
11045             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
11046      &        - 0.5d0*s2d
11047 #endif
11048 #ifdef MOMENT
11049             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11050      &        - 0.5d0*(s8d+s12d)
11051 #else
11052             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
11053      &        - 0.5d0*s12d
11054 #endif
11055           enddo
11056         enddo
11057       enddo
11058 #ifdef MOMENT
11059       do kkk=1,5
11060         do lll=1,3
11061           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
11062      &      achuj_tempd(1,1))
11063           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
11064           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
11065           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
11066           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
11067           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
11068      &      vtemp4d(1))
11069           ss13d = scalar2(b1(1,k),vtemp4d(1))
11070           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
11071           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
11072         enddo
11073       enddo
11074 #endif
11075 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
11076 cd     &  16*eel_turn6_num
11077 cd      goto 1112
11078       if (j.lt.nres-1) then
11079         j1=j+1
11080         j2=j-1
11081       else
11082         j1=j-1
11083         j2=j-2
11084       endif
11085       if (l.lt.nres-1) then
11086         l1=l+1
11087         l2=l-1
11088       else
11089         l1=l-1
11090         l2=l-2
11091       endif
11092       do ll=1,3
11093 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
11094 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
11095 cgrad        ghalf=0.5d0*ggg1(ll)
11096 cd        ghalf=0.0d0
11097         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
11098         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
11099         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
11100      &    +ekont*derx_turn(ll,2,1)
11101         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
11102         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
11103      &    +ekont*derx_turn(ll,4,1)
11104         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
11105         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
11106         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
11107 cgrad        ghalf=0.5d0*ggg2(ll)
11108 cd        ghalf=0.0d0
11109         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
11110      &    +ekont*derx_turn(ll,2,2)
11111         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
11112         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
11113      &    +ekont*derx_turn(ll,4,2)
11114         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
11115         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
11116         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
11117       enddo
11118 cd      goto 1112
11119 cgrad      do m=i+1,j-1
11120 cgrad        do ll=1,3
11121 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
11122 cgrad        enddo
11123 cgrad      enddo
11124 cgrad      do m=k+1,l-1
11125 cgrad        do ll=1,3
11126 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
11127 cgrad        enddo
11128 cgrad      enddo
11129 cgrad1112  continue
11130 cgrad      do m=i+2,j2
11131 cgrad        do ll=1,3
11132 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
11133 cgrad        enddo
11134 cgrad      enddo
11135 cgrad      do m=k+2,l2
11136 cgrad        do ll=1,3
11137 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
11138 cgrad        enddo
11139 cgrad      enddo
11140 cd      do iii=1,nres-3
11141 cd        write (2,*) iii,g_corr6_loc(iii)
11142 cd      enddo
11143       eello_turn6=ekont*eel_turn6
11144 cd      write (2,*) 'ekont',ekont
11145 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
11146       return
11147       end
11148
11149 C-----------------------------------------------------------------------------
11150       double precision function scalar(u,v)
11151 !DIR$ INLINEALWAYS scalar
11152 #ifndef OSF
11153 cDEC$ ATTRIBUTES FORCEINLINE::scalar
11154 #endif
11155       implicit none
11156       double precision u(3),v(3)
11157 cd      double precision sc
11158 cd      integer i
11159 cd      sc=0.0d0
11160 cd      do i=1,3
11161 cd        sc=sc+u(i)*v(i)
11162 cd      enddo
11163 cd      scalar=sc
11164
11165       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
11166       return
11167       end
11168 crc-------------------------------------------------
11169       SUBROUTINE MATVEC2(A1,V1,V2)
11170 !DIR$ INLINEALWAYS MATVEC2
11171 #ifndef OSF
11172 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
11173 #endif
11174       implicit real*8 (a-h,o-z)
11175       include 'DIMENSIONS'
11176       DIMENSION A1(2,2),V1(2),V2(2)
11177 c      DO 1 I=1,2
11178 c        VI=0.0
11179 c        DO 3 K=1,2
11180 c    3     VI=VI+A1(I,K)*V1(K)
11181 c        Vaux(I)=VI
11182 c    1 CONTINUE
11183
11184       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
11185       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
11186
11187       v2(1)=vaux1
11188       v2(2)=vaux2
11189       END
11190 C---------------------------------------
11191       SUBROUTINE MATMAT2(A1,A2,A3)
11192 #ifndef OSF
11193 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
11194 #endif
11195       implicit real*8 (a-h,o-z)
11196       include 'DIMENSIONS'
11197       DIMENSION A1(2,2),A2(2,2),A3(2,2)
11198 c      DIMENSION AI3(2,2)
11199 c        DO  J=1,2
11200 c          A3IJ=0.0
11201 c          DO K=1,2
11202 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
11203 c          enddo
11204 c          A3(I,J)=A3IJ
11205 c       enddo
11206 c      enddo
11207
11208       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
11209       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
11210       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
11211       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
11212
11213       A3(1,1)=AI3_11
11214       A3(2,1)=AI3_21
11215       A3(1,2)=AI3_12
11216       A3(2,2)=AI3_22
11217       END
11218
11219 c-------------------------------------------------------------------------
11220       double precision function scalar2(u,v)
11221 !DIR$ INLINEALWAYS scalar2
11222       implicit none
11223       double precision u(2),v(2)
11224       double precision sc
11225       integer i
11226       scalar2=u(1)*v(1)+u(2)*v(2)
11227       return
11228       end
11229
11230 C-----------------------------------------------------------------------------
11231
11232       subroutine transpose2(a,at)
11233 !DIR$ INLINEALWAYS transpose2
11234 #ifndef OSF
11235 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
11236 #endif
11237       implicit none
11238       double precision a(2,2),at(2,2)
11239       at(1,1)=a(1,1)
11240       at(1,2)=a(2,1)
11241       at(2,1)=a(1,2)
11242       at(2,2)=a(2,2)
11243       return
11244       end
11245 c--------------------------------------------------------------------------
11246       subroutine transpose(n,a,at)
11247       implicit none
11248       integer n,i,j
11249       double precision a(n,n),at(n,n)
11250       do i=1,n
11251         do j=1,n
11252           at(j,i)=a(i,j)
11253         enddo
11254       enddo
11255       return
11256       end
11257 C---------------------------------------------------------------------------
11258       subroutine prodmat3(a1,a2,kk,transp,prod)
11259 !DIR$ INLINEALWAYS prodmat3
11260 #ifndef OSF
11261 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
11262 #endif
11263       implicit none
11264       integer i,j
11265       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
11266       logical transp
11267 crc      double precision auxmat(2,2),prod_(2,2)
11268
11269       if (transp) then
11270 crc        call transpose2(kk(1,1),auxmat(1,1))
11271 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
11272 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11273
11274            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
11275      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
11276            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
11277      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
11278            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
11279      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
11280            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
11281      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
11282
11283       else
11284 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
11285 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
11286
11287            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
11288      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
11289            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
11290      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
11291            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
11292      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
11293            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
11294      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
11295
11296       endif
11297 c      call transpose2(a2(1,1),a2t(1,1))
11298
11299 crc      print *,transp
11300 crc      print *,((prod_(i,j),i=1,2),j=1,2)
11301 crc      print *,((prod(i,j),i=1,2),j=1,2)
11302
11303       return
11304       end
11305 CCC----------------------------------------------
11306       subroutine Eliptransfer(eliptran)
11307       implicit real*8 (a-h,o-z)
11308       include 'DIMENSIONS'
11309       include 'COMMON.GEO'
11310       include 'COMMON.VAR'
11311       include 'COMMON.LOCAL'
11312       include 'COMMON.CHAIN'
11313       include 'COMMON.DERIV'
11314       include 'COMMON.NAMES'
11315       include 'COMMON.INTERACT'
11316       include 'COMMON.IOUNITS'
11317       include 'COMMON.CALC'
11318       include 'COMMON.CONTROL'
11319       include 'COMMON.SPLITELE'
11320       include 'COMMON.SBRIDGE'
11321 C this is done by Adasko
11322 C      print *,"wchodze"
11323 C structure of box:
11324 C      water
11325 C--bordliptop-- buffore starts
11326 C--bufliptop--- here true lipid starts
11327 C      lipid
11328 C--buflipbot--- lipid ends buffore starts
11329 C--bordlipbot--buffore ends
11330       eliptran=0.0
11331       do i=ilip_start,ilip_end
11332 C       do i=1,1
11333         if (itype(i).eq.ntyp1) cycle
11334
11335         positi=(mod(((c(3,i)+c(3,i+1))/2.0d0),boxzsize))
11336         if (positi.le.0.0) positi=positi+boxzsize
11337 C        print *,i
11338 C first for peptide groups
11339 c for each residue check if it is in lipid or lipid water border area
11340        if ((positi.gt.bordlipbot)
11341      &.and.(positi.lt.bordliptop)) then
11342 C the energy transfer exist
11343         if (positi.lt.buflipbot) then
11344 C what fraction I am in
11345          fracinbuf=1.0d0-
11346      &        ((positi-bordlipbot)/lipbufthick)
11347 C lipbufthick is thickenes of lipid buffore
11348          sslip=sscalelip(fracinbuf)
11349          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11350          eliptran=eliptran+sslip*pepliptran
11351          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11352          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11353 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11354
11355 C        print *,"doing sccale for lower part"
11356 C         print *,i,sslip,fracinbuf,ssgradlip
11357         elseif (positi.gt.bufliptop) then
11358          fracinbuf=1.0d0-((bordliptop-positi)/lipbufthick)
11359          sslip=sscalelip(fracinbuf)
11360          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11361          eliptran=eliptran+sslip*pepliptran
11362          gliptranc(3,i)=gliptranc(3,i)+ssgradlip*pepliptran/2.0d0
11363          gliptranc(3,i-1)=gliptranc(3,i-1)+ssgradlip*pepliptran/2.0d0
11364 C         gliptranc(3,i-2)=gliptranc(3,i)+ssgradlip*pepliptran
11365 C          print *, "doing sscalefor top part"
11366 C         print *,i,sslip,fracinbuf,ssgradlip
11367         else
11368          eliptran=eliptran+pepliptran
11369 C         print *,"I am in true lipid"
11370         endif
11371 C       else
11372 C       eliptran=elpitran+0.0 ! I am in water
11373        endif
11374        enddo
11375 C       print *, "nic nie bylo w lipidzie?"
11376 C now multiply all by the peptide group transfer factor
11377 C       eliptran=eliptran*pepliptran
11378 C now the same for side chains
11379 CV       do i=1,1
11380        do i=ilip_start,ilip_end
11381         if (itype(i).eq.ntyp1) cycle
11382         positi=(mod(c(3,i+nres),boxzsize))
11383         if (positi.le.0) positi=positi+boxzsize
11384 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
11385 c for each residue check if it is in lipid or lipid water border area
11386 C       respos=mod(c(3,i+nres),boxzsize)
11387 C       print *,positi,bordlipbot,buflipbot
11388        if ((positi.gt.bordlipbot)
11389      & .and.(positi.lt.bordliptop)) then
11390 C the energy transfer exist
11391         if (positi.lt.buflipbot) then
11392          fracinbuf=1.0d0-
11393      &     ((positi-bordlipbot)/lipbufthick)
11394 C lipbufthick is thickenes of lipid buffore
11395          sslip=sscalelip(fracinbuf)
11396          ssgradlip=-sscagradlip(fracinbuf)/lipbufthick
11397          eliptran=eliptran+sslip*liptranene(itype(i))
11398          gliptranx(3,i)=gliptranx(3,i)
11399      &+ssgradlip*liptranene(itype(i))
11400          gliptranc(3,i-1)= gliptranc(3,i-1)
11401      &+ssgradlip*liptranene(itype(i))
11402 C         print *,"doing sccale for lower part"
11403         elseif (positi.gt.bufliptop) then
11404          fracinbuf=1.0d0-
11405      &((bordliptop-positi)/lipbufthick)
11406          sslip=sscalelip(fracinbuf)
11407          ssgradlip=sscagradlip(fracinbuf)/lipbufthick
11408          eliptran=eliptran+sslip*liptranene(itype(i))
11409          gliptranx(3,i)=gliptranx(3,i)
11410      &+ssgradlip*liptranene(itype(i))
11411          gliptranc(3,i-1)= gliptranc(3,i-1)
11412      &+ssgradlip*liptranene(itype(i))
11413 C          print *, "doing sscalefor top part",sslip,fracinbuf
11414         else
11415          eliptran=eliptran+liptranene(itype(i))
11416 C         print *,"I am in true lipid"
11417         endif
11418         endif ! if in lipid or buffor
11419 C       else
11420 C       eliptran=elpitran+0.0 ! I am in water
11421        enddo
11422        return
11423        end
11424 C---------------------------------------------------------
11425 C AFM soubroutine for constant force
11426        subroutine AFMforce(Eafmforce)
11427        implicit real*8 (a-h,o-z)
11428       include 'DIMENSIONS'
11429       include 'COMMON.GEO'
11430       include 'COMMON.VAR'
11431       include 'COMMON.LOCAL'
11432       include 'COMMON.CHAIN'
11433       include 'COMMON.DERIV'
11434       include 'COMMON.NAMES'
11435       include 'COMMON.INTERACT'
11436       include 'COMMON.IOUNITS'
11437       include 'COMMON.CALC'
11438       include 'COMMON.CONTROL'
11439       include 'COMMON.SPLITELE'
11440       include 'COMMON.SBRIDGE'
11441       real*8 diffafm(3)
11442       dist=0.0d0
11443       Eafmforce=0.0d0
11444       do i=1,3
11445       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11446       dist=dist+diffafm(i)**2
11447       enddo
11448       dist=dsqrt(dist)
11449       Eafmforce=-forceAFMconst*(dist-distafminit)
11450       do i=1,3
11451       gradafm(i,afmend-1)=-forceAFMconst*diffafm(i)/dist
11452       gradafm(i,afmbeg-1)=forceAFMconst*diffafm(i)/dist
11453       enddo
11454 C      print *,'AFM',Eafmforce
11455       return
11456       end
11457 C---------------------------------------------------------
11458 C AFM subroutine with pseudoconstant velocity
11459        subroutine AFMvel(Eafmforce)
11460        implicit real*8 (a-h,o-z)
11461       include 'DIMENSIONS'
11462       include 'COMMON.GEO'
11463       include 'COMMON.VAR'
11464       include 'COMMON.LOCAL'
11465       include 'COMMON.CHAIN'
11466       include 'COMMON.DERIV'
11467       include 'COMMON.NAMES'
11468       include 'COMMON.INTERACT'
11469       include 'COMMON.IOUNITS'
11470       include 'COMMON.CALC'
11471       include 'COMMON.CONTROL'
11472       include 'COMMON.SPLITELE'
11473       include 'COMMON.SBRIDGE'
11474       real*8 diffafm(3)
11475 C Only for check grad COMMENT if not used for checkgrad
11476 C      totT=3.0d0
11477 C--------------------------------------------------------
11478 C      print *,"wchodze"
11479       dist=0.0d0
11480       Eafmforce=0.0d0
11481       do i=1,3
11482       diffafm(i)=c(i,afmend)-c(i,afmbeg)
11483       dist=dist+diffafm(i)**2
11484       enddo
11485       dist=dsqrt(dist)
11486       Eafmforce=0.5d0*forceAFMconst
11487      & *(distafminit+totTafm*velAFMconst-dist)**2
11488 C      Eafmforce=-forceAFMconst*(dist-distafminit)
11489       do i=1,3
11490       gradafm(i,afmend-1)=-forceAFMconst*
11491      &(distafminit+totTafm*velAFMconst-dist)
11492      &*diffafm(i)/dist
11493       gradafm(i,afmbeg-1)=forceAFMconst*
11494      &(distafminit+totTafm*velAFMconst-dist)
11495      &*diffafm(i)/dist
11496       enddo
11497 C      print *,'AFM',Eafmforce,totTafm*velAFMconst,dist
11498       return
11499       end
11500 C-----------------------------------------------------------
11501 C first for shielding is setting of function of side-chains
11502        subroutine set_shield_fac
11503       implicit real*8 (a-h,o-z)
11504       include 'DIMENSIONS'
11505       include 'COMMON.CHAIN'
11506       include 'COMMON.DERIV'
11507       include 'COMMON.IOUNITS'
11508       include 'COMMON.SHIELD'
11509       include 'COMMON.INTERACT'
11510 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11511       double precision div77_81/0.974996043d0/,
11512      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11513
11514 C the vector between center of side_chain and peptide group
11515        double precision pep_side(3),long,side_calf(3),
11516      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11517      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11518 C the line belowe needs to be changed for FGPROC>1
11519       do i=1,nres-1
11520       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11521       ishield_list(i)=0
11522 Cif there two consequtive dummy atoms there is no peptide group between them
11523 C the line below has to be changed for FGPROC>1
11524       VolumeTotal=0.0
11525       do k=1,nres
11526        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11527        dist_pep_side=0.0
11528        dist_side_calf=0.0
11529        do j=1,3
11530 C first lets set vector conecting the ithe side-chain with kth side-chain
11531       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11532 C      pep_side(j)=2.0d0
11533 C and vector conecting the side-chain with its proper calfa
11534       side_calf(j)=c(j,k+nres)-c(j,k)
11535 C      side_calf(j)=2.0d0
11536       pept_group(j)=c(j,i)-c(j,i+1)
11537 C lets have their lenght
11538       dist_pep_side=pep_side(j)**2+dist_pep_side
11539       dist_side_calf=dist_side_calf+side_calf(j)**2
11540       dist_pept_group=dist_pept_group+pept_group(j)**2
11541       enddo
11542        dist_pep_side=dsqrt(dist_pep_side)
11543        dist_pept_group=dsqrt(dist_pept_group)
11544        dist_side_calf=dsqrt(dist_side_calf)
11545       do j=1,3
11546         pep_side_norm(j)=pep_side(j)/dist_pep_side
11547         side_calf_norm(j)=dist_side_calf
11548       enddo
11549 C now sscale fraction
11550        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11551 C       print *,buff_shield,"buff"
11552 C now sscale
11553         if (sh_frac_dist.le.0.0) cycle
11554 C If we reach here it means that this side chain reaches the shielding sphere
11555 C Lets add him to the list for gradient
11556         ishield_list(i)=ishield_list(i)+1
11557 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11558 C this list is essential otherwise problem would be O3
11559         shield_list(ishield_list(i),i)=k
11560 C Lets have the sscale value
11561         if (sh_frac_dist.gt.1.0) then
11562          scale_fac_dist=1.0d0
11563          do j=1,3
11564          sh_frac_dist_grad(j)=0.0d0
11565          enddo
11566         else
11567          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11568      &                   *(2.0*sh_frac_dist-3.0d0)
11569          fac_help_scale=6.0*(sh_frac_dist-sh_frac_dist**2)
11570      &                  /dist_pep_side/buff_shield*0.5
11571 C remember for the final gradient multiply sh_frac_dist_grad(j)
11572 C for side_chain by factor -2 !
11573          do j=1,3
11574          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11575 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11576 C     &                    sh_frac_dist_grad(j)
11577          enddo
11578         endif
11579 C        if ((i.eq.3).and.(k.eq.2)) then
11580 C        print *,i,sh_frac_dist,dist_pep,fac_help_scale,scale_fac_dist
11581 C     & ,"TU"
11582 C        endif
11583
11584 C this is what is now we have the distance scaling now volume...
11585       short=short_r_sidechain(itype(k))
11586       long=long_r_sidechain(itype(k))
11587       costhet=1.0d0/dsqrt(1.0+short**2/dist_pep_side**2)
11588 C now costhet_grad
11589 C       costhet=0.0d0
11590        costhet_fac=costhet**3*short**2*(-0.5)/dist_pep_side**4
11591 C       costhet_fac=0.0d0
11592        do j=1,3
11593          costhet_grad(j)=costhet_fac*pep_side(j)
11594        enddo
11595 C remember for the final gradient multiply costhet_grad(j)
11596 C for side_chain by factor -2 !
11597 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11598 C pep_side0pept_group is vector multiplication
11599       pep_side0pept_group=0.0
11600       do j=1,3
11601       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11602       enddo
11603       cosalfa=(pep_side0pept_group/
11604      & (dist_pep_side*dist_side_calf))
11605       fac_alfa_sin=1.0-cosalfa**2
11606       fac_alfa_sin=dsqrt(fac_alfa_sin)
11607       rkprim=fac_alfa_sin*(long-short)+short
11608 C now costhet_grad
11609        cosphi=1.0d0/dsqrt(1.0+rkprim**2/dist_pep_side**2)
11610        cosphi_fac=cosphi**3*rkprim**2*(-0.5)/dist_pep_side**4
11611
11612        do j=1,3
11613          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11614      &+cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11615      &*(long-short)/fac_alfa_sin*cosalfa/
11616      &((dist_pep_side*dist_side_calf))*
11617      &((side_calf(j))-cosalfa*
11618      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11619
11620         cosphi_grad_loc(j)=cosphi**3*0.5/dist_pep_side**2*(-rkprim)
11621      &*(long-short)/fac_alfa_sin*cosalfa
11622      &/((dist_pep_side*dist_side_calf))*
11623      &(pep_side(j)-
11624      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11625        enddo
11626
11627       VofOverlap=VSolvSphere/2.0d0*(1.0-costhet)*(1.0-cosphi)
11628      &                    /VSolvSphere_div
11629      &                    *wshield
11630 C now the gradient...
11631 C grad_shield is gradient of Calfa for peptide groups
11632 C      write(iout,*) "shield_compon",i,k,VSolvSphere,scale_fac_dist,
11633 C     &               costhet,cosphi
11634 C       write(iout,*) "cosphi_compon",i,k,pep_side0pept_group,
11635 C     & dist_pep_side,dist_side_calf,c(1,k+nres),c(1,k),itype(k)
11636       do j=1,3
11637       grad_shield(j,i)=grad_shield(j,i)
11638 C gradient po skalowaniu
11639      &                +(sh_frac_dist_grad(j)
11640 C  gradient po costhet
11641      &-scale_fac_dist*costhet_grad(j)/(1.0-costhet)
11642      &-scale_fac_dist*(cosphi_grad_long(j))
11643      &/(1.0-cosphi) )*div77_81
11644      &*VofOverlap
11645 C grad_shield_side is Cbeta sidechain gradient
11646       grad_shield_side(j,ishield_list(i),i)=
11647      &        (sh_frac_dist_grad(j)*(-2.0d0)
11648      &       +scale_fac_dist*costhet_grad(j)*2.0d0/(1.0-costhet)
11649      &       +scale_fac_dist*(cosphi_grad_long(j))
11650      &        *2.0d0/(1.0-cosphi))
11651      &        *div77_81*VofOverlap
11652
11653        grad_shield_loc(j,ishield_list(i),i)=
11654      &   scale_fac_dist*cosphi_grad_loc(j)
11655      &        *2.0d0/(1.0-cosphi)
11656      &        *div77_81*VofOverlap
11657       enddo
11658       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11659       enddo
11660       fac_shield(i)=VolumeTotal*div77_81+div4_81
11661 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i)
11662       enddo
11663       return
11664       end
11665 C--------------------------------------------------------------------------
11666       double precision function tschebyshev(m,n,x,y)
11667       implicit none
11668       include "DIMENSIONS"
11669       integer i,m,n
11670       double precision x(n),y,yy(0:maxvar),aux
11671 c Tschebyshev polynomial. Note that the first term is omitted
11672 c m=0: the constant term is included
11673 c m=1: the constant term is not included
11674       yy(0)=1.0d0
11675       yy(1)=y
11676       do i=2,n
11677         yy(i)=2*yy(1)*yy(i-1)-yy(i-2)
11678       enddo
11679       aux=0.0d0
11680       do i=m,n
11681         aux=aux+x(i)*yy(i)
11682       enddo
11683       tschebyshev=aux
11684       return
11685       end
11686 C--------------------------------------------------------------------------
11687       double precision function gradtschebyshev(m,n,x,y)
11688       implicit none
11689       include "DIMENSIONS"
11690       integer i,m,n
11691       double precision x(n+1),y,yy(0:maxvar),aux
11692 c Tschebyshev polynomial. Note that the first term is omitted
11693 c m=0: the constant term is included
11694 c m=1: the constant term is not included
11695       yy(0)=1.0d0
11696       yy(1)=2.0d0*y
11697       do i=2,n
11698         yy(i)=2*y*yy(i-1)-yy(i-2)
11699       enddo
11700       aux=0.0d0
11701       do i=m,n
11702         aux=aux+x(i+1)*yy(i)*(i+1)
11703 C        print *, x(i+1),yy(i),i
11704       enddo
11705       gradtschebyshev=aux
11706       return
11707       end
11708 C------------------------------------------------------------------------
11709 C first for shielding is setting of function of side-chains
11710        subroutine set_shield_fac2
11711       implicit real*8 (a-h,o-z)
11712       include 'DIMENSIONS'
11713       include 'COMMON.CHAIN'
11714       include 'COMMON.DERIV'
11715       include 'COMMON.IOUNITS'
11716       include 'COMMON.SHIELD'
11717       include 'COMMON.INTERACT'
11718 C this is the squar root 77 devided by 81 the epislion in lipid (in protein)
11719       double precision div77_81/0.974996043d0/,
11720      &div4_81/0.2222222222d0/,sh_frac_dist_grad(3)
11721
11722 C the vector between center of side_chain and peptide group
11723        double precision pep_side(3),long,side_calf(3),
11724      &pept_group(3),costhet_grad(3),cosphi_grad_long(3),
11725      &cosphi_grad_loc(3),pep_side_norm(3),side_calf_norm(3)
11726 C the line belowe needs to be changed for FGPROC>1
11727       do i=1,nres-1
11728       if ((itype(i).eq.ntyp1).and.itype(i+1).eq.ntyp1) cycle
11729       ishield_list(i)=0
11730 Cif there two consequtive dummy atoms there is no peptide group between them
11731 C the line below has to be changed for FGPROC>1
11732       VolumeTotal=0.0
11733       do k=1,nres
11734        if ((itype(k).eq.ntyp1).or.(itype(k).eq.10)) cycle
11735        dist_pep_side=0.0
11736        dist_side_calf=0.0
11737        do j=1,3
11738 C first lets set vector conecting the ithe side-chain with kth side-chain
11739       pep_side(j)=c(j,k+nres)-(c(j,i)+c(j,i+1))/2.0d0
11740 C      pep_side(j)=2.0d0
11741 C and vector conecting the side-chain with its proper calfa
11742       side_calf(j)=c(j,k+nres)-c(j,k)
11743 C      side_calf(j)=2.0d0
11744       pept_group(j)=c(j,i)-c(j,i+1)
11745 C lets have their lenght
11746       dist_pep_side=pep_side(j)**2+dist_pep_side
11747       dist_side_calf=dist_side_calf+side_calf(j)**2
11748       dist_pept_group=dist_pept_group+pept_group(j)**2
11749       enddo
11750        dist_pep_side=dsqrt(dist_pep_side)
11751        dist_pept_group=dsqrt(dist_pept_group)
11752        dist_side_calf=dsqrt(dist_side_calf)
11753       do j=1,3
11754         pep_side_norm(j)=pep_side(j)/dist_pep_side
11755         side_calf_norm(j)=dist_side_calf
11756       enddo
11757 C now sscale fraction
11758        sh_frac_dist=-(dist_pep_side-rpp(1,1)-buff_shield)/buff_shield
11759 C       print *,buff_shield,"buff"
11760 C now sscale
11761         if (sh_frac_dist.le.0.0) cycle
11762 C If we reach here it means that this side chain reaches the shielding sphere
11763 C Lets add him to the list for gradient
11764         ishield_list(i)=ishield_list(i)+1
11765 C ishield_list is a list of non 0 side-chain that contribute to factor gradient
11766 C this list is essential otherwise problem would be O3
11767         shield_list(ishield_list(i),i)=k
11768 C Lets have the sscale value
11769         if (sh_frac_dist.gt.1.0) then
11770          scale_fac_dist=1.0d0
11771          do j=1,3
11772          sh_frac_dist_grad(j)=0.0d0
11773          enddo
11774         else
11775          scale_fac_dist=-sh_frac_dist*sh_frac_dist
11776      &                   *(2.0d0*sh_frac_dist-3.0d0)
11777          fac_help_scale=6.0d0*(sh_frac_dist-sh_frac_dist**2)
11778      &                  /dist_pep_side/buff_shield*0.5d0
11779 C remember for the final gradient multiply sh_frac_dist_grad(j)
11780 C for side_chain by factor -2 !
11781          do j=1,3
11782          sh_frac_dist_grad(j)=fac_help_scale*pep_side(j)
11783 C         sh_frac_dist_grad(j)=0.0d0
11784 C         scale_fac_dist=1.0d0
11785 C         print *,"jestem",scale_fac_dist,fac_help_scale,
11786 C     &                    sh_frac_dist_grad(j)
11787          enddo
11788         endif
11789 C this is what is now we have the distance scaling now volume...
11790       short=short_r_sidechain(itype(k))
11791       long=long_r_sidechain(itype(k))
11792       costhet=1.0d0/dsqrt(1.0d0+short**2/dist_pep_side**2)
11793       sinthet=short/dist_pep_side*costhet
11794 C now costhet_grad
11795 C       costhet=0.6d0
11796 C       sinthet=0.8
11797        costhet_fac=costhet**3*short**2*(-0.5d0)/dist_pep_side**4
11798 C       sinthet_fac=costhet**2*0.5d0*(short**3/dist_pep_side**4*costhet
11799 C     &             -short/dist_pep_side**2/costhet)
11800 C       costhet_fac=0.0d0
11801        do j=1,3
11802          costhet_grad(j)=costhet_fac*pep_side(j)
11803        enddo
11804 C remember for the final gradient multiply costhet_grad(j)
11805 C for side_chain by factor -2 !
11806 C fac alfa is angle between CB_k,CA_k, CA_i,CA_i+1
11807 C pep_side0pept_group is vector multiplication
11808       pep_side0pept_group=0.0d0
11809       do j=1,3
11810       pep_side0pept_group=pep_side0pept_group+pep_side(j)*side_calf(j)
11811       enddo
11812       cosalfa=(pep_side0pept_group/
11813      & (dist_pep_side*dist_side_calf))
11814       fac_alfa_sin=1.0d0-cosalfa**2
11815       fac_alfa_sin=dsqrt(fac_alfa_sin)
11816       rkprim=fac_alfa_sin*(long-short)+short
11817 C      rkprim=short
11818
11819 C now costhet_grad
11820        cosphi=1.0d0/dsqrt(1.0d0+rkprim**2/dist_pep_side**2)
11821 C       cosphi=0.6
11822        cosphi_fac=cosphi**3*rkprim**2*(-0.5d0)/dist_pep_side**4
11823        sinphi=rkprim/dist_pep_side/dsqrt(1.0d0+rkprim**2/
11824      &      dist_pep_side**2)
11825 C       sinphi=0.8
11826        do j=1,3
11827          cosphi_grad_long(j)=cosphi_fac*pep_side(j)
11828      &+cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11829      &*(long-short)/fac_alfa_sin*cosalfa/
11830      &((dist_pep_side*dist_side_calf))*
11831      &((side_calf(j))-cosalfa*
11832      &((pep_side(j)/dist_pep_side)*dist_side_calf))
11833 C       cosphi_grad_long(j)=0.0d0
11834         cosphi_grad_loc(j)=cosphi**3*0.5d0/dist_pep_side**2*(-rkprim)
11835      &*(long-short)/fac_alfa_sin*cosalfa
11836      &/((dist_pep_side*dist_side_calf))*
11837      &(pep_side(j)-
11838      &cosalfa*side_calf(j)/dist_side_calf*dist_pep_side)
11839 C       cosphi_grad_loc(j)=0.0d0
11840        enddo
11841 C      print *,sinphi,sinthet
11842 c      write (iout,*) "VSolvSphere",VSolvSphere," VSolvSphere_div",
11843 c     &  VSolvSphere_div," sinphi",sinphi," sinthet",sinthet
11844       VofOverlap=VSolvSphere/2.0d0*(1.0d0-dsqrt(1.0d0-sinphi*sinthet))
11845      &                    /VSolvSphere_div
11846 C     &                    *wshield
11847 C now the gradient...
11848       do j=1,3
11849       grad_shield(j,i)=grad_shield(j,i)
11850 C gradient po skalowaniu
11851      &                +(sh_frac_dist_grad(j)*VofOverlap
11852 C  gradient po costhet
11853      &       +scale_fac_dist*VSolvSphere/VSolvSphere_div/4.0d0*
11854      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11855      &       sinphi/sinthet*costhet*costhet_grad(j)
11856      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11857      & )*wshield
11858 C grad_shield_side is Cbeta sidechain gradient
11859       grad_shield_side(j,ishield_list(i),i)=
11860      &        (sh_frac_dist_grad(j)*(-2.0d0)
11861      &        *VofOverlap
11862      &       -scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11863      &(1.0d0/(-dsqrt(1.0d0-sinphi*sinthet))*(
11864      &       sinphi/sinthet*costhet*costhet_grad(j)
11865      &      +sinthet/sinphi*cosphi*cosphi_grad_long(j)))
11866      &       )*wshield
11867
11868        grad_shield_loc(j,ishield_list(i),i)=
11869      &       scale_fac_dist*VSolvSphere/VSolvSphere_div/2.0d0*
11870      &(1.0d0/(dsqrt(1.0d0-sinphi*sinthet))*(
11871      &       sinthet/sinphi*cosphi*cosphi_grad_loc(j)
11872      &        ))
11873      &        *wshield
11874       enddo
11875 c      write (iout,*) "VofOverlap",VofOverlap," scale_fac_dist",
11876 c     & scale_fac_dist
11877       VolumeTotal=VolumeTotal+VofOverlap*scale_fac_dist
11878       enddo
11879       fac_shield(i)=VolumeTotal*wshield+(1.0d0-wshield)
11880 c      write(2,*) "TOTAL VOLUME",i,VolumeTotal,fac_shield(i),
11881 c     &  " wshield",wshield
11882 c      write(2,*) "TU",rpp(1,1),short,long,buff_shield
11883       enddo
11884       return
11885       end
11886 C-----------------------------------------------------------------------
11887 C-----------------------------------------------------------
11888 C This subroutine is to mimic the histone like structure but as well can be
11889 C utilizet to nanostructures (infinit) small modification has to be used to
11890 C make it finite (z gradient at the ends has to be changes as well as the x,y
11891 C gradient has to be modified at the ends
11892 C The energy function is Kihara potential
11893 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
11894 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
11895 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
11896 C simple Kihara potential
11897       subroutine calctube(Etube)
11898        implicit real*8 (a-h,o-z)
11899       include 'DIMENSIONS'
11900       include 'COMMON.GEO'
11901       include 'COMMON.VAR'
11902       include 'COMMON.LOCAL'
11903       include 'COMMON.CHAIN'
11904       include 'COMMON.DERIV'
11905       include 'COMMON.NAMES'
11906       include 'COMMON.INTERACT'
11907       include 'COMMON.IOUNITS'
11908       include 'COMMON.CALC'
11909       include 'COMMON.CONTROL'
11910       include 'COMMON.SPLITELE'
11911       include 'COMMON.SBRIDGE'
11912       double precision tub_r,vectube(3),enetube(maxres*2)
11913       Etube=0.0d0
11914       do i=1,2*nres
11915         enetube(i)=0.0d0
11916       enddo
11917 C first we calculate the distance from tube center
11918 C first sugare-phosphate group for NARES this would be peptide group
11919 C for UNRES
11920       do i=1,nres
11921 C lets ommit dummy atoms for now
11922        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
11923 C now calculate distance from center of tube and direction vectors
11924       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
11925           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11926       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
11927           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11928       vectube(1)=vectube(1)-tubecenter(1)
11929       vectube(2)=vectube(2)-tubecenter(2)
11930
11931 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
11932 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
11933
11934 C as the tube is infinity we do not calculate the Z-vector use of Z
11935 C as chosen axis
11936       vectube(3)=0.0d0
11937 C now calculte the distance
11938        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11939 C now normalize vector
11940       vectube(1)=vectube(1)/tub_r
11941       vectube(2)=vectube(2)/tub_r
11942 C calculte rdiffrence between r and r0
11943       rdiff=tub_r-tubeR0
11944 C and its 6 power
11945       rdiff6=rdiff**6.0d0
11946 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11947        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
11948 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
11949 C       print *,rdiff,rdiff6,pep_aa_tube
11950 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11951 C now we calculate gradient
11952        fac=(-12.0d0*pep_aa_tube/rdiff6+
11953      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
11954 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
11955 C     &rdiff,fac
11956
11957 C now direction of gg_tube vector
11958         do j=1,3
11959         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
11960         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
11961         enddo
11962         enddo
11963 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
11964         do i=1,nres
11965 C Lets not jump over memory as we use many times iti
11966          iti=itype(i)
11967 C lets ommit dummy atoms for now
11968          if ((iti.eq.ntyp1)
11969 C in UNRES uncomment the line below as GLY has no side-chain...
11970 C      .or.(iti.eq.10)
11971      &   ) cycle
11972           vectube(1)=c(1,i+nres)
11973           vectube(1)=mod(vectube(1),boxxsize)
11974           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
11975           vectube(2)=c(2,i+nres)
11976           vectube(2)=mod(vectube(2),boxxsize)
11977           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
11978
11979       vectube(1)=vectube(1)-tubecenter(1)
11980       vectube(2)=vectube(2)-tubecenter(2)
11981
11982 C as the tube is infinity we do not calculate the Z-vector use of Z
11983 C as chosen axis
11984       vectube(3)=0.0d0
11985 C now calculte the distance
11986        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
11987 C now normalize vector
11988       vectube(1)=vectube(1)/tub_r
11989       vectube(2)=vectube(2)/tub_r
11990 C calculte rdiffrence between r and r0
11991       rdiff=tub_r-tubeR0
11992 C and its 6 power
11993       rdiff6=rdiff**6.0d0
11994 C for vectorization reasons we will sumup at the end to avoid depenence of previous
11995        sc_aa_tube=sc_aa_tube_par(iti)
11996        sc_bb_tube=sc_bb_tube_par(iti)
11997        enetube(i+nres)=sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6
11998 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
11999 C now we calculate gradient
12000        fac=-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12001      &       6.0d0*sc_bb_tube/rdiff6/rdiff
12002 C now direction of gg_tube vector
12003          do j=1,3
12004           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12005           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12006          enddo
12007         enddo
12008         do i=1,2*nres
12009           Etube=Etube+enetube(i)
12010         enddo
12011 C        print *,"ETUBE", etube
12012         return
12013         end
12014 C TO DO 1) add to total energy
12015 C       2) add to gradient summation
12016 C       3) add reading parameters (AND of course oppening of PARAM file)
12017 C       4) add reading the center of tube
12018 C       5) add COMMONs
12019 C       6) add to zerograd
12020
12021 C-----------------------------------------------------------------------
12022 C-----------------------------------------------------------
12023 C This subroutine is to mimic the histone like structure but as well can be
12024 C utilizet to nanostructures (infinit) small modification has to be used to
12025 C make it finite (z gradient at the ends has to be changes as well as the x,y
12026 C gradient has to be modified at the ends
12027 C The energy function is Kihara potential
12028 C E=4esp*((sigma/(r-r0))^12 - (sigma/(r-r0))^6)
12029 C 4eps is depth of well sigma is r_minimum r is distance from center of tube
12030 C and r0 is the excluded size of nanotube (can be set to 0 if we want just a
12031 C simple Kihara potential
12032       subroutine calctube2(Etube)
12033        implicit real*8 (a-h,o-z)
12034       include 'DIMENSIONS'
12035       include 'COMMON.GEO'
12036       include 'COMMON.VAR'
12037       include 'COMMON.LOCAL'
12038       include 'COMMON.CHAIN'
12039       include 'COMMON.DERIV'
12040       include 'COMMON.NAMES'
12041       include 'COMMON.INTERACT'
12042       include 'COMMON.IOUNITS'
12043       include 'COMMON.CALC'
12044       include 'COMMON.CONTROL'
12045       include 'COMMON.SPLITELE'
12046       include 'COMMON.SBRIDGE'
12047       double precision tub_r,vectube(3),enetube(maxres*2)
12048       Etube=0.0d0
12049       do i=1,2*nres
12050         enetube(i)=0.0d0
12051       enddo
12052 C first we calculate the distance from tube center
12053 C first sugare-phosphate group for NARES this would be peptide group
12054 C for UNRES
12055       do i=1,nres
12056 C lets ommit dummy atoms for now
12057        if ((itype(i).eq.ntyp1).or.(itype(i+1).eq.ntyp1)) cycle
12058 C now calculate distance from center of tube and direction vectors
12059       vectube(1)=mod((c(1,i)+c(1,i+1))/2.0d0,boxxsize)
12060           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12061       vectube(2)=mod((c(2,i)+c(2,i+1))/2.0d0,boxxsize)
12062           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12063       vectube(1)=vectube(1)-tubecenter(1)
12064       vectube(2)=vectube(2)-tubecenter(2)
12065
12066 C      print *,"x",(c(1,i)+c(1,i+1))/2.0d0,tubecenter(1)
12067 C      print *,"y",(c(2,i)+c(2,i+1))/2.0d0,tubecenter(2)
12068
12069 C as the tube is infinity we do not calculate the Z-vector use of Z
12070 C as chosen axis
12071       vectube(3)=0.0d0
12072 C now calculte the distance
12073        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12074 C now normalize vector
12075       vectube(1)=vectube(1)/tub_r
12076       vectube(2)=vectube(2)/tub_r
12077 C calculte rdiffrence between r and r0
12078       rdiff=tub_r-tubeR0
12079 C and its 6 power
12080       rdiff6=rdiff**6.0d0
12081 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12082        enetube(i)=pep_aa_tube/rdiff6**2.0d0-pep_bb_tube/rdiff6
12083 C       write(iout,*) "TU13",i,rdiff6,enetube(i)
12084 C       print *,rdiff,rdiff6,pep_aa_tube
12085 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12086 C now we calculate gradient
12087        fac=(-12.0d0*pep_aa_tube/rdiff6+
12088      &       6.0d0*pep_bb_tube)/rdiff6/rdiff
12089 C       write(iout,'(a5,i4,f12.1,3f12.5)') "TU13",i,rdiff6,enetube(i),
12090 C     &rdiff,fac
12091
12092 C now direction of gg_tube vector
12093         do j=1,3
12094         gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac/2.0d0
12095         gg_tube(j,i)=gg_tube(j,i)+vectube(j)*fac/2.0d0
12096         enddo
12097         enddo
12098 C basically thats all code now we split for side-chains (REMEMBER to sum up at the END)
12099         do i=1,nres
12100 C Lets not jump over memory as we use many times iti
12101          iti=itype(i)
12102 C lets ommit dummy atoms for now
12103          if ((iti.eq.ntyp1)
12104 C in UNRES uncomment the line below as GLY has no side-chain...
12105      &      .or.(iti.eq.10)
12106      &   ) cycle
12107           vectube(1)=c(1,i+nres)
12108           vectube(1)=mod(vectube(1),boxxsize)
12109           if (vectube(1).lt.0) vectube(1)=vectube(1)+boxxsize
12110           vectube(2)=c(2,i+nres)
12111           vectube(2)=mod(vectube(2),boxxsize)
12112           if (vectube(2).lt.0) vectube(2)=vectube(2)+boxxsize
12113
12114       vectube(1)=vectube(1)-tubecenter(1)
12115       vectube(2)=vectube(2)-tubecenter(2)
12116 C THIS FRAGMENT MAKES TUBE FINITE
12117         positi=(mod(c(3,i+nres),boxzsize))
12118         if (positi.le.0) positi=positi+boxzsize
12119 C       print *,mod(c(3,i+nres),boxzsize),bordlipbot,bordliptop
12120 c for each residue check if it is in lipid or lipid water border area
12121 C       respos=mod(c(3,i+nres),boxzsize)
12122        print *,positi,bordtubebot,buftubebot,bordtubetop
12123        if ((positi.gt.bordtubebot)
12124      & .and.(positi.lt.bordtubetop)) then
12125 C the energy transfer exist
12126         if (positi.lt.buftubebot) then
12127          fracinbuf=1.0d0-
12128      &     ((positi-bordtubebot)/tubebufthick)
12129 C lipbufthick is thickenes of lipid buffore
12130          sstube=sscalelip(fracinbuf)
12131          ssgradtube=-sscagradlip(fracinbuf)/tubebufthick
12132          print *,ssgradtube, sstube,tubetranene(itype(i))
12133          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12134          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12135      &+ssgradtube*tubetranene(itype(i))
12136          gg_tube(3,i-1)= gg_tube(3,i-1)
12137      &+ssgradtube*tubetranene(itype(i))
12138 C         print *,"doing sccale for lower part"
12139         elseif (positi.gt.buftubetop) then
12140          fracinbuf=1.0d0-
12141      &((bordtubetop-positi)/tubebufthick)
12142          sstube=sscalelip(fracinbuf)
12143          ssgradtube=sscagradlip(fracinbuf)/tubebufthick
12144          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12145 C         gg_tube_SC(3,i)=gg_tube_SC(3,i)
12146 C     &+ssgradtube*tubetranene(itype(i))
12147 C         gg_tube(3,i-1)= gg_tube(3,i-1)
12148 C     &+ssgradtube*tubetranene(itype(i))
12149 C          print *, "doing sscalefor top part",sslip,fracinbuf
12150         else
12151          sstube=1.0d0
12152          ssgradtube=0.0d0
12153          enetube(i+nres)=enetube(i+nres)+sstube*tubetranene(itype(i))
12154 C         print *,"I am in true lipid"
12155         endif
12156         else
12157 C          sstube=0.0d0
12158 C          ssgradtube=0.0d0
12159         cycle
12160         endif ! if in lipid or buffor
12161 CEND OF FINITE FRAGMENT
12162 C as the tube is infinity we do not calculate the Z-vector use of Z
12163 C as chosen axis
12164       vectube(3)=0.0d0
12165 C now calculte the distance
12166        tub_r=dsqrt(vectube(1)**2+vectube(2)**2+vectube(3)**2)
12167 C now normalize vector
12168       vectube(1)=vectube(1)/tub_r
12169       vectube(2)=vectube(2)/tub_r
12170 C calculte rdiffrence between r and r0
12171       rdiff=tub_r-tubeR0
12172 C and its 6 power
12173       rdiff6=rdiff**6.0d0
12174 C for vectorization reasons we will sumup at the end to avoid depenence of previous
12175        sc_aa_tube=sc_aa_tube_par(iti)
12176        sc_bb_tube=sc_bb_tube_par(iti)
12177        enetube(i+nres)=(sc_aa_tube/rdiff6**2.0d0-sc_bb_tube/rdiff6)
12178      &                 *sstube+enetube(i+nres)
12179 C pep_aa_tube and pep_bb_tube are precomputed values A=4eps*sigma^12 B=4eps*sigma^6
12180 C now we calculate gradient
12181        fac=(-12.0d0*sc_aa_tube/rdiff6**2.0d0/rdiff+
12182      &       6.0d0*sc_bb_tube/rdiff6/rdiff)*sstube
12183 C now direction of gg_tube vector
12184          do j=1,3
12185           gg_tube_SC(j,i)=gg_tube_SC(j,i)+vectube(j)*fac
12186           gg_tube(j,i-1)=gg_tube(j,i-1)+vectube(j)*fac
12187          enddo
12188          gg_tube_SC(3,i)=gg_tube_SC(3,i)
12189      &+ssgradtube*enetube(i+nres)/sstube
12190          gg_tube(3,i-1)= gg_tube(3,i-1)
12191      &+ssgradtube*enetube(i+nres)/sstube
12192
12193         enddo
12194         do i=1,2*nres
12195           Etube=Etube+enetube(i)
12196         enddo
12197 C        print *,"ETUBE", etube
12198         return
12199         end
12200 C TO DO 1) add to total energy
12201 C       2) add to gradient summation
12202 C       3) add reading parameters (AND of course oppening of PARAM file)
12203 C       4) add reading the center of tube
12204 C       5) add COMMONs
12205 C       6) add to zerograd
12206 c----------------------------------------------------------------------------
12207       subroutine e_saxs(Esaxs_constr)
12208       implicit none
12209       include 'DIMENSIONS'
12210 #ifdef MPI
12211       include "mpif.h"
12212       include "COMMON.SETUP"
12213       integer IERR
12214 #endif
12215       include 'COMMON.SBRIDGE'
12216       include 'COMMON.CHAIN'
12217       include 'COMMON.GEO'
12218       include 'COMMON.DERIV'
12219       include 'COMMON.LOCAL'
12220       include 'COMMON.INTERACT'
12221       include 'COMMON.VAR'
12222       include 'COMMON.IOUNITS'
12223       include 'COMMON.MD'
12224       include 'COMMON.CONTROL'
12225       include 'COMMON.NAMES'
12226       include 'COMMON.TIME1'
12227       include 'COMMON.FFIELD'
12228 c
12229       double precision Esaxs_constr
12230       integer i,iint,j,k,l
12231       double precision PgradC(maxSAXS,3,maxres),
12232      &  PgradX(maxSAXS,3,maxres),Pcalc(maxSAXS)
12233 #ifdef MPI
12234       double precision PgradC_(maxSAXS,3,maxres),
12235      &  PgradX_(maxSAXS,3,maxres),Pcalc_(maxSAXS)
12236 #endif
12237       double precision dk,dijCACA,dijCASC,dijSCCA,dijSCSC,
12238      & sigma2CACA,sigma2CASC,sigma2SCCA,sigma2SCSC,expCACA,expCASC,
12239      & expSCCA,expSCSC,CASCgrad,SCCAgrad,SCSCgrad,aux,auxC,auxC1,
12240      & auxX,auxX1,CACAgrad,Cnorm,sigmaCACA,threesig
12241       double precision sss2,ssgrad2,rrr,sscalgrad2,sscale2
12242       double precision dist,mygauss,mygaussder
12243       external dist
12244       integer llicz,lllicz
12245       double precision time01
12246 c  SAXS restraint penalty function
12247 #ifdef DEBUG
12248       write(iout,*) "------- SAXS penalty function start -------"
12249       write (iout,*) "nsaxs",nsaxs
12250       write (iout,*) "Esaxs: iatsc_s",iatsc_s," iatsc_e",iatsc_e
12251       write (iout,*) "Psaxs"
12252       do i=1,nsaxs
12253         write (iout,'(i5,e15.5)') i, Psaxs(i)
12254       enddo
12255 #endif
12256 #ifdef TIMING
12257       time01=MPI_Wtime()
12258 #endif
12259       Esaxs_constr = 0.0d0
12260       do k=1,nsaxs
12261         Pcalc(k)=0.0d0
12262         do j=1,nres
12263           do l=1,3
12264             PgradC(k,l,j)=0.0d0
12265             PgradX(k,l,j)=0.0d0
12266           enddo
12267         enddo
12268       enddo
12269 c      lllicz=0
12270       do i=iatsc_s,iatsc_e
12271        if (itype(i).eq.ntyp1) cycle
12272        do iint=1,nint_gr(i)
12273          do j=istart(i,iint),iend(i,iint)
12274            if (itype(j).eq.ntyp1) cycle
12275 #ifdef ALLSAXS
12276            dijCACA=dist(i,j)
12277            dijCASC=dist(i,j+nres)
12278            dijSCCA=dist(i+nres,j)
12279            dijSCSC=dist(i+nres,j+nres)
12280            sigma2CACA=2.0d0/(pstok**2)
12281            sigma2CASC=4.0d0/(pstok**2+restok(itype(j))**2)
12282            sigma2SCCA=4.0d0/(pstok**2+restok(itype(i))**2)
12283            sigma2SCSC=4.0d0/(restok(itype(j))**2+restok(itype(i))**2)
12284            do k=1,nsaxs
12285              dk = distsaxs(k)
12286              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12287              if (itype(j).ne.10) then
12288              expCASC = dexp(-0.5d0*sigma2CASC*(dijCASC-dk)**2)
12289              else
12290              endif
12291              expCASC = 0.0d0
12292              if (itype(i).ne.10) then
12293              expSCCA = dexp(-0.5d0*sigma2SCCA*(dijSCCA-dk)**2)
12294              else
12295              expSCCA = 0.0d0
12296              endif
12297              if (itype(i).ne.10 .and. itype(j).ne.10) then
12298              expSCSC = dexp(-0.5d0*sigma2SCSC*(dijSCSC-dk)**2)
12299              else
12300              expSCSC = 0.0d0
12301              endif
12302              Pcalc(k) = Pcalc(k)+expCACA+expCASC+expSCCA+expSCSC
12303 #ifdef DEBUG
12304              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12305 #endif
12306              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12307              CASCgrad = sigma2CASC*(dijCASC-dk)*expCASC
12308              SCCAgrad = sigma2SCCA*(dijSCCA-dk)*expSCCA
12309              SCSCgrad = sigma2SCSC*(dijSCSC-dk)*expSCSC
12310              do l=1,3
12311 c CA CA
12312                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12313                PgradC(k,l,i) = PgradC(k,l,i)-aux
12314                PgradC(k,l,j) = PgradC(k,l,j)+aux
12315 c CA SC
12316                if (itype(j).ne.10) then
12317                aux = CASCgrad*(C(l,j+nres)-C(l,i))/dijCASC
12318                PgradC(k,l,i) = PgradC(k,l,i)-aux
12319                PgradC(k,l,j) = PgradC(k,l,j)+aux
12320                PgradX(k,l,j) = PgradX(k,l,j)+aux
12321                endif
12322 c SC CA
12323                if (itype(i).ne.10) then
12324                aux = SCCAgrad*(C(l,j)-C(l,i+nres))/dijSCCA
12325                PgradX(k,l,i) = PgradX(k,l,i)-aux
12326                PgradC(k,l,i) = PgradC(k,l,i)-aux
12327                PgradC(k,l,j) = PgradC(k,l,j)+aux
12328                endif
12329 c SC SC
12330                if (itype(i).ne.10 .and. itype(j).ne.10) then
12331                aux = SCSCgrad*(C(l,j+nres)-C(l,i+nres))/dijSCSC
12332                PgradC(k,l,i) = PgradC(k,l,i)-aux
12333                PgradC(k,l,j) = PgradC(k,l,j)+aux
12334                PgradX(k,l,i) = PgradX(k,l,i)-aux
12335                PgradX(k,l,j) = PgradX(k,l,j)+aux
12336                endif
12337              enddo ! l
12338            enddo ! k
12339 #else
12340            dijCACA=dist(i,j)
12341            sigma2CACA=scal_rad**2*0.25d0/
12342      &        (restok(itype(j))**2+restok(itype(i))**2)
12343 c           write (iout,*) "scal_rad",scal_rad," restok",restok(itype(j))
12344 c     &       ,restok(itype(i)),"sigma",1.0d0/dsqrt(sigma2CACA)
12345 #ifdef MYGAUSS
12346            sigmaCACA=dsqrt(sigma2CACA)
12347            threesig=3.0d0/sigmaCACA
12348 c           llicz=0
12349            do k=1,nsaxs
12350              dk = distsaxs(k)
12351              if (dabs(dijCACA-dk).ge.threesig) cycle
12352 c             llicz=llicz+1
12353 c             lllicz=lllicz+1
12354              aux = sigmaCACA*(dijCACA-dk)
12355              expCACA = mygauss(aux)
12356 c             if (expcaca.eq.0.0d0) cycle
12357              Pcalc(k) = Pcalc(k)+expCACA
12358              CACAgrad = -sigmaCACA*mygaussder(aux)
12359 c             write (iout,*) "i,j,k,aux",i,j,k,CACAgrad
12360              do l=1,3
12361                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12362                PgradC(k,l,i) = PgradC(k,l,i)-aux
12363                PgradC(k,l,j) = PgradC(k,l,j)+aux
12364              enddo ! l
12365            enddo ! k
12366 c           write (iout,*) "i",i," j",j," llicz",llicz
12367 #else
12368            IF (saxs_cutoff.eq.0) THEN
12369            do k=1,nsaxs
12370              dk = distsaxs(k)
12371              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)
12372              Pcalc(k) = Pcalc(k)+expCACA
12373              CACAgrad = sigma2CACA*(dijCACA-dk)*expCACA
12374              do l=1,3
12375                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12376                PgradC(k,l,i) = PgradC(k,l,i)-aux
12377                PgradC(k,l,j) = PgradC(k,l,j)+aux
12378              enddo ! l
12379            enddo ! k
12380            ELSE
12381            rrr = saxs_cutoff*2.0d0/dsqrt(sigma2CACA)
12382            do k=1,nsaxs
12383              dk = distsaxs(k)
12384 c             write (2,*) "ijk",i,j,k
12385              sss2 = sscale2(dijCACA,rrr,dk,0.3d0)
12386              if (sss2.eq.0.0d0) cycle
12387              ssgrad2 = sscalgrad2(dijCACA,rrr,dk,0.3d0)
12388              if (energy_dec) write(iout,'(a4,3i5,8f10.4)')
12389      &          'saxs',i,j,k,dijCACA,restok(itype(i)),restok(itype(j)),
12390      &          1.0d0/dsqrt(sigma2CACA),rrr,dk,
12391      &           sss2,ssgrad2
12392              expCACA = dexp(-0.5d0*sigma2CACA*(dijCACA-dk)**2)*sss2
12393              Pcalc(k) = Pcalc(k)+expCACA
12394 #ifdef DEBUG
12395              write(iout,*) "i j k Pcalc",i,j,Pcalc(k)
12396 #endif
12397              CACAgrad = -sigma2CACA*(dijCACA-dk)*expCACA+
12398      &             ssgrad2*expCACA/sss2
12399              do l=1,3
12400 c CA CA
12401                aux = CACAgrad*(C(l,j)-C(l,i))/dijCACA
12402                PgradC(k,l,i) = PgradC(k,l,i)+aux
12403                PgradC(k,l,j) = PgradC(k,l,j)-aux
12404              enddo ! l
12405            enddo ! k
12406            ENDIF
12407 #endif
12408 #endif
12409          enddo ! j
12410        enddo ! iint
12411       enddo ! i
12412 c#ifdef TIMING
12413 c      time_SAXS=time_SAXS+MPI_Wtime()-time01
12414 c#endif
12415 c      write (iout,*) "lllicz",lllicz
12416 c#ifdef TIMING
12417 c      time01=MPI_Wtime()
12418 c#endif
12419 #ifdef MPI
12420       if (nfgtasks.gt.1) then
12421        call MPI_AllReduce(Pcalc(1),Pcalc_(1),nsaxs,MPI_DOUBLE_PRECISION,
12422      &    MPI_SUM,FG_COMM,IERR)
12423 c        if (fg_rank.eq.king) then
12424           do k=1,nsaxs
12425             Pcalc(k) = Pcalc_(k)
12426           enddo
12427 c        endif
12428 c        call MPI_AllReduce(PgradC(k,1,1),PgradC_(k,1,1),3*maxsaxs*nres,
12429 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12430 c        if (fg_rank.eq.king) then
12431 c          do i=1,nres
12432 c            do l=1,3
12433 c              do k=1,nsaxs
12434 c                PgradC(k,l,i) = PgradC_(k,l,i)
12435 c              enddo
12436 c            enddo
12437 c          enddo
12438 c        endif
12439 #ifdef ALLSAXS
12440 c        call MPI_AllReduce(PgradX(k,1,1),PgradX_(k,1,1),3*maxsaxs*nres,
12441 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
12442 c        if (fg_rank.eq.king) then
12443 c          do i=1,nres
12444 c            do l=1,3
12445 c              do k=1,nsaxs
12446 c                PgradX(k,l,i) = PgradX_(k,l,i)
12447 c              enddo
12448 c            enddo
12449 c          enddo
12450 c        endif
12451 #endif
12452       endif
12453 #endif
12454       Cnorm = 0.0d0
12455       do k=1,nsaxs
12456         Cnorm = Cnorm + Pcalc(k)
12457       enddo
12458 #ifdef MPI
12459       if (fg_rank.eq.king) then
12460 #endif
12461       Esaxs_constr = dlog(Cnorm)-wsaxs0
12462       do k=1,nsaxs
12463         if (Pcalc(k).gt.0.0d0)
12464      &  Esaxs_constr = Esaxs_constr - Psaxs(k)*dlog(Pcalc(k))
12465 #ifdef DEBUG
12466         write (iout,*) "k",k," Esaxs_constr",Esaxs_constr
12467 #endif
12468       enddo
12469 #ifdef DEBUG
12470       write (iout,*) "Cnorm",Cnorm," Esaxs_constr",Esaxs_constr
12471 #endif
12472 #ifdef MPI
12473       endif
12474 #endif
12475       gsaxsC=0.0d0
12476       gsaxsX=0.0d0
12477       do i=nnt,nct
12478         do l=1,3
12479           auxC=0.0d0
12480           auxC1=0.0d0
12481           auxX=0.0d0
12482           auxX1=0.d0
12483           do k=1,nsaxs
12484             if (Pcalc(k).gt.0)
12485      &      auxC  = auxC +Psaxs(k)*PgradC(k,l,i)/Pcalc(k)
12486             auxC1 = auxC1+PgradC(k,l,i)
12487 #ifdef ALLSAXS
12488             auxX  = auxX +Psaxs(k)*PgradX(k,l,i)/Pcalc(k)
12489             auxX1 = auxX1+PgradX(k,l,i)
12490 #endif
12491           enddo
12492           gsaxsC(l,i) = auxC - auxC1/Cnorm
12493 #ifdef ALLSAXS
12494           gsaxsX(l,i) = auxX - auxX1/Cnorm
12495 #endif
12496 c          write (iout,*) "l i",l,i," gradC",wsaxs*(auxC - auxC1/Cnorm),
12497 c     *     " gradX",wsaxs*(auxX - auxX1/Cnorm)
12498 c          write (iout,*) "l i",l,i," gradC",wsaxs*gsaxsC(l,i),
12499 c     *     " gradX",wsaxs*gsaxsX(l,i)
12500         enddo
12501       enddo
12502 #ifdef TIMING
12503       time_SAXS=time_SAXS+MPI_Wtime()-time01
12504 #endif
12505 #ifdef DEBUG
12506       write (iout,*) "gsaxsc"
12507       do i=nnt,nct
12508         write (iout,'(i5,3e15.5)') i,(gsaxsc(j,i),j=1,3)
12509       enddo
12510 #endif
12511 #ifdef MPI
12512 c      endif
12513 #endif
12514       return
12515       end
12516 c----------------------------------------------------------------------------
12517       subroutine e_saxsC(Esaxs_constr)
12518       implicit none
12519       include 'DIMENSIONS'
12520 #ifdef MPI
12521       include "mpif.h"
12522       include "COMMON.SETUP"
12523       integer IERR
12524 #endif
12525       include 'COMMON.SBRIDGE'
12526       include 'COMMON.CHAIN'
12527       include 'COMMON.GEO'
12528       include 'COMMON.DERIV'
12529       include 'COMMON.LOCAL'
12530       include 'COMMON.INTERACT'
12531       include 'COMMON.VAR'
12532       include 'COMMON.IOUNITS'
12533       include 'COMMON.MD'
12534       include 'COMMON.CONTROL'
12535       include 'COMMON.NAMES'
12536       include 'COMMON.TIME1'
12537       include 'COMMON.FFIELD'
12538 c
12539       double precision Esaxs_constr
12540       integer i,iint,j,k,l
12541       double precision PgradC(3,maxres),PgradX(3,maxres),Pcalc,logPtot
12542 #ifdef MPI
12543       double precision gsaxsc_(3,maxres),gsaxsx_(3,maxres),logPtot_
12544 #endif
12545       double precision dk,dijCASPH,dijSCSPH,
12546      & sigma2CA,sigma2SC,expCASPH,expSCSPH,
12547      & CASPHgrad,SCSPHgrad,aux,auxC,auxC1,
12548      & auxX,auxX1,Cnorm
12549 c  SAXS restraint penalty function
12550 #ifdef DEBUG
12551       write(iout,*) "------- SAXS penalty function start -------"
12552       write (iout,*) "nsaxs",nsaxs
12553
12554       do i=nnt,nct
12555         print *,MyRank,"C",i,(C(j,i),j=1,3)
12556       enddo
12557       do i=nnt,nct
12558         print *,MyRank,"CSaxs",i,(Csaxs(j,i),j=1,3)
12559       enddo
12560 #endif
12561       Esaxs_constr = 0.0d0
12562       logPtot=0.0d0
12563       do j=isaxs_start,isaxs_end
12564         Pcalc=0.0d0
12565         do i=1,nres
12566           do l=1,3
12567             PgradC(l,i)=0.0d0
12568             PgradX(l,i)=0.0d0
12569           enddo
12570         enddo
12571         do i=nnt,nct
12572           if (itype(i).eq.ntyp1) cycle
12573           dijCASPH=0.0d0
12574           dijSCSPH=0.0d0
12575           do l=1,3
12576             dijCASPH=dijCASPH+(C(l,i)-Csaxs(l,j))**2
12577           enddo
12578           if (itype(i).ne.10) then
12579           do l=1,3
12580             dijSCSPH=dijSCSPH+(C(l,i+nres)-Csaxs(l,j))**2
12581           enddo
12582           endif
12583           sigma2CA=2.0d0/pstok**2
12584           sigma2SC=4.0d0/restok(itype(i))**2
12585           expCASPH = dexp(-0.5d0*sigma2CA*dijCASPH)
12586           expSCSPH = dexp(-0.5d0*sigma2SC*dijSCSPH)
12587           Pcalc = Pcalc+expCASPH+expSCSPH
12588 #ifdef DEBUG
12589           write(*,*) "processor i j Pcalc",
12590      &       MyRank,i,j,dijCASPH,dijSCSPH, Pcalc
12591 #endif
12592           CASPHgrad = sigma2CA*expCASPH
12593           SCSPHgrad = sigma2SC*expSCSPH
12594           do l=1,3
12595             aux = (C(l,i+nres)-Csaxs(l,j))*SCSPHgrad
12596             PgradX(l,i) = PgradX(l,i) + aux
12597             PgradC(l,i) = PgradC(l,i)+(C(l,i)-Csaxs(l,j))*CASPHgrad+aux
12598           enddo ! l
12599         enddo ! i
12600         do i=nnt,nct
12601           do l=1,3
12602             gsaxsc(l,i)=gsaxsc(l,i)+PgradC(l,i)/Pcalc
12603             gsaxsx(l,i)=gsaxsx(l,i)+PgradX(l,i)/Pcalc
12604           enddo
12605         enddo
12606         logPtot = logPtot - dlog(Pcalc)
12607 c        print *,"me",me,MyRank," j",j," logPcalc",-dlog(Pcalc),
12608 c     &    " logPtot",logPtot
12609       enddo ! j
12610 #ifdef MPI
12611       if (nfgtasks.gt.1) then
12612 c        write (iout,*) "logPtot before reduction",logPtot
12613         call MPI_Reduce(logPtot,logPtot_,1,MPI_DOUBLE_PRECISION,
12614      &    MPI_SUM,king,FG_COMM,IERR)
12615         logPtot = logPtot_
12616 c        write (iout,*) "logPtot after reduction",logPtot
12617         call MPI_Reduce(gsaxsC(1,1),gsaxsC_(1,1),3*nres,
12618      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12619         if (fg_rank.eq.king) then
12620           do i=1,nres
12621             do l=1,3
12622               gsaxsC(l,i) = gsaxsC_(l,i)
12623             enddo
12624           enddo
12625         endif
12626         call MPI_Reduce(gsaxsX(1,1),gsaxsX_(1,1),3*nres,
12627      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
12628         if (fg_rank.eq.king) then
12629           do i=1,nres
12630             do l=1,3
12631               gsaxsX(l,i) = gsaxsX_(l,i)
12632             enddo
12633           enddo
12634         endif
12635       endif
12636 #endif
12637       Esaxs_constr = logPtot
12638       return
12639       end
12640 c----------------------------------------------------------------------------
12641       double precision function sscale2(r,r_cut,r0,rlamb)
12642       implicit none
12643       double precision r,gamm,r_cut,r0,rlamb,rr
12644       rr = dabs(r-r0)
12645 c      write (2,*) "r",r," r_cut",r_cut," r0",r0," rlamb",rlamb
12646 c      write (2,*) "rr",rr
12647       if(rr.lt.r_cut-rlamb) then
12648         sscale2=1.0d0
12649       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
12650         gamm=(rr-(r_cut-rlamb))/rlamb
12651         sscale2=1.0d0+gamm*gamm*(2*gamm-3.0d0)
12652       else
12653         sscale2=0d0
12654       endif
12655       return
12656       end
12657 C-----------------------------------------------------------------------
12658       double precision function sscalgrad2(r,r_cut,r0,rlamb)
12659       implicit none
12660       double precision r,gamm,r_cut,r0,rlamb,rr
12661       rr = dabs(r-r0)
12662       if(rr.lt.r_cut-rlamb) then
12663         sscalgrad2=0.0d0
12664       else if(rr.le.r_cut.and.rr.ge.r_cut-rlamb) then
12665         gamm=(rr-(r_cut-rlamb))/rlamb
12666         if (r.ge.r0) then
12667           sscalgrad2=gamm*(6*gamm-6.0d0)/rlamb
12668         else
12669           sscalgrad2=-gamm*(6*gamm-6.0d0)/rlamb
12670         endif
12671       else
12672         sscalgrad2=0.0d0
12673       endif
12674       return
12675       end