source/unres/src_MD-M/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 #ifdef MPI
  28 c      print*,"ETOTAL Processor",fg_rank," absolute rank",myrank,
  29 c     & " nfgtasks",nfgtasks
  30       if (nfgtasks.gt.1) then
  31         time00=MPI_Wtime()
  32 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
  33         if (fg_rank.eq.0) then
  34           call MPI_Bcast(0,1,MPI_INTEGER,king,FG_COMM,IERROR)
  35 c          print *,"Processor",myrank," BROADCAST iorder"
  36 C FG master sets up the WEIGHTS_ array which will be broadcast to the
  37 C FG slaves as WEIGHTS array.
  38           weights_(1)=wsc
  39           weights_(2)=wscp
  40           weights_(3)=welec
  41           weights_(4)=wcorr
  42           weights_(5)=wcorr5
  43           weights_(6)=wcorr6
  44           weights_(7)=wel_loc
  45           weights_(8)=wturn3
  46           weights_(9)=wturn4
  47           weights_(10)=wturn6
  48           weights_(11)=wang
  49           weights_(12)=wscloc
  50           weights_(13)=wtor
  51           weights_(14)=wtor_d
  52           weights_(15)=wstrain
  53           weights_(16)=wvdwpp
  54           weights_(17)=wbond
  55           weights_(18)=scal14
  56           weights_(21)=wsccor
  57 C FG Master broadcasts the WEIGHTS_ array
  58           call MPI_Bcast(weights_(1),n_ene,
  59      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  60         else
  61 C FG slaves receive the WEIGHTS array
  62           call MPI_Bcast(weights(1),n_ene,
  63      &        MPI_DOUBLE_PRECISION,king,FG_COMM,IERROR)
  64           wsc=weights(1)
  65           wscp=weights(2)
  66           welec=weights(3)
  67           wcorr=weights(4)
  68           wcorr5=weights(5)
  69           wcorr6=weights(6)
  70           wel_loc=weights(7)
  71           wturn3=weights(8)
  72           wturn4=weights(9)
  73           wturn6=weights(10)
  74           wang=weights(11)
  75           wscloc=weights(12)
  76           wtor=weights(13)
  77           wtor_d=weights(14)
  78           wstrain=weights(15)
  79           wvdwpp=weights(16)
  80           wbond=weights(17)
  81           scal14=weights(18)
  82           wsccor=weights(21)
  83         endif
  84         time_Bcast=time_Bcast+MPI_Wtime()-time00
  85         time_Bcastw=time_Bcastw+MPI_Wtime()-time00
  86 c        call chainbuild_cart
  87       endif
  88 c      print *,'Processor',myrank,' calling etotal ipot=',ipot
  89 c      print *,'Processor',myrank,' nnt=',nnt,' nct=',nct
  90 #else
  91 c      if (modecalc.eq.12.or.modecalc.eq.14) then
  92 c        call int_from_cart1(.false.)
  93 c      endif
  94 #endif
  95 #ifdef TIMING
  96       time00=MPI_Wtime()
  97 #endif
  98 C
  99 C Compute the side-chain and electrostatic interaction energy
 100 C
 101       goto (101,102,103,104,105,106) ipot
 102 C Lennard-Jones potential.
 103   101 call elj(evdw)
 104 cd    print '(a)','Exit ELJ'
 105       goto 107
 106 C Lennard-Jones-Kihara potential (shifted).
 107   102 call eljk(evdw)
 108       goto 107
 109 C Berne-Pechukas potential (dilated LJ, angular dependence).
 110   103 call ebp(evdw)
 111       goto 107
 112 C Gay-Berne potential (shifted LJ, angular dependence).
 113   104 call egb(evdw)
 114       goto 107
 115 C Gay-Berne-Vorobjev potential (shifted LJ, angular dependence).
 116   105 call egbv(evdw)
 117       goto 107
 118 C Soft-sphere potential
 119   106 call e_softsphere(evdw)
 120 C
 121 C Calculate electrostatic (H-bonding) energy of the main chain.
 122 C
 123   107 continue
 124 cmc
 125 cmc Sep-06: egb takes care of dynamic ss bonds too
 126 cmc
 127 c      if (dyn_ss) call dyn_set_nss
 128
 129 c      print *,"Processor",myrank," computed USCSC"
 130 #ifdef TIMING
 131       time01=MPI_Wtime()
 132 #endif
 133       call vec_and_deriv
 134 #ifdef TIMING
 135       time_vec=time_vec+MPI_Wtime()-time01
 136 #endif
 137 c      print *,"Processor",myrank," left VEC_AND_DERIV"
 138       if (ipot.lt.6) then
 139 #ifdef SPLITELE
 140          if (welec.gt.0d0.or.wvdwpp.gt.0d0.or.wel_loc.gt.0d0.or.
 141      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 142      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 143      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 144 #else
 145          if (welec.gt.0d0.or.wel_loc.gt.0d0.or.
 146      &       wturn3.gt.0d0.or.wturn4.gt.0d0 .or. wcorr.gt.0.0d0
 147      &       .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.d0
 148      &       .or. wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0 ) then
 149 #endif
 150             call eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
 151          else
 152             ees=0.0d0
 153             evdw1=0.0d0
 154             eel_loc=0.0d0
 155             eello_turn3=0.0d0
 156             eello_turn4=0.0d0
 157          endif
 158       else
 159 c        write (iout,*) "Soft-spheer ELEC potential"
 160         call eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
 161      &   eello_turn4)
 162       endif
 163 c      print *,"Processor",myrank," computed UELEC"
 164 C
 165 C Calculate excluded-volume interaction energy between peptide groups
 166 C and side chains.
 167 C
 168       if (ipot.lt.6) then
 169        if(wscp.gt.0d0) then
 170         call escp(evdw2,evdw2_14)
 171        else
 172         evdw2=0
 173         evdw2_14=0
 174        endif
 175       else
 176 c        write (iout,*) "Soft-sphere SCP potential"
 177         call escp_soft_sphere(evdw2,evdw2_14)
 178       endif
 179 c
 180 c Calculate the bond-stretching energy
 181 c
 182       call ebond(estr)
 183 C
 184 C Calculate the disulfide-bridge and other energy and the contributions
 185 C from other distance constraints.
 186 cd    print *,'Calling EHPB'
 187       call edis(ehpb)
 188 cd    print *,'EHPB exitted succesfully.'
 189 C
 190 C Calculate the virtual-bond-angle energy.
 191 C
 192       if (wang.gt.0d0) then
 193         call ebend(ebe,ethetacnstr)
 194       else
 195         ebe=0
 196       endif
 197 c      print *,"Processor",myrank," computed UB"
 198 C
 199 C Calculate the SC local energy.
 200 C
 201       call esc(escloc)
 202 c      print *,"Processor",myrank," computed USC"
 203 C
 204 C Calculate the virtual-bond torsional energy.
 205 C
 206 cd    print *,'nterm=',nterm
 207       if (wtor.gt.0) then
 208        call etor(etors,edihcnstr)
 209       else
 210        etors=0
 211        edihcnstr=0
 212       endif
 213 c      print *,"Processor",myrank," computed Utor"
 214 C
 215 C 6/23/01 Calculate double-torsional energy
 216 C
 217       if (wtor_d.gt.0) then
 218        call etor_d(etors_d)
 219       else
 220        etors_d=0
 221       endif
 222 c      print *,"Processor",myrank," computed Utord"
 223 C
 224 C 21/5/07 Calculate local sicdechain correlation energy
 225 C
 226       if (wsccor.gt.0.0d0) then
 227         call eback_sc_corr(esccor)
 228       else
 229         esccor=0.0d0
 230       endif
 231 c      print *,"Processor",myrank," computed Usccorr"
 232 C
 233 C 12/1/95 Multi-body terms
 234 C
 235       n_corr=0
 236       n_corr1=0
 237       if ((wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0
 238      &    .or. wturn6.gt.0.0d0) .and. ipot.lt.6) then
 239          call multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,n_corr1)
 240 cd         write(2,*)'multibody_eello n_corr=',n_corr,' n_corr1=',n_corr1,
 241 cd     &" ecorr",ecorr," ecorr5",ecorr5," ecorr6",ecorr6," eturn6",eturn6
 242       else
 243          ecorr=0.0d0
 244          ecorr5=0.0d0
 245          ecorr6=0.0d0
 246          eturn6=0.0d0
 247       endif
 248       if ((wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) .and. ipot.lt.6) then
 249          call multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
 250 cd         write (iout,*) "multibody_hb ecorr",ecorr
 251       endif
 252 c      print *,"Processor",myrank," computed Ucorr"
 253 C
 254 C If performing constraint dynamics, call the constraint energy
 255 C  after the equilibration time
 256       if(usampl.and.totT.gt.eq_time) then
 257          call EconstrQ
 258          call Econstr_back
 259       else
 260          Uconst=0.0d0
 261          Uconst_back=0.0d0
 262       endif
 263 #ifdef TIMING
 264       time_enecalc=time_enecalc+MPI_Wtime()-time00
 265 #endif
 266 c      print *,"Processor",myrank," computed Uconstr"
 267 #ifdef TIMING
 268       time00=MPI_Wtime()
 269 #endif
 270 c
 271 C Sum the energies
 272 C
 273       energia(1)=evdw
 274 #ifdef SCP14
 275       energia(2)=evdw2-evdw2_14
 276       energia(18)=evdw2_14
 277 #else
 278       energia(2)=evdw2
 279       energia(18)=0.0d0
 280 #endif
 281 #ifdef SPLITELE
 282       energia(3)=ees
 283       energia(16)=evdw1
 284 #else
 285       energia(3)=ees+evdw1
 286       energia(16)=0.0d0
 287 #endif
 288       energia(4)=ecorr
 289       energia(5)=ecorr5
 290       energia(6)=ecorr6
 291       energia(7)=eel_loc
 292       energia(8)=eello_turn3
 293       energia(9)=eello_turn4
 294       energia(10)=eturn6
 295       energia(11)=ebe
 296       energia(12)=escloc
 297       energia(13)=etors
 298       energia(14)=etors_d
 299       energia(15)=ehpb
 300       energia(19)=edihcnstr
 301       energia(17)=estr
 302       energia(20)=Uconst+Uconst_back
 303       energia(21)=esccor
 304 C      energia(22)=
 305 c    Here are the energies showed per procesor if the are more processors
 306 c    per molecule then we sum it up in sum_energy subroutine
 307 c      print *," Processor",myrank," calls SUM_ENERGY"
 308       call sum_energy(energia,.true.)
 309       if (dyn_ss) call dyn_set_nss
 310 c      print *," Processor",myrank," left SUM_ENERGY"
 311 #ifdef TIMING
 312       time_sumene=time_sumene+MPI_Wtime()-time00
 313 #endif
 314       return
 315       end
 316 c-------------------------------------------------------------------------------
 317       subroutine sum_energy(energia,reduce)
 318       implicit real*8 (a-h,o-z)
 319       include 'DIMENSIONS'
 320 #ifndef ISNAN
 321       external proc_proc
 322 #ifdef WINPGI
 323 cMS$ATTRIBUTES C ::  proc_proc
 324 #endif
 325 #endif
 326 #ifdef MPI
 327       include "mpif.h"
 328 #endif
 329       include 'COMMON.SETUP'
 330       include 'COMMON.IOUNITS'
 331       double precision energia(0:n_ene),enebuff(0:n_ene+1)
 332       include 'COMMON.FFIELD'
 333       include 'COMMON.DERIV'
 334       include 'COMMON.INTERACT'
 335       include 'COMMON.SBRIDGE'
 336       include 'COMMON.CHAIN'
 337       include 'COMMON.VAR'
 338       include 'COMMON.CONTROL'
 339       include 'COMMON.TIME1'
 340       logical reduce
 341 #ifdef MPI
 342       if (nfgtasks.gt.1 .and. reduce) then
 343 #ifdef DEBUG
 344         write (iout,*) "energies before REDUCE"
 345         call enerprint(energia)
 346         call flush(iout)
 347 #endif
 348         do i=0,n_ene
 349           enebuff(i)=energia(i)
 350         enddo
 351         time00=MPI_Wtime()
 352         call MPI_Barrier(FG_COMM,IERR)
 353         time_barrier_e=time_barrier_e+MPI_Wtime()-time00
 354         time00=MPI_Wtime()
 355         call MPI_Reduce(enebuff(0),energia(0),n_ene+1,
 356      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 357 #ifdef DEBUG
 358         write (iout,*) "energies after REDUCE"
 359         call enerprint(energia)
 360         call flush(iout)
 361 #endif
 362         time_Reduce=time_Reduce+MPI_Wtime()-time00
 363       endif
 364       if (fg_rank.eq.0) then
 365 #endif
 366       evdw=energia(1)
 367 #ifdef SCP14
 368       evdw2=energia(2)+energia(18)
 369       evdw2_14=energia(18)
 370 #else
 371       evdw2=energia(2)
 372 #endif
 373 #ifdef SPLITELE
 374       ees=energia(3)
 375       evdw1=energia(16)
 376 #else
 377       ees=energia(3)
 378       evdw1=0.0d0
 379 #endif
 380       ecorr=energia(4)
 381       ecorr5=energia(5)
 382       ecorr6=energia(6)
 383       eel_loc=energia(7)
 384       eello_turn3=energia(8)
 385       eello_turn4=energia(9)
 386       eturn6=energia(10)
 387       ebe=energia(11)
 388       escloc=energia(12)
 389       etors=energia(13)
 390       etors_d=energia(14)
 391       ehpb=energia(15)
 392       edihcnstr=energia(19)
 393       estr=energia(17)
 394       Uconst=energia(20)
 395       esccor=energia(21)
 396 #ifdef SPLITELE
 397       etot=wsc*evdw+wscp*evdw2+welec*ees+wvdwpp*evdw1
 398      & +wang*ebe+wtor*etors+wscloc*escloc
 399      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 400      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 401      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 402      & +wbond*estr+Uconst+wsccor*esccor
 403 #else
 404       etot=wsc*evdw+wscp*evdw2+welec*(ees+evdw1)
 405      & +wang*ebe+wtor*etors+wscloc*escloc
 406      & +wstrain*ehpb+wcorr*ecorr+wcorr5*ecorr5
 407      & +wcorr6*ecorr6+wturn4*eello_turn4+wturn3*eello_turn3
 408      & +wturn6*eturn6+wel_loc*eel_loc+edihcnstr+wtor_d*etors_d
 409      & +wbond*estr+Uconst+wsccor*esccor
 410 #endif
 411       energia(0)=etot
 412 c detecting NaNQ
 413 #ifdef ISNAN
 414 #ifdef AIX
 415       if (isnan(etot).ne.0) energia(0)=1.0d+99
 416 #else
 417       if (isnan(etot)) energia(0)=1.0d+99
 418 #endif
 419 #else
 420       i=0
 421 #ifdef WINPGI
 422       idumm=proc_proc(etot,i)
 423 #else
 424       call proc_proc(etot,i)
 425 #endif
 426       if(i.eq.1)energia(0)=1.0d+99
 427 #endif
 428 #ifdef MPI
 429       endif
 430 #endif
 431       return
 432       end
 433 c-------------------------------------------------------------------------------
 434       subroutine sum_gradient
 435       implicit real*8 (a-h,o-z)
 436       include 'DIMENSIONS'
 437 #ifndef ISNAN
 438       external proc_proc
 439 #ifdef WINPGI
 440 cMS$ATTRIBUTES C ::  proc_proc
 441 #endif
 442 #endif
 443 #ifdef MPI
 444       include 'mpif.h'
 445       double precision gradbufc(3,maxres),gradbufx(3,maxres),
 446      &  glocbuf(4*maxres),gradbufc_sum(3,maxres),gloc_scbuf(3,maxres)
 447 #endif
 448       include 'COMMON.SETUP'
 449       include 'COMMON.IOUNITS'
 450       include 'COMMON.FFIELD'
 451       include 'COMMON.DERIV'
 452       include 'COMMON.INTERACT'
 453       include 'COMMON.SBRIDGE'
 454       include 'COMMON.CHAIN'
 455       include 'COMMON.VAR'
 456       include 'COMMON.CONTROL'
 457       include 'COMMON.TIME1'
 458       include 'COMMON.MAXGRAD'
 459       include 'COMMON.SCCOR'
 460 #ifdef TIMING
 461       time01=MPI_Wtime()
 462 #endif
 463 #ifdef DEBUG
 464       write (iout,*) "sum_gradient gvdwc, gvdwx"
 465       do i=1,nres
 466         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 467      &   i,(gvdwx(j,i),j=1,3),(gvdwc(j,i),j=1,3)
 468       enddo
 469       call flush(iout)
 470 #endif
 471 #ifdef MPI
 472 C FG slaves call the following matching MPI_Bcast in ERGASTULUM
 473         if (nfgtasks.gt.1 .and. fg_rank.eq.0)
 474      &    call MPI_Bcast(1,1,MPI_INTEGER,king,FG_COMM,IERROR)
 475 #endif
 476 C
 477 C 9/29/08 AL Transform parts of gradients in site coordinates to the gradient
 478 C            in virtual-bond-vector coordinates
 479 C
 480 #ifdef DEBUG
 481 c      write (iout,*) "gel_loc gel_loc_long and gel_loc_loc"
 482 c      do i=1,nres-1
 483 c        write (iout,'(i5,3f10.5,2x,3f10.5,2x,f10.5)')
 484 c     &   i,(gel_loc(j,i),j=1,3),(gel_loc_long(j,i),j=1,3),gel_loc_loc(i)
 485 c      enddo
 486 c      write (iout,*) "gel_loc_tur3 gel_loc_turn4"
 487 c      do i=1,nres-1
 488 c        write (iout,'(i5,3f10.5,2x,f10.5)')
 489 c     &  i,(gcorr4_turn(j,i),j=1,3),gel_loc_turn4(i)
 490 c      enddo
 491       write (iout,*) "gradcorr5 gradcorr5_long gradcorr5_loc"
 492       do i=1,nres
 493         write (iout,'(i3,3f10.5,5x,3f10.5,5x,f10.5)')
 494      &   i,(gradcorr5(j,i),j=1,3),(gradcorr5_long(j,i),j=1,3),
 495      &   g_corr5_loc(i)
 496       enddo
 497       call flush(iout)
 498 #endif
 499 #ifdef SPLITELE
 500       do i=1,nct
 501         do j=1,3
 502           gradbufc(j,i)=wsc*gvdwc(j,i)+
 503      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 504      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 505      &                wel_loc*gel_loc_long(j,i)+
 506      &                wcorr*gradcorr_long(j,i)+
 507      &                wcorr5*gradcorr5_long(j,i)+
 508      &                wcorr6*gradcorr6_long(j,i)+
 509      &                wturn6*gcorr6_turn_long(j,i)+
 510      &                wstrain*ghpbc(j,i)
 511         enddo
 512       enddo
 513 #else
 514       do i=1,nct
 515         do j=1,3
 516           gradbufc(j,i)=wsc*gvdwc(j,i)+
 517      &                wscp*(gvdwc_scp(j,i)+gvdwc_scpp(j,i))+
 518      &                welec*gelc_long(j,i)+
 519      &                wbond*gradb(j,i)+
 520      &                wel_loc*gel_loc_long(j,i)+
 521      &                wcorr*gradcorr_long(j,i)+
 522      &                wcorr5*gradcorr5_long(j,i)+
 523      &                wcorr6*gradcorr6_long(j,i)+
 524      &                wturn6*gcorr6_turn_long(j,i)+
 525      &                wstrain*ghpbc(j,i)
 526         enddo
 527       enddo
 528 #endif
 529 #ifdef MPI
 530       if (nfgtasks.gt.1) then
 531       time00=MPI_Wtime()
 532 #ifdef DEBUG
 533       write (iout,*) "gradbufc before allreduce"
 534       do i=1,nres
 535         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 536       enddo
 537       call flush(iout)
 538 #endif
 539       do i=1,nres
 540         do j=1,3
 541           gradbufc_sum(j,i)=gradbufc(j,i)
 542         enddo
 543       enddo
 544 c      call MPI_AllReduce(gradbufc(1,1),gradbufc_sum(1,1),3*nres,
 545 c     &    MPI_DOUBLE_PRECISION,MPI_SUM,FG_COMM,IERR)
 546 c      time_reduce=time_reduce+MPI_Wtime()-time00
 547 #ifdef DEBUG
 548 c      write (iout,*) "gradbufc_sum after allreduce"
 549 c      do i=1,nres
 550 c        write (iout,'(i3,3f10.5)') i,(gradbufc_sum(j,i),j=1,3)
 551 c      enddo
 552 c      call flush(iout)
 553 #endif
 554 #ifdef TIMING
 555 c      time_allreduce=time_allreduce+MPI_Wtime()-time00
 556 #endif
 557       do i=nnt,nres
 558         do k=1,3
 559           gradbufc(k,i)=0.0d0
 560         enddo
 561       enddo
 562 #ifdef DEBUG
 563       write (iout,*) "igrad_start",igrad_start," igrad_end",igrad_end
 564       write (iout,*) (i," jgrad_start",jgrad_start(i),
 565      &                  " jgrad_end  ",jgrad_end(i),
 566      &                  i=igrad_start,igrad_end)
 567 #endif
 568 c
 569 c Obsolete and inefficient code; we can make the effort O(n) and, therefore,
 570 c do not parallelize this part.
 571 c
 572 c      do i=igrad_start,igrad_end
 573 c        do j=jgrad_start(i),jgrad_end(i)
 574 c          do k=1,3
 575 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc_sum(k,j)
 576 c          enddo
 577 c        enddo
 578 c      enddo
 579       do j=1,3
 580         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 581       enddo
 582       do i=nres-2,nnt,-1
 583         do j=1,3
 584           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 585         enddo
 586       enddo
 587 #ifdef DEBUG
 588       write (iout,*) "gradbufc after summing"
 589       do i=1,nres
 590         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 591       enddo
 592       call flush(iout)
 593 #endif
 594       else
 595 #endif
 596 #ifdef DEBUG
 597       write (iout,*) "gradbufc"
 598       do i=1,nres
 599         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 600       enddo
 601       call flush(iout)
 602 #endif
 603       do i=1,nres
 604         do j=1,3
 605           gradbufc_sum(j,i)=gradbufc(j,i)
 606           gradbufc(j,i)=0.0d0
 607         enddo
 608       enddo
 609       do j=1,3
 610         gradbufc(j,nres-1)=gradbufc_sum(j,nres)
 611       enddo
 612       do i=nres-2,nnt,-1
 613         do j=1,3
 614           gradbufc(j,i)=gradbufc(j,i+1)+gradbufc_sum(j,i+1)
 615         enddo
 616       enddo
 617 c      do i=nnt,nres-1
 618 c        do k=1,3
 619 c          gradbufc(k,i)=0.0d0
 620 c        enddo
 621 c        do j=i+1,nres
 622 c          do k=1,3
 623 c            gradbufc(k,i)=gradbufc(k,i)+gradbufc(k,j)
 624 c          enddo
 625 c        enddo
 626 c      enddo
 627 #ifdef DEBUG
 628       write (iout,*) "gradbufc after summing"
 629       do i=1,nres
 630         write (iout,'(i3,3f10.5)') i,(gradbufc(j,i),j=1,3)
 631       enddo
 632       call flush(iout)
 633 #endif
 634 #ifdef MPI
 635       endif
 636 #endif
 637       do k=1,3
 638         gradbufc(k,nres)=0.0d0
 639       enddo
 640       do i=1,nct
 641         do j=1,3
 642 #ifdef SPLITELE
 643           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 644      &                wel_loc*gel_loc(j,i)+
 645      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 646      &                welec*gelc_long(j,i)+wvdwpp*gvdwpp(j,i)+
 647      &                wel_loc*gel_loc_long(j,i)+
 648      &                wcorr*gradcorr_long(j,i)+
 649      &                wcorr5*gradcorr5_long(j,i)+
 650      &                wcorr6*gradcorr6_long(j,i)+
 651      &                wturn6*gcorr6_turn_long(j,i))+
 652      &                wbond*gradb(j,i)+
 653      &                wcorr*gradcorr(j,i)+
 654      &                wturn3*gcorr3_turn(j,i)+
 655      &                wturn4*gcorr4_turn(j,i)+
 656      &                wcorr5*gradcorr5(j,i)+
 657      &                wcorr6*gradcorr6(j,i)+
 658      &                wturn6*gcorr6_turn(j,i)+
 659      &                wsccor*gsccorc(j,i)
 660      &               +wscloc*gscloc(j,i)
 661 #else
 662           gradc(j,i,icg)=gradbufc(j,i)+welec*gelc(j,i)+
 663      &                wel_loc*gel_loc(j,i)+
 664      &                0.5d0*(wscp*gvdwc_scpp(j,i)+
 665      &                welec*gelc_long(j,i)
 666      &                wel_loc*gel_loc_long(j,i)+
 667      &                wcorr*gcorr_long(j,i)+
 668      &                wcorr5*gradcorr5_long(j,i)+
 669      &                wcorr6*gradcorr6_long(j,i)+
 670      &                wturn6*gcorr6_turn_long(j,i))+
 671      &                wbond*gradb(j,i)+
 672      &                wcorr*gradcorr(j,i)+
 673      &                wturn3*gcorr3_turn(j,i)+
 674      &                wturn4*gcorr4_turn(j,i)+
 675      &                wcorr5*gradcorr5(j,i)+
 676      &                wcorr6*gradcorr6(j,i)+
 677      &                wturn6*gcorr6_turn(j,i)+
 678      &                wsccor*gsccorc(j,i)
 679      &               +wscloc*gscloc(j,i)
 680 #endif
 681           gradx(j,i,icg)=wsc*gvdwx(j,i)+wscp*gradx_scp(j,i)+
 682      &                  wbond*gradbx(j,i)+
 683      &                  wstrain*ghpbx(j,i)+wcorr*gradxorr(j,i)+
 684      &                  wsccor*gsccorx(j,i)
 685      &                 +wscloc*gsclocx(j,i)
 686         enddo
 687       enddo
 688 #ifdef DEBUG
 689       write (iout,*) "gloc before adding corr"
 690       do i=1,4*nres
 691         write (iout,*) i,gloc(i,icg)
 692       enddo
 693 #endif
 694       do i=1,nres-3
 695         gloc(i,icg)=gloc(i,icg)+wcorr*gcorr_loc(i)
 696      &   +wcorr5*g_corr5_loc(i)
 697      &   +wcorr6*g_corr6_loc(i)
 698      &   +wturn4*gel_loc_turn4(i)
 699      &   +wturn3*gel_loc_turn3(i)
 700      &   +wturn6*gel_loc_turn6(i)
 701      &   +wel_loc*gel_loc_loc(i)
 702       enddo
 703 #ifdef DEBUG
 704       write (iout,*) "gloc after adding corr"
 705       do i=1,4*nres
 706         write (iout,*) i,gloc(i,icg)
 707       enddo
 708 #endif
 709 #ifdef MPI
 710       if (nfgtasks.gt.1) then
 711         do j=1,3
 712           do i=1,nres
 713             gradbufc(j,i)=gradc(j,i,icg)
 714             gradbufx(j,i)=gradx(j,i,icg)
 715           enddo
 716         enddo
 717         do i=1,4*nres
 718           glocbuf(i)=gloc(i,icg)
 719         enddo
 720 c#define DEBUG
 721 #ifdef DEBUG
 722       write (iout,*) "gloc_sc before reduce"
 723       do i=1,nres
 724        do j=1,1
 725         write (iout,*) i,j,gloc_sc(j,i,icg)
 726        enddo
 727       enddo
 728 #endif
 729 c#undef DEBUG
 730         do i=1,nres
 731          do j=1,3
 732           gloc_scbuf(j,i)=gloc_sc(j,i,icg)
 733          enddo
 734         enddo
 735         time00=MPI_Wtime()
 736         call MPI_Barrier(FG_COMM,IERR)
 737         time_barrier_g=time_barrier_g+MPI_Wtime()-time00
 738         time00=MPI_Wtime()
 739         call MPI_Reduce(gradbufc(1,1),gradc(1,1,icg),3*nres,
 740      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 741         call MPI_Reduce(gradbufx(1,1),gradx(1,1,icg),3*nres,
 742      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 743         call MPI_Reduce(glocbuf(1),gloc(1,icg),4*nres,
 744      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 745         time_reduce=time_reduce+MPI_Wtime()-time00
 746         call MPI_Reduce(gloc_scbuf(1,1),gloc_sc(1,1,icg),3*nres,
 747      &    MPI_DOUBLE_PRECISION,MPI_SUM,king,FG_COMM,IERR)
 748         time_reduce=time_reduce+MPI_Wtime()-time00
 749 c#define DEBUG
 750 #ifdef DEBUG
 751       write (iout,*) "gloc_sc after reduce"
 752       do i=1,nres
 753        do j=1,1
 754         write (iout,*) i,j,gloc_sc(j,i,icg)
 755        enddo
 756       enddo
 757 #endif
 758 c#undef DEBUG
 759 #ifdef DEBUG
 760       write (iout,*) "gloc after reduce"
 761       do i=1,4*nres
 762         write (iout,*) i,gloc(i,icg)
 763       enddo
 764 #endif
 765       endif
 766 #endif
 767       if (gnorm_check) then
 768 c
 769 c Compute the maximum elements of the gradient
 770 c
 771       gvdwc_max=0.0d0
 772       gvdwc_scp_max=0.0d0
 773       gelc_max=0.0d0
 774       gvdwpp_max=0.0d0
 775       gradb_max=0.0d0
 776       ghpbc_max=0.0d0
 777       gradcorr_max=0.0d0
 778       gel_loc_max=0.0d0
 779       gcorr3_turn_max=0.0d0
 780       gcorr4_turn_max=0.0d0
 781       gradcorr5_max=0.0d0
 782       gradcorr6_max=0.0d0
 783       gcorr6_turn_max=0.0d0
 784       gsccorc_max=0.0d0
 785       gscloc_max=0.0d0
 786       gvdwx_max=0.0d0
 787       gradx_scp_max=0.0d0
 788       ghpbx_max=0.0d0
 789       gradxorr_max=0.0d0
 790       gsccorx_max=0.0d0
 791       gsclocx_max=0.0d0
 792       do i=1,nct
 793         gvdwc_norm=dsqrt(scalar(gvdwc(1,i),gvdwc(1,i)))
 794         if (gvdwc_norm.gt.gvdwc_max) gvdwc_max=gvdwc_norm
 795         gvdwc_scp_norm=dsqrt(scalar(gvdwc_scp(1,i),gvdwc_scp(1,i)))
 796         if (gvdwc_scp_norm.gt.gvdwc_scp_max)
 797      &   gvdwc_scp_max=gvdwc_scp_norm
 798         gelc_norm=dsqrt(scalar(gelc(1,i),gelc(1,i)))
 799         if (gelc_norm.gt.gelc_max) gelc_max=gelc_norm
 800         gvdwpp_norm=dsqrt(scalar(gvdwpp(1,i),gvdwpp(1,i)))
 801         if (gvdwpp_norm.gt.gvdwpp_max) gvdwpp_max=gvdwpp_norm
 802         gradb_norm=dsqrt(scalar(gradb(1,i),gradb(1,i)))
 803         if (gradb_norm.gt.gradb_max) gradb_max=gradb_norm
 804         ghpbc_norm=dsqrt(scalar(ghpbc(1,i),ghpbc(1,i)))
 805         if (ghpbc_norm.gt.ghpbc_max) ghpbc_max=ghpbc_norm
 806         gradcorr_norm=dsqrt(scalar(gradcorr(1,i),gradcorr(1,i)))
 807         if (gradcorr_norm.gt.gradcorr_max) gradcorr_max=gradcorr_norm
 808         gel_loc_norm=dsqrt(scalar(gel_loc(1,i),gel_loc(1,i)))
 809         if (gel_loc_norm.gt.gel_loc_max) gel_loc_max=gel_loc_norm
 810         gcorr3_turn_norm=dsqrt(scalar(gcorr3_turn(1,i),
 811      &    gcorr3_turn(1,i)))
 812         if (gcorr3_turn_norm.gt.gcorr3_turn_max)
 813      &    gcorr3_turn_max=gcorr3_turn_norm
 814         gcorr4_turn_norm=dsqrt(scalar(gcorr4_turn(1,i),
 815      &    gcorr4_turn(1,i)))
 816         if (gcorr4_turn_norm.gt.gcorr4_turn_max)
 817      &    gcorr4_turn_max=gcorr4_turn_norm
 818         gradcorr5_norm=dsqrt(scalar(gradcorr5(1,i),gradcorr5(1,i)))
 819         if (gradcorr5_norm.gt.gradcorr5_max)
 820      &    gradcorr5_max=gradcorr5_norm
 821         gradcorr6_norm=dsqrt(scalar(gradcorr6(1,i),gradcorr6(1,i)))
 822         if (gradcorr6_norm.gt.gradcorr6_max) gcorr6_max=gradcorr6_norm
 823         gcorr6_turn_norm=dsqrt(scalar(gcorr6_turn(1,i),
 824      &    gcorr6_turn(1,i)))
 825         if (gcorr6_turn_norm.gt.gcorr6_turn_max)
 826      &    gcorr6_turn_max=gcorr6_turn_norm
 827         gsccorr_norm=dsqrt(scalar(gsccorc(1,i),gsccorc(1,i)))
 828         if (gsccorr_norm.gt.gsccorr_max) gsccorr_max=gsccorr_norm
 829         gscloc_norm=dsqrt(scalar(gscloc(1,i),gscloc(1,i)))
 830         if (gscloc_norm.gt.gscloc_max) gscloc_max=gscloc_norm
 831         gvdwx_norm=dsqrt(scalar(gvdwx(1,i),gvdwx(1,i)))
 832         if (gvdwx_norm.gt.gvdwx_max) gvdwx_max=gvdwx_norm
 833         gradx_scp_norm=dsqrt(scalar(gradx_scp(1,i),gradx_scp(1,i)))
 834         if (gradx_scp_norm.gt.gradx_scp_max)
 835      &    gradx_scp_max=gradx_scp_norm
 836         ghpbx_norm=dsqrt(scalar(ghpbx(1,i),ghpbx(1,i)))
 837         if (ghpbx_norm.gt.ghpbx_max) ghpbx_max=ghpbx_norm
 838         gradxorr_norm=dsqrt(scalar(gradxorr(1,i),gradxorr(1,i)))
 839         if (gradxorr_norm.gt.gradxorr_max) gradxorr_max=gradxorr_norm
 840         gsccorrx_norm=dsqrt(scalar(gsccorx(1,i),gsccorx(1,i)))
 841         if (gsccorrx_norm.gt.gsccorrx_max) gsccorrx_max=gsccorrx_norm
 842         gsclocx_norm=dsqrt(scalar(gsclocx(1,i),gsclocx(1,i)))
 843         if (gsclocx_norm.gt.gsclocx_max) gsclocx_max=gsclocx_norm
 844       enddo
 845       if (gradout) then
 846 #ifdef AIX
 847         open(istat,file=statname,position="append")
 848 #else
 849         open(istat,file=statname,access="append")
 850 #endif
 851         write (istat,'(1h#,21f10.2)') gvdwc_max,gvdwc_scp_max,
 852      &     gelc_max,gvdwpp_max,gradb_max,ghpbc_max,
 853      &     gradcorr_max,gel_loc_max,gcorr3_turn_max,gcorr4_turn_max,
 854      &     gradcorr5_max,gradcorr6_max,gcorr6_turn_max,gsccorc_max,
 855      &     gscloc_max,gvdwx_max,gradx_scp_max,ghpbx_max,gradxorr_max,
 856      &     gsccorx_max,gsclocx_max
 857         close(istat)
 858         if (gvdwc_max.gt.1.0d4) then
 859           write (iout,*) "gvdwc gvdwx gradb gradbx"
 860           do i=nnt,nct
 861             write(iout,'(i5,4(3f10.2,5x))') i,(gvdwc(j,i),gvdwx(j,i),
 862      &        gradb(j,i),gradbx(j,i),j=1,3)
 863           enddo
 864           call pdbout(0.0d0,'cipiszcze',iout)
 865           call flush(iout)
 866         endif
 867       endif
 868       endif
 869 #ifdef DEBUG
 870       write (iout,*) "gradc gradx gloc"
 871       do i=1,nres
 872         write (iout,'(i5,3f10.5,5x,3f10.5,5x,f10.5)')
 873      &   i,(gradc(j,i,icg),j=1,3),(gradx(j,i,icg),j=1,3),gloc(i,icg)
 874       enddo
 875 #endif
 876 #ifdef TIMING
 877       time_sumgradient=time_sumgradient+MPI_Wtime()-time01
 878 #endif
 879       return
 880       end
 881 c-------------------------------------------------------------------------------
 882       subroutine rescale_weights(t_bath)
 883       implicit real*8 (a-h,o-z)
 884       include 'DIMENSIONS'
 885       include 'COMMON.IOUNITS'
 886       include 'COMMON.FFIELD'
 887       include 'COMMON.SBRIDGE'
 888       double precision kfac /2.4d0/
 889       double precision x,x2,x3,x4,x5,licznik /1.12692801104297249644/
 890 c      facT=temp0/t_bath
 891 c      facT=2*temp0/(t_bath+temp0)
 892       if (rescale_mode.eq.0) then
 893         facT=1.0d0
 894         facT2=1.0d0
 895         facT3=1.0d0
 896         facT4=1.0d0
 897         facT5=1.0d0
 898       else if (rescale_mode.eq.1) then
 899         facT=kfac/(kfac-1.0d0+t_bath/temp0)
 900         facT2=kfac**2/(kfac**2-1.0d0+(t_bath/temp0)**2)
 901         facT3=kfac**3/(kfac**3-1.0d0+(t_bath/temp0)**3)
 902         facT4=kfac**4/(kfac**4-1.0d0+(t_bath/temp0)**4)
 903         facT5=kfac**5/(kfac**5-1.0d0+(t_bath/temp0)**5)
 904       else if (rescale_mode.eq.2) then
 905         x=t_bath/temp0
 906         x2=x*x
 907         x3=x2*x
 908         x4=x3*x
 909         x5=x4*x
 910         facT=licznik/dlog(dexp(x)+dexp(-x))
 911         facT2=licznik/dlog(dexp(x2)+dexp(-x2))
 912         facT3=licznik/dlog(dexp(x3)+dexp(-x3))
 913         facT4=licznik/dlog(dexp(x4)+dexp(-x4))
 914         facT5=licznik/dlog(dexp(x5)+dexp(-x5))
 915       else
 916         write (iout,*) "Wrong RESCALE_MODE",rescale_mode
 917         write (*,*) "Wrong RESCALE_MODE",rescale_mode
 918 #ifdef MPI
 919        call MPI_Finalize(MPI_COMM_WORLD,IERROR)
 920 #endif
 921        stop 555
 922       endif
 923       welec=weights(3)*fact
 924       wcorr=weights(4)*fact3
 925       wcorr5=weights(5)*fact4
 926       wcorr6=weights(6)*fact5
 927       wel_loc=weights(7)*fact2
 928       wturn3=weights(8)*fact2
 929       wturn4=weights(9)*fact3
 930       wturn6=weights(10)*fact5
 931       wtor=weights(13)*fact
 932       wtor_d=weights(14)*fact2
 933       wsccor=weights(21)*fact
 934
 935       return
 936       end
 937 C------------------------------------------------------------------------
 938       subroutine enerprint(energia)
 939       implicit real*8 (a-h,o-z)
 940       include 'DIMENSIONS'
 941       include 'COMMON.IOUNITS'
 942       include 'COMMON.FFIELD'
 943       include 'COMMON.SBRIDGE'
 944       include 'COMMON.MD'
 945       double precision energia(0:n_ene)
 946       etot=energia(0)
 947       evdw=energia(1)
 948       evdw2=energia(2)
 949 #ifdef SCP14
 950       evdw2=energia(2)+energia(18)
 951 #else
 952       evdw2=energia(2)
 953 #endif
 954       ees=energia(3)
 955 #ifdef SPLITELE
 956       evdw1=energia(16)
 957 #endif
 958       ecorr=energia(4)
 959       ecorr5=energia(5)
 960       ecorr6=energia(6)
 961       eel_loc=energia(7)
 962       eello_turn3=energia(8)
 963       eello_turn4=energia(9)
 964       eello_turn6=energia(10)
 965       ebe=energia(11)
 966       escloc=energia(12)
 967       etors=energia(13)
 968       etors_d=energia(14)
 969       ehpb=energia(15)
 970       edihcnstr=energia(19)
 971       estr=energia(17)
 972       Uconst=energia(20)
 973       esccor=energia(21)
 974 #ifdef SPLITELE
 975       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,evdw1,wvdwpp,
 976      &  estr,wbond,ebe,wang,
 977      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
 978      &  ecorr,wcorr,
 979      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
 980      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccor,
 981      &  edihcnstr,
 982      &  ethetacnstr,ebr*nss,
 983      &  Uconst,etot
 984    10 format (/'Virtual-chain energies:'//
 985      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
 986      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
 987      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
 988      & 'EVDWPP=',1pE16.6,' WEIGHT=',1pD16.6,' (p-p VDW)'/
 989      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
 990      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
 991      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
 992      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
 993      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
 994      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
 995      & ' (SS bridges & dist. cnstr.)'/
 996      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 997      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 998      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
 999      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1000      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1001      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1002      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1003      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1004      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1005      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1006      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1007      & 'UCONST= ',1pE16.6,' (Constraint energy)'/
1008      & 'ETOT=  ',1pE16.6,' (total)')
1009 #else
1010       write (iout,10) evdw,wsc,evdw2,wscp,ees,welec,
1011      &  estr,wbond,ebe,wang,
1012      &  escloc,wscloc,etors,wtor,etors_d,wtor_d,ehpb,wstrain,
1013      &  ecorr,wcorr,
1014      &  ecorr5,wcorr5,ecorr6,wcorr6,eel_loc,wel_loc,eello_turn3,wturn3,
1015      &  eello_turn4,wturn4,eello_turn6,wturn6,esccor,wsccro,edihcnstr,
1016      &  ethetacnstr,
1017      &  ebr*nss,Uconst,etot
1018    10 format (/'Virtual-chain energies:'//
1019      & 'EVDW=  ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-SC)'/
1020      & 'EVDW2= ',1pE16.6,' WEIGHT=',1pD16.6,' (SC-p)'/
1021      & 'EES=   ',1pE16.6,' WEIGHT=',1pD16.6,' (p-p)'/
1022      & 'ESTR=  ',1pE16.6,' WEIGHT=',1pD16.6,' (stretching)'/
1023      & 'EBE=   ',1pE16.6,' WEIGHT=',1pD16.6,' (bending)'/
1024      & 'ESC=   ',1pE16.6,' WEIGHT=',1pD16.6,' (SC local)'/
1025      & 'ETORS= ',1pE16.6,' WEIGHT=',1pD16.6,' (torsional)'/
1026      & 'ETORSD=',1pE16.6,' WEIGHT=',1pD16.6,' (double torsional)'/
1027      & 'EHBP=  ',1pE16.6,' WEIGHT=',1pD16.6,
1028      & ' (SS bridges & dist. cnstr.)'/
1029      & 'ECORR4=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1030      & 'ECORR5=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1031      & 'ECORR6=',1pE16.6,' WEIGHT=',1pD16.6,' (multi-body)'/
1032      & 'EELLO= ',1pE16.6,' WEIGHT=',1pD16.6,' (electrostatic-local)'/
1033      & 'ETURN3=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 3rd order)'/
1034      & 'ETURN4=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 4th order)'/
1035      & 'ETURN6=',1pE16.6,' WEIGHT=',1pD16.6,' (turns, 6th order)'/
1036      & 'ESCCOR=',1pE16.6,' WEIGHT=',1pD16.6,' (backbone-rotamer corr)'/
1037      & 'EDIHC= ',1pE16.6,' (dihedral angle constraints)'/
1038      & 'ETHETC= ',1pE16.6,' (valence angle constraints)'/
1039      & 'ESS=   ',1pE16.6,' (disulfide-bridge intrinsic energy)'/
1040      & 'UCONST=',1pE16.6,' (Constraint energy)'/
1041      & 'ETOT=  ',1pE16.6,' (total)')
1042 #endif
1043       return
1044       end
1045 C-----------------------------------------------------------------------
1046       subroutine elj(evdw)
1047 C
1048 C This subroutine calculates the interaction energy of nonbonded side chains
1049 C assuming the LJ potential of interaction.
1050 C
1051       implicit real*8 (a-h,o-z)
1052       include 'DIMENSIONS'
1053       parameter (accur=1.0d-10)
1054       include 'COMMON.GEO'
1055       include 'COMMON.VAR'
1056       include 'COMMON.LOCAL'
1057       include 'COMMON.CHAIN'
1058       include 'COMMON.DERIV'
1059       include 'COMMON.INTERACT'
1060       include 'COMMON.TORSION'
1061       include 'COMMON.SBRIDGE'
1062       include 'COMMON.NAMES'
1063       include 'COMMON.IOUNITS'
1064       include 'COMMON.CONTACTS'
1065       dimension gg(3)
1066 c      write(iout,*)'Entering ELJ nnt=',nnt,' nct=',nct,' expon=',expon
1067       evdw=0.0D0
1068       do i=iatsc_s,iatsc_e
1069         itypi=iabs(itype(i))
1070         if (itypi.eq.ntyp1) cycle
1071         itypi1=iabs(itype(i+1))
1072         xi=c(1,nres+i)
1073         yi=c(2,nres+i)
1074         zi=c(3,nres+i)
1075 C Change 12/1/95
1076         num_conti=0
1077 C
1078 C Calculate SC interaction energy.
1079 C
1080         do iint=1,nint_gr(i)
1081 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1082 cd   &                  'iend=',iend(i,iint)
1083           do j=istart(i,iint),iend(i,iint)
1084             itypj=iabs(itype(j))
1085             if (itypj.eq.ntyp1) cycle
1086             xj=c(1,nres+j)-xi
1087             yj=c(2,nres+j)-yi
1088             zj=c(3,nres+j)-zi
1089 C Change 12/1/95 to calculate four-body interactions
1090             rij=xj*xj+yj*yj+zj*zj
1091             rrij=1.0D0/rij
1092 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1093             eps0ij=eps(itypi,itypj)
1094             fac=rrij**expon2
1095             e1=fac*fac*aa(itypi,itypj)
1096             e2=fac*bb(itypi,itypj)
1097             evdwij=e1+e2
1098 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1099 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1100 cd          write (iout,'(2(a3,i3,2x),6(1pd12.4)/2(3(1pd12.4),5x)/)')
1101 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1102 cd   &        bb(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,epsi,sigm,
1103 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1104             evdw=evdw+evdwij
1105 C
1106 C Calculate the components of the gradient in DC and X
1107 C
1108             fac=-rrij*(e1+evdwij)
1109             gg(1)=xj*fac
1110             gg(2)=yj*fac
1111             gg(3)=zj*fac
1112             do k=1,3
1113               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1114               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1115               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1116               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1117             enddo
1118 cgrad            do k=i,j-1
1119 cgrad              do l=1,3
1120 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1121 cgrad              enddo
1122 cgrad            enddo
1123 C
1124 C 12/1/95, revised on 5/20/97
1125 C
1126 C Calculate the contact function. The ith column of the array JCONT will
1127 C contain the numbers of atoms that make contacts with the atom I (of numbers
1128 C greater than I). The arrays FACONT and GACONT will contain the values of
1129 C the contact function and its derivative.
1130 C
1131 C Uncomment next line, if the correlation interactions include EVDW explicitly.
1132 c           if (j.gt.i+1 .and. evdwij.le.0.0D0) then
1133 C Uncomment next line, if the correlation interactions are contact function only
1134             if (j.gt.i+1.and. eps0ij.gt.0.0D0) then
1135               rij=dsqrt(rij)
1136               sigij=sigma(itypi,itypj)
1137               r0ij=rs0(itypi,itypj)
1138 C
1139 C Check whether the SC's are not too far to make a contact.
1140 C
1141               rcut=1.5d0*r0ij
1142               call gcont(rij,rcut,1.0d0,0.2d0*rcut,fcont,fprimcont)
1143 C Add a new contact, if the SC's are close enough, but not too close (r<sigma).
1144 C
1145               if (fcont.gt.0.0D0) then
1146 C If the SC-SC distance if close to sigma, apply spline.
1147 cAdam           call gcont(-rij,-1.03d0*sigij,2.0d0*sigij,1.0d0,
1148 cAdam &             fcont1,fprimcont1)
1149 cAdam           fcont1=1.0d0-fcont1
1150 cAdam           if (fcont1.gt.0.0d0) then
1151 cAdam             fprimcont=fprimcont*fcont1+fcont*fprimcont1
1152 cAdam             fcont=fcont*fcont1
1153 cAdam           endif
1154 C Uncomment following 4 lines to have the geometric average of the epsilon0's
1155 cga             eps0ij=1.0d0/dsqrt(eps0ij)
1156 cga             do k=1,3
1157 cga               gg(k)=gg(k)*eps0ij
1158 cga             enddo
1159 cga             eps0ij=-evdwij*eps0ij
1160 C Uncomment for AL's type of SC correlation interactions.
1161 cadam           eps0ij=-evdwij
1162                 num_conti=num_conti+1
1163                 jcont(num_conti,i)=j
1164                 facont(num_conti,i)=fcont*eps0ij
1165                 fprimcont=eps0ij*fprimcont/rij
1166                 fcont=expon*fcont
1167 cAdam           gacont(1,num_conti,i)=-fprimcont*xj+fcont*gg(1)
1168 cAdam           gacont(2,num_conti,i)=-fprimcont*yj+fcont*gg(2)
1169 cAdam           gacont(3,num_conti,i)=-fprimcont*zj+fcont*gg(3)
1170 C Uncomment following 3 lines for Skolnick's type of SC correlation.
1171                 gacont(1,num_conti,i)=-fprimcont*xj
1172                 gacont(2,num_conti,i)=-fprimcont*yj
1173                 gacont(3,num_conti,i)=-fprimcont*zj
1174 cd              write (iout,'(2i5,2f10.5)') i,j,rij,facont(num_conti,i)
1175 cd              write (iout,'(2i3,3f10.5)')
1176 cd   &           i,j,(gacont(kk,num_conti,i),kk=1,3)
1177               endif
1178             endif
1179           enddo      ! j
1180         enddo        ! iint
1181 C Change 12/1/95
1182         num_cont(i)=num_conti
1183       enddo          ! i
1184       do i=1,nct
1185         do j=1,3
1186           gvdwc(j,i)=expon*gvdwc(j,i)
1187           gvdwx(j,i)=expon*gvdwx(j,i)
1188         enddo
1189       enddo
1190 C******************************************************************************
1191 C
1192 C                              N O T E !!!
1193 C
1194 C To save time, the factor of EXPON has been extracted from ALL components
1195 C of GVDWC and GRADX. Remember to multiply them by this factor before further
1196 C use!
1197 C
1198 C******************************************************************************
1199       return
1200       end
1201 C-----------------------------------------------------------------------------
1202       subroutine eljk(evdw)
1203 C
1204 C This subroutine calculates the interaction energy of nonbonded side chains
1205 C assuming the LJK potential of interaction.
1206 C
1207       implicit real*8 (a-h,o-z)
1208       include 'DIMENSIONS'
1209       include 'COMMON.GEO'
1210       include 'COMMON.VAR'
1211       include 'COMMON.LOCAL'
1212       include 'COMMON.CHAIN'
1213       include 'COMMON.DERIV'
1214       include 'COMMON.INTERACT'
1215       include 'COMMON.IOUNITS'
1216       include 'COMMON.NAMES'
1217       dimension gg(3)
1218       logical scheck
1219 c     print *,'Entering ELJK nnt=',nnt,' nct=',nct,' expon=',expon
1220       evdw=0.0D0
1221       do i=iatsc_s,iatsc_e
1222         itypi=iabs(itype(i))
1223         if (itypi.eq.ntyp1) cycle
1224         itypi1=iabs(itype(i+1))
1225         xi=c(1,nres+i)
1226         yi=c(2,nres+i)
1227         zi=c(3,nres+i)
1228 C
1229 C Calculate SC interaction energy.
1230 C
1231         do iint=1,nint_gr(i)
1232           do j=istart(i,iint),iend(i,iint)
1233             itypj=iabs(itype(j))
1234             if (itypj.eq.ntyp1) cycle
1235             xj=c(1,nres+j)-xi
1236             yj=c(2,nres+j)-yi
1237             zj=c(3,nres+j)-zi
1238             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1239             fac_augm=rrij**expon
1240             e_augm=augm(itypi,itypj)*fac_augm
1241             r_inv_ij=dsqrt(rrij)
1242             rij=1.0D0/r_inv_ij
1243             r_shift_inv=1.0D0/(rij+r0(itypi,itypj)-sigma(itypi,itypj))
1244             fac=r_shift_inv**expon
1245             e1=fac*fac*aa(itypi,itypj)
1246             e2=fac*bb(itypi,itypj)
1247             evdwij=e_augm+e1+e2
1248 cd          sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1249 cd          epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1250 cd          write (iout,'(2(a3,i3,2x),8(1pd12.4)/2(3(1pd12.4),5x)/)')
1251 cd   &        restyp(itypi),i,restyp(itypj),j,aa(itypi,itypj),
1252 cd   &        bb(itypi,itypj),augm(itypi,itypj),epsi,sigm,
1253 cd   &        sigma(itypi,itypj),1.0D0/dsqrt(rrij),evdwij,
1254 cd   &        (c(k,i),k=1,3),(c(k,j),k=1,3)
1255             evdw=evdw+evdwij
1256 C
1257 C Calculate the components of the gradient in DC and X
1258 C
1259             fac=-2.0D0*rrij*e_augm-r_inv_ij*r_shift_inv*(e1+e1+e2)
1260             gg(1)=xj*fac
1261             gg(2)=yj*fac
1262             gg(3)=zj*fac
1263             do k=1,3
1264               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1265               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1266               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1267               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1268             enddo
1269 cgrad            do k=i,j-1
1270 cgrad              do l=1,3
1271 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1272 cgrad              enddo
1273 cgrad            enddo
1274           enddo      ! j
1275         enddo        ! iint
1276       enddo          ! i
1277       do i=1,nct
1278         do j=1,3
1279           gvdwc(j,i)=expon*gvdwc(j,i)
1280           gvdwx(j,i)=expon*gvdwx(j,i)
1281         enddo
1282       enddo
1283       return
1284       end
1285 C-----------------------------------------------------------------------------
1286       subroutine ebp(evdw)
1287 C
1288 C This subroutine calculates the interaction energy of nonbonded side chains
1289 C assuming the Berne-Pechukas potential of interaction.
1290 C
1291       implicit real*8 (a-h,o-z)
1292       include 'DIMENSIONS'
1293       include 'COMMON.GEO'
1294       include 'COMMON.VAR'
1295       include 'COMMON.LOCAL'
1296       include 'COMMON.CHAIN'
1297       include 'COMMON.DERIV'
1298       include 'COMMON.NAMES'
1299       include 'COMMON.INTERACT'
1300       include 'COMMON.IOUNITS'
1301       include 'COMMON.CALC'
1302       common /srutu/ icall
1303 c     double precision rrsave(maxdim)
1304       logical lprn
1305       evdw=0.0D0
1306 c     print *,'Entering EBP nnt=',nnt,' nct=',nct,' expon=',expon
1307       evdw=0.0D0
1308 c     if (icall.eq.0) then
1309 c       lprn=.true.
1310 c     else
1311         lprn=.false.
1312 c     endif
1313       ind=0
1314       do i=iatsc_s,iatsc_e
1315         itypi=iabs(itype(i))
1316         if (itypi.eq.ntyp1) cycle
1317         itypi1=iabs(itype(i+1))
1318         xi=c(1,nres+i)
1319         yi=c(2,nres+i)
1320         zi=c(3,nres+i)
1321         dxi=dc_norm(1,nres+i)
1322         dyi=dc_norm(2,nres+i)
1323         dzi=dc_norm(3,nres+i)
1324 c        dsci_inv=dsc_inv(itypi)
1325         dsci_inv=vbld_inv(i+nres)
1326 C
1327 C Calculate SC interaction energy.
1328 C
1329         do iint=1,nint_gr(i)
1330           do j=istart(i,iint),iend(i,iint)
1331             ind=ind+1
1332             itypj=iabs(itype(j))
1333             if (itypj.eq.ntyp1) cycle
1334 c            dscj_inv=dsc_inv(itypj)
1335             dscj_inv=vbld_inv(j+nres)
1336             chi1=chi(itypi,itypj)
1337             chi2=chi(itypj,itypi)
1338             chi12=chi1*chi2
1339             chip1=chip(itypi)
1340             chip2=chip(itypj)
1341             chip12=chip1*chip2
1342             alf1=alp(itypi)
1343             alf2=alp(itypj)
1344             alf12=0.5D0*(alf1+alf2)
1345 C For diagnostics only!!!
1346 c           chi1=0.0D0
1347 c           chi2=0.0D0
1348 c           chi12=0.0D0
1349 c           chip1=0.0D0
1350 c           chip2=0.0D0
1351 c           chip12=0.0D0
1352 c           alf1=0.0D0
1353 c           alf2=0.0D0
1354 c           alf12=0.0D0
1355             xj=c(1,nres+j)-xi
1356             yj=c(2,nres+j)-yi
1357             zj=c(3,nres+j)-zi
1358             dxj=dc_norm(1,nres+j)
1359             dyj=dc_norm(2,nres+j)
1360             dzj=dc_norm(3,nres+j)
1361             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1362 cd          if (icall.eq.0) then
1363 cd            rrsave(ind)=rrij
1364 cd          else
1365 cd            rrij=rrsave(ind)
1366 cd          endif
1367             rij=dsqrt(rrij)
1368 C Calculate the angle-dependent terms of energy & contributions to derivatives.
1369             call sc_angular
1370 C Calculate whole angle-dependent part of epsilon and contributions
1371 C to its derivatives
1372             fac=(rrij*sigsq)**expon2
1373             e1=fac*fac*aa(itypi,itypj)
1374             e2=fac*bb(itypi,itypj)
1375             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1376             eps2der=evdwij*eps3rt
1377             eps3der=evdwij*eps2rt
1378             evdwij=evdwij*eps2rt*eps3rt
1379             evdw=evdw+evdwij
1380             if (lprn) then
1381             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1382             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1383 cd            write (iout,'(2(a3,i3,2x),15(0pf7.3))')
1384 cd     &        restyp(itypi),i,restyp(itypj),j,
1385 cd     &        epsi,sigm,chi1,chi2,chip1,chip2,
1386 cd     &        eps1,eps2rt**2,eps3rt**2,1.0D0/dsqrt(sigsq),
1387 cd     &        om1,om2,om12,1.0D0/dsqrt(rrij),
1388 cd     &        evdwij
1389             endif
1390 C Calculate gradient components.
1391             e1=e1*eps1*eps2rt**2*eps3rt**2
1392             fac=-expon*(e1+evdwij)
1393             sigder=fac/sigsq
1394             fac=rrij*fac
1395 C Calculate radial part of the gradient
1396             gg(1)=xj*fac
1397             gg(2)=yj*fac
1398             gg(3)=zj*fac
1399 C Calculate the angular part of the gradient and sum add the contributions
1400 C to the appropriate components of the Cartesian gradient.
1401             call sc_grad
1402           enddo      ! j
1403         enddo        ! iint
1404       enddo          ! i
1405 c     stop
1406       return
1407       end
1408 C-----------------------------------------------------------------------------
1409       subroutine egb(evdw)
1410 C
1411 C This subroutine calculates the interaction energy of nonbonded side chains
1412 C assuming the Gay-Berne potential of interaction.
1413 C
1414       implicit real*8 (a-h,o-z)
1415       include 'DIMENSIONS'
1416       include 'COMMON.GEO'
1417       include 'COMMON.VAR'
1418       include 'COMMON.LOCAL'
1419       include 'COMMON.CHAIN'
1420       include 'COMMON.DERIV'
1421       include 'COMMON.NAMES'
1422       include 'COMMON.INTERACT'
1423       include 'COMMON.IOUNITS'
1424       include 'COMMON.CALC'
1425       include 'COMMON.CONTROL'
1426       include 'COMMON.SBRIDGE'
1427       logical lprn
1428
1429 c      write(iout,*) "Jestem w egb(evdw)"
1430
1431       evdw=0.0D0
1432 ccccc      energy_dec=.false.
1433 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1434       evdw=0.0D0
1435       lprn=.false.
1436 c     if (icall.eq.0) lprn=.false.
1437       ind=0
1438       do i=iatsc_s,iatsc_e
1439         itypi=iabs(itype(i))
1440         if (itypi.eq.ntyp1) cycle
1441         itypi1=iabs(itype(i+1))
1442         xi=c(1,nres+i)
1443         yi=c(2,nres+i)
1444         zi=c(3,nres+i)
1445         dxi=dc_norm(1,nres+i)
1446         dyi=dc_norm(2,nres+i)
1447         dzi=dc_norm(3,nres+i)
1448 c        dsci_inv=dsc_inv(itypi)
1449         dsci_inv=vbld_inv(i+nres)
1450 c        write (iout,*) "i",i,dsc_inv(itypi),dsci_inv,1.0d0/vbld(i+nres)
1451 c        write (iout,*) "dcnori",dxi*dxi+dyi*dyi+dzi*dzi
1452 C
1453 C Calculate SC interaction energy.
1454 C
1455         do iint=1,nint_gr(i)
1456           do j=istart(i,iint),iend(i,iint)
1457             IF (dyn_ss_mask(i).and.dyn_ss_mask(j)) THEN
1458
1459 c              write(iout,*) "PRZED ZWYKLE", evdwij
1460               call dyn_ssbond_ene(i,j,evdwij)
1461 c              write(iout,*) "PO ZWYKLE", evdwij
1462
1463               evdw=evdw+evdwij
1464               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1465      &                        'evdw',i,j,evdwij,' ss'
1466 C triple bond artifac removal
1467              do k=j+1,iend(i,iint)
1468 C search over all next residues
1469               if (dyn_ss_mask(k)) then
1470 C check if they are cysteins
1471 C              write(iout,*) 'k=',k
1472
1473 c              write(iout,*) "PRZED TRI", evdwij
1474                evdwij_przed_tri=evdwij
1475               call triple_ssbond_ene(i,j,k,evdwij)
1476 c               if(evdwij_przed_tri.ne.evdwij) then
1477 c                 write (iout,*) "TRI:", evdwij, evdwij_przed_tri
1478 c               endif
1479
1480 c              write(iout,*) "PO TRI", evdwij
1481 C call the energy function that removes the artifical triple disulfide
1482 C bond the soubroutine is located in ssMD.F
1483               evdw=evdw+evdwij
1484               if (energy_dec) write (iout,'(a6,2i5,0pf7.3,a3)')
1485      &                        'evdw',i,j,evdwij,'tss'
1486               endif!dyn_ss_mask(k)
1487              enddo! k
1488             ELSE
1489             ind=ind+1
1490             itypj=iabs(itype(j))
1491             if (itypj.eq.ntyp1) cycle
1492 c            dscj_inv=dsc_inv(itypj)
1493             dscj_inv=vbld_inv(j+nres)
1494 c            write (iout,*) "j",j,dsc_inv(itypj),dscj_inv,
1495 c     &       1.0d0/vbld(j+nres)
1496 c            write (iout,*) "i",i," j", j," itype",itype(i),itype(j)
1497             sig0ij=sigma(itypi,itypj)
1498             chi1=chi(itypi,itypj)
1499             chi2=chi(itypj,itypi)
1500             chi12=chi1*chi2
1501             chip1=chip(itypi)
1502             chip2=chip(itypj)
1503             chip12=chip1*chip2
1504             alf1=alp(itypi)
1505             alf2=alp(itypj)
1506             alf12=0.5D0*(alf1+alf2)
1507 C For diagnostics only!!!
1508 c           chi1=0.0D0
1509 c           chi2=0.0D0
1510 c           chi12=0.0D0
1511 c           chip1=0.0D0
1512 c           chip2=0.0D0
1513 c           chip12=0.0D0
1514 c           alf1=0.0D0
1515 c           alf2=0.0D0
1516 c           alf12=0.0D0
1517             xj=c(1,nres+j)-xi
1518             yj=c(2,nres+j)-yi
1519             zj=c(3,nres+j)-zi
1520             dxj=dc_norm(1,nres+j)
1521             dyj=dc_norm(2,nres+j)
1522             dzj=dc_norm(3,nres+j)
1523 c            write (iout,*) "dcnorj",dxi*dxi+dyi*dyi+dzi*dzi
1524 c            write (iout,*) "j",j," dc_norm",
1525 c     &       dc_norm(1,nres+j),dc_norm(2,nres+j),dc_norm(3,nres+j)
1526             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1527             rij=dsqrt(rrij)
1528 C Calculate angle-dependent terms of energy and contributions to their
1529 C derivatives.
1530             call sc_angular
1531             sigsq=1.0D0/sigsq
1532             sig=sig0ij*dsqrt(sigsq)
1533             rij_shift=1.0D0/rij-sig+sig0ij
1534 c for diagnostics; uncomment
1535 c            rij_shift=1.2*sig0ij
1536 C I hate to put IF's in the loops, but here don't have another choice!!!!
1537             if (rij_shift.le.0.0D0) then
1538               evdw=1.0D20
1539 cd              write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1540 cd     &        restyp(itypi),i,restyp(itypj),j,
1541 cd     &        rij_shift,1.0D0/rij,sig,sig0ij,sigsq,1-dsqrt(sigsq)
1542               return
1543             endif
1544             sigder=-sig*sigsq
1545 c---------------------------------------------------------------
1546             rij_shift=1.0D0/rij_shift
1547             fac=rij_shift**expon
1548             e1=fac*fac*aa(itypi,itypj)
1549             e2=fac*bb(itypi,itypj)
1550             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1551             eps2der=evdwij*eps3rt
1552             eps3der=evdwij*eps2rt
1553 c            write (iout,*) "sigsq",sigsq," sig",sig," eps2rt",eps2rt,
1554 c     &        " eps3rt",eps3rt," eps1",eps1," e1",e1," e2",e2
1555             evdwij=evdwij*eps2rt*eps3rt
1556             evdw=evdw+evdwij
1557             if (lprn) then
1558             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1559             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1560             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1561      &        restyp(itypi),i,restyp(itypj),j,
1562      &        epsi,sigm,chi1,chi2,chip1,chip2,
1563      &        eps1,eps2rt**2,eps3rt**2,sig,sig0ij,
1564      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1565      &        evdwij
1566             endif
1567
1568             if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
1569      &                        'evdw',i,j,evdwij
1570
1571 C Calculate gradient components.
1572             e1=e1*eps1*eps2rt**2*eps3rt**2
1573             fac=-expon*(e1+evdwij)*rij_shift
1574             sigder=fac*sigder
1575             fac=rij*fac
1576 c            fac=0.0d0
1577 C Calculate the radial part of the gradient
1578             gg(1)=xj*fac
1579             gg(2)=yj*fac
1580             gg(3)=zj*fac
1581 C Calculate angular part of the gradient.
1582             call sc_grad
1583             ENDIF    ! dyn_ss
1584           enddo      ! j
1585         enddo        ! iint
1586       enddo          ! i
1587 c      write (iout,*) "Number of loop steps in EGB:",ind
1588 cccc      energy_dec=.false.
1589       return
1590       end
1591 C-----------------------------------------------------------------------------
1592       subroutine egbv(evdw)
1593 C
1594 C This subroutine calculates the interaction energy of nonbonded side chains
1595 C assuming the Gay-Berne-Vorobjev potential of interaction.
1596 C
1597       implicit real*8 (a-h,o-z)
1598       include 'DIMENSIONS'
1599       include 'COMMON.GEO'
1600       include 'COMMON.VAR'
1601       include 'COMMON.LOCAL'
1602       include 'COMMON.CHAIN'
1603       include 'COMMON.DERIV'
1604       include 'COMMON.NAMES'
1605       include 'COMMON.INTERACT'
1606       include 'COMMON.IOUNITS'
1607       include 'COMMON.CALC'
1608       common /srutu/ icall
1609       logical lprn
1610       evdw=0.0D0
1611 c     print *,'Entering EGB nnt=',nnt,' nct=',nct,' expon=',expon
1612       evdw=0.0D0
1613       lprn=.false.
1614 c     if (icall.eq.0) lprn=.true.
1615       ind=0
1616       do i=iatsc_s,iatsc_e
1617         itypi=iabs(itype(i))
1618         if (itypi.eq.ntyp1) cycle
1619         itypi1=iabs(itype(i+1))
1620         xi=c(1,nres+i)
1621         yi=c(2,nres+i)
1622         zi=c(3,nres+i)
1623         dxi=dc_norm(1,nres+i)
1624         dyi=dc_norm(2,nres+i)
1625         dzi=dc_norm(3,nres+i)
1626 c        dsci_inv=dsc_inv(itypi)
1627         dsci_inv=vbld_inv(i+nres)
1628 C
1629 C Calculate SC interaction energy.
1630 C
1631         do iint=1,nint_gr(i)
1632           do j=istart(i,iint),iend(i,iint)
1633             ind=ind+1
1634             itypj=iabs(itype(j))
1635             if (itypj.eq.ntyp1) cycle
1636 c            dscj_inv=dsc_inv(itypj)
1637             dscj_inv=vbld_inv(j+nres)
1638             sig0ij=sigma(itypi,itypj)
1639             r0ij=r0(itypi,itypj)
1640             chi1=chi(itypi,itypj)
1641             chi2=chi(itypj,itypi)
1642             chi12=chi1*chi2
1643             chip1=chip(itypi)
1644             chip2=chip(itypj)
1645             chip12=chip1*chip2
1646             alf1=alp(itypi)
1647             alf2=alp(itypj)
1648             alf12=0.5D0*(alf1+alf2)
1649 C For diagnostics only!!!
1650 c           chi1=0.0D0
1651 c           chi2=0.0D0
1652 c           chi12=0.0D0
1653 c           chip1=0.0D0
1654 c           chip2=0.0D0
1655 c           chip12=0.0D0
1656 c           alf1=0.0D0
1657 c           alf2=0.0D0
1658 c           alf12=0.0D0
1659             xj=c(1,nres+j)-xi
1660             yj=c(2,nres+j)-yi
1661             zj=c(3,nres+j)-zi
1662             dxj=dc_norm(1,nres+j)
1663             dyj=dc_norm(2,nres+j)
1664             dzj=dc_norm(3,nres+j)
1665             rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
1666             rij=dsqrt(rrij)
1667 C Calculate angle-dependent terms of energy and contributions to their
1668 C derivatives.
1669             call sc_angular
1670             sigsq=1.0D0/sigsq
1671             sig=sig0ij*dsqrt(sigsq)
1672             rij_shift=1.0D0/rij-sig+r0ij
1673 C I hate to put IF's in the loops, but here don't have another choice!!!!
1674             if (rij_shift.le.0.0D0) then
1675               evdw=1.0D20
1676               return
1677             endif
1678             sigder=-sig*sigsq
1679 c---------------------------------------------------------------
1680             rij_shift=1.0D0/rij_shift
1681             fac=rij_shift**expon
1682             e1=fac*fac*aa(itypi,itypj)
1683             e2=fac*bb(itypi,itypj)
1684             evdwij=eps1*eps2rt*eps3rt*(e1+e2)
1685             eps2der=evdwij*eps3rt
1686             eps3der=evdwij*eps2rt
1687             fac_augm=rrij**expon
1688             e_augm=augm(itypi,itypj)*fac_augm
1689             evdwij=evdwij*eps2rt*eps3rt
1690             evdw=evdw+evdwij+e_augm
1691             if (lprn) then
1692             sigm=dabs(aa(itypi,itypj)/bb(itypi,itypj))**(1.0D0/6.0D0)
1693             epsi=bb(itypi,itypj)**2/aa(itypi,itypj)
1694             write (iout,'(2(a3,i3,2x),17(0pf7.3))')
1695      &        restyp(itypi),i,restyp(itypj),j,
1696      &        epsi,sigm,sig,(augm(itypi,itypj)/epsi)**(1.0D0/12.0D0),
1697      &        chi1,chi2,chip1,chip2,
1698      &        eps1,eps2rt**2,eps3rt**2,
1699      &        om1,om2,om12,1.0D0/rij,1.0D0/rij_shift,
1700      &        evdwij+e_augm
1701             endif
1702 C Calculate gradient components.
1703             e1=e1*eps1*eps2rt**2*eps3rt**2
1704             fac=-expon*(e1+evdwij)*rij_shift
1705             sigder=fac*sigder
1706             fac=rij*fac-2*expon*rrij*e_augm
1707 C Calculate the radial part of the gradient
1708             gg(1)=xj*fac
1709             gg(2)=yj*fac
1710             gg(3)=zj*fac
1711 C Calculate angular part of the gradient.
1712             call sc_grad
1713           enddo      ! j
1714         enddo        ! iint
1715       enddo          ! i
1716       end
1717 C-----------------------------------------------------------------------------
1718       subroutine sc_angular
1719 C Calculate eps1,eps2,eps3,sigma, and parts of their derivatives in om1,om2,
1720 C om12. Called by ebp, egb, and egbv.
1721       implicit none
1722       include 'COMMON.CALC'
1723       include 'COMMON.IOUNITS'
1724       erij(1)=xj*rij
1725       erij(2)=yj*rij
1726       erij(3)=zj*rij
1727       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
1728       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
1729       om12=dxi*dxj+dyi*dyj+dzi*dzj
1730       chiom12=chi12*om12
1731 C Calculate eps1(om12) and its derivative in om12
1732       faceps1=1.0D0-om12*chiom12
1733       faceps1_inv=1.0D0/faceps1
1734       eps1=dsqrt(faceps1_inv)
1735 C Following variable is eps1*deps1/dom12
1736       eps1_om12=faceps1_inv*chiom12
1737 c diagnostics only
1738 c      faceps1_inv=om12
1739 c      eps1=om12
1740 c      eps1_om12=1.0d0
1741 c      write (iout,*) "om12",om12," eps1",eps1
1742 C Calculate sigma(om1,om2,om12) and the derivatives of sigma**2 in om1,om2,
1743 C and om12.
1744       om1om2=om1*om2
1745       chiom1=chi1*om1
1746       chiom2=chi2*om2
1747       facsig=om1*chiom1+om2*chiom2-2.0D0*om1om2*chiom12
1748       sigsq=1.0D0-facsig*faceps1_inv
1749       sigsq_om1=(chiom1-chiom12*om2)*faceps1_inv
1750       sigsq_om2=(chiom2-chiom12*om1)*faceps1_inv
1751       sigsq_om12=-chi12*(om1om2*faceps1-om12*facsig)*faceps1_inv**2
1752 c diagnostics only
1753 c      sigsq=1.0d0
1754 c      sigsq_om1=0.0d0
1755 c      sigsq_om2=0.0d0
1756 c      sigsq_om12=0.0d0
1757 c      write (iout,*) "chiom1",chiom1," chiom2",chiom2," chiom12",chiom12
1758 c      write (iout,*) "faceps1",faceps1," faceps1_inv",faceps1_inv,
1759 c     &    " eps1",eps1
1760 C Calculate eps2 and its derivatives in om1, om2, and om12.
1761       chipom1=chip1*om1
1762       chipom2=chip2*om2
1763       chipom12=chip12*om12
1764       facp=1.0D0-om12*chipom12
1765       facp_inv=1.0D0/facp
1766       facp1=om1*chipom1+om2*chipom2-2.0D0*om1om2*chipom12
1767 c      write (iout,*) "chipom1",chipom1," chipom2",chipom2,
1768 c     &  " chipom12",chipom12," facp",facp," facp_inv",facp_inv
1769 C Following variable is the square root of eps2
1770       eps2rt=1.0D0-facp1*facp_inv
1771 C Following three variables are the derivatives of the square root of eps
1772 C in om1, om2, and om12.
1773       eps2rt_om1=-4.0D0*(chipom1-chipom12*om2)*facp_inv
1774       eps2rt_om2=-4.0D0*(chipom2-chipom12*om1)*facp_inv
1775       eps2rt_om12=4.0D0*chip12*(om1om2*facp-om12*facp1)*facp_inv**2
1776 C Evaluate the "asymmetric" factor in the VDW constant, eps3
1777       eps3rt=1.0D0-alf1*om1+alf2*om2-alf12*om12
1778 c      write (iout,*) "eps2rt",eps2rt," eps3rt",eps3rt
1779 c      write (iout,*) "eps2rt_om1",eps2rt_om1," eps2rt_om2",eps2rt_om2,
1780 c     &  " eps2rt_om12",eps2rt_om12
1781 C Calculate whole angle-dependent part of epsilon and contributions
1782 C to its derivatives
1783       return
1784       end
1785 C----------------------------------------------------------------------------
1786       subroutine sc_grad
1787       implicit real*8 (a-h,o-z)
1788       include 'DIMENSIONS'
1789       include 'COMMON.CHAIN'
1790       include 'COMMON.DERIV'
1791       include 'COMMON.CALC'
1792       include 'COMMON.IOUNITS'
1793       double precision dcosom1(3),dcosom2(3)
1794       eom1=eps2der*eps2rt_om1-2.0D0*alf1*eps3der+sigder*sigsq_om1
1795       eom2=eps2der*eps2rt_om2+2.0D0*alf2*eps3der+sigder*sigsq_om2
1796       eom12=evdwij*eps1_om12+eps2der*eps2rt_om12
1797      &     -2.0D0*alf12*eps3der+sigder*sigsq_om12
1798 c diagnostics only
1799 c      eom1=0.0d0
1800 c      eom2=0.0d0
1801 c      eom12=evdwij*eps1_om12
1802 c end diagnostics
1803 c      write (iout,*) "eps2der",eps2der," eps3der",eps3der,
1804 c     &  " sigder",sigder
1805 c      write (iout,*) "eps1_om12",eps1_om12," eps2rt_om12",eps2rt_om12
1806 c      write (iout,*) "eom1",eom1," eom2",eom2," eom12",eom12
1807       do k=1,3
1808         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
1809         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
1810       enddo
1811       do k=1,3
1812         gg(k)=gg(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
1813       enddo
1814 c      write (iout,*) "gg",(gg(k),k=1,3)
1815       do k=1,3
1816         gvdwx(k,i)=gvdwx(k,i)-gg(k)
1817      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1818      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1819         gvdwx(k,j)=gvdwx(k,j)+gg(k)
1820      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1821      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1822 c        write (iout,*)(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
1823 c     &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
1824 c        write (iout,*)(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
1825 c     &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
1826       enddo
1827 C
1828 C Calculate the components of the gradient in DC and X
1829 C
1830 cgrad      do k=i,j-1
1831 cgrad        do l=1,3
1832 cgrad          gvdwc(l,k)=gvdwc(l,k)+gg(l)
1833 cgrad        enddo
1834 cgrad      enddo
1835       do l=1,3
1836         gvdwc(l,i)=gvdwc(l,i)-gg(l)
1837         gvdwc(l,j)=gvdwc(l,j)+gg(l)
1838       enddo
1839       return
1840       end
1841 C-----------------------------------------------------------------------
1842       subroutine e_softsphere(evdw)
1843 C
1844 C This subroutine calculates the interaction energy of nonbonded side chains
1845 C assuming the LJ potential of interaction.
1846 C
1847       implicit real*8 (a-h,o-z)
1848       include 'DIMENSIONS'
1849       parameter (accur=1.0d-10)
1850       include 'COMMON.GEO'
1851       include 'COMMON.VAR'
1852       include 'COMMON.LOCAL'
1853       include 'COMMON.CHAIN'
1854       include 'COMMON.DERIV'
1855       include 'COMMON.INTERACT'
1856       include 'COMMON.TORSION'
1857       include 'COMMON.SBRIDGE'
1858       include 'COMMON.NAMES'
1859       include 'COMMON.IOUNITS'
1860       include 'COMMON.CONTACTS'
1861       dimension gg(3)
1862 cd    print *,'Entering Esoft_sphere nnt=',nnt,' nct=',nct
1863       evdw=0.0D0
1864       do i=iatsc_s,iatsc_e
1865         itypi=iabs(itype(i))
1866         if (itypi.eq.ntyp1) cycle
1867         itypi1=iabs(itype(i+1))
1868         xi=c(1,nres+i)
1869         yi=c(2,nres+i)
1870         zi=c(3,nres+i)
1871 C
1872 C Calculate SC interaction energy.
1873 C
1874         do iint=1,nint_gr(i)
1875 cd        write (iout,*) 'i=',i,' iint=',iint,' istart=',istart(i,iint),
1876 cd   &                  'iend=',iend(i,iint)
1877           do j=istart(i,iint),iend(i,iint)
1878             itypj=iabs(itype(j))
1879             if (itypj.eq.ntyp1) cycle
1880             xj=c(1,nres+j)-xi
1881             yj=c(2,nres+j)-yi
1882             zj=c(3,nres+j)-zi
1883             rij=xj*xj+yj*yj+zj*zj
1884 c           write (iout,*)'i=',i,' j=',j,' itypi=',itypi,' itypj=',itypj
1885             r0ij=r0(itypi,itypj)
1886             r0ijsq=r0ij*r0ij
1887 c            print *,i,j,r0ij,dsqrt(rij)
1888             if (rij.lt.r0ijsq) then
1889               evdwij=0.25d0*(rij-r0ijsq)**2
1890               fac=rij-r0ijsq
1891             else
1892               evdwij=0.0d0
1893               fac=0.0d0
1894             endif
1895             evdw=evdw+evdwij
1896 C
1897 C Calculate the components of the gradient in DC and X
1898 C
1899             gg(1)=xj*fac
1900             gg(2)=yj*fac
1901             gg(3)=zj*fac
1902             do k=1,3
1903               gvdwx(k,i)=gvdwx(k,i)-gg(k)
1904               gvdwx(k,j)=gvdwx(k,j)+gg(k)
1905               gvdwc(k,i)=gvdwc(k,i)-gg(k)
1906               gvdwc(k,j)=gvdwc(k,j)+gg(k)
1907             enddo
1908 cgrad            do k=i,j-1
1909 cgrad              do l=1,3
1910 cgrad                gvdwc(l,k)=gvdwc(l,k)+gg(l)
1911 cgrad              enddo
1912 cgrad            enddo
1913           enddo ! j
1914         enddo ! iint
1915       enddo ! i
1916       return
1917       end
1918 C--------------------------------------------------------------------------
1919       subroutine eelec_soft_sphere(ees,evdw1,eel_loc,eello_turn3,
1920      &              eello_turn4)
1921 C
1922 C Soft-sphere potential of p-p interaction
1923 C
1924       implicit real*8 (a-h,o-z)
1925       include 'DIMENSIONS'
1926       include 'COMMON.CONTROL'
1927       include 'COMMON.IOUNITS'
1928       include 'COMMON.GEO'
1929       include 'COMMON.VAR'
1930       include 'COMMON.LOCAL'
1931       include 'COMMON.CHAIN'
1932       include 'COMMON.DERIV'
1933       include 'COMMON.INTERACT'
1934       include 'COMMON.CONTACTS'
1935       include 'COMMON.TORSION'
1936       include 'COMMON.VECTORS'
1937       include 'COMMON.FFIELD'
1938       dimension ggg(3)
1939 cd      write(iout,*) 'In EELEC_soft_sphere'
1940       ees=0.0D0
1941       evdw1=0.0D0
1942       eel_loc=0.0d0
1943       eello_turn3=0.0d0
1944       eello_turn4=0.0d0
1945       ind=0
1946       do i=iatel_s,iatel_e
1947         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
1948         dxi=dc(1,i)
1949         dyi=dc(2,i)
1950         dzi=dc(3,i)
1951         xmedi=c(1,i)+0.5d0*dxi
1952         ymedi=c(2,i)+0.5d0*dyi
1953         zmedi=c(3,i)+0.5d0*dzi
1954         num_conti=0
1955 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
1956         do j=ielstart(i),ielend(i)
1957           if (itype(j).eq.ntyp1 .or. itype(j+1).eq.ntyp1) cycle
1958           ind=ind+1
1959           iteli=itel(i)
1960           itelj=itel(j)
1961           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
1962           r0ij=rpp(iteli,itelj)
1963           r0ijsq=r0ij*r0ij
1964           dxj=dc(1,j)
1965           dyj=dc(2,j)
1966           dzj=dc(3,j)
1967           xj=c(1,j)+0.5D0*dxj-xmedi
1968           yj=c(2,j)+0.5D0*dyj-ymedi
1969           zj=c(3,j)+0.5D0*dzj-zmedi
1970           rij=xj*xj+yj*yj+zj*zj
1971           if (rij.lt.r0ijsq) then
1972             evdw1ij=0.25d0*(rij-r0ijsq)**2
1973             fac=rij-r0ijsq
1974           else
1975             evdw1ij=0.0d0
1976             fac=0.0d0
1977           endif
1978           evdw1=evdw1+evdw1ij
1979 C
1980 C Calculate contributions to the Cartesian gradient.
1981 C
1982           ggg(1)=fac*xj
1983           ggg(2)=fac*yj
1984           ggg(3)=fac*zj
1985           do k=1,3
1986             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
1987             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
1988           enddo
1989 *
1990 * Loop over residues i+1 thru j-1.
1991 *
1992 cgrad          do k=i+1,j-1
1993 cgrad            do l=1,3
1994 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
1995 cgrad            enddo
1996 cgrad          enddo
1997         enddo ! j
1998       enddo   ! i
1999 cgrad      do i=nnt,nct-1
2000 cgrad        do k=1,3
2001 cgrad          gelc(k,i)=gelc(k,i)+0.5d0*gelc(k,i)
2002 cgrad        enddo
2003 cgrad        do j=i+1,nct-1
2004 cgrad          do k=1,3
2005 cgrad            gelc(k,i)=gelc(k,i)+gelc(k,j)
2006 cgrad          enddo
2007 cgrad        enddo
2008 cgrad      enddo
2009       return
2010       end
2011 c------------------------------------------------------------------------------
2012       subroutine vec_and_deriv
2013       implicit real*8 (a-h,o-z)
2014       include 'DIMENSIONS'
2015 #ifdef MPI
2016       include 'mpif.h'
2017 #endif
2018       include 'COMMON.IOUNITS'
2019       include 'COMMON.GEO'
2020       include 'COMMON.VAR'
2021       include 'COMMON.LOCAL'
2022       include 'COMMON.CHAIN'
2023       include 'COMMON.VECTORS'
2024       include 'COMMON.SETUP'
2025       include 'COMMON.TIME1'
2026       dimension uyder(3,3,2),uzder(3,3,2),vbld_inv_temp(2)
2027 C Compute the local reference systems. For reference system (i), the
2028 C X-axis points from CA(i) to CA(i+1), the Y axis is in the
2029 C CA(i)-CA(i+1)-CA(i+2) plane, and the Z axis is perpendicular to this plane.
2030 #ifdef PARVEC
2031       do i=ivec_start,ivec_end
2032 #else
2033       do i=1,nres-1
2034 #endif
2035           if (i.eq.nres-1) then
2036 C Case of the last full residue
2037 C Compute the Z-axis
2038             call vecpr(dc_norm(1,i),dc_norm(1,i-1),uz(1,i))
2039             costh=dcos(pi-theta(nres))
2040             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2041             do k=1,3
2042               uz(k,i)=fac*uz(k,i)
2043             enddo
2044 C Compute the derivatives of uz
2045             uzder(1,1,1)= 0.0d0
2046             uzder(2,1,1)=-dc_norm(3,i-1)
2047             uzder(3,1,1)= dc_norm(2,i-1)
2048             uzder(1,2,1)= dc_norm(3,i-1)
2049             uzder(2,2,1)= 0.0d0
2050             uzder(3,2,1)=-dc_norm(1,i-1)
2051             uzder(1,3,1)=-dc_norm(2,i-1)
2052             uzder(2,3,1)= dc_norm(1,i-1)
2053             uzder(3,3,1)= 0.0d0
2054             uzder(1,1,2)= 0.0d0
2055             uzder(2,1,2)= dc_norm(3,i)
2056             uzder(3,1,2)=-dc_norm(2,i)
2057             uzder(1,2,2)=-dc_norm(3,i)
2058             uzder(2,2,2)= 0.0d0
2059             uzder(3,2,2)= dc_norm(1,i)
2060             uzder(1,3,2)= dc_norm(2,i)
2061             uzder(2,3,2)=-dc_norm(1,i)
2062             uzder(3,3,2)= 0.0d0
2063 C Compute the Y-axis
2064             facy=fac
2065             do k=1,3
2066               uy(k,i)=fac*(dc_norm(k,i-1)-costh*dc_norm(k,i))
2067             enddo
2068 C Compute the derivatives of uy
2069             do j=1,3
2070               do k=1,3
2071                 uyder(k,j,1)=2*dc_norm(k,i-1)*dc_norm(j,i)
2072      &                        -dc_norm(k,i)*dc_norm(j,i-1)
2073                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2074               enddo
2075               uyder(j,j,1)=uyder(j,j,1)-costh
2076               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2077             enddo
2078             do j=1,2
2079               do k=1,3
2080                 do l=1,3
2081                   uygrad(l,k,j,i)=uyder(l,k,j)
2082                   uzgrad(l,k,j,i)=uzder(l,k,j)
2083                 enddo
2084               enddo
2085             enddo
2086             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2087             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2088             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2089             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2090           else
2091 C Other residues
2092 C Compute the Z-axis
2093             call vecpr(dc_norm(1,i),dc_norm(1,i+1),uz(1,i))
2094             costh=dcos(pi-theta(i+2))
2095             fac=1.0d0/dsqrt(1.0d0-costh*costh)
2096             do k=1,3
2097               uz(k,i)=fac*uz(k,i)
2098             enddo
2099 C Compute the derivatives of uz
2100             uzder(1,1,1)= 0.0d0
2101             uzder(2,1,1)=-dc_norm(3,i+1)
2102             uzder(3,1,1)= dc_norm(2,i+1)
2103             uzder(1,2,1)= dc_norm(3,i+1)
2104             uzder(2,2,1)= 0.0d0
2105             uzder(3,2,1)=-dc_norm(1,i+1)
2106             uzder(1,3,1)=-dc_norm(2,i+1)
2107             uzder(2,3,1)= dc_norm(1,i+1)
2108             uzder(3,3,1)= 0.0d0
2109             uzder(1,1,2)= 0.0d0
2110             uzder(2,1,2)= dc_norm(3,i)
2111             uzder(3,1,2)=-dc_norm(2,i)
2112             uzder(1,2,2)=-dc_norm(3,i)
2113             uzder(2,2,2)= 0.0d0
2114             uzder(3,2,2)= dc_norm(1,i)
2115             uzder(1,3,2)= dc_norm(2,i)
2116             uzder(2,3,2)=-dc_norm(1,i)
2117             uzder(3,3,2)= 0.0d0
2118 C Compute the Y-axis
2119             facy=fac
2120             do k=1,3
2121               uy(k,i)=facy*(dc_norm(k,i+1)-costh*dc_norm(k,i))
2122             enddo
2123 C Compute the derivatives of uy
2124             do j=1,3
2125               do k=1,3
2126                 uyder(k,j,1)=2*dc_norm(k,i+1)*dc_norm(j,i)
2127      &                        -dc_norm(k,i)*dc_norm(j,i+1)
2128                 uyder(k,j,2)=-dc_norm(j,i)*dc_norm(k,i)
2129               enddo
2130               uyder(j,j,1)=uyder(j,j,1)-costh
2131               uyder(j,j,2)=1.0d0+uyder(j,j,2)
2132             enddo
2133             do j=1,2
2134               do k=1,3
2135                 do l=1,3
2136                   uygrad(l,k,j,i)=uyder(l,k,j)
2137                   uzgrad(l,k,j,i)=uzder(l,k,j)
2138                 enddo
2139               enddo
2140             enddo
2141             call unormderiv(uy(1,i),uyder(1,1,1),facy,uygrad(1,1,1,i))
2142             call unormderiv(uy(1,i),uyder(1,1,2),facy,uygrad(1,1,2,i))
2143             call unormderiv(uz(1,i),uzder(1,1,1),fac,uzgrad(1,1,1,i))
2144             call unormderiv(uz(1,i),uzder(1,1,2),fac,uzgrad(1,1,2,i))
2145           endif
2146       enddo
2147       do i=1,nres-1
2148         vbld_inv_temp(1)=vbld_inv(i+1)
2149         if (i.lt.nres-1) then
2150           vbld_inv_temp(2)=vbld_inv(i+2)
2151           else
2152           vbld_inv_temp(2)=vbld_inv(i)
2153           endif
2154         do j=1,2
2155           do k=1,3
2156             do l=1,3
2157               uygrad(l,k,j,i)=vbld_inv_temp(j)*uygrad(l,k,j,i)
2158               uzgrad(l,k,j,i)=vbld_inv_temp(j)*uzgrad(l,k,j,i)
2159             enddo
2160           enddo
2161         enddo
2162       enddo
2163 #if defined(PARVEC) && defined(MPI)
2164       if (nfgtasks1.gt.1) then
2165         time00=MPI_Wtime()
2166 c        print *,"Processor",fg_rank1,kolor1," ivec_start",ivec_start,
2167 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks1-1),
2168 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks1-1)
2169         call MPI_Allgatherv(uy(1,ivec_start),ivec_count(fg_rank1),
2170      &   MPI_UYZ,uy(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2171      &   FG_COMM1,IERR)
2172         call MPI_Allgatherv(uz(1,ivec_start),ivec_count(fg_rank1),
2173      &   MPI_UYZ,uz(1,1),ivec_count(0),ivec_displ(0),MPI_UYZ,
2174      &   FG_COMM1,IERR)
2175         call MPI_Allgatherv(uygrad(1,1,1,ivec_start),
2176      &   ivec_count(fg_rank1),MPI_UYZGRAD,uygrad(1,1,1,1),ivec_count(0),
2177      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2178         call MPI_Allgatherv(uzgrad(1,1,1,ivec_start),
2179      &   ivec_count(fg_rank1),MPI_UYZGRAD,uzgrad(1,1,1,1),ivec_count(0),
2180      &   ivec_displ(0),MPI_UYZGRAD,FG_COMM1,IERR)
2181         time_gather=time_gather+MPI_Wtime()-time00
2182       endif
2183 c      if (fg_rank.eq.0) then
2184 c        write (iout,*) "Arrays UY and UZ"
2185 c        do i=1,nres-1
2186 c          write (iout,'(i5,3f10.5,5x,3f10.5)') i,(uy(k,i),k=1,3),
2187 c     &     (uz(k,i),k=1,3)
2188 c        enddo
2189 c      endif
2190 #endif
2191       return
2192       end
2193 C-----------------------------------------------------------------------------
2194       subroutine check_vecgrad
2195       implicit real*8 (a-h,o-z)
2196       include 'DIMENSIONS'
2197       include 'COMMON.IOUNITS'
2198       include 'COMMON.GEO'
2199       include 'COMMON.VAR'
2200       include 'COMMON.LOCAL'
2201       include 'COMMON.CHAIN'
2202       include 'COMMON.VECTORS'
2203       dimension uygradt(3,3,2,maxres),uzgradt(3,3,2,maxres)
2204       dimension uyt(3,maxres),uzt(3,maxres)
2205       dimension uygradn(3,3,2),uzgradn(3,3,2),erij(3)
2206       double precision delta /1.0d-7/
2207       call vec_and_deriv
2208 cd      do i=1,nres
2209 crc          write(iout,'(2i5,2(3f10.5,5x))') i,1,dc_norm(:,i)
2210 crc          write(iout,'(2i5,2(3f10.5,5x))') i,2,uy(:,i)
2211 crc          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,uz(:,i)
2212 cd          write(iout,'(2i5,2(3f10.5,5x))') i,1,
2213 cd     &     (dc_norm(if90,i),if90=1,3)
2214 cd          write(iout,'(2i5,2(3f10.5,5x))') i,2,(uy(if90,i),if90=1,3)
2215 cd          write(iout,'(2i5,2(3f10.5,5x)/)')i,3,(uz(if90,i),if90=1,3)
2216 cd          write(iout,'(a)')
2217 cd      enddo
2218       do i=1,nres
2219         do j=1,2
2220           do k=1,3
2221             do l=1,3
2222               uygradt(l,k,j,i)=uygrad(l,k,j,i)
2223               uzgradt(l,k,j,i)=uzgrad(l,k,j,i)
2224             enddo
2225           enddo
2226         enddo
2227       enddo
2228       call vec_and_deriv
2229       do i=1,nres
2230         do j=1,3
2231           uyt(j,i)=uy(j,i)
2232           uzt(j,i)=uz(j,i)
2233         enddo
2234       enddo
2235       do i=1,nres
2236 cd        write (iout,*) 'i=',i
2237         do k=1,3
2238           erij(k)=dc_norm(k,i)
2239         enddo
2240         do j=1,3
2241           do k=1,3
2242             dc_norm(k,i)=erij(k)
2243           enddo
2244           dc_norm(j,i)=dc_norm(j,i)+delta
2245 c          fac=dsqrt(scalar(dc_norm(1,i),dc_norm(1,i)))
2246 c          do k=1,3
2247 c            dc_norm(k,i)=dc_norm(k,i)/fac
2248 c          enddo
2249 c          write (iout,*) (dc_norm(k,i),k=1,3)
2250 c          write (iout,*) (erij(k),k=1,3)
2251           call vec_and_deriv
2252           do k=1,3
2253             uygradn(k,j,1)=(uy(k,i)-uyt(k,i))/delta
2254             uygradn(k,j,2)=(uy(k,i-1)-uyt(k,i-1))/delta
2255             uzgradn(k,j,1)=(uz(k,i)-uzt(k,i))/delta
2256             uzgradn(k,j,2)=(uz(k,i-1)-uzt(k,i-1))/delta
2257           enddo
2258 c          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2259 c     &      j,(uzgradt(k,j,1,i),k=1,3),(uzgradn(k,j,1),k=1,3),
2260 c     &      (uzgradt(k,j,2,i-1),k=1,3),(uzgradn(k,j,2),k=1,3)
2261         enddo
2262         do k=1,3
2263           dc_norm(k,i)=erij(k)
2264         enddo
2265 cd        do k=1,3
2266 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2267 cd     &      k,(uygradt(k,l,1,i),l=1,3),(uygradn(k,l,1),l=1,3),
2268 cd     &      (uygradt(k,l,2,i-1),l=1,3),(uygradn(k,l,2),l=1,3)
2269 cd          write (iout,'(i5,3f8.5,3x,3f8.5,5x,3f8.5,3x,3f8.5)')
2270 cd     &      k,(uzgradt(k,l,1,i),l=1,3),(uzgradn(k,l,1),l=1,3),
2271 cd     &      (uzgradt(k,l,2,i-1),l=1,3),(uzgradn(k,l,2),l=1,3)
2272 cd          write (iout,'(a)')
2273 cd        enddo
2274       enddo
2275       return
2276       end
2277 C--------------------------------------------------------------------------
2278       subroutine set_matrices
2279       implicit real*8 (a-h,o-z)
2280       include 'DIMENSIONS'
2281 #ifdef MPI
2282       include "mpif.h"
2283       include "COMMON.SETUP"
2284       integer IERR
2285       integer status(MPI_STATUS_SIZE)
2286 #endif
2287       include 'COMMON.IOUNITS'
2288       include 'COMMON.GEO'
2289       include 'COMMON.VAR'
2290       include 'COMMON.LOCAL'
2291       include 'COMMON.CHAIN'
2292       include 'COMMON.DERIV'
2293       include 'COMMON.INTERACT'
2294       include 'COMMON.CONTACTS'
2295       include 'COMMON.TORSION'
2296       include 'COMMON.VECTORS'
2297       include 'COMMON.FFIELD'
2298       double precision auxvec(2),auxmat(2,2)
2299 C
2300 C Compute the virtual-bond-torsional-angle dependent quantities needed
2301 C to calculate the el-loc multibody terms of various order.
2302 C
2303 #ifdef PARMAT
2304       do i=ivec_start+2,ivec_end+2
2305 #else
2306       do i=3,nres+1
2307 #endif
2308         if (i .lt. nres+1) then
2309           sin1=dsin(phi(i))
2310           cos1=dcos(phi(i))
2311           sintab(i-2)=sin1
2312           costab(i-2)=cos1
2313           obrot(1,i-2)=cos1
2314           obrot(2,i-2)=sin1
2315           sin2=dsin(2*phi(i))
2316           cos2=dcos(2*phi(i))
2317           sintab2(i-2)=sin2
2318           costab2(i-2)=cos2
2319           obrot2(1,i-2)=cos2
2320           obrot2(2,i-2)=sin2
2321           Ug(1,1,i-2)=-cos1
2322           Ug(1,2,i-2)=-sin1
2323           Ug(2,1,i-2)=-sin1
2324           Ug(2,2,i-2)= cos1
2325           Ug2(1,1,i-2)=-cos2
2326           Ug2(1,2,i-2)=-sin2
2327           Ug2(2,1,i-2)=-sin2
2328           Ug2(2,2,i-2)= cos2
2329         else
2330           costab(i-2)=1.0d0
2331           sintab(i-2)=0.0d0
2332           obrot(1,i-2)=1.0d0
2333           obrot(2,i-2)=0.0d0
2334           obrot2(1,i-2)=0.0d0
2335           obrot2(2,i-2)=0.0d0
2336           Ug(1,1,i-2)=1.0d0
2337           Ug(1,2,i-2)=0.0d0
2338           Ug(2,1,i-2)=0.0d0
2339           Ug(2,2,i-2)=1.0d0
2340           Ug2(1,1,i-2)=0.0d0
2341           Ug2(1,2,i-2)=0.0d0
2342           Ug2(2,1,i-2)=0.0d0
2343           Ug2(2,2,i-2)=0.0d0
2344         endif
2345         if (i .gt. 3 .and. i .lt. nres+1) then
2346           obrot_der(1,i-2)=-sin1
2347           obrot_der(2,i-2)= cos1
2348           Ugder(1,1,i-2)= sin1
2349           Ugder(1,2,i-2)=-cos1
2350           Ugder(2,1,i-2)=-cos1
2351           Ugder(2,2,i-2)=-sin1
2352           dwacos2=cos2+cos2
2353           dwasin2=sin2+sin2
2354           obrot2_der(1,i-2)=-dwasin2
2355           obrot2_der(2,i-2)= dwacos2
2356           Ug2der(1,1,i-2)= dwasin2
2357           Ug2der(1,2,i-2)=-dwacos2
2358           Ug2der(2,1,i-2)=-dwacos2
2359           Ug2der(2,2,i-2)=-dwasin2
2360         else
2361           obrot_der(1,i-2)=0.0d0
2362           obrot_der(2,i-2)=0.0d0
2363           Ugder(1,1,i-2)=0.0d0
2364           Ugder(1,2,i-2)=0.0d0
2365           Ugder(2,1,i-2)=0.0d0
2366           Ugder(2,2,i-2)=0.0d0
2367           obrot2_der(1,i-2)=0.0d0
2368           obrot2_der(2,i-2)=0.0d0
2369           Ug2der(1,1,i-2)=0.0d0
2370           Ug2der(1,2,i-2)=0.0d0
2371           Ug2der(2,1,i-2)=0.0d0
2372           Ug2der(2,2,i-2)=0.0d0
2373         endif
2374 c        if (i.gt. iatel_s+2 .and. i.lt.iatel_e+5) then
2375         if (i.gt. nnt+2 .and. i.lt.nct+2) then
2376           iti = itortyp(itype(i-2))
2377         else
2378           iti=ntortyp+1
2379         endif
2380 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2381         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2382           iti1 = itortyp(itype(i-1))
2383         else
2384           iti1=ntortyp+1
2385         endif
2386 cd        write (iout,*) '*******i',i,' iti1',iti
2387 cd        write (iout,*) 'b1',b1(:,iti)
2388 cd        write (iout,*) 'b2',b2(:,iti)
2389 cd        write (iout,*) 'Ug',Ug(:,:,i-2)
2390 c        if (i .gt. iatel_s+2) then
2391         if (i .gt. nnt+2) then
2392           call matvec2(Ug(1,1,i-2),b2(1,iti),Ub2(1,i-2))
2393           call matmat2(EE(1,1,iti),Ug(1,1,i-2),EUg(1,1,i-2))
2394           if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2395      &    then
2396           call matmat2(CC(1,1,iti),Ug(1,1,i-2),CUg(1,1,i-2))
2397           call matmat2(DD(1,1,iti),Ug(1,1,i-2),DUg(1,1,i-2))
2398           call matmat2(Dtilde(1,1,iti),Ug2(1,1,i-2),DtUg2(1,1,i-2))
2399           call matvec2(Ctilde(1,1,iti1),obrot(1,i-2),Ctobr(1,i-2))
2400           call matvec2(Dtilde(1,1,iti),obrot2(1,i-2),Dtobr2(1,i-2))
2401           endif
2402         else
2403           do k=1,2
2404             Ub2(k,i-2)=0.0d0
2405             Ctobr(k,i-2)=0.0d0
2406             Dtobr2(k,i-2)=0.0d0
2407             do l=1,2
2408               EUg(l,k,i-2)=0.0d0
2409               CUg(l,k,i-2)=0.0d0
2410               DUg(l,k,i-2)=0.0d0
2411               DtUg2(l,k,i-2)=0.0d0
2412             enddo
2413           enddo
2414         endif
2415         call matvec2(Ugder(1,1,i-2),b2(1,iti),Ub2der(1,i-2))
2416         call matmat2(EE(1,1,iti),Ugder(1,1,i-2),EUgder(1,1,i-2))
2417         do k=1,2
2418           muder(k,i-2)=Ub2der(k,i-2)
2419         enddo
2420 c        if (i.gt. iatel_s+1 .and. i.lt.iatel_e+4) then
2421         if (i.gt. nnt+1 .and. i.lt.nct+1) then
2422           if (itype(i-1).le.ntyp) then
2423             iti1 = itortyp(itype(i-1))
2424           else
2425             iti1=ntortyp+1
2426           endif
2427         else
2428           iti1=ntortyp+1
2429         endif
2430         do k=1,2
2431           mu(k,i-2)=Ub2(k,i-2)+b1(k,iti1)
2432         enddo
2433 cd        write (iout,*) 'mu ',mu(:,i-2)
2434 cd        write (iout,*) 'mu1',mu1(:,i-2)
2435 cd        write (iout,*) 'mu2',mu2(:,i-2)
2436         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2437      &  then
2438         call matmat2(CC(1,1,iti1),Ugder(1,1,i-2),CUgder(1,1,i-2))
2439         call matmat2(DD(1,1,iti),Ugder(1,1,i-2),DUgder(1,1,i-2))
2440         call matmat2(Dtilde(1,1,iti),Ug2der(1,1,i-2),DtUg2der(1,1,i-2))
2441         call matvec2(Ctilde(1,1,iti1),obrot_der(1,i-2),Ctobrder(1,i-2))
2442         call matvec2(Dtilde(1,1,iti),obrot2_der(1,i-2),Dtobr2der(1,i-2))
2443 C Vectors and matrices dependent on a single virtual-bond dihedral.
2444         call matvec2(DD(1,1,iti),b1tilde(1,iti1),auxvec(1))
2445         call matvec2(Ug2(1,1,i-2),auxvec(1),Ug2Db1t(1,i-2))
2446         call matvec2(Ug2der(1,1,i-2),auxvec(1),Ug2Db1tder(1,i-2))
2447         call matvec2(CC(1,1,iti1),Ub2(1,i-2),CUgb2(1,i-2))
2448         call matvec2(CC(1,1,iti1),Ub2der(1,i-2),CUgb2der(1,i-2))
2449         call matmat2(EUg(1,1,i-2),CC(1,1,iti1),EUgC(1,1,i-2))
2450         call matmat2(EUgder(1,1,i-2),CC(1,1,iti1),EUgCder(1,1,i-2))
2451         call matmat2(EUg(1,1,i-2),DD(1,1,iti1),EUgD(1,1,i-2))
2452         call matmat2(EUgder(1,1,i-2),DD(1,1,iti1),EUgDder(1,1,i-2))
2453         endif
2454       enddo
2455 C Matrices dependent on two consecutive virtual-bond dihedrals.
2456 C The order of matrices is from left to right.
2457       if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.wcorr6.gt.0.0d0)
2458      &then
2459 c      do i=max0(ivec_start,2),ivec_end
2460       do i=2,nres-1
2461         call matmat2(DtUg2(1,1,i-1),EUg(1,1,i),DtUg2EUg(1,1,i))
2462         call matmat2(DtUg2der(1,1,i-1),EUg(1,1,i),DtUg2EUgder(1,1,1,i))
2463         call matmat2(DtUg2(1,1,i-1),EUgder(1,1,i),DtUg2EUgder(1,1,2,i))
2464         call transpose2(DtUg2(1,1,i-1),auxmat(1,1))
2465         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUg(1,1,i))
2466         call matmat2(auxmat(1,1),EUgder(1,1,i),Ug2DtEUgder(1,1,2,i))
2467         call transpose2(DtUg2der(1,1,i-1),auxmat(1,1))
2468         call matmat2(auxmat(1,1),EUg(1,1,i),Ug2DtEUgder(1,1,1,i))
2469       enddo
2470       endif
2471 #if defined(MPI) && defined(PARMAT)
2472 #ifdef DEBUG
2473 c      if (fg_rank.eq.0) then
2474         write (iout,*) "Arrays UG and UGDER before GATHER"
2475         do i=1,nres-1
2476           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2477      &     ((ug(l,k,i),l=1,2),k=1,2),
2478      &     ((ugder(l,k,i),l=1,2),k=1,2)
2479         enddo
2480         write (iout,*) "Arrays UG2 and UG2DER"
2481         do i=1,nres-1
2482           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2483      &     ((ug2(l,k,i),l=1,2),k=1,2),
2484      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2485         enddo
2486         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2487         do i=1,nres-1
2488           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2489      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2490      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2491         enddo
2492         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2493         do i=1,nres-1
2494           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2495      &     costab(i),sintab(i),costab2(i),sintab2(i)
2496         enddo
2497         write (iout,*) "Array MUDER"
2498         do i=1,nres-1
2499           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2500         enddo
2501 c      endif
2502 #endif
2503       if (nfgtasks.gt.1) then
2504         time00=MPI_Wtime()
2505 c        write(iout,*)"Processor",fg_rank,kolor," ivec_start",ivec_start,
2506 c     &   " ivec_displ",(ivec_displ(i),i=0,nfgtasks-1),
2507 c     &   " ivec_count",(ivec_count(i),i=0,nfgtasks-1)
2508 #ifdef MATGATHER
2509         call MPI_Allgatherv(Ub2(1,ivec_start),ivec_count(fg_rank1),
2510      &   MPI_MU,Ub2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2511      &   FG_COMM1,IERR)
2512         call MPI_Allgatherv(Ub2der(1,ivec_start),ivec_count(fg_rank1),
2513      &   MPI_MU,Ub2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2514      &   FG_COMM1,IERR)
2515         call MPI_Allgatherv(mu(1,ivec_start),ivec_count(fg_rank1),
2516      &   MPI_MU,mu(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2517      &   FG_COMM1,IERR)
2518         call MPI_Allgatherv(muder(1,ivec_start),ivec_count(fg_rank1),
2519      &   MPI_MU,muder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2520      &   FG_COMM1,IERR)
2521         call MPI_Allgatherv(Eug(1,1,ivec_start),ivec_count(fg_rank1),
2522      &   MPI_MAT1,Eug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2523      &   FG_COMM1,IERR)
2524         call MPI_Allgatherv(Eugder(1,1,ivec_start),ivec_count(fg_rank1),
2525      &   MPI_MAT1,Eugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2526      &   FG_COMM1,IERR)
2527         call MPI_Allgatherv(costab(ivec_start),ivec_count(fg_rank1),
2528      &   MPI_DOUBLE_PRECISION,costab(1),ivec_count(0),ivec_displ(0),
2529      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2530         call MPI_Allgatherv(sintab(ivec_start),ivec_count(fg_rank1),
2531      &   MPI_DOUBLE_PRECISION,sintab(1),ivec_count(0),ivec_displ(0),
2532      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2533         call MPI_Allgatherv(costab2(ivec_start),ivec_count(fg_rank1),
2534      &   MPI_DOUBLE_PRECISION,costab2(1),ivec_count(0),ivec_displ(0),
2535      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2536         call MPI_Allgatherv(sintab2(ivec_start),ivec_count(fg_rank1),
2537      &   MPI_DOUBLE_PRECISION,sintab2(1),ivec_count(0),ivec_displ(0),
2538      &   MPI_DOUBLE_PRECISION,FG_COMM1,IERR)
2539         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2540      &  then
2541         call MPI_Allgatherv(Ctobr(1,ivec_start),ivec_count(fg_rank1),
2542      &   MPI_MU,Ctobr(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2543      &   FG_COMM1,IERR)
2544         call MPI_Allgatherv(Ctobrder(1,ivec_start),ivec_count(fg_rank1),
2545      &   MPI_MU,Ctobrder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2546      &   FG_COMM1,IERR)
2547         call MPI_Allgatherv(Dtobr2(1,ivec_start),ivec_count(fg_rank1),
2548      &   MPI_MU,Dtobr2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2549      &   FG_COMM1,IERR)
2550        call MPI_Allgatherv(Dtobr2der(1,ivec_start),ivec_count(fg_rank1),
2551      &   MPI_MU,Dtobr2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2552      &   FG_COMM1,IERR)
2553         call MPI_Allgatherv(Ug2Db1t(1,ivec_start),ivec_count(fg_rank1),
2554      &   MPI_MU,Ug2Db1t(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2555      &   FG_COMM1,IERR)
2556         call MPI_Allgatherv(Ug2Db1tder(1,ivec_start),
2557      &   ivec_count(fg_rank1),
2558      &   MPI_MU,Ug2Db1tder(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2559      &   FG_COMM1,IERR)
2560         call MPI_Allgatherv(CUgb2(1,ivec_start),ivec_count(fg_rank1),
2561      &   MPI_MU,CUgb2(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2562      &   FG_COMM1,IERR)
2563         call MPI_Allgatherv(CUgb2der(1,ivec_start),ivec_count(fg_rank1),
2564      &   MPI_MU,CUgb2der(1,1),ivec_count(0),ivec_displ(0),MPI_MU,
2565      &   FG_COMM1,IERR)
2566         call MPI_Allgatherv(Cug(1,1,ivec_start),ivec_count(fg_rank1),
2567      &   MPI_MAT1,Cug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2568      &   FG_COMM1,IERR)
2569         call MPI_Allgatherv(Cugder(1,1,ivec_start),ivec_count(fg_rank1),
2570      &   MPI_MAT1,Cugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2571      &   FG_COMM1,IERR)
2572         call MPI_Allgatherv(Dug(1,1,ivec_start),ivec_count(fg_rank1),
2573      &   MPI_MAT1,Dug(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2574      &   FG_COMM1,IERR)
2575         call MPI_Allgatherv(Dugder(1,1,ivec_start),ivec_count(fg_rank1),
2576      &   MPI_MAT1,Dugder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2577      &   FG_COMM1,IERR)
2578         call MPI_Allgatherv(Dtug2(1,1,ivec_start),ivec_count(fg_rank1),
2579      &   MPI_MAT1,Dtug2(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2580      &   FG_COMM1,IERR)
2581         call MPI_Allgatherv(Dtug2der(1,1,ivec_start),
2582      &   ivec_count(fg_rank1),
2583      &   MPI_MAT1,Dtug2der(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2584      &   FG_COMM1,IERR)
2585         call MPI_Allgatherv(EugC(1,1,ivec_start),ivec_count(fg_rank1),
2586      &   MPI_MAT1,EugC(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2587      &   FG_COMM1,IERR)
2588        call MPI_Allgatherv(EugCder(1,1,ivec_start),ivec_count(fg_rank1),
2589      &   MPI_MAT1,EugCder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2590      &   FG_COMM1,IERR)
2591         call MPI_Allgatherv(EugD(1,1,ivec_start),ivec_count(fg_rank1),
2592      &   MPI_MAT1,EugD(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2593      &   FG_COMM1,IERR)
2594        call MPI_Allgatherv(EugDder(1,1,ivec_start),ivec_count(fg_rank1),
2595      &   MPI_MAT1,EugDder(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2596      &   FG_COMM1,IERR)
2597         call MPI_Allgatherv(DtUg2EUg(1,1,ivec_start),
2598      &   ivec_count(fg_rank1),
2599      &   MPI_MAT1,DtUg2EUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2600      &   FG_COMM1,IERR)
2601         call MPI_Allgatherv(Ug2DtEUg(1,1,ivec_start),
2602      &   ivec_count(fg_rank1),
2603      &   MPI_MAT1,Ug2DtEUg(1,1,1),ivec_count(0),ivec_displ(0),MPI_MAT1,
2604      &   FG_COMM1,IERR)
2605         call MPI_Allgatherv(DtUg2EUgder(1,1,1,ivec_start),
2606      &   ivec_count(fg_rank1),
2607      &   MPI_MAT2,DtUg2EUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2608      &   MPI_MAT2,FG_COMM1,IERR)
2609         call MPI_Allgatherv(Ug2DtEUgder(1,1,1,ivec_start),
2610      &   ivec_count(fg_rank1),
2611      &   MPI_MAT2,Ug2DtEUgder(1,1,1,1),ivec_count(0),ivec_displ(0),
2612      &   MPI_MAT2,FG_COMM1,IERR)
2613         endif
2614 #else
2615 c Passes matrix info through the ring
2616       isend=fg_rank1
2617       irecv=fg_rank1-1
2618       if (irecv.lt.0) irecv=nfgtasks1-1
2619       iprev=irecv
2620       inext=fg_rank1+1
2621       if (inext.ge.nfgtasks1) inext=0
2622       do i=1,nfgtasks1-1
2623 c        write (iout,*) "isend",isend," irecv",irecv
2624 c        call flush(iout)
2625         lensend=lentyp(isend)
2626         lenrecv=lentyp(irecv)
2627 c        write (iout,*) "lensend",lensend," lenrecv",lenrecv
2628 c        call MPI_SENDRECV(ug(1,1,ivec_displ(isend)+1),1,
2629 c     &   MPI_ROTAT1(lensend),inext,2200+isend,
2630 c     &   ug(1,1,ivec_displ(irecv)+1),1,MPI_ROTAT1(lenrecv),
2631 c     &   iprev,2200+irecv,FG_COMM,status,IERR)
2632 c        write (iout,*) "Gather ROTAT1"
2633 c        call flush(iout)
2634 c        call MPI_SENDRECV(obrot(1,ivec_displ(isend)+1),1,
2635 c     &   MPI_ROTAT2(lensend),inext,3300+isend,
2636 c     &   obrot(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2637 c     &   iprev,3300+irecv,FG_COMM,status,IERR)
2638 c        write (iout,*) "Gather ROTAT2"
2639 c        call flush(iout)
2640         call MPI_SENDRECV(costab(ivec_displ(isend)+1),1,
2641      &   MPI_ROTAT_OLD(lensend),inext,4400+isend,
2642      &   costab(ivec_displ(irecv)+1),1,MPI_ROTAT_OLD(lenrecv),
2643      &   iprev,4400+irecv,FG_COMM,status,IERR)
2644 c        write (iout,*) "Gather ROTAT_OLD"
2645 c        call flush(iout)
2646         call MPI_SENDRECV(mu(1,ivec_displ(isend)+1),1,
2647      &   MPI_PRECOMP11(lensend),inext,5500+isend,
2648      &   mu(1,ivec_displ(irecv)+1),1,MPI_PRECOMP11(lenrecv),
2649      &   iprev,5500+irecv,FG_COMM,status,IERR)
2650 c        write (iout,*) "Gather PRECOMP11"
2651 c        call flush(iout)
2652         call MPI_SENDRECV(Eug(1,1,ivec_displ(isend)+1),1,
2653      &   MPI_PRECOMP12(lensend),inext,6600+isend,
2654      &   Eug(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP12(lenrecv),
2655      &   iprev,6600+irecv,FG_COMM,status,IERR)
2656 c        write (iout,*) "Gather PRECOMP12"
2657 c        call flush(iout)
2658         if (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0)
2659      &  then
2660         call MPI_SENDRECV(ug2db1t(1,ivec_displ(isend)+1),1,
2661      &   MPI_ROTAT2(lensend),inext,7700+isend,
2662      &   ug2db1t(1,ivec_displ(irecv)+1),1,MPI_ROTAT2(lenrecv),
2663      &   iprev,7700+irecv,FG_COMM,status,IERR)
2664 c        write (iout,*) "Gather PRECOMP21"
2665 c        call flush(iout)
2666         call MPI_SENDRECV(EUgC(1,1,ivec_displ(isend)+1),1,
2667      &   MPI_PRECOMP22(lensend),inext,8800+isend,
2668      &   EUgC(1,1,ivec_displ(irecv)+1),1,MPI_PRECOMP22(lenrecv),
2669      &   iprev,8800+irecv,FG_COMM,status,IERR)
2670 c        write (iout,*) "Gather PRECOMP22"
2671 c        call flush(iout)
2672         call MPI_SENDRECV(Ug2DtEUgder(1,1,1,ivec_displ(isend)+1),1,
2673      &   MPI_PRECOMP23(lensend),inext,9900+isend,
2674      &   Ug2DtEUgder(1,1,1,ivec_displ(irecv)+1),1,
2675      &   MPI_PRECOMP23(lenrecv),
2676      &   iprev,9900+irecv,FG_COMM,status,IERR)
2677 c        write (iout,*) "Gather PRECOMP23"
2678 c        call flush(iout)
2679         endif
2680         isend=irecv
2681         irecv=irecv-1
2682         if (irecv.lt.0) irecv=nfgtasks1-1
2683       enddo
2684 #endif
2685         time_gather=time_gather+MPI_Wtime()-time00
2686       endif
2687 #ifdef DEBUG
2688 c      if (fg_rank.eq.0) then
2689         write (iout,*) "Arrays UG and UGDER"
2690         do i=1,nres-1
2691           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2692      &     ((ug(l,k,i),l=1,2),k=1,2),
2693      &     ((ugder(l,k,i),l=1,2),k=1,2)
2694         enddo
2695         write (iout,*) "Arrays UG2 and UG2DER"
2696         do i=1,nres-1
2697           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2698      &     ((ug2(l,k,i),l=1,2),k=1,2),
2699      &     ((ug2der(l,k,i),l=1,2),k=1,2)
2700         enddo
2701         write (iout,*) "Arrays OBROT OBROT2 OBROTDER and OBROT2DER"
2702         do i=1,nres-1
2703           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2704      &     (obrot(k,i),k=1,2),(obrot2(k,i),k=1,2),
2705      &     (obrot_der(k,i),k=1,2),(obrot2_der(k,i),k=1,2)
2706         enddo
2707         write (iout,*) "Arrays COSTAB SINTAB COSTAB2 and SINTAB2"
2708         do i=1,nres-1
2709           write (iout,'(i5,4f10.5,5x,4f10.5)') i,
2710      &     costab(i),sintab(i),costab2(i),sintab2(i)
2711         enddo
2712         write (iout,*) "Array MUDER"
2713         do i=1,nres-1
2714           write (iout,'(i5,2f10.5)') i,muder(1,i),muder(2,i)
2715         enddo
2716 c      endif
2717 #endif
2718 #endif
2719 cd      do i=1,nres
2720 cd        iti = itortyp(itype(i))
2721 cd        write (iout,*) i
2722 cd        do j=1,2
2723 cd        write (iout,'(2f10.5,5x,2f10.5,5x,2f10.5)')
2724 cd     &  (EE(j,k,iti),k=1,2),(Ug(j,k,i),k=1,2),(EUg(j,k,i),k=1,2)
2725 cd        enddo
2726 cd      enddo
2727       return
2728       end
2729 C--------------------------------------------------------------------------
2730       subroutine eelec(ees,evdw1,eel_loc,eello_turn3,eello_turn4)
2731 C
2732 C This subroutine calculates the average interaction energy and its gradient
2733 C in the virtual-bond vectors between non-adjacent peptide groups, based on
2734 C the potential described in Liwo et al., Protein Sci., 1993, 2, 1715.
2735 C The potential depends both on the distance of peptide-group centers and on
2736 C the orientation of the CA-CA virtual bonds.
2737 C
2738       implicit real*8 (a-h,o-z)
2739 #ifdef MPI
2740       include 'mpif.h'
2741 #endif
2742       include 'DIMENSIONS'
2743       include 'COMMON.CONTROL'
2744       include 'COMMON.SETUP'
2745       include 'COMMON.IOUNITS'
2746       include 'COMMON.GEO'
2747       include 'COMMON.VAR'
2748       include 'COMMON.LOCAL'
2749       include 'COMMON.CHAIN'
2750       include 'COMMON.DERIV'
2751       include 'COMMON.INTERACT'
2752       include 'COMMON.CONTACTS'
2753       include 'COMMON.TORSION'
2754       include 'COMMON.VECTORS'
2755       include 'COMMON.FFIELD'
2756       include 'COMMON.TIME1'
2757       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2758      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2759       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2760      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2761       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2762      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2763      &    num_conti,j1,j2
2764 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2765 #ifdef MOMENT
2766       double precision scal_el /1.0d0/
2767 #else
2768       double precision scal_el /0.5d0/
2769 #endif
2770 C 12/13/98
2771 C 13-go grudnia roku pamietnego...
2772       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2773      &                   0.0d0,1.0d0,0.0d0,
2774      &                   0.0d0,0.0d0,1.0d0/
2775 cd      write(iout,*) 'In EELEC'
2776 cd      do i=1,nloctyp
2777 cd        write(iout,*) 'Type',i
2778 cd        write(iout,*) 'B1',B1(:,i)
2779 cd        write(iout,*) 'B2',B2(:,i)
2780 cd        write(iout,*) 'CC',CC(:,:,i)
2781 cd        write(iout,*) 'DD',DD(:,:,i)
2782 cd        write(iout,*) 'EE',EE(:,:,i)
2783 cd      enddo
2784 cd      call check_vecgrad
2785 cd      stop
2786       if (icheckgrad.eq.1) then
2787         do i=1,nres-1
2788           fac=1.0d0/dsqrt(scalar(dc(1,i),dc(1,i)))
2789           do k=1,3
2790             dc_norm(k,i)=dc(k,i)*fac
2791           enddo
2792 c          write (iout,*) 'i',i,' fac',fac
2793         enddo
2794       endif
2795       if (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
2796      &    .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0 .or.
2797      &    wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) then
2798 c        call vec_and_deriv
2799 #ifdef TIMING
2800         time01=MPI_Wtime()
2801 #endif
2802         call set_matrices
2803 #ifdef TIMING
2804         time_mat=time_mat+MPI_Wtime()-time01
2805 #endif
2806       endif
2807 cd      do i=1,nres-1
2808 cd        write (iout,*) 'i=',i
2809 cd        do k=1,3
2810 cd        write (iout,'(i5,2f10.5)') k,uy(k,i),uz(k,i)
2811 cd        enddo
2812 cd        do k=1,3
2813 cd          write (iout,'(f10.5,2x,3f10.5,2x,3f10.5)')
2814 cd     &     uz(k,i),(uzgrad(k,l,1,i),l=1,3),(uzgrad(k,l,2,i),l=1,3)
2815 cd        enddo
2816 cd      enddo
2817       t_eelecij=0.0d0
2818       ees=0.0D0
2819       evdw1=0.0D0
2820       eel_loc=0.0d0
2821       eello_turn3=0.0d0
2822       eello_turn4=0.0d0
2823       ind=0
2824       do i=1,nres
2825         num_cont_hb(i)=0
2826       enddo
2827 cd      print '(a)','Enter EELEC'
2828 cd      write (iout,*) 'iatel_s=',iatel_s,' iatel_e=',iatel_e
2829       do i=1,nres
2830         gel_loc_loc(i)=0.0d0
2831         gcorr_loc(i)=0.0d0
2832       enddo
2833 c
2834 c
2835 c 9/27/08 AL Split the interaction loop to ensure load balancing of turn terms
2836 C
2837 C Loop over i,i+2 and i,i+3 pairs of the peptide groups
2838 C
2839       do i=iturn3_start,iturn3_end
2840         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2841      &  .or. itype(i+2).eq.ntyp1 .or. itype(i+3).eq.ntyp1) cycle
2842         dxi=dc(1,i)
2843         dyi=dc(2,i)
2844         dzi=dc(3,i)
2845         dx_normi=dc_norm(1,i)
2846         dy_normi=dc_norm(2,i)
2847         dz_normi=dc_norm(3,i)
2848         xmedi=c(1,i)+0.5d0*dxi
2849         ymedi=c(2,i)+0.5d0*dyi
2850         zmedi=c(3,i)+0.5d0*dzi
2851         num_conti=0
2852         call eelecij(i,i+2,ees,evdw1,eel_loc)
2853         if (wturn3.gt.0.0d0) call eturn3(i,eello_turn3)
2854         num_cont_hb(i)=num_conti
2855       enddo
2856       do i=iturn4_start,iturn4_end
2857         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1
2858      &    .or. itype(i+3).eq.ntyp1
2859      &    .or. itype(i+4).eq.ntyp1) cycle
2860         dxi=dc(1,i)
2861         dyi=dc(2,i)
2862         dzi=dc(3,i)
2863         dx_normi=dc_norm(1,i)
2864         dy_normi=dc_norm(2,i)
2865         dz_normi=dc_norm(3,i)
2866         xmedi=c(1,i)+0.5d0*dxi
2867         ymedi=c(2,i)+0.5d0*dyi
2868         zmedi=c(3,i)+0.5d0*dzi
2869         num_conti=num_cont_hb(i)
2870         call eelecij(i,i+3,ees,evdw1,eel_loc)
2871         if (wturn4.gt.0.0d0 .and. itype(i+2).ne.ntyp1)
2872      &   call eturn4(i,eello_turn4)
2873         num_cont_hb(i)=num_conti
2874       enddo   ! i
2875 c
2876 c Loop over all pairs of interacting peptide groups except i,i+2 and i,i+3
2877 c
2878       do i=iatel_s,iatel_e
2879         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
2880         dxi=dc(1,i)
2881         dyi=dc(2,i)
2882         dzi=dc(3,i)
2883         dx_normi=dc_norm(1,i)
2884         dy_normi=dc_norm(2,i)
2885         dz_normi=dc_norm(3,i)
2886         xmedi=c(1,i)+0.5d0*dxi
2887         ymedi=c(2,i)+0.5d0*dyi
2888         zmedi=c(3,i)+0.5d0*dzi
2889 c        write (iout,*) 'i',i,' ielstart',ielstart(i),' ielend',ielend(i)
2890         num_conti=num_cont_hb(i)
2891         do j=ielstart(i),ielend(i)
2892 c          write (iout,*) i,j,itype(i),itype(j)
2893           if (itype(j).eq.ntyp1.or. itype(j+1).eq.ntyp1) cycle
2894           call eelecij(i,j,ees,evdw1,eel_loc)
2895         enddo ! j
2896         num_cont_hb(i)=num_conti
2897       enddo   ! i
2898 c      write (iout,*) "Number of loop steps in EELEC:",ind
2899 cd      do i=1,nres
2900 cd        write (iout,'(i3,3f10.5,5x,3f10.5)')
2901 cd     &     i,(gel_loc(k,i),k=1,3),gel_loc_loc(i)
2902 cd      enddo
2903 c 12/7/99 Adam eello_turn3 will be considered as a separate energy term
2904 ccc      eel_loc=eel_loc+eello_turn3
2905 cd      print *,"Processor",fg_rank," t_eelecij",t_eelecij
2906       return
2907       end
2908 C-------------------------------------------------------------------------------
2909       subroutine eelecij(i,j,ees,evdw1,eel_loc)
2910       implicit real*8 (a-h,o-z)
2911       include 'DIMENSIONS'
2912 #ifdef MPI
2913       include "mpif.h"
2914 #endif
2915       include 'COMMON.CONTROL'
2916       include 'COMMON.IOUNITS'
2917       include 'COMMON.GEO'
2918       include 'COMMON.VAR'
2919       include 'COMMON.LOCAL'
2920       include 'COMMON.CHAIN'
2921       include 'COMMON.DERIV'
2922       include 'COMMON.INTERACT'
2923       include 'COMMON.CONTACTS'
2924       include 'COMMON.TORSION'
2925       include 'COMMON.VECTORS'
2926       include 'COMMON.FFIELD'
2927       include 'COMMON.TIME1'
2928       dimension ggg(3),gggp(3),gggm(3),erij(3),dcosb(3),dcosg(3),
2929      &          erder(3,3),uryg(3,3),urzg(3,3),vryg(3,3),vrzg(3,3)
2930       double precision acipa(2,2),agg(3,4),aggi(3,4),aggi1(3,4),
2931      &    aggj(3,4),aggj1(3,4),a_temp(2,2),muij(4)
2932       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
2933      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
2934      &    num_conti,j1,j2
2935 c 4/26/02 - AL scaling factor for 1,4 repulsive VDW interactions
2936 #ifdef MOMENT
2937       double precision scal_el /1.0d0/
2938 #else
2939       double precision scal_el /0.5d0/
2940 #endif
2941 C 12/13/98
2942 C 13-go grudnia roku pamietnego...
2943       double precision unmat(3,3) /1.0d0,0.0d0,0.0d0,
2944      &                   0.0d0,1.0d0,0.0d0,
2945      &                   0.0d0,0.0d0,1.0d0/
2946 c          time00=MPI_Wtime()
2947 cd      write (iout,*) "eelecij",i,j
2948 c          ind=ind+1
2949           iteli=itel(i)
2950           itelj=itel(j)
2951           if (j.eq.i+2 .and. itelj.eq.2) iteli=2
2952           aaa=app(iteli,itelj)
2953           bbb=bpp(iteli,itelj)
2954           ael6i=ael6(iteli,itelj)
2955           ael3i=ael3(iteli,itelj)
2956           dxj=dc(1,j)
2957           dyj=dc(2,j)
2958           dzj=dc(3,j)
2959           dx_normj=dc_norm(1,j)
2960           dy_normj=dc_norm(2,j)
2961           dz_normj=dc_norm(3,j)
2962           xj=c(1,j)+0.5D0*dxj-xmedi
2963           yj=c(2,j)+0.5D0*dyj-ymedi
2964           zj=c(3,j)+0.5D0*dzj-zmedi
2965           rij=xj*xj+yj*yj+zj*zj
2966           rrmij=1.0D0/rij
2967           rij=dsqrt(rij)
2968           rmij=1.0D0/rij
2969           r3ij=rrmij*rmij
2970           r6ij=r3ij*r3ij
2971           cosa=dx_normi*dx_normj+dy_normi*dy_normj+dz_normi*dz_normj
2972           cosb=(xj*dx_normi+yj*dy_normi+zj*dz_normi)*rmij
2973           cosg=(xj*dx_normj+yj*dy_normj+zj*dz_normj)*rmij
2974           fac=cosa-3.0D0*cosb*cosg
2975           ev1=aaa*r6ij*r6ij
2976 c 4/26/02 - AL scaling down 1,4 repulsive VDW interactions
2977           if (j.eq.i+2) ev1=scal_el*ev1
2978           ev2=bbb*r6ij
2979           fac3=ael6i*r6ij
2980           fac4=ael3i*r3ij
2981           evdwij=ev1+ev2
2982           el1=fac3*(4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg))
2983           el2=fac4*fac
2984           eesij=el1+el2
2985 C 12/26/95 - for the evaluation of multi-body H-bonding interactions
2986           ees0ij=4.0D0+fac*fac-3.0D0*(cosb*cosb+cosg*cosg)
2987           ees=ees+eesij
2988           evdw1=evdw1+evdwij
2989 cd          write(iout,'(2(2i3,2x),7(1pd12.4)/2(3(1pd12.4),5x)/)')
2990 cd     &      iteli,i,itelj,j,aaa,bbb,ael6i,ael3i,
2991 cd     &      1.0D0/dsqrt(rrmij),evdwij,eesij,
2992 cd     &      xmedi,ymedi,zmedi,xj,yj,zj
2993
2994           if (energy_dec) then
2995               write (iout,'(a6,2i5,0pf7.3,2i5,2e11.3)')
2996      &'evdw1',i,j,evdwij
2997      &,iteli,itelj,aaa,evdw1
2998               write (iout,'(a6,2i5,0pf7.3)') 'ees',i,j,eesij
2999           endif
3000
3001 C
3002 C Calculate contributions to the Cartesian gradient.
3003 C
3004 #ifdef SPLITELE
3005           facvdw=-6*rrmij*(ev1+evdwij)
3006           facel=-3*rrmij*(el1+eesij)
3007           fac1=fac
3008           erij(1)=xj*rmij
3009           erij(2)=yj*rmij
3010           erij(3)=zj*rmij
3011 *
3012 * Radial derivatives. First process both termini of the fragment (i,j)
3013 *
3014           ggg(1)=facel*xj
3015           ggg(2)=facel*yj
3016           ggg(3)=facel*zj
3017 c          do k=1,3
3018 c            ghalf=0.5D0*ggg(k)
3019 c            gelc(k,i)=gelc(k,i)+ghalf
3020 c            gelc(k,j)=gelc(k,j)+ghalf
3021 c          enddo
3022 c 9/28/08 AL Gradient compotents will be summed only at the end
3023           do k=1,3
3024             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3025             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3026           enddo
3027 *
3028 * Loop over residues i+1 thru j-1.
3029 *
3030 cgrad          do k=i+1,j-1
3031 cgrad            do l=1,3
3032 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3033 cgrad            enddo
3034 cgrad          enddo
3035           ggg(1)=facvdw*xj
3036           ggg(2)=facvdw*yj
3037           ggg(3)=facvdw*zj
3038 c          do k=1,3
3039 c            ghalf=0.5D0*ggg(k)
3040 c            gvdwpp(k,i)=gvdwpp(k,i)+ghalf
3041 c            gvdwpp(k,j)=gvdwpp(k,j)+ghalf
3042 c          enddo
3043 c 9/28/08 AL Gradient compotents will be summed only at the end
3044           do k=1,3
3045             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3046             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3047           enddo
3048 *
3049 * Loop over residues i+1 thru j-1.
3050 *
3051 cgrad          do k=i+1,j-1
3052 cgrad            do l=1,3
3053 cgrad              gvdwpp(l,k)=gvdwpp(l,k)+ggg(l)
3054 cgrad            enddo
3055 cgrad          enddo
3056 #else
3057           facvdw=ev1+evdwij
3058           facel=el1+eesij
3059           fac1=fac
3060           fac=-3*rrmij*(facvdw+facvdw+facel)
3061           erij(1)=xj*rmij
3062           erij(2)=yj*rmij
3063           erij(3)=zj*rmij
3064 *
3065 * Radial derivatives. First process both termini of the fragment (i,j)
3066 *
3067           ggg(1)=fac*xj
3068           ggg(2)=fac*yj
3069           ggg(3)=fac*zj
3070 c          do k=1,3
3071 c            ghalf=0.5D0*ggg(k)
3072 c            gelc(k,i)=gelc(k,i)+ghalf
3073 c            gelc(k,j)=gelc(k,j)+ghalf
3074 c          enddo
3075 c 9/28/08 AL Gradient compotents will be summed only at the end
3076           do k=1,3
3077             gelc_long(k,j)=gelc(k,j)+ggg(k)
3078             gelc_long(k,i)=gelc(k,i)-ggg(k)
3079           enddo
3080 *
3081 * Loop over residues i+1 thru j-1.
3082 *
3083 cgrad          do k=i+1,j-1
3084 cgrad            do l=1,3
3085 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3086 cgrad            enddo
3087 cgrad          enddo
3088 c 9/28/08 AL Gradient compotents will be summed only at the end
3089           ggg(1)=facvdw*xj
3090           ggg(2)=facvdw*yj
3091           ggg(3)=facvdw*zj
3092           do k=1,3
3093             gvdwpp(k,j)=gvdwpp(k,j)+ggg(k)
3094             gvdwpp(k,i)=gvdwpp(k,i)-ggg(k)
3095           enddo
3096 #endif
3097 *
3098 * Angular part
3099 *
3100           ecosa=2.0D0*fac3*fac1+fac4
3101           fac4=-3.0D0*fac4
3102           fac3=-6.0D0*fac3
3103           ecosb=(fac3*(fac1*cosg+cosb)+cosg*fac4)
3104           ecosg=(fac3*(fac1*cosb+cosg)+cosb*fac4)
3105           do k=1,3
3106             dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3107             dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3108           enddo
3109 cd        print '(2i3,2(3(1pd14.5),3x))',i,j,(dcosb(k),k=1,3),
3110 cd   &          (dcosg(k),k=1,3)
3111           do k=1,3
3112             ggg(k)=ecosb*dcosb(k)+ecosg*dcosg(k)
3113           enddo
3114 c          do k=1,3
3115 c            ghalf=0.5D0*ggg(k)
3116 c            gelc(k,i)=gelc(k,i)+ghalf
3117 c     &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3118 c     &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3119 c            gelc(k,j)=gelc(k,j)+ghalf
3120 c     &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3121 c     &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3122 c          enddo
3123 cgrad          do k=i+1,j-1
3124 cgrad            do l=1,3
3125 cgrad              gelc(l,k)=gelc(l,k)+ggg(l)
3126 cgrad            enddo
3127 cgrad          enddo
3128           do k=1,3
3129             gelc(k,i)=gelc(k,i)
3130      &               +(ecosa*(dc_norm(k,j)-cosa*dc_norm(k,i))
3131      &               + ecosb*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3132             gelc(k,j)=gelc(k,j)
3133      &               +(ecosa*(dc_norm(k,i)-cosa*dc_norm(k,j))
3134      &               + ecosg*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3135             gelc_long(k,j)=gelc_long(k,j)+ggg(k)
3136             gelc_long(k,i)=gelc_long(k,i)-ggg(k)
3137           enddo
3138           IF (wel_loc.gt.0.0d0 .or. wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0
3139      &        .or. wcorr6.gt.0.0d0 .or. wturn3.gt.0.0d0
3140      &        .or. wturn4.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3141 C
3142 C 9/25/99 Mixed third-order local-electrostatic terms. The local-interaction
3143 C   energy of a peptide unit is assumed in the form of a second-order
3144 C   Fourier series in the angles lambda1 and lambda2 (see Nishikawa et al.
3145 C   Macromolecules, 1974, 7, 797-806 for definition). This correlation terms
3146 C   are computed for EVERY pair of non-contiguous peptide groups.
3147 C
3148           if (j.lt.nres-1) then
3149             j1=j+1
3150             j2=j-1
3151           else
3152             j1=j-1
3153             j2=j-2
3154           endif
3155           kkk=0
3156           do k=1,2
3157             do l=1,2
3158               kkk=kkk+1
3159               muij(kkk)=mu(k,i)*mu(l,j)
3160             enddo
3161           enddo
3162 cd         write (iout,*) 'EELEC: i',i,' j',j
3163 cd          write (iout,*) 'j',j,' j1',j1,' j2',j2
3164 cd          write(iout,*) 'muij',muij
3165           ury=scalar(uy(1,i),erij)
3166           urz=scalar(uz(1,i),erij)
3167           vry=scalar(uy(1,j),erij)
3168           vrz=scalar(uz(1,j),erij)
3169           a22=scalar(uy(1,i),uy(1,j))-3*ury*vry
3170           a23=scalar(uy(1,i),uz(1,j))-3*ury*vrz
3171           a32=scalar(uz(1,i),uy(1,j))-3*urz*vry
3172           a33=scalar(uz(1,i),uz(1,j))-3*urz*vrz
3173           fac=dsqrt(-ael6i)*r3ij
3174           a22=a22*fac
3175           a23=a23*fac
3176           a32=a32*fac
3177           a33=a33*fac
3178 cd          write (iout,'(4i5,4f10.5)')
3179 cd     &     i,itortyp(itype(i)),j,itortyp(itype(j)),a22,a23,a32,a33
3180 cd          write (iout,'(6f10.5)') (muij(k),k=1,4),fac,eel_loc_ij
3181 cd          write (iout,'(2(3f10.5,5x)/2(3f10.5,5x))') uy(:,i),uz(:,i),
3182 cd     &      uy(:,j),uz(:,j)
3183 cd          write (iout,'(4f10.5)')
3184 cd     &      scalar(uy(1,i),uy(1,j)),scalar(uy(1,i),uz(1,j)),
3185 cd     &      scalar(uz(1,i),uy(1,j)),scalar(uz(1,i),uz(1,j))
3186 cd          write (iout,'(4f10.5)') ury,urz,vry,vrz
3187 cd           write (iout,'(9f10.5/)')
3188 cd     &      fac22,a22,fac23,a23,fac32,a32,fac33,a33,eel_loc_ij
3189 C Derivatives of the elements of A in virtual-bond vectors
3190           call unormderiv(erij(1),unmat(1,1),rmij,erder(1,1))
3191           do k=1,3
3192             uryg(k,1)=scalar(erder(1,k),uy(1,i))
3193             uryg(k,2)=scalar(uygrad(1,k,1,i),erij(1))
3194             uryg(k,3)=scalar(uygrad(1,k,2,i),erij(1))
3195             urzg(k,1)=scalar(erder(1,k),uz(1,i))
3196             urzg(k,2)=scalar(uzgrad(1,k,1,i),erij(1))
3197             urzg(k,3)=scalar(uzgrad(1,k,2,i),erij(1))
3198             vryg(k,1)=scalar(erder(1,k),uy(1,j))
3199             vryg(k,2)=scalar(uygrad(1,k,1,j),erij(1))
3200             vryg(k,3)=scalar(uygrad(1,k,2,j),erij(1))
3201             vrzg(k,1)=scalar(erder(1,k),uz(1,j))
3202             vrzg(k,2)=scalar(uzgrad(1,k,1,j),erij(1))
3203             vrzg(k,3)=scalar(uzgrad(1,k,2,j),erij(1))
3204           enddo
3205 C Compute radial contributions to the gradient
3206           facr=-3.0d0*rrmij
3207           a22der=a22*facr
3208           a23der=a23*facr
3209           a32der=a32*facr
3210           a33der=a33*facr
3211           agg(1,1)=a22der*xj
3212           agg(2,1)=a22der*yj
3213           agg(3,1)=a22der*zj
3214           agg(1,2)=a23der*xj
3215           agg(2,2)=a23der*yj
3216           agg(3,2)=a23der*zj
3217           agg(1,3)=a32der*xj
3218           agg(2,3)=a32der*yj
3219           agg(3,3)=a32der*zj
3220           agg(1,4)=a33der*xj
3221           agg(2,4)=a33der*yj
3222           agg(3,4)=a33der*zj
3223 C Add the contributions coming from er
3224           fac3=-3.0d0*fac
3225           do k=1,3
3226             agg(k,1)=agg(k,1)+fac3*(uryg(k,1)*vry+vryg(k,1)*ury)
3227             agg(k,2)=agg(k,2)+fac3*(uryg(k,1)*vrz+vrzg(k,1)*ury)
3228             agg(k,3)=agg(k,3)+fac3*(urzg(k,1)*vry+vryg(k,1)*urz)
3229             agg(k,4)=agg(k,4)+fac3*(urzg(k,1)*vrz+vrzg(k,1)*urz)
3230           enddo
3231           do k=1,3
3232 C Derivatives in DC(i)
3233 cgrad            ghalf1=0.5d0*agg(k,1)
3234 cgrad            ghalf2=0.5d0*agg(k,2)
3235 cgrad            ghalf3=0.5d0*agg(k,3)
3236 cgrad            ghalf4=0.5d0*agg(k,4)
3237             aggi(k,1)=fac*(scalar(uygrad(1,k,1,i),uy(1,j))
3238      &      -3.0d0*uryg(k,2)*vry)!+ghalf1
3239             aggi(k,2)=fac*(scalar(uygrad(1,k,1,i),uz(1,j))
3240      &      -3.0d0*uryg(k,2)*vrz)!+ghalf2
3241             aggi(k,3)=fac*(scalar(uzgrad(1,k,1,i),uy(1,j))
3242      &      -3.0d0*urzg(k,2)*vry)!+ghalf3
3243             aggi(k,4)=fac*(scalar(uzgrad(1,k,1,i),uz(1,j))
3244      &      -3.0d0*urzg(k,2)*vrz)!+ghalf4
3245 C Derivatives in DC(i+1)
3246             aggi1(k,1)=fac*(scalar(uygrad(1,k,2,i),uy(1,j))
3247      &      -3.0d0*uryg(k,3)*vry)!+agg(k,1)
3248             aggi1(k,2)=fac*(scalar(uygrad(1,k,2,i),uz(1,j))
3249      &      -3.0d0*uryg(k,3)*vrz)!+agg(k,2)
3250             aggi1(k,3)=fac*(scalar(uzgrad(1,k,2,i),uy(1,j))
3251      &      -3.0d0*urzg(k,3)*vry)!+agg(k,3)
3252             aggi1(k,4)=fac*(scalar(uzgrad(1,k,2,i),uz(1,j))
3253      &      -3.0d0*urzg(k,3)*vrz)!+agg(k,4)
3254 C Derivatives in DC(j)
3255             aggj(k,1)=fac*(scalar(uygrad(1,k,1,j),uy(1,i))
3256      &      -3.0d0*vryg(k,2)*ury)!+ghalf1
3257             aggj(k,2)=fac*(scalar(uzgrad(1,k,1,j),uy(1,i))
3258      &      -3.0d0*vrzg(k,2)*ury)!+ghalf2
3259             aggj(k,3)=fac*(scalar(uygrad(1,k,1,j),uz(1,i))
3260      &      -3.0d0*vryg(k,2)*urz)!+ghalf3
3261             aggj(k,4)=fac*(scalar(uzgrad(1,k,1,j),uz(1,i))
3262      &      -3.0d0*vrzg(k,2)*urz)!+ghalf4
3263 C Derivatives in DC(j+1) or DC(nres-1)
3264             aggj1(k,1)=fac*(scalar(uygrad(1,k,2,j),uy(1,i))
3265      &      -3.0d0*vryg(k,3)*ury)
3266             aggj1(k,2)=fac*(scalar(uzgrad(1,k,2,j),uy(1,i))
3267      &      -3.0d0*vrzg(k,3)*ury)
3268             aggj1(k,3)=fac*(scalar(uygrad(1,k,2,j),uz(1,i))
3269      &      -3.0d0*vryg(k,3)*urz)
3270             aggj1(k,4)=fac*(scalar(uzgrad(1,k,2,j),uz(1,i))
3271      &      -3.0d0*vrzg(k,3)*urz)
3272 cgrad            if (j.eq.nres-1 .and. i.lt.j-2) then
3273 cgrad              do l=1,4
3274 cgrad                aggj1(k,l)=aggj1(k,l)+agg(k,l)
3275 cgrad              enddo
3276 cgrad            endif
3277           enddo
3278           acipa(1,1)=a22
3279           acipa(1,2)=a23
3280           acipa(2,1)=a32
3281           acipa(2,2)=a33
3282           a22=-a22
3283           a23=-a23
3284           do l=1,2
3285             do k=1,3
3286               agg(k,l)=-agg(k,l)
3287               aggi(k,l)=-aggi(k,l)
3288               aggi1(k,l)=-aggi1(k,l)
3289               aggj(k,l)=-aggj(k,l)
3290               aggj1(k,l)=-aggj1(k,l)
3291             enddo
3292           enddo
3293           if (j.lt.nres-1) then
3294             a22=-a22
3295             a32=-a32
3296             do l=1,3,2
3297               do k=1,3
3298                 agg(k,l)=-agg(k,l)
3299                 aggi(k,l)=-aggi(k,l)
3300                 aggi1(k,l)=-aggi1(k,l)
3301                 aggj(k,l)=-aggj(k,l)
3302                 aggj1(k,l)=-aggj1(k,l)
3303               enddo
3304             enddo
3305           else
3306             a22=-a22
3307             a23=-a23
3308             a32=-a32
3309             a33=-a33
3310             do l=1,4
3311               do k=1,3
3312                 agg(k,l)=-agg(k,l)
3313                 aggi(k,l)=-aggi(k,l)
3314                 aggi1(k,l)=-aggi1(k,l)
3315                 aggj(k,l)=-aggj(k,l)
3316                 aggj1(k,l)=-aggj1(k,l)
3317               enddo
3318             enddo
3319           endif
3320           ENDIF ! WCORR
3321           IF (wel_loc.gt.0.0d0) THEN
3322 C Contribution to the local-electrostatic energy coming from the i-j pair
3323           eel_loc_ij=a22*muij(1)+a23*muij(2)+a32*muij(3)
3324      &     +a33*muij(4)
3325 cd          write (iout,*) 'i',i,' j',j,' eel_loc_ij',eel_loc_ij
3326
3327           if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3328      &            'eelloc',i,j,eel_loc_ij
3329 c              write (iout,*) a22,muij(1),a23,muij(2),a32,muij(3)
3330
3331           eel_loc=eel_loc+eel_loc_ij
3332 C Partial derivatives in virtual-bond dihedral angles gamma
3333           if (i.gt.1)
3334      &    gel_loc_loc(i-1)=gel_loc_loc(i-1)+
3335      &            a22*muder(1,i)*mu(1,j)+a23*muder(1,i)*mu(2,j)
3336      &           +a32*muder(2,i)*mu(1,j)+a33*muder(2,i)*mu(2,j)
3337           gel_loc_loc(j-1)=gel_loc_loc(j-1)+
3338      &            a22*mu(1,i)*muder(1,j)+a23*mu(1,i)*muder(2,j)
3339      &           +a32*mu(2,i)*muder(1,j)+a33*mu(2,i)*muder(2,j)
3340 C Derivatives of eello in DC(i+1) thru DC(j-1) or DC(nres-2)
3341           do l=1,3
3342             ggg(l)=agg(l,1)*muij(1)+
3343      &          agg(l,2)*muij(2)+agg(l,3)*muij(3)+agg(l,4)*muij(4)
3344             gel_loc_long(l,j)=gel_loc_long(l,j)+ggg(l)
3345             gel_loc_long(l,i)=gel_loc_long(l,i)-ggg(l)
3346 cgrad            ghalf=0.5d0*ggg(l)
3347 cgrad            gel_loc(l,i)=gel_loc(l,i)+ghalf
3348 cgrad            gel_loc(l,j)=gel_loc(l,j)+ghalf
3349           enddo
3350 cgrad          do k=i+1,j2
3351 cgrad            do l=1,3
3352 cgrad              gel_loc(l,k)=gel_loc(l,k)+ggg(l)
3353 cgrad            enddo
3354 cgrad          enddo
3355 C Remaining derivatives of eello
3356           do l=1,3
3357             gel_loc(l,i)=gel_loc(l,i)+aggi(l,1)*muij(1)+
3358      &          aggi(l,2)*muij(2)+aggi(l,3)*muij(3)+aggi(l,4)*muij(4)
3359             gel_loc(l,i+1)=gel_loc(l,i+1)+aggi1(l,1)*muij(1)+
3360      &          aggi1(l,2)*muij(2)+aggi1(l,3)*muij(3)+aggi1(l,4)*muij(4)
3361             gel_loc(l,j)=gel_loc(l,j)+aggj(l,1)*muij(1)+
3362      &          aggj(l,2)*muij(2)+aggj(l,3)*muij(3)+aggj(l,4)*muij(4)
3363             gel_loc(l,j1)=gel_loc(l,j1)+aggj1(l,1)*muij(1)+
3364      &          aggj1(l,2)*muij(2)+aggj1(l,3)*muij(3)+aggj1(l,4)*muij(4)
3365           enddo
3366           ENDIF
3367 C Change 12/26/95 to calculate four-body contributions to H-bonding energy
3368 c          if (j.gt.i+1 .and. num_conti.le.maxconts) then
3369           if (wcorr+wcorr4+wcorr5+wcorr6.gt.0.0d0
3370      &       .and. num_conti.le.maxconts) then
3371 c            write (iout,*) i,j," entered corr"
3372 C
3373 C Calculate the contact function. The ith column of the array JCONT will
3374 C contain the numbers of atoms that make contacts with the atom I (of numbers
3375 C greater than I). The arrays FACONT and GACONT will contain the values of
3376 C the contact function and its derivative.
3377 c           r0ij=1.02D0*rpp(iteli,itelj)
3378 c           r0ij=1.11D0*rpp(iteli,itelj)
3379             r0ij=2.20D0*rpp(iteli,itelj)
3380 c           r0ij=1.55D0*rpp(iteli,itelj)
3381             call gcont(rij,r0ij,1.0D0,0.2d0*r0ij,fcont,fprimcont)
3382             if (fcont.gt.0.0D0) then
3383               num_conti=num_conti+1
3384               if (num_conti.gt.maxconts) then
3385                 write (iout,*) 'WARNING - max. # of contacts exceeded;',
3386      &                         ' will skip next contacts for this conf.'
3387               else
3388                 jcont_hb(num_conti,i)=j
3389 cd                write (iout,*) "i",i," j",j," num_conti",num_conti,
3390 cd     &           " jcont_hb",jcont_hb(num_conti,i)
3391                 IF (wcorr4.gt.0.0d0 .or. wcorr5.gt.0.0d0 .or.
3392      &          wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) THEN
3393 C 9/30/99 (AL) - store components necessary to evaluate higher-order loc-el
3394 C  terms.
3395                 d_cont(num_conti,i)=rij
3396 cd                write (2,'(3e15.5)') rij,r0ij+0.2d0*r0ij,rij
3397 C     --- Electrostatic-interaction matrix ---
3398                 a_chuj(1,1,num_conti,i)=a22
3399                 a_chuj(1,2,num_conti,i)=a23
3400                 a_chuj(2,1,num_conti,i)=a32
3401                 a_chuj(2,2,num_conti,i)=a33
3402 C     --- Gradient of rij
3403                 do kkk=1,3
3404                   grij_hb_cont(kkk,num_conti,i)=erij(kkk)
3405                 enddo
3406                 kkll=0
3407                 do k=1,2
3408                   do l=1,2
3409                     kkll=kkll+1
3410                     do m=1,3
3411                       a_chuj_der(k,l,m,1,num_conti,i)=agg(m,kkll)
3412                       a_chuj_der(k,l,m,2,num_conti,i)=aggi(m,kkll)
3413                       a_chuj_der(k,l,m,3,num_conti,i)=aggi1(m,kkll)
3414                       a_chuj_der(k,l,m,4,num_conti,i)=aggj(m,kkll)
3415                       a_chuj_der(k,l,m,5,num_conti,i)=aggj1(m,kkll)
3416                     enddo
3417                   enddo
3418                 enddo
3419                 ENDIF
3420                 IF (wcorr4.eq.0.0d0 .and. wcorr.gt.0.0d0) THEN
3421 C Calculate contact energies
3422                 cosa4=4.0D0*cosa
3423                 wij=cosa-3.0D0*cosb*cosg
3424                 cosbg1=cosb+cosg
3425                 cosbg2=cosb-cosg
3426 c               fac3=dsqrt(-ael6i)/r0ij**3
3427                 fac3=dsqrt(-ael6i)*r3ij
3428 c                 ees0pij=dsqrt(4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1)
3429                 ees0tmp=4.0D0+cosa4+wij*wij-3.0D0*cosbg1*cosbg1
3430                 if (ees0tmp.gt.0) then
3431                   ees0pij=dsqrt(ees0tmp)
3432                 else
3433                   ees0pij=0
3434                 endif
3435 c                ees0mij=dsqrt(4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2)
3436                 ees0tmp=4.0D0-cosa4+wij*wij-3.0D0*cosbg2*cosbg2
3437                 if (ees0tmp.gt.0) then
3438                   ees0mij=dsqrt(ees0tmp)
3439                 else
3440                   ees0mij=0
3441                 endif
3442 c               ees0mij=0.0D0
3443                 ees0p(num_conti,i)=0.5D0*fac3*(ees0pij+ees0mij)
3444                 ees0m(num_conti,i)=0.5D0*fac3*(ees0pij-ees0mij)
3445 C Diagnostics. Comment out or remove after debugging!
3446 c               ees0p(num_conti,i)=0.5D0*fac3*ees0pij
3447 c               ees0m(num_conti,i)=0.5D0*fac3*ees0mij
3448 c               ees0m(num_conti,i)=0.0D0
3449 C End diagnostics.
3450 c               write (iout,*) 'i=',i,' j=',j,' rij=',rij,' r0ij=',r0ij,
3451 c    & ' ees0ij=',ees0p(num_conti,i),ees0m(num_conti,i),' fcont=',fcont
3452 C Angular derivatives of the contact function
3453                 ees0pij1=fac3/ees0pij
3454                 ees0mij1=fac3/ees0mij
3455                 fac3p=-3.0D0*fac3*rrmij
3456                 ees0pijp=0.5D0*fac3p*(ees0pij+ees0mij)
3457                 ees0mijp=0.5D0*fac3p*(ees0pij-ees0mij)
3458 c               ees0mij1=0.0D0
3459                 ecosa1=       ees0pij1*( 1.0D0+0.5D0*wij)
3460                 ecosb1=-1.5D0*ees0pij1*(wij*cosg+cosbg1)
3461                 ecosg1=-1.5D0*ees0pij1*(wij*cosb+cosbg1)
3462                 ecosa2=       ees0mij1*(-1.0D0+0.5D0*wij)
3463                 ecosb2=-1.5D0*ees0mij1*(wij*cosg+cosbg2)
3464                 ecosg2=-1.5D0*ees0mij1*(wij*cosb-cosbg2)
3465                 ecosap=ecosa1+ecosa2
3466                 ecosbp=ecosb1+ecosb2
3467                 ecosgp=ecosg1+ecosg2
3468                 ecosam=ecosa1-ecosa2
3469                 ecosbm=ecosb1-ecosb2
3470                 ecosgm=ecosg1-ecosg2
3471 C Diagnostics
3472 c               ecosap=ecosa1
3473 c               ecosbp=ecosb1
3474 c               ecosgp=ecosg1
3475 c               ecosam=0.0D0
3476 c               ecosbm=0.0D0
3477 c               ecosgm=0.0D0
3478 C End diagnostics
3479                 facont_hb(num_conti,i)=fcont
3480                 fprimcont=fprimcont/rij
3481 cd              facont_hb(num_conti,i)=1.0D0
3482 C Following line is for diagnostics.
3483 cd              fprimcont=0.0D0
3484                 do k=1,3
3485                   dcosb(k)=rmij*(dc_norm(k,i)-erij(k)*cosb)
3486                   dcosg(k)=rmij*(dc_norm(k,j)-erij(k)*cosg)
3487                 enddo
3488                 do k=1,3
3489                   gggp(k)=ecosbp*dcosb(k)+ecosgp*dcosg(k)
3490                   gggm(k)=ecosbm*dcosb(k)+ecosgm*dcosg(k)
3491                 enddo
3492                 gggp(1)=gggp(1)+ees0pijp*xj
3493                 gggp(2)=gggp(2)+ees0pijp*yj
3494                 gggp(3)=gggp(3)+ees0pijp*zj
3495                 gggm(1)=gggm(1)+ees0mijp*xj
3496                 gggm(2)=gggm(2)+ees0mijp*yj
3497                 gggm(3)=gggm(3)+ees0mijp*zj
3498 C Derivatives due to the contact function
3499                 gacont_hbr(1,num_conti,i)=fprimcont*xj
3500                 gacont_hbr(2,num_conti,i)=fprimcont*yj
3501                 gacont_hbr(3,num_conti,i)=fprimcont*zj
3502                 do k=1,3
3503 c
3504 c 10/24/08 cgrad and ! comments indicate the parts of the code removed
3505 c          following the change of gradient-summation algorithm.
3506 c
3507 cgrad                  ghalfp=0.5D0*gggp(k)
3508 cgrad                  ghalfm=0.5D0*gggm(k)
3509                   gacontp_hb1(k,num_conti,i)=!ghalfp
3510      &              +(ecosap*(dc_norm(k,j)-cosa*dc_norm(k,i))
3511      &              + ecosbp*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3512                   gacontp_hb2(k,num_conti,i)=!ghalfp
3513      &              +(ecosap*(dc_norm(k,i)-cosa*dc_norm(k,j))
3514      &              + ecosgp*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3515                   gacontp_hb3(k,num_conti,i)=gggp(k)
3516                   gacontm_hb1(k,num_conti,i)=!ghalfm
3517      &              +(ecosam*(dc_norm(k,j)-cosa*dc_norm(k,i))
3518      &              + ecosbm*(erij(k)-cosb*dc_norm(k,i)))*vbld_inv(i+1)
3519                   gacontm_hb2(k,num_conti,i)=!ghalfm
3520      &              +(ecosam*(dc_norm(k,i)-cosa*dc_norm(k,j))
3521      &              + ecosgm*(erij(k)-cosg*dc_norm(k,j)))*vbld_inv(j+1)
3522                   gacontm_hb3(k,num_conti,i)=gggm(k)
3523                 enddo
3524 C Diagnostics. Comment out or remove after debugging!
3525 cdiag           do k=1,3
3526 cdiag             gacontp_hb1(k,num_conti,i)=0.0D0
3527 cdiag             gacontp_hb2(k,num_conti,i)=0.0D0
3528 cdiag             gacontp_hb3(k,num_conti,i)=0.0D0
3529 cdiag             gacontm_hb1(k,num_conti,i)=0.0D0
3530 cdiag             gacontm_hb2(k,num_conti,i)=0.0D0
3531 cdiag             gacontm_hb3(k,num_conti,i)=0.0D0
3532 cdiag           enddo
3533               ENDIF ! wcorr
3534               endif  ! num_conti.le.maxconts
3535             endif  ! fcont.gt.0
3536           endif    ! j.gt.i+1
3537           if (wturn3.gt.0.0d0 .or. wturn4.gt.0.0d0) then
3538             do k=1,4
3539               do l=1,3
3540                 ghalf=0.5d0*agg(l,k)
3541                 aggi(l,k)=aggi(l,k)+ghalf
3542                 aggi1(l,k)=aggi1(l,k)+agg(l,k)
3543                 aggj(l,k)=aggj(l,k)+ghalf
3544               enddo
3545             enddo
3546             if (j.eq.nres-1 .and. i.lt.j-2) then
3547               do k=1,4
3548                 do l=1,3
3549                   aggj1(l,k)=aggj1(l,k)+agg(l,k)
3550                 enddo
3551               enddo
3552             endif
3553           endif
3554 c          t_eelecij=t_eelecij+MPI_Wtime()-time00
3555       return
3556       end
3557 C-----------------------------------------------------------------------------
3558       subroutine eturn3(i,eello_turn3)
3559 C Third- and fourth-order contributions from turns
3560       implicit real*8 (a-h,o-z)
3561       include 'DIMENSIONS'
3562       include 'COMMON.IOUNITS'
3563       include 'COMMON.GEO'
3564       include 'COMMON.VAR'
3565       include 'COMMON.LOCAL'
3566       include 'COMMON.CHAIN'
3567       include 'COMMON.DERIV'
3568       include 'COMMON.INTERACT'
3569       include 'COMMON.CONTACTS'
3570       include 'COMMON.TORSION'
3571       include 'COMMON.VECTORS'
3572       include 'COMMON.FFIELD'
3573       include 'COMMON.CONTROL'
3574       dimension ggg(3)
3575       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3576      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3577      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3578       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3579      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3580       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3581      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3582      &    num_conti,j1,j2
3583       j=i+2
3584 c      write (iout,*) "eturn3",i,j,j1,j2
3585       a_temp(1,1)=a22
3586       a_temp(1,2)=a23
3587       a_temp(2,1)=a32
3588       a_temp(2,2)=a33
3589 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3590 C
3591 C               Third-order contributions
3592 C
3593 C                 (i+2)o----(i+3)
3594 C                      | |
3595 C                      | |
3596 C                 (i+1)o----i
3597 C
3598 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3599 cd        call checkint_turn3(i,a_temp,eello_turn3_num)
3600         call matmat2(EUg(1,1,i+1),EUg(1,1,i+2),auxmat(1,1))
3601         call transpose2(auxmat(1,1),auxmat1(1,1))
3602         call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3603         eello_turn3=eello_turn3+0.5d0*(pizda(1,1)+pizda(2,2))
3604         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3605      &          'eturn3',i,j,0.5d0*(pizda(1,1)+pizda(2,2))
3606 cd        write (2,*) 'i,',i,' j',j,'eello_turn3',
3607 cd     &    0.5d0*(pizda(1,1)+pizda(2,2)),
3608 cd     &    ' eello_turn3_num',4*eello_turn3_num
3609 C Derivatives in gamma(i)
3610         call matmat2(EUgder(1,1,i+1),EUg(1,1,i+2),auxmat2(1,1))
3611         call transpose2(auxmat2(1,1),auxmat3(1,1))
3612         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3613         gel_loc_turn3(i)=gel_loc_turn3(i)+0.5d0*(pizda(1,1)+pizda(2,2))
3614 C Derivatives in gamma(i+1)
3615         call matmat2(EUg(1,1,i+1),EUgder(1,1,i+2),auxmat2(1,1))
3616         call transpose2(auxmat2(1,1),auxmat3(1,1))
3617         call matmat2(a_temp(1,1),auxmat3(1,1),pizda(1,1))
3618         gel_loc_turn3(i+1)=gel_loc_turn3(i+1)
3619      &    +0.5d0*(pizda(1,1)+pizda(2,2))
3620 C Cartesian derivatives
3621         do l=1,3
3622 c            ghalf1=0.5d0*agg(l,1)
3623 c            ghalf2=0.5d0*agg(l,2)
3624 c            ghalf3=0.5d0*agg(l,3)
3625 c            ghalf4=0.5d0*agg(l,4)
3626           a_temp(1,1)=aggi(l,1)!+ghalf1
3627           a_temp(1,2)=aggi(l,2)!+ghalf2
3628           a_temp(2,1)=aggi(l,3)!+ghalf3
3629           a_temp(2,2)=aggi(l,4)!+ghalf4
3630           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3631           gcorr3_turn(l,i)=gcorr3_turn(l,i)
3632      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3633           a_temp(1,1)=aggi1(l,1)!+agg(l,1)
3634           a_temp(1,2)=aggi1(l,2)!+agg(l,2)
3635           a_temp(2,1)=aggi1(l,3)!+agg(l,3)
3636           a_temp(2,2)=aggi1(l,4)!+agg(l,4)
3637           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3638           gcorr3_turn(l,i+1)=gcorr3_turn(l,i+1)
3639      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3640           a_temp(1,1)=aggj(l,1)!+ghalf1
3641           a_temp(1,2)=aggj(l,2)!+ghalf2
3642           a_temp(2,1)=aggj(l,3)!+ghalf3
3643           a_temp(2,2)=aggj(l,4)!+ghalf4
3644           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3645           gcorr3_turn(l,j)=gcorr3_turn(l,j)
3646      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3647           a_temp(1,1)=aggj1(l,1)
3648           a_temp(1,2)=aggj1(l,2)
3649           a_temp(2,1)=aggj1(l,3)
3650           a_temp(2,2)=aggj1(l,4)
3651           call matmat2(a_temp(1,1),auxmat1(1,1),pizda(1,1))
3652           gcorr3_turn(l,j1)=gcorr3_turn(l,j1)
3653      &      +0.5d0*(pizda(1,1)+pizda(2,2))
3654         enddo
3655       return
3656       end
3657 C-------------------------------------------------------------------------------
3658       subroutine eturn4(i,eello_turn4)
3659 C Third- and fourth-order contributions from turns
3660       implicit real*8 (a-h,o-z)
3661       include 'DIMENSIONS'
3662       include 'COMMON.IOUNITS'
3663       include 'COMMON.GEO'
3664       include 'COMMON.VAR'
3665       include 'COMMON.LOCAL'
3666       include 'COMMON.CHAIN'
3667       include 'COMMON.DERIV'
3668       include 'COMMON.INTERACT'
3669       include 'COMMON.CONTACTS'
3670       include 'COMMON.TORSION'
3671       include 'COMMON.VECTORS'
3672       include 'COMMON.FFIELD'
3673       include 'COMMON.CONTROL'
3674       dimension ggg(3)
3675       double precision auxmat(2,2),auxmat1(2,2),auxmat2(2,2),pizda(2,2),
3676      &  e1t(2,2),e2t(2,2),e3t(2,2),e1tder(2,2),e2tder(2,2),e3tder(2,2),
3677      &  e1a(2,2),ae3(2,2),ae3e2(2,2),auxvec(2),auxvec1(2)
3678       double precision agg(3,4),aggi(3,4),aggi1(3,4),
3679      &    aggj(3,4),aggj1(3,4),a_temp(2,2),auxmat3(2,2)
3680       common /locel/ a_temp,agg,aggi,aggi1,aggj,aggj1,a22,a23,a32,a33,
3681      &    dxi,dyi,dzi,dx_normi,dy_normi,dz_normi,xmedi,ymedi,zmedi,
3682      &    num_conti,j1,j2
3683       j=i+3
3684 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3685 C
3686 C               Fourth-order contributions
3687 C
3688 C                 (i+3)o----(i+4)
3689 C                     /  |
3690 C               (i+2)o   |
3691 C                     \  |
3692 C                 (i+1)o----i
3693 C
3694 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
3695 cd        call checkint_turn4(i,a_temp,eello_turn4_num)
3696 c        write (iout,*) "eturn4 i",i," j",j," j1",j1," j2",j2
3697         a_temp(1,1)=a22
3698         a_temp(1,2)=a23
3699         a_temp(2,1)=a32
3700         a_temp(2,2)=a33
3701         iti1=itortyp(itype(i+1))
3702         iti2=itortyp(itype(i+2))
3703         iti3=itortyp(itype(i+3))
3704 c        write(iout,*) "iti1",iti1," iti2",iti2," iti3",iti3
3705         call transpose2(EUg(1,1,i+1),e1t(1,1))
3706         call transpose2(Eug(1,1,i+2),e2t(1,1))
3707         call transpose2(Eug(1,1,i+3),e3t(1,1))
3708         call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3709         call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3710         s1=scalar2(b1(1,iti2),auxvec(1))
3711         call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3712         call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3713         s2=scalar2(b1(1,iti1),auxvec(1))
3714         call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3715         call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3716         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3717         eello_turn4=eello_turn4-(s1+s2+s3)
3718         if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
3719      &      'eturn4',i,j,-(s1+s2+s3)
3720 cd        write (2,*) 'i,',i,' j',j,'eello_turn4',-(s1+s2+s3),
3721 cd     &    ' eello_turn4_num',8*eello_turn4_num
3722 C Derivatives in gamma(i)
3723         call transpose2(EUgder(1,1,i+1),e1tder(1,1))
3724         call matmat2(e1tder(1,1),a_temp(1,1),auxmat(1,1))
3725         call matvec2(auxmat(1,1),Ub2(1,i+3),auxvec(1))
3726         s1=scalar2(b1(1,iti2),auxvec(1))
3727         call matmat2(ae3e2(1,1),e1tder(1,1),pizda(1,1))
3728         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3729         gel_loc_turn4(i)=gel_loc_turn4(i)-(s1+s3)
3730 C Derivatives in gamma(i+1)
3731         call transpose2(EUgder(1,1,i+2),e2tder(1,1))
3732         call matvec2(ae3(1,1),Ub2der(1,i+2),auxvec(1))
3733         s2=scalar2(b1(1,iti1),auxvec(1))
3734         call matmat2(ae3(1,1),e2tder(1,1),auxmat(1,1))
3735         call matmat2(auxmat(1,1),e1t(1,1),pizda(1,1))
3736         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3737         gel_loc_turn4(i+1)=gel_loc_turn4(i+1)-(s2+s3)
3738 C Derivatives in gamma(i+2)
3739         call transpose2(EUgder(1,1,i+3),e3tder(1,1))
3740         call matvec2(e1a(1,1),Ub2der(1,i+3),auxvec(1))
3741         s1=scalar2(b1(1,iti2),auxvec(1))
3742         call matmat2(a_temp(1,1),e3tder(1,1),auxmat(1,1))
3743         call matvec2(auxmat(1,1),Ub2(1,i+2),auxvec(1))
3744         s2=scalar2(b1(1,iti1),auxvec(1))
3745         call matmat2(auxmat(1,1),e2t(1,1),auxmat3(1,1))
3746         call matmat2(auxmat3(1,1),e1t(1,1),pizda(1,1))
3747         s3=0.5d0*(pizda(1,1)+pizda(2,2))
3748         gel_loc_turn4(i+2)=gel_loc_turn4(i+2)-(s1+s2+s3)
3749 C Cartesian derivatives
3750 C Derivatives of this turn contributions in DC(i+2)
3751         if (j.lt.nres-1) then
3752           do l=1,3
3753             a_temp(1,1)=agg(l,1)
3754             a_temp(1,2)=agg(l,2)
3755             a_temp(2,1)=agg(l,3)
3756             a_temp(2,2)=agg(l,4)
3757             call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3758             call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3759             s1=scalar2(b1(1,iti2),auxvec(1))
3760             call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3761             call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3762             s2=scalar2(b1(1,iti1),auxvec(1))
3763             call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3764             call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3765             s3=0.5d0*(pizda(1,1)+pizda(2,2))
3766             ggg(l)=-(s1+s2+s3)
3767             gcorr4_turn(l,i+2)=gcorr4_turn(l,i+2)-(s1+s2+s3)
3768           enddo
3769         endif
3770 C Remaining derivatives of this turn contribution
3771         do l=1,3
3772           a_temp(1,1)=aggi(l,1)
3773           a_temp(1,2)=aggi(l,2)
3774           a_temp(2,1)=aggi(l,3)
3775           a_temp(2,2)=aggi(l,4)
3776           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3777           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3778           s1=scalar2(b1(1,iti2),auxvec(1))
3779           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3780           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3781           s2=scalar2(b1(1,iti1),auxvec(1))
3782           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3783           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3784           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3785           gcorr4_turn(l,i)=gcorr4_turn(l,i)-(s1+s2+s3)
3786           a_temp(1,1)=aggi1(l,1)
3787           a_temp(1,2)=aggi1(l,2)
3788           a_temp(2,1)=aggi1(l,3)
3789           a_temp(2,2)=aggi1(l,4)
3790           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3791           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3792           s1=scalar2(b1(1,iti2),auxvec(1))
3793           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3794           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3795           s2=scalar2(b1(1,iti1),auxvec(1))
3796           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3797           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3798           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3799           gcorr4_turn(l,i+1)=gcorr4_turn(l,i+1)-(s1+s2+s3)
3800           a_temp(1,1)=aggj(l,1)
3801           a_temp(1,2)=aggj(l,2)
3802           a_temp(2,1)=aggj(l,3)
3803           a_temp(2,2)=aggj(l,4)
3804           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3805           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3806           s1=scalar2(b1(1,iti2),auxvec(1))
3807           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3808           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3809           s2=scalar2(b1(1,iti1),auxvec(1))
3810           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3811           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3812           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3813           gcorr4_turn(l,j)=gcorr4_turn(l,j)-(s1+s2+s3)
3814           a_temp(1,1)=aggj1(l,1)
3815           a_temp(1,2)=aggj1(l,2)
3816           a_temp(2,1)=aggj1(l,3)
3817           a_temp(2,2)=aggj1(l,4)
3818           call matmat2(e1t(1,1),a_temp(1,1),e1a(1,1))
3819           call matvec2(e1a(1,1),Ub2(1,i+3),auxvec(1))
3820           s1=scalar2(b1(1,iti2),auxvec(1))
3821           call matmat2(a_temp(1,1),e3t(1,1),ae3(1,1))
3822           call matvec2(ae3(1,1),Ub2(1,i+2),auxvec(1))
3823           s2=scalar2(b1(1,iti1),auxvec(1))
3824           call matmat2(ae3(1,1),e2t(1,1),ae3e2(1,1))
3825           call matmat2(ae3e2(1,1),e1t(1,1),pizda(1,1))
3826           s3=0.5d0*(pizda(1,1)+pizda(2,2))
3827 c          write (iout,*) "s1",s1," s2",s2," s3",s3," s1+s2+s3",s1+s2+s3
3828           gcorr4_turn(l,j1)=gcorr4_turn(l,j1)-(s1+s2+s3)
3829         enddo
3830       return
3831       end
3832 C-----------------------------------------------------------------------------
3833       subroutine vecpr(u,v,w)
3834       implicit real*8(a-h,o-z)
3835       dimension u(3),v(3),w(3)
3836       w(1)=u(2)*v(3)-u(3)*v(2)
3837       w(2)=-u(1)*v(3)+u(3)*v(1)
3838       w(3)=u(1)*v(2)-u(2)*v(1)
3839       return
3840       end
3841 C-----------------------------------------------------------------------------
3842       subroutine unormderiv(u,ugrad,unorm,ungrad)
3843 C This subroutine computes the derivatives of a normalized vector u, given
3844 C the derivatives computed without normalization conditions, ugrad. Returns
3845 C ungrad.
3846       implicit none
3847       double precision u(3),ugrad(3,3),unorm,ungrad(3,3)
3848       double precision vec(3)
3849       double precision scalar
3850       integer i,j
3851 c      write (2,*) 'ugrad',ugrad
3852 c      write (2,*) 'u',u
3853       do i=1,3
3854         vec(i)=scalar(ugrad(1,i),u(1))
3855       enddo
3856 c      write (2,*) 'vec',vec
3857       do i=1,3
3858         do j=1,3
3859           ungrad(j,i)=(ugrad(j,i)-u(j)*vec(i))*unorm
3860         enddo
3861       enddo
3862 c      write (2,*) 'ungrad',ungrad
3863       return
3864       end
3865 C-----------------------------------------------------------------------------
3866       subroutine escp_soft_sphere(evdw2,evdw2_14)
3867 C
3868 C This subroutine calculates the excluded-volume interaction energy between
3869 C peptide-group centers and side chains and its gradient in virtual-bond and
3870 C side-chain vectors.
3871 C
3872       implicit real*8 (a-h,o-z)
3873       include 'DIMENSIONS'
3874       include 'COMMON.GEO'
3875       include 'COMMON.VAR'
3876       include 'COMMON.LOCAL'
3877       include 'COMMON.CHAIN'
3878       include 'COMMON.DERIV'
3879       include 'COMMON.INTERACT'
3880       include 'COMMON.FFIELD'
3881       include 'COMMON.IOUNITS'
3882       include 'COMMON.CONTROL'
3883       dimension ggg(3)
3884       evdw2=0.0D0
3885       evdw2_14=0.0d0
3886       r0_scp=4.5d0
3887 cd    print '(a)','Enter ESCP'
3888 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3889       do i=iatscp_s,iatscp_e
3890         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3891         iteli=itel(i)
3892         xi=0.5D0*(c(1,i)+c(1,i+1))
3893         yi=0.5D0*(c(2,i)+c(2,i+1))
3894         zi=0.5D0*(c(3,i)+c(3,i+1))
3895
3896         do iint=1,nscp_gr(i)
3897
3898         do j=iscpstart(i,iint),iscpend(i,iint)
3899           if (itype(j).eq.ntyp1) cycle
3900           itypj=iabs(itype(j))
3901 C Uncomment following three lines for SC-p interactions
3902 c         xj=c(1,nres+j)-xi
3903 c         yj=c(2,nres+j)-yi
3904 c         zj=c(3,nres+j)-zi
3905 C Uncomment following three lines for Ca-p interactions
3906           xj=c(1,j)-xi
3907           yj=c(2,j)-yi
3908           zj=c(3,j)-zi
3909           rij=xj*xj+yj*yj+zj*zj
3910           r0ij=r0_scp
3911           r0ijsq=r0ij*r0ij
3912           if (rij.lt.r0ijsq) then
3913             evdwij=0.25d0*(rij-r0ijsq)**2
3914             fac=rij-r0ijsq
3915           else
3916             evdwij=0.0d0
3917             fac=0.0d0
3918           endif
3919           evdw2=evdw2+evdwij
3920 C
3921 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
3922 C
3923           ggg(1)=xj*fac
3924           ggg(2)=yj*fac
3925           ggg(3)=zj*fac
3926 cgrad          if (j.lt.i) then
3927 cd          write (iout,*) 'j<i'
3928 C Uncomment following three lines for SC-p interactions
3929 c           do k=1,3
3930 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
3931 c           enddo
3932 cgrad          else
3933 cd          write (iout,*) 'j>i'
3934 cgrad            do k=1,3
3935 cgrad              ggg(k)=-ggg(k)
3936 C Uncomment following line for SC-p interactions
3937 c             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
3938 cgrad            enddo
3939 cgrad          endif
3940 cgrad          do k=1,3
3941 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
3942 cgrad          enddo
3943 cgrad          kstart=min0(i+1,j)
3944 cgrad          kend=max0(i-1,j-1)
3945 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
3946 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
3947 cgrad          do k=kstart,kend
3948 cgrad            do l=1,3
3949 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
3950 cgrad            enddo
3951 cgrad          enddo
3952           do k=1,3
3953             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
3954             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
3955           enddo
3956         enddo
3957
3958         enddo ! iint
3959       enddo ! i
3960       return
3961       end
3962 C-----------------------------------------------------------------------------
3963       subroutine escp(evdw2,evdw2_14)
3964 C
3965 C This subroutine calculates the excluded-volume interaction energy between
3966 C peptide-group centers and side chains and its gradient in virtual-bond and
3967 C side-chain vectors.
3968 C
3969       implicit real*8 (a-h,o-z)
3970       include 'DIMENSIONS'
3971       include 'COMMON.GEO'
3972       include 'COMMON.VAR'
3973       include 'COMMON.LOCAL'
3974       include 'COMMON.CHAIN'
3975       include 'COMMON.DERIV'
3976       include 'COMMON.INTERACT'
3977       include 'COMMON.FFIELD'
3978       include 'COMMON.IOUNITS'
3979       include 'COMMON.CONTROL'
3980       dimension ggg(3)
3981       evdw2=0.0D0
3982       evdw2_14=0.0d0
3983 cd    print '(a)','Enter ESCP'
3984 cd    write (iout,*) 'iatscp_s=',iatscp_s,' iatscp_e=',iatscp_e
3985       do i=iatscp_s,iatscp_e
3986         if (itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
3987         iteli=itel(i)
3988         xi=0.5D0*(c(1,i)+c(1,i+1))
3989         yi=0.5D0*(c(2,i)+c(2,i+1))
3990         zi=0.5D0*(c(3,i)+c(3,i+1))
3991
3992         do iint=1,nscp_gr(i)
3993
3994         do j=iscpstart(i,iint),iscpend(i,iint)
3995           itypj=iabs(itype(j))
3996           if (itypj.eq.ntyp1) cycle
3997 C Uncomment following three lines for SC-p interactions
3998 c         xj=c(1,nres+j)-xi
3999 c         yj=c(2,nres+j)-yi
4000 c         zj=c(3,nres+j)-zi
4001 C Uncomment following three lines for Ca-p interactions
4002           xj=c(1,j)-xi
4003           yj=c(2,j)-yi
4004           zj=c(3,j)-zi
4005           rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4006           fac=rrij**expon2
4007           e1=fac*fac*aad(itypj,iteli)
4008           e2=fac*bad(itypj,iteli)
4009           if (iabs(j-i) .le. 2) then
4010             e1=scal14*e1
4011             e2=scal14*e2
4012             evdw2_14=evdw2_14+e1+e2
4013           endif
4014           evdwij=e1+e2
4015           evdw2=evdw2+evdwij
4016           if (energy_dec) write (iout,'(a6,2i5,0pf7.3,2i3,3e11.3)')
4017      &        'evdw2',i,j,evdwij,iteli,itypj,fac,aad(itypj,iteli),
4018      &       bad(itypj,iteli)
4019 C
4020 C Calculate contributions to the gradient in the virtual-bond and SC vectors.
4021 C
4022           fac=-(evdwij+e1)*rrij
4023           ggg(1)=xj*fac
4024           ggg(2)=yj*fac
4025           ggg(3)=zj*fac
4026 cgrad          if (j.lt.i) then
4027 cd          write (iout,*) 'j<i'
4028 C Uncomment following three lines for SC-p interactions
4029 c           do k=1,3
4030 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4031 c           enddo
4032 cgrad          else
4033 cd          write (iout,*) 'j>i'
4034 cgrad            do k=1,3
4035 cgrad              ggg(k)=-ggg(k)
4036 C Uncomment following line for SC-p interactions
4037 ccgrad             gradx_scp(k,j)=gradx_scp(k,j)-ggg(k)
4038 c             gradx_scp(k,j)=gradx_scp(k,j)+ggg(k)
4039 cgrad            enddo
4040 cgrad          endif
4041 cgrad          do k=1,3
4042 cgrad            gvdwc_scp(k,i)=gvdwc_scp(k,i)-0.5D0*ggg(k)
4043 cgrad          enddo
4044 cgrad          kstart=min0(i+1,j)
4045 cgrad          kend=max0(i-1,j-1)
4046 cd        write (iout,*) 'i=',i,' j=',j,' kstart=',kstart,' kend=',kend
4047 cd        write (iout,*) ggg(1),ggg(2),ggg(3)
4048 cgrad          do k=kstart,kend
4049 cgrad            do l=1,3
4050 cgrad              gvdwc_scp(l,k)=gvdwc_scp(l,k)-ggg(l)
4051 cgrad            enddo
4052 cgrad          enddo
4053           do k=1,3
4054             gvdwc_scpp(k,i)=gvdwc_scpp(k,i)-ggg(k)
4055             gvdwc_scp(k,j)=gvdwc_scp(k,j)+ggg(k)
4056           enddo
4057         enddo
4058
4059         enddo ! iint
4060       enddo ! i
4061       do i=1,nct
4062         do j=1,3
4063           gvdwc_scp(j,i)=expon*gvdwc_scp(j,i)
4064           gvdwc_scpp(j,i)=expon*gvdwc_scpp(j,i)
4065           gradx_scp(j,i)=expon*gradx_scp(j,i)
4066         enddo
4067       enddo
4068 C******************************************************************************
4069 C
4070 C                              N O T E !!!
4071 C
4072 C To save time the factor EXPON has been extracted from ALL components
4073 C of GVDWC and GRADX. Remember to multiply them by this factor before further
4074 C use!
4075 C
4076 C******************************************************************************
4077       return
4078       end
4079 C--------------------------------------------------------------------------
4080       subroutine edis(ehpb)
4081 C
4082 C Evaluate bridge-strain energy and its gradient in virtual-bond and SC vectors.
4083 C
4084       implicit real*8 (a-h,o-z)
4085       include 'DIMENSIONS'
4086       include 'COMMON.SBRIDGE'
4087       include 'COMMON.CHAIN'
4088       include 'COMMON.DERIV'
4089       include 'COMMON.VAR'
4090       include 'COMMON.INTERACT'
4091       include 'COMMON.IOUNITS'
4092       include 'COMMON.CONTROL'
4093       dimension ggg(3)
4094       ehpb=0.0D0
4095       do i=1,3
4096        ggg(i)=0.0d0
4097       enddo
4098 C      write (iout,*) ,"link_end",link_end,constr_dist
4099 cd      write(iout,*)'edis: nhpb=',nhpb,' fbr=',fbr
4100 cd      write(iout,*)'link_start=',link_start,' link_end=',link_end
4101       if (link_end.eq.0) return
4102       do i=link_start,link_end
4103 C If ihpb(i) and jhpb(i) > NRES, this is a SC-SC distance, otherwise a
4104 C CA-CA distance used in regularization of structure.
4105         ii=ihpb(i)
4106         jj=jhpb(i)
4107 C iii and jjj point to the residues for which the distance is assigned.
4108         if (ii.gt.nres) then
4109           iii=ii-nres
4110           jjj=jj-nres
4111         else
4112           iii=ii
4113           jjj=jj
4114         endif
4115 c        write (iout,*) "i",i," ii",ii," iii",iii," jj",jj," jjj",jjj,
4116 c     &    dhpb(i),dhpb1(i),forcon(i)
4117 C 24/11/03 AL: SS bridges handled separately because of introducing a specific
4118 C    distance and angle dependent SS bond potential.
4119 cmc        if (ii.gt.nres .and. itype(iii).eq.1 .and. itype(jjj).eq.1) then
4120 C 18/07/06 MC: Use the convention that the first nss pairs are SS bonds
4121         if (.not.dyn_ss .and. i.le.nss) then
4122 C 15/02/13 CC dynamic SSbond - additional check
4123          if (ii.gt.nres .and. iabs(itype(iii)).eq.1 .and.
4124      & iabs(itype(jjj)).eq.1) then
4125           call ssbond_ene(iii,jjj,eij)
4126           ehpb=ehpb+2*eij
4127          endif
4128 cd          write (iout,*) "eij",eij
4129 cd   &   ' waga=',waga,' fac=',fac
4130         else if (ii.gt.nres .and. jj.gt.nres) then
4131 c Restraints from contact prediction
4132           dd=dist(ii,jj)
4133           if (constr_dist.eq.11) then
4134             ehpb=ehpb+fordepth(i)**4.0d0
4135      &          *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4136             fac=fordepth(i)**4.0d0
4137      &          *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4138           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4139      &    ehpb,fordepth(i),dd
4140            else
4141           if (dhpb1(i).gt.0.0d0) then
4142             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4143             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4144 c            write (iout,*) "beta nmr",
4145 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4146           else
4147             dd=dist(ii,jj)
4148             rdis=dd-dhpb(i)
4149 C Get the force constant corresponding to this distance.
4150             waga=forcon(i)
4151 C Calculate the contribution to energy.
4152             ehpb=ehpb+waga*rdis*rdis
4153 c            write (iout,*) "beta reg",dd,waga*rdis*rdis
4154 C
4155 C Evaluate gradient.
4156 C
4157             fac=waga*rdis/dd
4158           endif
4159           endif
4160           do j=1,3
4161             ggg(j)=fac*(c(j,jj)-c(j,ii))
4162           enddo
4163           do j=1,3
4164             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4165             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4166           enddo
4167           do k=1,3
4168             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4169             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4170           enddo
4171         else
4172 C Calculate the distance between the two points and its difference from the
4173 C target distance.
4174           dd=dist(ii,jj)
4175           if (constr_dist.eq.11) then
4176             ehpb=ehpb+fordepth(i)**4.0d0
4177      &           *rlornmr1(dd,dhpb(i),dhpb1(i),forcon(i))
4178             fac=fordepth(i)**4.0d0
4179      &           *rlornmr1prim(dd,dhpb(i),dhpb1(i),forcon(i))/dd
4180           if (energy_dec) write (iout,'(a6,2i5,3f8.3)') "edisl",ii,jj,
4181      &    ehpb,fordepth(i),dd
4182            else
4183           if (dhpb1(i).gt.0.0d0) then
4184             ehpb=ehpb+2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4185             fac=forcon(i)*gnmr1prim(dd,dhpb(i),dhpb1(i))/dd
4186 c            write (iout,*) "alph nmr",
4187 c     &        dd,2*forcon(i)*gnmr1(dd,dhpb(i),dhpb1(i))
4188           else
4189             rdis=dd-dhpb(i)
4190 C Get the force constant corresponding to this distance.
4191             waga=forcon(i)
4192 C Calculate the contribution to energy.
4193             ehpb=ehpb+waga*rdis*rdis
4194 c            write (iout,*) "alpha reg",dd,waga*rdis*rdis
4195 C
4196 C Evaluate gradient.
4197 C
4198             fac=waga*rdis/dd
4199           endif
4200           endif
4201             do j=1,3
4202               ggg(j)=fac*(c(j,jj)-c(j,ii))
4203             enddo
4204 cd      print '(i3,3(1pe14.5))',i,(ggg(j),j=1,3)
4205 C If this is a SC-SC distance, we need to calculate the contributions to the
4206 C Cartesian gradient in the SC vectors (ghpbx).
4207           if (iii.lt.ii) then
4208           do j=1,3
4209             ghpbx(j,iii)=ghpbx(j,iii)-ggg(j)
4210             ghpbx(j,jjj)=ghpbx(j,jjj)+ggg(j)
4211           enddo
4212           endif
4213 cgrad        do j=iii,jjj-1
4214 cgrad          do k=1,3
4215 cgrad            ghpbc(k,j)=ghpbc(k,j)+ggg(k)
4216 cgrad          enddo
4217 cgrad        enddo
4218           do k=1,3
4219             ghpbc(k,jjj)=ghpbc(k,jjj)+ggg(k)
4220             ghpbc(k,iii)=ghpbc(k,iii)-ggg(k)
4221           enddo
4222         endif
4223       enddo
4224       if (constr_dist.ne.11) ehpb=0.5D0*ehpb
4225       return
4226       end
4227 C--------------------------------------------------------------------------
4228       subroutine ssbond_ene(i,j,eij)
4229 C
4230 C Calculate the distance and angle dependent SS-bond potential energy
4231 C using a free-energy function derived based on RHF/6-31G** ab initio
4232 C calculations of diethyl disulfide.
4233 C
4234 C A. Liwo and U. Kozlowska, 11/24/03
4235 C
4236       implicit real*8 (a-h,o-z)
4237       include 'DIMENSIONS'
4238       include 'COMMON.SBRIDGE'
4239       include 'COMMON.CHAIN'
4240       include 'COMMON.DERIV'
4241       include 'COMMON.LOCAL'
4242       include 'COMMON.INTERACT'
4243       include 'COMMON.VAR'
4244       include 'COMMON.IOUNITS'
4245       double precision erij(3),dcosom1(3),dcosom2(3),gg(3)
4246       itypi=iabs(itype(i))
4247       xi=c(1,nres+i)
4248       yi=c(2,nres+i)
4249       zi=c(3,nres+i)
4250       dxi=dc_norm(1,nres+i)
4251       dyi=dc_norm(2,nres+i)
4252       dzi=dc_norm(3,nres+i)
4253 c      dsci_inv=dsc_inv(itypi)
4254       dsci_inv=vbld_inv(nres+i)
4255       itypj=iabs(itype(j))
4256 c      dscj_inv=dsc_inv(itypj)
4257       dscj_inv=vbld_inv(nres+j)
4258       xj=c(1,nres+j)-xi
4259       yj=c(2,nres+j)-yi
4260       zj=c(3,nres+j)-zi
4261       dxj=dc_norm(1,nres+j)
4262       dyj=dc_norm(2,nres+j)
4263       dzj=dc_norm(3,nres+j)
4264       rrij=1.0D0/(xj*xj+yj*yj+zj*zj)
4265       rij=dsqrt(rrij)
4266       erij(1)=xj*rij
4267       erij(2)=yj*rij
4268       erij(3)=zj*rij
4269       om1=dxi*erij(1)+dyi*erij(2)+dzi*erij(3)
4270       om2=dxj*erij(1)+dyj*erij(2)+dzj*erij(3)
4271       om12=dxi*dxj+dyi*dyj+dzi*dzj
4272       do k=1,3
4273         dcosom1(k)=rij*(dc_norm(k,nres+i)-om1*erij(k))
4274         dcosom2(k)=rij*(dc_norm(k,nres+j)-om2*erij(k))
4275       enddo
4276       rij=1.0d0/rij
4277       deltad=rij-d0cm
4278       deltat1=1.0d0-om1
4279       deltat2=1.0d0+om2
4280       deltat12=om2-om1+2.0d0
4281       cosphi=om12-om1*om2
4282       eij=akcm*deltad*deltad+akth*(deltat1*deltat1+deltat2*deltat2)
4283      &  +akct*deltad*deltat12
4284      &  +v1ss*cosphi+v2ss*cosphi*cosphi+v3ss*cosphi*cosphi*cosphi+ebr
4285 c      write(iout,*) i,j,"rij",rij,"d0cm",d0cm," akcm",akcm," akth",akth,
4286 c     &  " akct",akct," deltad",deltad," deltat",deltat1,deltat2,
4287 c     &  " deltat12",deltat12," eij",eij
4288       ed=2*akcm*deltad+akct*deltat12
4289       pom1=akct*deltad
4290       pom2=v1ss+2*v2ss*cosphi+3*v3ss*cosphi*cosphi
4291       eom1=-2*akth*deltat1-pom1-om2*pom2
4292       eom2= 2*akth*deltat2+pom1-om1*pom2
4293       eom12=pom2
4294       do k=1,3
4295         ggk=ed*erij(k)+eom1*dcosom1(k)+eom2*dcosom2(k)
4296         ghpbx(k,i)=ghpbx(k,i)-ggk
4297      &            +(eom12*(dc_norm(k,nres+j)-om12*dc_norm(k,nres+i))
4298      &            +eom1*(erij(k)-om1*dc_norm(k,nres+i)))*dsci_inv
4299         ghpbx(k,j)=ghpbx(k,j)+ggk
4300      &            +(eom12*(dc_norm(k,nres+i)-om12*dc_norm(k,nres+j))
4301      &            +eom2*(erij(k)-om2*dc_norm(k,nres+j)))*dscj_inv
4302         ghpbc(k,i)=ghpbc(k,i)-ggk
4303         ghpbc(k,j)=ghpbc(k,j)+ggk
4304       enddo
4305 C
4306 C Calculate the components of the gradient in DC and X
4307 C
4308 cgrad      do k=i,j-1
4309 cgrad        do l=1,3
4310 cgrad          ghpbc(l,k)=ghpbc(l,k)+gg(l)
4311 cgrad        enddo
4312 cgrad      enddo
4313       return
4314       end
4315 C--------------------------------------------------------------------------
4316       subroutine ebond(estr)
4317 c
4318 c Evaluate the energy of stretching of the CA-CA and CA-SC virtual bonds
4319 c
4320       implicit real*8 (a-h,o-z)
4321       include 'DIMENSIONS'
4322       include 'COMMON.LOCAL'
4323       include 'COMMON.GEO'
4324       include 'COMMON.INTERACT'
4325       include 'COMMON.DERIV'
4326       include 'COMMON.VAR'
4327       include 'COMMON.CHAIN'
4328       include 'COMMON.IOUNITS'
4329       include 'COMMON.NAMES'
4330       include 'COMMON.FFIELD'
4331       include 'COMMON.CONTROL'
4332       include 'COMMON.SETUP'
4333       double precision u(3),ud(3)
4334       estr=0.0d0
4335       estr1=0.0d0
4336       do i=ibondp_start,ibondp_end
4337         if (itype(i-1).eq.ntyp1 .or. itype(i).eq.ntyp1) then
4338           estr1=estr1+gnmr1(vbld(i),-1.0d0,distchainmax)
4339           do j=1,3
4340           gradb(j,i-1)=gnmr1prim(vbld(i),-1.0d0,distchainmax)
4341      &      *dc(j,i-1)/vbld(i)
4342           enddo
4343           if (energy_dec) write(iout,*)
4344      &       "estr1",i,gnmr1(vbld(i),-1.0d0,distchainmax)
4345         else
4346         diff = vbld(i)-vbldp0
4347         if (energy_dec) write (iout,*)
4348      &     "estr bb",i,vbld(i),vbldp0,diff,AKP*diff*diff
4349         estr=estr+diff*diff
4350         do j=1,3
4351           gradb(j,i-1)=AKP*diff*dc(j,i-1)/vbld(i)
4352         enddo
4353 c        write (iout,'(i5,3f10.5)') i,(gradb(j,i-1),j=1,3)
4354         endif
4355       enddo
4356       estr=0.5d0*AKP*estr+estr1
4357 c
4358 c 09/18/07 AL: multimodal bond potential based on AM1 CA-SC PMF's included
4359 c
4360       do i=ibond_start,ibond_end
4361         iti=iabs(itype(i))
4362         if (iti.ne.10 .and. iti.ne.ntyp1) then
4363           nbi=nbondterm(iti)
4364           if (nbi.eq.1) then
4365             diff=vbld(i+nres)-vbldsc0(1,iti)
4366             if (energy_dec) write (iout,*)
4367      &      "estr sc",i,iti,vbld(i+nres),vbldsc0(1,iti),diff,
4368      &      AKSC(1,iti),AKSC(1,iti)*diff*diff
4369             estr=estr+0.5d0*AKSC(1,iti)*diff*diff
4370             do j=1,3
4371               gradbx(j,i)=AKSC(1,iti)*diff*dc(j,i+nres)/vbld(i+nres)
4372             enddo
4373           else
4374             do j=1,nbi
4375               diff=vbld(i+nres)-vbldsc0(j,iti)
4376               ud(j)=aksc(j,iti)*diff
4377               u(j)=abond0(j,iti)+0.5d0*ud(j)*diff
4378             enddo
4379             uprod=u(1)
4380             do j=2,nbi
4381               uprod=uprod*u(j)
4382             enddo
4383             usum=0.0d0
4384             usumsqder=0.0d0
4385             do j=1,nbi
4386               uprod1=1.0d0
4387               uprod2=1.0d0
4388               do k=1,nbi
4389                 if (k.ne.j) then
4390                   uprod1=uprod1*u(k)
4391                   uprod2=uprod2*u(k)*u(k)
4392                 endif
4393               enddo
4394               usum=usum+uprod1
4395               usumsqder=usumsqder+ud(j)*uprod2
4396             enddo
4397             estr=estr+uprod/usum
4398             do j=1,3
4399              gradbx(j,i)=usumsqder/(usum*usum)*dc(j,i+nres)/vbld(i+nres)
4400             enddo
4401           endif
4402         endif
4403       enddo
4404       return
4405       end
4406 #ifdef CRYST_THETA
4407 C--------------------------------------------------------------------------
4408       subroutine ebend(etheta)
4409 C
4410 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4411 C angles gamma and its derivatives in consecutive thetas and gammas.
4412 C
4413       implicit real*8 (a-h,o-z)
4414       include 'DIMENSIONS'
4415       include 'COMMON.LOCAL'
4416       include 'COMMON.GEO'
4417       include 'COMMON.INTERACT'
4418       include 'COMMON.DERIV'
4419       include 'COMMON.VAR'
4420       include 'COMMON.CHAIN'
4421       include 'COMMON.IOUNITS'
4422       include 'COMMON.NAMES'
4423       include 'COMMON.FFIELD'
4424       include 'COMMON.CONTROL'
4425       common /calcthet/ term1,term2,termm,diffak,ratak,
4426      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4427      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4428       double precision y(2),z(2)
4429       delta=0.02d0*pi
4430 c      time11=dexp(-2*time)
4431 c      time12=1.0d0
4432       etheta=0.0D0
4433 c     write (*,'(a,i2)') 'EBEND ICG=',icg
4434       do i=ithet_start,ithet_end
4435         if (itype(i-1).eq.ntyp1) cycle
4436 C Zero the energy function and its derivative at 0 or pi.
4437         call splinthet(theta(i),0.5d0*delta,ss,ssd)
4438         it=itype(i-1)
4439         ichir1=isign(1,itype(i-2))
4440         ichir2=isign(1,itype(i))
4441          if (itype(i-2).eq.10) ichir1=isign(1,itype(i-1))
4442          if (itype(i).eq.10) ichir2=isign(1,itype(i-1))
4443          if (itype(i-1).eq.10) then
4444           itype1=isign(10,itype(i-2))
4445           ichir11=isign(1,itype(i-2))
4446           ichir12=isign(1,itype(i-2))
4447           itype2=isign(10,itype(i))
4448           ichir21=isign(1,itype(i))
4449           ichir22=isign(1,itype(i))
4450          endif
4451
4452         if (i.gt.3 .and. itype(i-2).ne.ntyp1) then
4453 #ifdef OSF
4454           phii=phi(i)
4455           if (phii.ne.phii) phii=150.0
4456 #else
4457           phii=phi(i)
4458 #endif
4459           y(1)=dcos(phii)
4460           y(2)=dsin(phii)
4461         else
4462           y(1)=0.0D0
4463           y(2)=0.0D0
4464         endif
4465         if (i.lt.nres .and. itype(i).ne.ntyp1) then
4466 #ifdef OSF
4467           phii1=phi(i+1)
4468           if (phii1.ne.phii1) phii1=150.0
4469           phii1=pinorm(phii1)
4470           z(1)=cos(phii1)
4471 #else
4472           phii1=phi(i+1)
4473           z(1)=dcos(phii1)
4474 #endif
4475           z(2)=dsin(phii1)
4476         else
4477           z(1)=0.0D0
4478           z(2)=0.0D0
4479         endif
4480 C Calculate the "mean" value of theta from the part of the distribution
4481 C dependent on the adjacent virtual-bond-valence angles (gamma1 & gamma2).
4482 C In following comments this theta will be referred to as t_c.
4483         thet_pred_mean=0.0d0
4484         do k=1,2
4485             athetk=athet(k,it,ichir1,ichir2)
4486             bthetk=bthet(k,it,ichir1,ichir2)
4487           if (it.eq.10) then
4488              athetk=athet(k,itype1,ichir11,ichir12)
4489              bthetk=bthet(k,itype2,ichir21,ichir22)
4490           endif
4491          thet_pred_mean=thet_pred_mean+athetk*y(k)+bthetk*z(k)
4492         enddo
4493         dthett=thet_pred_mean*ssd
4494         thet_pred_mean=thet_pred_mean*ss+a0thet(it)
4495 C Derivatives of the "mean" values in gamma1 and gamma2.
4496         dthetg1=(-athet(1,it,ichir1,ichir2)*y(2)
4497      &+athet(2,it,ichir1,ichir2)*y(1))*ss
4498          dthetg2=(-bthet(1,it,ichir1,ichir2)*z(2)
4499      &          +bthet(2,it,ichir1,ichir2)*z(1))*ss
4500          if (it.eq.10) then
4501       dthetg1=(-athet(1,itype1,ichir11,ichir12)*y(2)
4502      &+athet(2,itype1,ichir11,ichir12)*y(1))*ss
4503         dthetg2=(-bthet(1,itype2,ichir21,ichir22)*z(2)
4504      &         +bthet(2,itype2,ichir21,ichir22)*z(1))*ss
4505          endif
4506         if (theta(i).gt.pi-delta) then
4507           call theteng(pi-delta,thet_pred_mean,theta0(it),f0,fprim0,
4508      &         E_tc0)
4509           call mixder(pi-delta,thet_pred_mean,theta0(it),fprim_tc0)
4510           call theteng(pi,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4511           call spline1(theta(i),pi-delta,delta,f0,f1,fprim0,ethetai,
4512      &        E_theta)
4513           call spline2(theta(i),pi-delta,delta,E_tc0,E_tc1,fprim_tc0,
4514      &        E_tc)
4515         else if (theta(i).lt.delta) then
4516           call theteng(delta,thet_pred_mean,theta0(it),f0,fprim0,E_tc0)
4517           call theteng(0.0d0,thet_pred_mean,theta0(it),f1,fprim1,E_tc1)
4518           call spline1(theta(i),delta,-delta,f0,f1,fprim0,ethetai,
4519      &        E_theta)
4520           call mixder(delta,thet_pred_mean,theta0(it),fprim_tc0)
4521           call spline2(theta(i),delta,-delta,E_tc0,E_tc1,fprim_tc0,
4522      &        E_tc)
4523         else
4524           call theteng(theta(i),thet_pred_mean,theta0(it),ethetai,
4525      &        E_theta,E_tc)
4526         endif
4527         etheta=etheta+ethetai
4528       do i=ithetaconstr_start,ithetaconstr_end
4529         itheta=itheta_constr(i)
4530         thetiii=theta(itori)
4531         difi=pinorm(thetiii-theta_constr0(i))
4532         if (difi.gt.theta_drange(i)) then
4533           difi=difi-theta_drange(i)
4534           ethetcnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
4535           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4536      &    +for_thet_constr(i)*difi**3
4537         else if (difi.lt.-drange(i)) then
4538           difi=difi+drange(i)
4539           ethetcnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
4540           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4541      &    +for_thet_constr(i)*difi**3
4542         else
4543           difi=0.0
4544         endif
4545        if (energy_dec) then
4546         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4547      &    i,itheta,rad2deg*thetiii,
4548      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4549      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4550      &    gloc(itheta+nphi-2,icg)
4551         endif
4552       enddo
4553         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
4554      &      'ebend',i,ethetai
4555         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*E_tc*dthetg1
4556         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*E_tc*dthetg2
4557         gloc(nphi+i-2,icg)=wang*(E_theta+E_tc*dthett)
4558       enddo
4559 C Ufff.... We've done all this!!!
4560       return
4561       end
4562 C---------------------------------------------------------------------------
4563       subroutine theteng(thetai,thet_pred_mean,theta0i,ethetai,E_theta,
4564      &     E_tc)
4565       implicit real*8 (a-h,o-z)
4566       include 'DIMENSIONS'
4567       include 'COMMON.LOCAL'
4568       include 'COMMON.IOUNITS'
4569       common /calcthet/ term1,term2,termm,diffak,ratak,
4570      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4571      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4572 C Calculate the contributions to both Gaussian lobes.
4573 C 6/6/97 - Deform the Gaussians using the factor of 1/(1+time)
4574 C The "polynomial part" of the "standard deviation" of this part of
4575 C the distribution.
4576         sig=polthet(3,it)
4577         do j=2,0,-1
4578           sig=sig*thet_pred_mean+polthet(j,it)
4579         enddo
4580 C Derivative of the "interior part" of the "standard deviation of the"
4581 C gamma-dependent Gaussian lobe in t_c.
4582         sigtc=3*polthet(3,it)
4583         do j=2,1,-1
4584           sigtc=sigtc*thet_pred_mean+j*polthet(j,it)
4585         enddo
4586         sigtc=sig*sigtc
4587 C Set the parameters of both Gaussian lobes of the distribution.
4588 C "Standard deviation" of the gamma-dependent Gaussian lobe (sigtc)
4589         fac=sig*sig+sigc0(it)
4590         sigcsq=fac+fac
4591         sigc=1.0D0/sigcsq
4592 C Following variable (sigsqtc) is -(1/2)d[sigma(t_c)**(-2))]/dt_c
4593         sigsqtc=-4.0D0*sigcsq*sigtc
4594 c       print *,i,sig,sigtc,sigsqtc
4595 C Following variable (sigtc) is d[sigma(t_c)]/dt_c
4596         sigtc=-sigtc/(fac*fac)
4597 C Following variable is sigma(t_c)**(-2)
4598         sigcsq=sigcsq*sigcsq
4599         sig0i=sig0(it)
4600         sig0inv=1.0D0/sig0i**2
4601         delthec=thetai-thet_pred_mean
4602         delthe0=thetai-theta0i
4603         term1=-0.5D0*sigcsq*delthec*delthec
4604         term2=-0.5D0*sig0inv*delthe0*delthe0
4605 C Following fuzzy logic is to avoid underflows in dexp and subsequent INFs and
4606 C NaNs in taking the logarithm. We extract the largest exponent which is added
4607 C to the energy (this being the log of the distribution) at the end of energy
4608 C term evaluation for this virtual-bond angle.
4609         if (term1.gt.term2) then
4610           termm=term1
4611           term2=dexp(term2-termm)
4612           term1=1.0d0
4613         else
4614           termm=term2
4615           term1=dexp(term1-termm)
4616           term2=1.0d0
4617         endif
4618 C The ratio between the gamma-independent and gamma-dependent lobes of
4619 C the distribution is a Gaussian function of thet_pred_mean too.
4620         diffak=gthet(2,it)-thet_pred_mean
4621         ratak=diffak/gthet(3,it)**2
4622         ak=dexp(gthet(1,it)-0.5D0*diffak*ratak)
4623 C Let's differentiate it in thet_pred_mean NOW.
4624         aktc=ak*ratak
4625 C Now put together the distribution terms to make complete distribution.
4626         termexp=term1+ak*term2
4627         termpre=sigc+ak*sig0i
4628 C Contribution of the bending energy from this theta is just the -log of
4629 C the sum of the contributions from the two lobes and the pre-exponential
4630 C factor. Simple enough, isn't it?
4631         ethetai=(-dlog(termexp)-termm+dlog(termpre))
4632 C NOW the derivatives!!!
4633 C 6/6/97 Take into account the deformation.
4634         E_theta=(delthec*sigcsq*term1
4635      &       +ak*delthe0*sig0inv*term2)/termexp
4636         E_tc=((sigtc+aktc*sig0i)/termpre
4637      &      -((delthec*sigcsq+delthec*delthec*sigsqtc)*term1+
4638      &       aktc*term2)/termexp)
4639       return
4640       end
4641 c-----------------------------------------------------------------------------
4642       subroutine mixder(thetai,thet_pred_mean,theta0i,E_tc_t)
4643       implicit real*8 (a-h,o-z)
4644       include 'DIMENSIONS'
4645       include 'COMMON.LOCAL'
4646       include 'COMMON.IOUNITS'
4647       common /calcthet/ term1,term2,termm,diffak,ratak,
4648      & ak,aktc,termpre,termexp,sigc,sig0i,time11,time12,sigcsq,
4649      & delthe0,sig0inv,sigtc,sigsqtc,delthec,it
4650       delthec=thetai-thet_pred_mean
4651       delthe0=thetai-theta0i
4652 C "Thank you" to MAPLE (probably spared one day of hand-differentiation).
4653       t3 = thetai-thet_pred_mean
4654       t6 = t3**2
4655       t9 = term1
4656       t12 = t3*sigcsq
4657       t14 = t12+t6*sigsqtc
4658       t16 = 1.0d0
4659       t21 = thetai-theta0i
4660       t23 = t21**2
4661       t26 = term2
4662       t27 = t21*t26
4663       t32 = termexp
4664       t40 = t32**2
4665       E_tc_t = -((sigcsq+2.D0*t3*sigsqtc)*t9-t14*sigcsq*t3*t16*t9
4666      & -aktc*sig0inv*t27)/t32+(t14*t9+aktc*t26)/t40
4667      & *(-t12*t9-ak*sig0inv*t27)
4668       return
4669       end
4670 #else
4671 C--------------------------------------------------------------------------
4672       subroutine ebend(etheta)
4673 C
4674 C Evaluate the virtual-bond-angle energy given the virtual-bond dihedral
4675 C angles gamma and its derivatives in consecutive thetas and gammas.
4676 C ab initio-derived potentials from
4677 c Kozlowska et al., J. Phys.: Condens. Matter 19 (2007) 285203
4678 C
4679       implicit real*8 (a-h,o-z)
4680       include 'DIMENSIONS'
4681       include 'COMMON.LOCAL'
4682       include 'COMMON.GEO'
4683       include 'COMMON.INTERACT'
4684       include 'COMMON.DERIV'
4685       include 'COMMON.VAR'
4686       include 'COMMON.CHAIN'
4687       include 'COMMON.IOUNITS'
4688       include 'COMMON.NAMES'
4689       include 'COMMON.FFIELD'
4690       include 'COMMON.CONTROL'
4691       double precision coskt(mmaxtheterm),sinkt(mmaxtheterm),
4692      & cosph1(maxsingle),sinph1(maxsingle),cosph2(maxsingle),
4693      & sinph2(maxsingle),cosph1ph2(maxdouble,maxdouble),
4694      & sinph1ph2(maxdouble,maxdouble)
4695       logical lprn /.false./, lprn1 /.false./
4696       etheta=0.0D0
4697       do i=ithet_start,ithet_end
4698         if ((itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
4699      &(itype(i).eq.ntyp1)) cycle
4700 C        print *,i,theta(i)
4701         if (iabs(itype(i+1)).eq.20) iblock=2
4702         if (iabs(itype(i+1)).ne.20) iblock=1
4703         dethetai=0.0d0
4704         dephii=0.0d0
4705         dephii1=0.0d0
4706         theti2=0.5d0*theta(i)
4707         ityp2=ithetyp((itype(i-1)))
4708         do k=1,nntheterm
4709           coskt(k)=dcos(k*theti2)
4710           sinkt(k)=dsin(k*theti2)
4711         enddo
4712 C        print *,ethetai
4713
4714         if (i.gt.3 .and. itype(i-3).ne.ntyp1) then
4715 #ifdef OSF
4716           phii=phi(i)
4717           if (phii.ne.phii) phii=150.0
4718 #else
4719           phii=phi(i)
4720 #endif
4721           ityp1=ithetyp((itype(i-2)))
4722 C propagation of chirality for glycine type
4723           do k=1,nsingle
4724             cosph1(k)=dcos(k*phii)
4725             sinph1(k)=dsin(k*phii)
4726           enddo
4727         else
4728           phii=0.0d0
4729           do k=1,nsingle
4730           ityp1=ithetyp((itype(i-2)))
4731             cosph1(k)=0.0d0
4732             sinph1(k)=0.0d0
4733           enddo
4734         endif
4735         if (i.lt.nres .and. itype(i+1).ne.ntyp1) then
4736 #ifdef OSF
4737           phii1=phi(i+1)
4738           if (phii1.ne.phii1) phii1=150.0
4739           phii1=pinorm(phii1)
4740 #else
4741           phii1=phi(i+1)
4742 #endif
4743           ityp3=ithetyp((itype(i)))
4744           do k=1,nsingle
4745             cosph2(k)=dcos(k*phii1)
4746             sinph2(k)=dsin(k*phii1)
4747           enddo
4748         else
4749           phii1=0.0d0
4750           ityp3=ithetyp((itype(i)))
4751           do k=1,nsingle
4752             cosph2(k)=0.0d0
4753             sinph2(k)=0.0d0
4754           enddo
4755         endif
4756         ethetai=aa0thet(ityp1,ityp2,ityp3,iblock)
4757         do k=1,ndouble
4758           do l=1,k-1
4759             ccl=cosph1(l)*cosph2(k-l)
4760             ssl=sinph1(l)*sinph2(k-l)
4761             scl=sinph1(l)*cosph2(k-l)
4762             csl=cosph1(l)*sinph2(k-l)
4763             cosph1ph2(l,k)=ccl-ssl
4764             cosph1ph2(k,l)=ccl+ssl
4765             sinph1ph2(l,k)=scl+csl
4766             sinph1ph2(k,l)=scl-csl
4767           enddo
4768         enddo
4769         if (lprn) then
4770         write (iout,*) "i",i," ityp1",ityp1," ityp2",ityp2,
4771      &    " ityp3",ityp3," theti2",theti2," phii",phii," phii1",phii1
4772         write (iout,*) "coskt and sinkt"
4773         do k=1,nntheterm
4774           write (iout,*) k,coskt(k),sinkt(k)
4775         enddo
4776         endif
4777         do k=1,ntheterm
4778           ethetai=ethetai+aathet(k,ityp1,ityp2,ityp3,iblock)*sinkt(k)
4779           dethetai=dethetai+0.5d0*k*aathet(k,ityp1,ityp2,ityp3,iblock)
4780      &      *coskt(k)
4781           if (lprn)
4782      &    write (iout,*) "k",k,"
4783      &     aathet",aathet(k,ityp1,ityp2,ityp3,iblock),
4784      &     " ethetai",ethetai
4785         enddo
4786         if (lprn) then
4787         write (iout,*) "cosph and sinph"
4788         do k=1,nsingle
4789           write (iout,*) k,cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4790         enddo
4791         write (iout,*) "cosph1ph2 and sinph2ph2"
4792         do k=2,ndouble
4793           do l=1,k-1
4794             write (iout,*) l,k,cosph1ph2(l,k),cosph1ph2(k,l),
4795      &         sinph1ph2(l,k),sinph1ph2(k,l)
4796           enddo
4797         enddo
4798         write(iout,*) "ethetai",ethetai
4799         endif
4800 C       print *,ethetai
4801         do m=1,ntheterm2
4802           do k=1,nsingle
4803             aux=bbthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)
4804      &         +ccthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k)
4805      &         +ddthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)
4806      &         +eethet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k)
4807             ethetai=ethetai+sinkt(m)*aux
4808             dethetai=dethetai+0.5d0*m*aux*coskt(m)
4809             dephii=dephii+k*sinkt(m)*(
4810      &          ccthet(k,m,ityp1,ityp2,ityp3,iblock)*cosph1(k)-
4811      &          bbthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph1(k))
4812             dephii1=dephii1+k*sinkt(m)*(
4813      &          eethet(k,m,ityp1,ityp2,ityp3,iblock)*cosph2(k)-
4814      &          ddthet(k,m,ityp1,ityp2,ityp3,iblock)*sinph2(k))
4815             if (lprn)
4816      &      write (iout,*) "m",m," k",k," bbthet",
4817      &         bbthet(k,m,ityp1,ityp2,ityp3,iblock)," ccthet",
4818      &         ccthet(k,m,ityp1,ityp2,ityp3,iblock)," ddthet",
4819      &         ddthet(k,m,ityp1,ityp2,ityp3,iblock)," eethet",
4820      &         eethet(k,m,ityp1,ityp2,ityp3,iblock)," ethetai",ethetai
4821 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4822           enddo
4823         enddo
4824 C        print *,"cosph1", (cosph1(k), k=1,nsingle)
4825 C        print *,"cosph2", (cosph2(k), k=1,nsingle)
4826 C        print *,"sinph1", (sinph1(k), k=1,nsingle)
4827 C        print *,"sinph2", (sinph2(k), k=1,nsingle)
4828         if (lprn)
4829      &  write(iout,*) "ethetai",ethetai
4830 C        print *,"tu",cosph1(k),sinph1(k),cosph2(k),sinph2(k)
4831         do m=1,ntheterm3
4832           do k=2,ndouble
4833             do l=1,k-1
4834               aux=ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4835      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l)+
4836      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4837      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)
4838               ethetai=ethetai+sinkt(m)*aux
4839               dethetai=dethetai+0.5d0*m*coskt(m)*aux
4840               dephii=dephii+l*sinkt(m)*(
4841      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)-
4842      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4843      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)+
4844      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4845               dephii1=dephii1+(k-l)*sinkt(m)*(
4846      &           -ffthet(l,k,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(l,k)+
4847      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)*sinph1ph2(k,l)+
4848      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(l,k)-
4849      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock)*cosph1ph2(k,l))
4850               if (lprn) then
4851               write (iout,*) "m",m," k",k," l",l," ffthet",
4852      &            ffthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4853      &            ffthet(k,l,m,ityp1,ityp2,ityp3,iblock)," ggthet",
4854      &            ggthet(l,k,m,ityp1,ityp2,ityp3,iblock),
4855      &            ggthet(k,l,m,ityp1,ityp2,ityp3,iblock),
4856      &            " ethetai",ethetai
4857               write (iout,*) cosph1ph2(l,k)*sinkt(m),
4858      &            cosph1ph2(k,l)*sinkt(m),
4859      &            sinph1ph2(l,k)*sinkt(m),sinph1ph2(k,l)*sinkt(m)
4860               endif
4861             enddo
4862           enddo
4863         enddo
4864 10      continue
4865 C now we have the theta_constrains
4866       do i=ithetaconstr_start,ithetaconstr_end
4867         itheta=itheta_constr(i)
4868         thetiii=theta(itori)
4869         difi=pinorm(thetiii-theta_constr0(i))
4870         if (difi.gt.theta_drange(i)) then
4871           difi=difi-theta_drange(i)
4872           ethetcnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
4873           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4874      &    +for_thet_constr(i)*difi**3
4875         else if (difi.lt.-drange(i)) then
4876           difi=difi+drange(i)
4877           ethetcnstr=ethetcnstr+0.25d0*for_thet_constr(i)*difi**4
4878           gloc(itheta+nphi-2,icg)=gloc(itheta+nphi-2,icg)
4879      &    +for_thet_constr(i)*difi**3
4880         else
4881           difi=0.0
4882         endif
4883        if (energy_dec) then
4884         write (iout,'(a6,2i5,4f8.3,2e14.5)') "ethetc",
4885      &    i,itheta,rad2deg*thetiii,
4886      &    rad2deg*theta_constr0(i),  rad2deg*theta_drange(i),
4887      &    rad2deg*difi,0.25d0*for_thet_constr(i)*difi**4,
4888      &    gloc(itheta+nphi-2,icg)
4889         endif
4890       enddo
4891
4892 c        lprn1=.true.
4893 C        print *,ethetai
4894         if (lprn1)
4895      &    write (iout,'(i2,3f8.1,9h ethetai ,f10.5)')
4896      &   i,theta(i)*rad2deg,phii*rad2deg,
4897      &   phii1*rad2deg,ethetai
4898 c        lprn1=.false.
4899         etheta=etheta+ethetai
4900         if (i.gt.3) gloc(i-3,icg)=gloc(i-3,icg)+wang*dephii
4901         if (i.lt.nres) gloc(i-2,icg)=gloc(i-2,icg)+wang*dephii1
4902         gloc(nphi+i-2,icg)=gloc(nphi+i-2,icg)+wang*dethetai
4903       enddo
4904       return
4905       end
4906 #endif
4907 #ifdef CRYST_SC
4908 c-----------------------------------------------------------------------------
4909       subroutine esc(escloc)
4910 C Calculate the local energy of a side chain and its derivatives in the
4911 C corresponding virtual-bond valence angles THETA and the spherical angles
4912 C ALPHA and OMEGA.
4913       implicit real*8 (a-h,o-z)
4914       include 'DIMENSIONS'
4915       include 'COMMON.GEO'
4916       include 'COMMON.LOCAL'
4917       include 'COMMON.VAR'
4918       include 'COMMON.INTERACT'
4919       include 'COMMON.DERIV'
4920       include 'COMMON.CHAIN'
4921       include 'COMMON.IOUNITS'
4922       include 'COMMON.NAMES'
4923       include 'COMMON.FFIELD'
4924       include 'COMMON.CONTROL'
4925       double precision x(3),dersc(3),xemp(3),dersc0(3),dersc1(3),
4926      &     ddersc0(3),ddummy(3),xtemp(3),temp(3)
4927       common /sccalc/ time11,time12,time112,theti,it,nlobit
4928       delta=0.02d0*pi
4929       escloc=0.0D0
4930 c     write (iout,'(a)') 'ESC'
4931       do i=loc_start,loc_end
4932         it=itype(i)
4933         if (it.eq.ntyp1) cycle
4934         if (it.eq.10) goto 1
4935         nlobit=nlob(iabs(it))
4936 c       print *,'i=',i,' it=',it,' nlobit=',nlobit
4937 c       write (iout,*) 'i=',i,' ssa=',ssa,' ssad=',ssad
4938         theti=theta(i+1)-pipol
4939         x(1)=dtan(theti)
4940         x(2)=alph(i)
4941         x(3)=omeg(i)
4942
4943         if (x(2).gt.pi-delta) then
4944           xtemp(1)=x(1)
4945           xtemp(2)=pi-delta
4946           xtemp(3)=x(3)
4947           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4948           xtemp(2)=pi
4949           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4950           call spline1(x(2),pi-delta,delta,escloci0,escloci1,dersc0(2),
4951      &        escloci,dersc(2))
4952           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4953      &        ddersc0(1),dersc(1))
4954           call spline2(x(2),pi-delta,delta,dersc0(3),dersc1(3),
4955      &        ddersc0(3),dersc(3))
4956           xtemp(2)=pi-delta
4957           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4958           xtemp(2)=pi
4959           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4960           call spline1(x(2),pi-delta,delta,esclocbi0,esclocbi1,
4961      &            dersc0(2),esclocbi,dersc02)
4962           call spline2(x(2),pi-delta,delta,dersc0(1),dersc1(1),
4963      &            dersc12,dersc01)
4964           call splinthet(x(2),0.5d0*delta,ss,ssd)
4965           dersc0(1)=dersc01
4966           dersc0(2)=dersc02
4967           dersc0(3)=0.0d0
4968           do k=1,3
4969             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
4970           enddo
4971           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
4972 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
4973 c    &             esclocbi,ss,ssd
4974           escloci=ss*escloci+(1.0d0-ss)*esclocbi
4975 c         escloci=esclocbi
4976 c         write (iout,*) escloci
4977         else if (x(2).lt.delta) then
4978           xtemp(1)=x(1)
4979           xtemp(2)=delta
4980           xtemp(3)=x(3)
4981           call enesc(xtemp,escloci0,dersc0,ddersc0,.true.)
4982           xtemp(2)=0.0d0
4983           call enesc(xtemp,escloci1,dersc1,ddummy,.false.)
4984           call spline1(x(2),delta,-delta,escloci0,escloci1,dersc0(2),
4985      &        escloci,dersc(2))
4986           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4987      &        ddersc0(1),dersc(1))
4988           call spline2(x(2),delta,-delta,dersc0(3),dersc1(3),
4989      &        ddersc0(3),dersc(3))
4990           xtemp(2)=delta
4991           call enesc_bound(xtemp,esclocbi0,dersc0,dersc12,.true.)
4992           xtemp(2)=0.0d0
4993           call enesc_bound(xtemp,esclocbi1,dersc1,chuju,.false.)
4994           call spline1(x(2),delta,-delta,esclocbi0,esclocbi1,
4995      &            dersc0(2),esclocbi,dersc02)
4996           call spline2(x(2),delta,-delta,dersc0(1),dersc1(1),
4997      &            dersc12,dersc01)
4998           dersc0(1)=dersc01
4999           dersc0(2)=dersc02
5000           dersc0(3)=0.0d0
5001           call splinthet(x(2),0.5d0*delta,ss,ssd)
5002           do k=1,3
5003             dersc(k)=ss*dersc(k)+(1.0d0-ss)*dersc0(k)
5004           enddo
5005           dersc(2)=dersc(2)+ssd*(escloci-esclocbi)
5006 c         write (iout,*) 'i=',i,x(2)*rad2deg,escloci0,escloci,
5007 c    &             esclocbi,ss,ssd
5008           escloci=ss*escloci+(1.0d0-ss)*esclocbi
5009 c         write (iout,*) escloci
5010         else
5011           call enesc(x,escloci,dersc,ddummy,.false.)
5012         endif
5013
5014         escloc=escloc+escloci
5015         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5016      &     'escloc',i,escloci
5017 c       write (iout,*) 'i=',i,' escloci=',escloci,' dersc=',dersc
5018
5019         gloc(nphi+i-1,icg)=gloc(nphi+i-1,icg)+
5020      &   wscloc*dersc(1)
5021         gloc(ialph(i,1),icg)=wscloc*dersc(2)
5022         gloc(ialph(i,1)+nside,icg)=wscloc*dersc(3)
5023     1   continue
5024       enddo
5025       return
5026       end
5027 C---------------------------------------------------------------------------
5028       subroutine enesc(x,escloci,dersc,ddersc,mixed)
5029       implicit real*8 (a-h,o-z)
5030       include 'DIMENSIONS'
5031       include 'COMMON.GEO'
5032       include 'COMMON.LOCAL'
5033       include 'COMMON.IOUNITS'
5034       common /sccalc/ time11,time12,time112,theti,it,nlobit
5035       double precision x(3),z(3),Ax(3,maxlob,-1:1),dersc(3),ddersc(3)
5036       double precision contr(maxlob,-1:1)
5037       logical mixed
5038 c       write (iout,*) 'it=',it,' nlobit=',nlobit
5039         escloc_i=0.0D0
5040         do j=1,3
5041           dersc(j)=0.0D0
5042           if (mixed) ddersc(j)=0.0d0
5043         enddo
5044         x3=x(3)
5045
5046 C Because of periodicity of the dependence of the SC energy in omega we have
5047 C to add up the contributions from x(3)-2*pi, x(3), and x(3+2*pi).
5048 C To avoid underflows, first compute & store the exponents.
5049
5050         do iii=-1,1
5051
5052           x(3)=x3+iii*dwapi
5053
5054           do j=1,nlobit
5055             do k=1,3
5056               z(k)=x(k)-censc(k,j,it)
5057             enddo
5058             do k=1,3
5059               Axk=0.0D0
5060               do l=1,3
5061                 Axk=Axk+gaussc(l,k,j,it)*z(l)
5062               enddo
5063               Ax(k,j,iii)=Axk
5064             enddo
5065             expfac=0.0D0
5066             do k=1,3
5067               expfac=expfac+Ax(k,j,iii)*z(k)
5068             enddo
5069             contr(j,iii)=expfac
5070           enddo ! j
5071
5072         enddo ! iii
5073
5074         x(3)=x3
5075 C As in the case of ebend, we want to avoid underflows in exponentiation and
5076 C subsequent NaNs and INFs in energy calculation.
5077 C Find the largest exponent
5078         emin=contr(1,-1)
5079         do iii=-1,1
5080           do j=1,nlobit
5081             if (emin.gt.contr(j,iii)) emin=contr(j,iii)
5082           enddo
5083         enddo
5084         emin=0.5D0*emin
5085 cd      print *,'it=',it,' emin=',emin
5086
5087 C Compute the contribution to SC energy and derivatives
5088         do iii=-1,1
5089
5090           do j=1,nlobit
5091 #ifdef OSF
5092             adexp=bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin
5093             if(adexp.ne.adexp) adexp=1.0
5094             expfac=dexp(adexp)
5095 #else
5096             expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j,iii)+emin)
5097 #endif
5098 cd          print *,'j=',j,' expfac=',expfac
5099             escloc_i=escloc_i+expfac
5100             do k=1,3
5101               dersc(k)=dersc(k)+Ax(k,j,iii)*expfac
5102             enddo
5103             if (mixed) then
5104               do k=1,3,2
5105                 ddersc(k)=ddersc(k)+(-Ax(2,j,iii)*Ax(k,j,iii)
5106      &            +gaussc(k,2,j,it))*expfac
5107               enddo
5108             endif
5109           enddo
5110
5111         enddo ! iii
5112
5113         dersc(1)=dersc(1)/cos(theti)**2
5114         ddersc(1)=ddersc(1)/cos(theti)**2
5115         ddersc(3)=ddersc(3)
5116
5117         escloci=-(dlog(escloc_i)-emin)
5118         do j=1,3
5119           dersc(j)=dersc(j)/escloc_i
5120         enddo
5121         if (mixed) then
5122           do j=1,3,2
5123             ddersc(j)=(ddersc(j)/escloc_i+dersc(2)*dersc(j))
5124           enddo
5125         endif
5126       return
5127       end
5128 C------------------------------------------------------------------------------
5129       subroutine enesc_bound(x,escloci,dersc,dersc12,mixed)
5130       implicit real*8 (a-h,o-z)
5131       include 'DIMENSIONS'
5132       include 'COMMON.GEO'
5133       include 'COMMON.LOCAL'
5134       include 'COMMON.IOUNITS'
5135       common /sccalc/ time11,time12,time112,theti,it,nlobit
5136       double precision x(3),z(3),Ax(3,maxlob),dersc(3)
5137       double precision contr(maxlob)
5138       logical mixed
5139
5140       escloc_i=0.0D0
5141
5142       do j=1,3
5143         dersc(j)=0.0D0
5144       enddo
5145
5146       do j=1,nlobit
5147         do k=1,2
5148           z(k)=x(k)-censc(k,j,it)
5149         enddo
5150         z(3)=dwapi
5151         do k=1,3
5152           Axk=0.0D0
5153           do l=1,3
5154             Axk=Axk+gaussc(l,k,j,it)*z(l)
5155           enddo
5156           Ax(k,j)=Axk
5157         enddo
5158         expfac=0.0D0
5159         do k=1,3
5160           expfac=expfac+Ax(k,j)*z(k)
5161         enddo
5162         contr(j)=expfac
5163       enddo ! j
5164
5165 C As in the case of ebend, we want to avoid underflows in exponentiation and
5166 C subsequent NaNs and INFs in energy calculation.
5167 C Find the largest exponent
5168       emin=contr(1)
5169       do j=1,nlobit
5170         if (emin.gt.contr(j)) emin=contr(j)
5171       enddo
5172       emin=0.5D0*emin
5173
5174 C Compute the contribution to SC energy and derivatives
5175
5176       dersc12=0.0d0
5177       do j=1,nlobit
5178         expfac=dexp(bsc(j,iabs(it))-0.5D0*contr(j)+emin)
5179         escloc_i=escloc_i+expfac
5180         do k=1,2
5181           dersc(k)=dersc(k)+Ax(k,j)*expfac
5182         enddo
5183         if (mixed) dersc12=dersc12+(-Ax(2,j)*Ax(1,j)
5184      &            +gaussc(1,2,j,it))*expfac
5185         dersc(3)=0.0d0
5186       enddo
5187
5188       dersc(1)=dersc(1)/cos(theti)**2
5189       dersc12=dersc12/cos(theti)**2
5190       escloci=-(dlog(escloc_i)-emin)
5191       do j=1,2
5192         dersc(j)=dersc(j)/escloc_i
5193       enddo
5194       if (mixed) dersc12=(dersc12/escloc_i+dersc(2)*dersc(1))
5195       return
5196       end
5197 #else
5198 c----------------------------------------------------------------------------------
5199       subroutine esc(escloc)
5200 C Calculate the local energy of a side chain and its derivatives in the
5201 C corresponding virtual-bond valence angles THETA and the spherical angles
5202 C ALPHA and OMEGA derived from AM1 all-atom calculations.
5203 C added by Urszula Kozlowska. 07/11/2007
5204 C
5205       implicit real*8 (a-h,o-z)
5206       include 'DIMENSIONS'
5207       include 'COMMON.GEO'
5208       include 'COMMON.LOCAL'
5209       include 'COMMON.VAR'
5210       include 'COMMON.SCROT'
5211       include 'COMMON.INTERACT'
5212       include 'COMMON.DERIV'
5213       include 'COMMON.CHAIN'
5214       include 'COMMON.IOUNITS'
5215       include 'COMMON.NAMES'
5216       include 'COMMON.FFIELD'
5217       include 'COMMON.CONTROL'
5218       include 'COMMON.VECTORS'
5219       double precision x_prime(3),y_prime(3),z_prime(3)
5220      &    , sumene,dsc_i,dp2_i,x(65),
5221      &     xx,yy,zz,sumene1,sumene2,sumene3,sumene4,s1,s1_6,s2,s2_6,
5222      &    de_dxx,de_dyy,de_dzz,de_dt
5223       double precision s1_t,s1_6_t,s2_t,s2_6_t
5224       double precision
5225      & dXX_Ci1(3),dYY_Ci1(3),dZZ_Ci1(3),dXX_Ci(3),
5226      & dYY_Ci(3),dZZ_Ci(3),dXX_XYZ(3),dYY_XYZ(3),dZZ_XYZ(3),
5227      & dt_dCi(3),dt_dCi1(3)
5228       common /sccalc/ time11,time12,time112,theti,it,nlobit
5229       delta=0.02d0*pi
5230       escloc=0.0D0
5231       do i=loc_start,loc_end
5232         if (itype(i).eq.ntyp1) cycle
5233         costtab(i+1) =dcos(theta(i+1))
5234         sinttab(i+1) =dsqrt(1-costtab(i+1)*costtab(i+1))
5235         cost2tab(i+1)=dsqrt(0.5d0*(1.0d0+costtab(i+1)))
5236         sint2tab(i+1)=dsqrt(0.5d0*(1.0d0-costtab(i+1)))
5237         cosfac2=0.5d0/(1.0d0+costtab(i+1))
5238         cosfac=dsqrt(cosfac2)
5239         sinfac2=0.5d0/(1.0d0-costtab(i+1))
5240         sinfac=dsqrt(sinfac2)
5241         it=iabs(itype(i))
5242         if (it.eq.10) goto 1
5243 c
5244 C  Compute the axes of tghe local cartesian coordinates system; store in
5245 c   x_prime, y_prime and z_prime
5246 c
5247         do j=1,3
5248           x_prime(j) = 0.00
5249           y_prime(j) = 0.00
5250           z_prime(j) = 0.00
5251         enddo
5252 C        write(2,*) "dc_norm", dc_norm(1,i+nres),dc_norm(2,i+nres),
5253 C     &   dc_norm(3,i+nres)
5254         do j = 1,3
5255           x_prime(j) = (dc_norm(j,i) - dc_norm(j,i-1))*cosfac
5256           y_prime(j) = (dc_norm(j,i) + dc_norm(j,i-1))*sinfac
5257         enddo
5258         do j = 1,3
5259           z_prime(j) = -uz(j,i-1)*dsign(1.0d0,dfloat(itype(i)))
5260         enddo
5261 c       write (2,*) "i",i
5262 c       write (2,*) "x_prime",(x_prime(j),j=1,3)
5263 c       write (2,*) "y_prime",(y_prime(j),j=1,3)
5264 c       write (2,*) "z_prime",(z_prime(j),j=1,3)
5265 c       write (2,*) "xx",scalar(x_prime(1),x_prime(1)),
5266 c      & " xy",scalar(x_prime(1),y_prime(1)),
5267 c      & " xz",scalar(x_prime(1),z_prime(1)),
5268 c      & " yy",scalar(y_prime(1),y_prime(1)),
5269 c      & " yz",scalar(y_prime(1),z_prime(1)),
5270 c      & " zz",scalar(z_prime(1),z_prime(1))
5271 c
5272 C Transform the unit vector of the ith side-chain centroid, dC_norm(*,i),
5273 C to local coordinate system. Store in xx, yy, zz.
5274 c
5275         xx=0.0d0
5276         yy=0.0d0
5277         zz=0.0d0
5278         do j = 1,3
5279           xx = xx + x_prime(j)*dc_norm(j,i+nres)
5280           yy = yy + y_prime(j)*dc_norm(j,i+nres)
5281           zz = zz + z_prime(j)*dc_norm(j,i+nres)
5282         enddo
5283
5284         xxtab(i)=xx
5285         yytab(i)=yy
5286         zztab(i)=zz
5287 C
5288 C Compute the energy of the ith side cbain
5289 C
5290 c        write (2,*) "xx",xx," yy",yy," zz",zz
5291         it=iabs(itype(i))
5292         do j = 1,65
5293           x(j) = sc_parmin(j,it)
5294         enddo
5295 #ifdef CHECK_COORD
5296 Cc diagnostics - remove later
5297         xx1 = dcos(alph(2))
5298         yy1 = dsin(alph(2))*dcos(omeg(2))
5299         zz1 = -dsign(1.0,dfloat(itype(i)))*dsin(alph(2))*dsin(omeg(2))
5300         write(2,'(3f8.1,3f9.3,1x,3f9.3)')
5301      &    alph(2)*rad2deg,omeg(2)*rad2deg,theta(3)*rad2deg,xx,yy,zz,
5302      &    xx1,yy1,zz1
5303 C,"  --- ", xx_w,yy_w,zz_w
5304 c end diagnostics
5305 #endif
5306         sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5307      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5308      &   + x(10)*yy*zz
5309         sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5310      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5311      & + x(20)*yy*zz
5312         sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5313      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5314      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5315      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5316      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5317      &  +x(40)*xx*yy*zz
5318         sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5319      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5320      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5321      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5322      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5323      &  +x(60)*xx*yy*zz
5324         dsc_i   = 0.743d0+x(61)
5325         dp2_i   = 1.9d0+x(62)
5326         dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5327      &          *(xx*cost2tab(i+1)+yy*sint2tab(i+1)))
5328         dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5329      &          *(xx*cost2tab(i+1)-yy*sint2tab(i+1)))
5330         s1=(1+x(63))/(0.1d0 + dscp1)
5331         s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5332         s2=(1+x(65))/(0.1d0 + dscp2)
5333         s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5334         sumene = ( sumene3*sint2tab(i+1) + sumene1)*(s1+s1_6)
5335      & + (sumene4*cost2tab(i+1) +sumene2)*(s2+s2_6)
5336 c        write(2,'(i2," sumene",7f9.3)') i,sumene1,sumene2,sumene3,
5337 c     &   sumene4,
5338 c     &   dscp1,dscp2,sumene
5339 c        sumene = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5340         escloc = escloc + sumene
5341 c        write (2,*) "i",i," escloc",sumene,escloc,it,itype(i)
5342 c     & ,zz,xx,yy
5343 c#define DEBUG
5344 #ifdef DEBUG
5345 C
5346 C This section to check the numerical derivatives of the energy of ith side
5347 C chain in xx, yy, zz, and theta. Use the -DDEBUG compiler option or insert
5348 C #define DEBUG in the code to turn it on.
5349 C
5350         write (2,*) "sumene               =",sumene
5351         aincr=1.0d-7
5352         xxsave=xx
5353         xx=xx+aincr
5354         write (2,*) xx,yy,zz
5355         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5356         de_dxx_num=(sumenep-sumene)/aincr
5357         xx=xxsave
5358         write (2,*) "xx+ sumene from enesc=",sumenep
5359         yysave=yy
5360         yy=yy+aincr
5361         write (2,*) xx,yy,zz
5362         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5363         de_dyy_num=(sumenep-sumene)/aincr
5364         yy=yysave
5365         write (2,*) "yy+ sumene from enesc=",sumenep
5366         zzsave=zz
5367         zz=zz+aincr
5368         write (2,*) xx,yy,zz
5369         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5370         de_dzz_num=(sumenep-sumene)/aincr
5371         zz=zzsave
5372         write (2,*) "zz+ sumene from enesc=",sumenep
5373         costsave=cost2tab(i+1)
5374         sintsave=sint2tab(i+1)
5375         cost2tab(i+1)=dcos(0.5d0*(theta(i+1)+aincr))
5376         sint2tab(i+1)=dsin(0.5d0*(theta(i+1)+aincr))
5377         sumenep = enesc(x,xx,yy,zz,cost2tab(i+1),sint2tab(i+1))
5378         de_dt_num=(sumenep-sumene)/aincr
5379         write (2,*) " t+ sumene from enesc=",sumenep
5380         cost2tab(i+1)=costsave
5381         sint2tab(i+1)=sintsave
5382 C End of diagnostics section.
5383 #endif
5384 C
5385 C Compute the gradient of esc
5386 C
5387 c        zz=zz*dsign(1.0,dfloat(itype(i)))
5388         pom_s1=(1.0d0+x(63))/(0.1d0 + dscp1)**2
5389         pom_s16=6*(1.0d0+x(64))/(0.1d0 + dscp1**6)**2
5390         pom_s2=(1.0d0+x(65))/(0.1d0 + dscp2)**2
5391         pom_s26=6*(1.0d0+x(65))/(0.1d0 + dscp2**6)**2
5392         pom_dx=dsc_i*dp2_i*cost2tab(i+1)
5393         pom_dy=dsc_i*dp2_i*sint2tab(i+1)
5394         pom_dt1=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)-yy*cost2tab(i+1))
5395         pom_dt2=-0.5d0*dsc_i*dp2_i*(xx*sint2tab(i+1)+yy*cost2tab(i+1))
5396         pom1=(sumene3*sint2tab(i+1)+sumene1)
5397      &     *(pom_s1/dscp1+pom_s16*dscp1**4)
5398         pom2=(sumene4*cost2tab(i+1)+sumene2)
5399      &     *(pom_s2/dscp2+pom_s26*dscp2**4)
5400         sumene1x=x(2)+2*x(5)*xx+x(8)*zz+ x(9)*yy
5401         sumene3x=x(22)+2*x(25)*xx+x(28)*zz+x(29)*yy+3*x(31)*xx**2
5402      &  +2*x(34)*xx*yy +2*x(35)*xx*zz +x(36)*(yy**2) +x(38)*(zz**2)
5403      &  +x(40)*yy*zz
5404         sumene2x=x(12)+2*x(15)*xx+x(18)*zz+ x(19)*yy
5405         sumene4x=x(42)+2*x(45)*xx +x(48)*zz +x(49)*yy +3*x(51)*xx**2
5406      &  +2*x(54)*xx*yy+2*x(55)*xx*zz+x(56)*(yy**2)+x(58)*(zz**2)
5407      &  +x(60)*yy*zz
5408         de_dxx =(sumene1x+sumene3x*sint2tab(i+1))*(s1+s1_6)
5409      &        +(sumene2x+sumene4x*cost2tab(i+1))*(s2+s2_6)
5410      &        +(pom1+pom2)*pom_dx
5411 #ifdef DEBUG
5412         write(2,*), "de_dxx = ", de_dxx,de_dxx_num,itype(i)
5413 #endif
5414 C
5415         sumene1y=x(3) + 2*x(6)*yy + x(9)*xx + x(10)*zz
5416         sumene3y=x(23) +2*x(26)*yy +x(29)*xx +x(30)*zz +3*x(32)*yy**2
5417      &  +x(34)*(xx**2) +2*x(36)*yy*xx +2*x(37)*yy*zz +x(39)*(zz**2)
5418      &  +x(40)*xx*zz
5419         sumene2y=x(13) + 2*x(16)*yy + x(19)*xx + x(20)*zz
5420         sumene4y=x(43)+2*x(46)*yy+x(49)*xx +x(50)*zz
5421      &  +3*x(52)*yy**2+x(54)*xx**2+2*x(56)*yy*xx +2*x(57)*yy*zz
5422      &  +x(59)*zz**2 +x(60)*xx*zz
5423         de_dyy =(sumene1y+sumene3y*sint2tab(i+1))*(s1+s1_6)
5424      &        +(sumene2y+sumene4y*cost2tab(i+1))*(s2+s2_6)
5425      &        +(pom1-pom2)*pom_dy
5426 #ifdef DEBUG
5427         write(2,*), "de_dyy = ", de_dyy,de_dyy_num,itype(i)
5428 #endif
5429 C
5430         de_dzz =(x(24) +2*x(27)*zz +x(28)*xx +x(30)*yy
5431      &  +3*x(33)*zz**2 +x(35)*xx**2 +x(37)*yy**2 +2*x(38)*zz*xx
5432      &  +2*x(39)*zz*yy +x(40)*xx*yy)*sint2tab(i+1)*(s1+s1_6)
5433      &  +(x(4) + 2*x(7)*zz+  x(8)*xx + x(10)*yy)*(s1+s1_6)
5434      &  +(x(44)+2*x(47)*zz +x(48)*xx   +x(50)*yy  +3*x(53)*zz**2
5435      &  +x(55)*xx**2 +x(57)*(yy**2)+2*x(58)*zz*xx +2*x(59)*zz*yy
5436      &  +x(60)*xx*yy)*cost2tab(i+1)*(s2+s2_6)
5437      &  + ( x(14) + 2*x(17)*zz+  x(18)*xx + x(20)*yy)*(s2+s2_6)
5438 #ifdef DEBUG
5439         write(2,*), "de_dzz = ", de_dzz,de_dzz_num,itype(i)
5440 #endif
5441 C
5442         de_dt =  0.5d0*sumene3*cost2tab(i+1)*(s1+s1_6)
5443      &  -0.5d0*sumene4*sint2tab(i+1)*(s2+s2_6)
5444      &  +pom1*pom_dt1+pom2*pom_dt2
5445 #ifdef DEBUG
5446         write(2,*), "de_dt = ", de_dt,de_dt_num,itype(i)
5447 #endif
5448 c#undef DEBUG
5449 c
5450 C
5451        cossc=scalar(dc_norm(1,i),dc_norm(1,i+nres))
5452        cossc1=scalar(dc_norm(1,i-1),dc_norm(1,i+nres))
5453        cosfac2xx=cosfac2*xx
5454        sinfac2yy=sinfac2*yy
5455        do k = 1,3
5456          dt_dCi(k) = -(dc_norm(k,i-1)+costtab(i+1)*dc_norm(k,i))*
5457      &      vbld_inv(i+1)
5458          dt_dCi1(k)= -(dc_norm(k,i)+costtab(i+1)*dc_norm(k,i-1))*
5459      &      vbld_inv(i)
5460          pom=(dC_norm(k,i+nres)-cossc*dC_norm(k,i))*vbld_inv(i+1)
5461          pom1=(dC_norm(k,i+nres)-cossc1*dC_norm(k,i-1))*vbld_inv(i)
5462 c         write (iout,*) "i",i," k",k," pom",pom," pom1",pom1,
5463 c     &    " dt_dCi",dt_dCi(k)," dt_dCi1",dt_dCi1(k)
5464 c         write (iout,*) "dC_norm",(dC_norm(j,i),j=1,3),
5465 c     &   (dC_norm(j,i-1),j=1,3)," vbld_inv",vbld_inv(i+1),vbld_inv(i)
5466          dXX_Ci(k)=pom*cosfac-dt_dCi(k)*cosfac2xx
5467          dXX_Ci1(k)=-pom1*cosfac-dt_dCi1(k)*cosfac2xx
5468          dYY_Ci(k)=pom*sinfac+dt_dCi(k)*sinfac2yy
5469          dYY_Ci1(k)=pom1*sinfac+dt_dCi1(k)*sinfac2yy
5470          dZZ_Ci1(k)=0.0d0
5471          dZZ_Ci(k)=0.0d0
5472          do j=1,3
5473            dZZ_Ci(k)=dZZ_Ci(k)-uzgrad(j,k,2,i-1)
5474      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5475            dZZ_Ci1(k)=dZZ_Ci1(k)-uzgrad(j,k,1,i-1)
5476      &     *dsign(1.0d0,dfloat(itype(i)))*dC_norm(j,i+nres)
5477          enddo
5478
5479          dXX_XYZ(k)=vbld_inv(i+nres)*(x_prime(k)-xx*dC_norm(k,i+nres))
5480          dYY_XYZ(k)=vbld_inv(i+nres)*(y_prime(k)-yy*dC_norm(k,i+nres))
5481          dZZ_XYZ(k)=vbld_inv(i+nres)*
5482      &   (z_prime(k)-zz*dC_norm(k,i+nres))
5483 c
5484          dt_dCi(k) = -dt_dCi(k)/sinttab(i+1)
5485          dt_dCi1(k)= -dt_dCi1(k)/sinttab(i+1)
5486        enddo
5487
5488        do k=1,3
5489          dXX_Ctab(k,i)=dXX_Ci(k)
5490          dXX_C1tab(k,i)=dXX_Ci1(k)
5491          dYY_Ctab(k,i)=dYY_Ci(k)
5492          dYY_C1tab(k,i)=dYY_Ci1(k)
5493          dZZ_Ctab(k,i)=dZZ_Ci(k)
5494          dZZ_C1tab(k,i)=dZZ_Ci1(k)
5495          dXX_XYZtab(k,i)=dXX_XYZ(k)
5496          dYY_XYZtab(k,i)=dYY_XYZ(k)
5497          dZZ_XYZtab(k,i)=dZZ_XYZ(k)
5498        enddo
5499
5500        do k = 1,3
5501 c         write (iout,*) "k",k," dxx_ci1",dxx_ci1(k)," dyy_ci1",
5502 c     &    dyy_ci1(k)," dzz_ci1",dzz_ci1(k)
5503 c         write (iout,*) "k",k," dxx_ci",dxx_ci(k)," dyy_ci",
5504 c     &    dyy_ci(k)," dzz_ci",dzz_ci(k)
5505 c         write (iout,*) "k",k," dt_dci",dt_dci(k)," dt_dci",
5506 c     &    dt_dci(k)
5507 c         write (iout,*) "k",k," dxx_XYZ",dxx_XYZ(k)," dyy_XYZ",
5508 c     &    dyy_XYZ(k)," dzz_XYZ",dzz_XYZ(k)
5509          gscloc(k,i-1)=gscloc(k,i-1)+de_dxx*dxx_ci1(k)
5510      &    +de_dyy*dyy_ci1(k)+de_dzz*dzz_ci1(k)+de_dt*dt_dCi1(k)
5511          gscloc(k,i)=gscloc(k,i)+de_dxx*dxx_Ci(k)
5512      &    +de_dyy*dyy_Ci(k)+de_dzz*dzz_Ci(k)+de_dt*dt_dCi(k)
5513          gsclocx(k,i)=                 de_dxx*dxx_XYZ(k)
5514      &    +de_dyy*dyy_XYZ(k)+de_dzz*dzz_XYZ(k)
5515        enddo
5516 c       write(iout,*) "ENERGY GRAD = ", (gscloc(k,i-1),k=1,3),
5517 c     &  (gscloc(k,i),k=1,3),(gsclocx(k,i),k=1,3)
5518
5519 C to check gradient call subroutine check_grad
5520
5521     1 continue
5522       enddo
5523       return
5524       end
5525 c------------------------------------------------------------------------------
5526       double precision function enesc(x,xx,yy,zz,cost2,sint2)
5527       implicit none
5528       double precision x(65),xx,yy,zz,cost2,sint2,sumene1,sumene2,
5529      & sumene3,sumene4,sumene,dsc_i,dp2_i,dscp1,dscp2,s1,s1_6,s2,s2_6
5530       sumene1= x(1)+  x(2)*xx+  x(3)*yy+  x(4)*zz+  x(5)*xx**2
5531      &   + x(6)*yy**2+  x(7)*zz**2+  x(8)*xx*zz+  x(9)*xx*yy
5532      &   + x(10)*yy*zz
5533       sumene2=  x(11) + x(12)*xx + x(13)*yy + x(14)*zz + x(15)*xx**2
5534      & + x(16)*yy**2 + x(17)*zz**2 + x(18)*xx*zz + x(19)*xx*yy
5535      & + x(20)*yy*zz
5536       sumene3=  x(21) +x(22)*xx +x(23)*yy +x(24)*zz +x(25)*xx**2
5537      &  +x(26)*yy**2 +x(27)*zz**2 +x(28)*xx*zz +x(29)*xx*yy
5538      &  +x(30)*yy*zz +x(31)*xx**3 +x(32)*yy**3 +x(33)*zz**3
5539      &  +x(34)*(xx**2)*yy +x(35)*(xx**2)*zz +x(36)*(yy**2)*xx
5540      &  +x(37)*(yy**2)*zz +x(38)*(zz**2)*xx +x(39)*(zz**2)*yy
5541      &  +x(40)*xx*yy*zz
5542       sumene4= x(41) +x(42)*xx +x(43)*yy +x(44)*zz +x(45)*xx**2
5543      &  +x(46)*yy**2 +x(47)*zz**2 +x(48)*xx*zz +x(49)*xx*yy
5544      &  +x(50)*yy*zz +x(51)*xx**3 +x(52)*yy**3 +x(53)*zz**3
5545      &  +x(54)*(xx**2)*yy +x(55)*(xx**2)*zz +x(56)*(yy**2)*xx
5546      &  +x(57)*(yy**2)*zz +x(58)*(zz**2)*xx +x(59)*(zz**2)*yy
5547      &  +x(60)*xx*yy*zz
5548       dsc_i   = 0.743d0+x(61)
5549       dp2_i   = 1.9d0+x(62)
5550       dscp1=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5551      &          *(xx*cost2+yy*sint2))
5552       dscp2=dsqrt(dsc_i**2+dp2_i**2-2*dsc_i*dp2_i
5553      &          *(xx*cost2-yy*sint2))
5554       s1=(1+x(63))/(0.1d0 + dscp1)
5555       s1_6=(1+x(64))/(0.1d0 + dscp1**6)
5556       s2=(1+x(65))/(0.1d0 + dscp2)
5557       s2_6=(1+x(65))/(0.1d0 + dscp2**6)
5558       sumene = ( sumene3*sint2 + sumene1)*(s1+s1_6)
5559      & + (sumene4*cost2 +sumene2)*(s2+s2_6)
5560       enesc=sumene
5561       return
5562       end
5563 #endif
5564 c------------------------------------------------------------------------------
5565       subroutine gcont(rij,r0ij,eps0ij,delta,fcont,fprimcont)
5566 C
5567 C This procedure calculates two-body contact function g(rij) and its derivative:
5568 C
5569 C           eps0ij                                     !       x < -1
5570 C g(rij) =  esp0ij*(-0.9375*x+0.625*x**3-0.1875*x**5)  ! -1 =< x =< 1
5571 C            0                                         !       x > 1
5572 C
5573 C where x=(rij-r0ij)/delta
5574 C
5575 C rij - interbody distance, r0ij - contact distance, eps0ij - contact energy
5576 C
5577       implicit none
5578       double precision rij,r0ij,eps0ij,fcont,fprimcont
5579       double precision x,x2,x4,delta
5580 c     delta=0.02D0*r0ij
5581 c      delta=0.2D0*r0ij
5582       x=(rij-r0ij)/delta
5583       if (x.lt.-1.0D0) then
5584         fcont=eps0ij
5585         fprimcont=0.0D0
5586       else if (x.le.1.0D0) then
5587         x2=x*x
5588         x4=x2*x2
5589         fcont=eps0ij*(x*(-0.9375D0+0.6250D0*x2-0.1875D0*x4)+0.5D0)
5590         fprimcont=eps0ij * (-0.9375D0+1.8750D0*x2-0.9375D0*x4)/delta
5591       else
5592         fcont=0.0D0
5593         fprimcont=0.0D0
5594       endif
5595       return
5596       end
5597 c------------------------------------------------------------------------------
5598       subroutine splinthet(theti,delta,ss,ssder)
5599       implicit real*8 (a-h,o-z)
5600       include 'DIMENSIONS'
5601       include 'COMMON.VAR'
5602       include 'COMMON.GEO'
5603       thetup=pi-delta
5604       thetlow=delta
5605       if (theti.gt.pipol) then
5606         call gcont(theti,thetup,1.0d0,delta,ss,ssder)
5607       else
5608         call gcont(-theti,-thetlow,1.0d0,delta,ss,ssder)
5609         ssder=-ssder
5610       endif
5611       return
5612       end
5613 c------------------------------------------------------------------------------
5614       subroutine spline1(x,x0,delta,f0,f1,fprim0,f,fprim)
5615       implicit none
5616       double precision x,x0,delta,f0,f1,fprim0,f,fprim
5617       double precision ksi,ksi2,ksi3,a1,a2,a3
5618       a1=fprim0*delta/(f1-f0)
5619       a2=3.0d0-2.0d0*a1
5620       a3=a1-2.0d0
5621       ksi=(x-x0)/delta
5622       ksi2=ksi*ksi
5623       ksi3=ksi2*ksi
5624       f=f0+(f1-f0)*ksi*(a1+ksi*(a2+a3*ksi))
5625       fprim=(f1-f0)/delta*(a1+ksi*(2*a2+3*ksi*a3))
5626       return
5627       end
5628 c------------------------------------------------------------------------------
5629       subroutine spline2(x,x0,delta,f0x,f1x,fprim0x,fx)
5630       implicit none
5631       double precision x,x0,delta,f0x,f1x,fprim0x,fx
5632       double precision ksi,ksi2,ksi3,a1,a2,a3
5633       ksi=(x-x0)/delta
5634       ksi2=ksi*ksi
5635       ksi3=ksi2*ksi
5636       a1=fprim0x*delta
5637       a2=3*(f1x-f0x)-2*fprim0x*delta
5638       a3=fprim0x*delta-2*(f1x-f0x)
5639       fx=f0x+a1*ksi+a2*ksi2+a3*ksi3
5640       return
5641       end
5642 C-----------------------------------------------------------------------------
5643 #ifdef CRYST_TOR
5644 C-----------------------------------------------------------------------------
5645       subroutine etor(etors,edihcnstr)
5646       implicit real*8 (a-h,o-z)
5647       include 'DIMENSIONS'
5648       include 'COMMON.VAR'
5649       include 'COMMON.GEO'
5650       include 'COMMON.LOCAL'
5651       include 'COMMON.TORSION'
5652       include 'COMMON.INTERACT'
5653       include 'COMMON.DERIV'
5654       include 'COMMON.CHAIN'
5655       include 'COMMON.NAMES'
5656       include 'COMMON.IOUNITS'
5657       include 'COMMON.FFIELD'
5658       include 'COMMON.TORCNSTR'
5659       include 'COMMON.CONTROL'
5660       logical lprn
5661 C Set lprn=.true. for debugging
5662       lprn=.false.
5663 c      lprn=.true.
5664       etors=0.0D0
5665       do i=iphi_start,iphi_end
5666       etors_ii=0.0D0
5667         if (itype(i-2).eq.ntyp1.or. itype(i-1).eq.ntyp1
5668      &      .or. itype(i).eq.ntyp1) cycle
5669         itori=itortyp(itype(i-2))
5670         itori1=itortyp(itype(i-1))
5671         phii=phi(i)
5672         gloci=0.0D0
5673 C Proline-Proline pair is a special case...
5674         if (itori.eq.3 .and. itori1.eq.3) then
5675           if (phii.gt.-dwapi3) then
5676             cosphi=dcos(3*phii)
5677             fac=1.0D0/(1.0D0-cosphi)
5678             etorsi=v1(1,3,3)*fac
5679             etorsi=etorsi+etorsi
5680             etors=etors+etorsi-v1(1,3,3)
5681             if (energy_dec) etors_ii=etors_ii+etorsi-v1(1,3,3)
5682             gloci=gloci-3*fac*etorsi*dsin(3*phii)
5683           endif
5684           do j=1,3
5685             v1ij=v1(j+1,itori,itori1)
5686             v2ij=v2(j+1,itori,itori1)
5687             cosphi=dcos(j*phii)
5688             sinphi=dsin(j*phii)
5689             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5690             if (energy_dec) etors_ii=etors_ii+
5691      &                              v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5692             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5693           enddo
5694         else
5695           do j=1,nterm_old
5696             v1ij=v1(j,itori,itori1)
5697             v2ij=v2(j,itori,itori1)
5698             cosphi=dcos(j*phii)
5699             sinphi=dsin(j*phii)
5700             etors=etors+v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5701             if (energy_dec) etors_ii=etors_ii+
5702      &                  v1ij*cosphi+v2ij*sinphi+dabs(v1ij)+dabs(v2ij)
5703             gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5704           enddo
5705         endif
5706         if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5707              'etor',i,etors_ii
5708         if (lprn)
5709      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5710      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5711      &  (v1(j,itori,itori1),j=1,6),(v2(j,itori,itori1),j=1,6)
5712         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5713 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5714       enddo
5715 ! 6/20/98 - dihedral angle constraints
5716       edihcnstr=0.0d0
5717       do i=1,ndih_constr
5718         itori=idih_constr(i)
5719         phii=phi(itori)
5720         difi=phii-phi0(i)
5721         if (difi.gt.drange(i)) then
5722           difi=difi-drange(i)
5723           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5724           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5725         else if (difi.lt.-drange(i)) then
5726           difi=difi+drange(i)
5727           edihcnstr=edihcnstr+0.25d0*ftors(i)**difi**4
5728           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5729         endif
5730 !        write (iout,'(2i5,2f8.3,2e14.5)') i,itori,rad2deg*phii,
5731 !     &    rad2deg*difi,0.25d0*ftors*difi**4,gloc(itori-3,icg)
5732       enddo
5733 !      write (iout,*) 'edihcnstr',edihcnstr
5734       return
5735       end
5736 c------------------------------------------------------------------------------
5737       subroutine etor_d(etors_d)
5738       etors_d=0.0d0
5739       return
5740       end
5741 c----------------------------------------------------------------------------
5742 #else
5743       subroutine etor(etors,edihcnstr)
5744       implicit real*8 (a-h,o-z)
5745       include 'DIMENSIONS'
5746       include 'COMMON.VAR'
5747       include 'COMMON.GEO'
5748       include 'COMMON.LOCAL'
5749       include 'COMMON.TORSION'
5750       include 'COMMON.INTERACT'
5751       include 'COMMON.DERIV'
5752       include 'COMMON.CHAIN'
5753       include 'COMMON.NAMES'
5754       include 'COMMON.IOUNITS'
5755       include 'COMMON.FFIELD'
5756       include 'COMMON.TORCNSTR'
5757       include 'COMMON.CONTROL'
5758       logical lprn
5759 C Set lprn=.true. for debugging
5760       lprn=.false.
5761 c     lprn=.true.
5762       etors=0.0D0
5763       do i=iphi_start,iphi_end
5764         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5765      &       .or. itype(i).eq.ntyp1) cycle
5766         etors_ii=0.0D0
5767          if (iabs(itype(i)).eq.20) then
5768          iblock=2
5769          else
5770          iblock=1
5771          endif
5772         itori=itortyp(itype(i-2))
5773         itori1=itortyp(itype(i-1))
5774         phii=phi(i)
5775         gloci=0.0D0
5776 C Regular cosine and sine terms
5777         do j=1,nterm(itori,itori1,iblock)
5778           v1ij=v1(j,itori,itori1,iblock)
5779           v2ij=v2(j,itori,itori1,iblock)
5780           cosphi=dcos(j*phii)
5781           sinphi=dsin(j*phii)
5782           etors=etors+v1ij*cosphi+v2ij*sinphi
5783           if (energy_dec) etors_ii=etors_ii+
5784      &                v1ij*cosphi+v2ij*sinphi
5785           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5786         enddo
5787 C Lorentz terms
5788 C                         v1
5789 C  E = SUM ----------------------------------- - v1
5790 C          [v2 cos(phi/2)+v3 sin(phi/2)]^2 + 1
5791 C
5792         cosphi=dcos(0.5d0*phii)
5793         sinphi=dsin(0.5d0*phii)
5794         do j=1,nlor(itori,itori1,iblock)
5795           vl1ij=vlor1(j,itori,itori1)
5796           vl2ij=vlor2(j,itori,itori1)
5797           vl3ij=vlor3(j,itori,itori1)
5798           pom=vl2ij*cosphi+vl3ij*sinphi
5799           pom1=1.0d0/(pom*pom+1.0d0)
5800           etors=etors+vl1ij*pom1
5801           if (energy_dec) etors_ii=etors_ii+
5802      &                vl1ij*pom1
5803           pom=-pom*pom1*pom1
5804           gloci=gloci+vl1ij*(vl3ij*cosphi-vl2ij*sinphi)*pom
5805         enddo
5806 C Subtract the constant term
5807         etors=etors-v0(itori,itori1,iblock)
5808           if (energy_dec) write (iout,'(a6,i5,0pf7.3)')
5809      &         'etor',i,etors_ii-v0(itori,itori1,iblock)
5810         if (lprn)
5811      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5812      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,itori,itori1,
5813      &  (v1(j,itori,itori1,iblock),j=1,6),
5814      &  (v2(j,itori,itori1,iblock),j=1,6)
5815         gloc(i-3,icg)=gloc(i-3,icg)+wtor*gloci
5816 c       write (iout,*) 'i=',i,' gloc=',gloc(i-3,icg)
5817       enddo
5818 ! 6/20/98 - dihedral angle constraints
5819       edihcnstr=0.0d0
5820 c      do i=1,ndih_constr
5821       do i=idihconstr_start,idihconstr_end
5822         itori=idih_constr(i)
5823         phii=phi(itori)
5824         difi=pinorm(phii-phi0(i))
5825         if (difi.gt.drange(i)) then
5826           difi=difi-drange(i)
5827           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5828           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5829         else if (difi.lt.-drange(i)) then
5830           difi=difi+drange(i)
5831           edihcnstr=edihcnstr+0.25d0*ftors(i)*difi**4
5832           gloc(itori-3,icg)=gloc(itori-3,icg)+ftors(i)*difi**3
5833         else
5834           difi=0.0
5835         endif
5836        if (energy_dec) then
5837         write (iout,'(a6,2i5,4f8.3,2e14.5)') "edihc",
5838      &    i,itori,rad2deg*phii,
5839      &    rad2deg*phi0(i),  rad2deg*drange(i),
5840      &    rad2deg*difi,0.25d0*ftors(i)*difi**4,gloc(itori-3,icg)
5841         endif
5842       enddo
5843 cd       write (iout,*) 'edihcnstr',edihcnstr
5844       return
5845       end
5846 c----------------------------------------------------------------------------
5847       subroutine etor_d(etors_d)
5848 C 6/23/01 Compute double torsional energy
5849       implicit real*8 (a-h,o-z)
5850       include 'DIMENSIONS'
5851       include 'COMMON.VAR'
5852       include 'COMMON.GEO'
5853       include 'COMMON.LOCAL'
5854       include 'COMMON.TORSION'
5855       include 'COMMON.INTERACT'
5856       include 'COMMON.DERIV'
5857       include 'COMMON.CHAIN'
5858       include 'COMMON.NAMES'
5859       include 'COMMON.IOUNITS'
5860       include 'COMMON.FFIELD'
5861       include 'COMMON.TORCNSTR'
5862       logical lprn
5863 C Set lprn=.true. for debugging
5864       lprn=.false.
5865 c     lprn=.true.
5866       etors_d=0.0D0
5867 c      write(iout,*) "a tu??"
5868       do i=iphid_start,iphid_end
5869         if (itype(i-2).eq.ntyp1 .or. itype(i-1).eq.ntyp1
5870      &      .or. itype(i).eq.ntyp1 .or. itype(i+1).eq.ntyp1) cycle
5871         itori=itortyp(itype(i-2))
5872         itori1=itortyp(itype(i-1))
5873         itori2=itortyp(itype(i))
5874         phii=phi(i)
5875         phii1=phi(i+1)
5876         gloci1=0.0D0
5877         gloci2=0.0D0
5878         iblock=1
5879         if (iabs(itype(i+1)).eq.20) iblock=2
5880
5881 C Regular cosine and sine terms
5882         do j=1,ntermd_1(itori,itori1,itori2,iblock)
5883           v1cij=v1c(1,j,itori,itori1,itori2,iblock)
5884           v1sij=v1s(1,j,itori,itori1,itori2,iblock)
5885           v2cij=v1c(2,j,itori,itori1,itori2,iblock)
5886           v2sij=v1s(2,j,itori,itori1,itori2,iblock)
5887           cosphi1=dcos(j*phii)
5888           sinphi1=dsin(j*phii)
5889           cosphi2=dcos(j*phii1)
5890           sinphi2=dsin(j*phii1)
5891           etors_d=etors_d+v1cij*cosphi1+v1sij*sinphi1+
5892      &     v2cij*cosphi2+v2sij*sinphi2
5893           gloci1=gloci1+j*(v1sij*cosphi1-v1cij*sinphi1)
5894           gloci2=gloci2+j*(v2sij*cosphi2-v2cij*sinphi2)
5895         enddo
5896         do k=2,ntermd_2(itori,itori1,itori2,iblock)
5897           do l=1,k-1
5898             v1cdij = v2c(k,l,itori,itori1,itori2,iblock)
5899             v2cdij = v2c(l,k,itori,itori1,itori2,iblock)
5900             v1sdij = v2s(k,l,itori,itori1,itori2,iblock)
5901             v2sdij = v2s(l,k,itori,itori1,itori2,iblock)
5902             cosphi1p2=dcos(l*phii+(k-l)*phii1)
5903             cosphi1m2=dcos(l*phii-(k-l)*phii1)
5904             sinphi1p2=dsin(l*phii+(k-l)*phii1)
5905             sinphi1m2=dsin(l*phii-(k-l)*phii1)
5906             etors_d=etors_d+v1cdij*cosphi1p2+v2cdij*cosphi1m2+
5907      &        v1sdij*sinphi1p2+v2sdij*sinphi1m2
5908             gloci1=gloci1+l*(v1sdij*cosphi1p2+v2sdij*cosphi1m2
5909      &        -v1cdij*sinphi1p2-v2cdij*sinphi1m2)
5910             gloci2=gloci2+(k-l)*(v1sdij*cosphi1p2-v2sdij*cosphi1m2
5911      &        -v1cdij*sinphi1p2+v2cdij*sinphi1m2)
5912           enddo
5913         enddo
5914         gloc(i-3,icg)=gloc(i-3,icg)+wtor_d*gloci1
5915         gloc(i-2,icg)=gloc(i-2,icg)+wtor_d*gloci2
5916       enddo
5917       return
5918       end
5919 #endif
5920 c------------------------------------------------------------------------------
5921       subroutine eback_sc_corr(esccor)
5922 c 7/21/2007 Correlations between the backbone-local and side-chain-local
5923 c        conformational states; temporarily implemented as differences
5924 c        between UNRES torsional potentials (dependent on three types of
5925 c        residues) and the torsional potentials dependent on all 20 types
5926 c        of residues computed from AM1  energy surfaces of terminally-blocked
5927 c        amino-acid residues.
5928       implicit real*8 (a-h,o-z)
5929       include 'DIMENSIONS'
5930       include 'COMMON.VAR'
5931       include 'COMMON.GEO'
5932       include 'COMMON.LOCAL'
5933       include 'COMMON.TORSION'
5934       include 'COMMON.SCCOR'
5935       include 'COMMON.INTERACT'
5936       include 'COMMON.DERIV'
5937       include 'COMMON.CHAIN'
5938       include 'COMMON.NAMES'
5939       include 'COMMON.IOUNITS'
5940       include 'COMMON.FFIELD'
5941       include 'COMMON.CONTROL'
5942       logical lprn
5943 C Set lprn=.true. for debugging
5944       lprn=.false.
5945 c      lprn=.true.
5946 c      write (iout,*) "EBACK_SC_COR",itau_start,itau_end
5947       esccor=0.0D0
5948       do i=itau_start,itau_end
5949         if ((itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)) cycle
5950         esccor_ii=0.0D0
5951         isccori=isccortyp(itype(i-2))
5952         isccori1=isccortyp(itype(i-1))
5953 c      write (iout,*) "EBACK_SC_COR",i,nterm_sccor(isccori,isccori1)
5954         phii=phi(i)
5955         do intertyp=1,3 !intertyp
5956 cc Added 09 May 2012 (Adasko)
5957 cc  Intertyp means interaction type of backbone mainchain correlation:
5958 c   1 = SC...Ca...Ca...Ca
5959 c   2 = Ca...Ca...Ca...SC
5960 c   3 = SC...Ca...Ca...SCi
5961         gloci=0.0D0
5962         if (((intertyp.eq.3).and.((itype(i-2).eq.10).or.
5963      &      (itype(i-1).eq.10).or.(itype(i-2).eq.ntyp1).or.
5964      &      (itype(i-1).eq.ntyp1)))
5965      &    .or. ((intertyp.eq.1).and.((itype(i-2).eq.10)
5966      &     .or.(itype(i-2).eq.ntyp1).or.(itype(i-1).eq.ntyp1)
5967      &     .or.(itype(i).eq.ntyp1)))
5968      &    .or.((intertyp.eq.2).and.((itype(i-1).eq.10).or.
5969      &      (itype(i-1).eq.ntyp1).or.(itype(i-2).eq.ntyp1).or.
5970      &      (itype(i-3).eq.ntyp1)))) cycle
5971         if ((intertyp.eq.2).and.(i.eq.4).and.(itype(1).eq.ntyp1)) cycle
5972         if ((intertyp.eq.1).and.(i.eq.nres).and.(itype(nres).eq.ntyp1))
5973      & cycle
5974        do j=1,nterm_sccor(isccori,isccori1)
5975           v1ij=v1sccor(j,intertyp,isccori,isccori1)
5976           v2ij=v2sccor(j,intertyp,isccori,isccori1)
5977           cosphi=dcos(j*tauangle(intertyp,i))
5978           sinphi=dsin(j*tauangle(intertyp,i))
5979           esccor=esccor+v1ij*cosphi+v2ij*sinphi
5980           gloci=gloci+j*(v2ij*cosphi-v1ij*sinphi)
5981         enddo
5982 c      write (iout,*) "EBACK_SC_COR",i,v1ij*cosphi+v2ij*sinphi,intertyp
5983         gloc_sc(intertyp,i-3,icg)=gloc_sc(intertyp,i-3,icg)+wsccor*gloci
5984         if (lprn)
5985      &  write (iout,'(2(a3,2x,i3,2x),2i3,6f8.3/26x,6f8.3/)')
5986      &  restyp(itype(i-2)),i-2,restyp(itype(i-1)),i-1,isccori,isccori1,
5987      &  (v1sccor(j,intertyp,isccori,isccori1),j=1,6)
5988      & ,(v2sccor(j,intertyp,isccori,isccori1),j=1,6)
5989         gsccor_loc(i-3)=gsccor_loc(i-3)+gloci
5990        enddo !intertyp
5991       enddo
5992
5993       return
5994       end
5995 c----------------------------------------------------------------------------
5996       subroutine multibody(ecorr)
5997 C This subroutine calculates multi-body contributions to energy following
5998 C the idea of Skolnick et al. If side chains I and J make a contact and
5999 C at the same time side chains I+1 and J+1 make a contact, an extra
6000 C contribution equal to sqrt(eps(i,j)*eps(i+1,j+1)) is added.
6001       implicit real*8 (a-h,o-z)
6002       include 'DIMENSIONS'
6003       include 'COMMON.IOUNITS'
6004       include 'COMMON.DERIV'
6005       include 'COMMON.INTERACT'
6006       include 'COMMON.CONTACTS'
6007       double precision gx(3),gx1(3)
6008       logical lprn
6009
6010 C Set lprn=.true. for debugging
6011       lprn=.false.
6012
6013       if (lprn) then
6014         write (iout,'(a)') 'Contact function values:'
6015         do i=nnt,nct-2
6016           write (iout,'(i2,20(1x,i2,f10.5))')
6017      &        i,(jcont(j,i),facont(j,i),j=1,num_cont(i))
6018         enddo
6019       endif
6020       ecorr=0.0D0
6021       do i=nnt,nct
6022         do j=1,3
6023           gradcorr(j,i)=0.0D0
6024           gradxorr(j,i)=0.0D0
6025         enddo
6026       enddo
6027       do i=nnt,nct-2
6028
6029         DO ISHIFT = 3,4
6030
6031         i1=i+ishift
6032         num_conti=num_cont(i)
6033         num_conti1=num_cont(i1)
6034         do jj=1,num_conti
6035           j=jcont(jj,i)
6036           do kk=1,num_conti1
6037             j1=jcont(kk,i1)
6038             if (j1.eq.j+ishift .or. j1.eq.j-ishift) then
6039 cd          write(iout,*)'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6040 cd   &                   ' ishift=',ishift
6041 C Contacts I--J and I+ISHIFT--J+-ISHIFT1 occur simultaneously.
6042 C The system gains extra energy.
6043               ecorr=ecorr+esccorr(i,j,i1,j1,jj,kk)
6044             endif   ! j1==j+-ishift
6045           enddo     ! kk
6046         enddo       ! jj
6047
6048         ENDDO ! ISHIFT
6049
6050       enddo         ! i
6051       return
6052       end
6053 c------------------------------------------------------------------------------
6054       double precision function esccorr(i,j,k,l,jj,kk)
6055       implicit real*8 (a-h,o-z)
6056       include 'DIMENSIONS'
6057       include 'COMMON.IOUNITS'
6058       include 'COMMON.DERIV'
6059       include 'COMMON.INTERACT'
6060       include 'COMMON.CONTACTS'
6061       double precision gx(3),gx1(3)
6062       logical lprn
6063       lprn=.false.
6064       eij=facont(jj,i)
6065       ekl=facont(kk,k)
6066 cd    write (iout,'(4i5,3f10.5)') i,j,k,l,eij,ekl,-eij*ekl
6067 C Calculate the multi-body contribution to energy.
6068 C Calculate multi-body contributions to the gradient.
6069 cd    write (iout,'(2(2i3,3f10.5))')i,j,(gacont(m,jj,i),m=1,3),
6070 cd   & k,l,(gacont(m,kk,k),m=1,3)
6071       do m=1,3
6072         gx(m) =ekl*gacont(m,jj,i)
6073         gx1(m)=eij*gacont(m,kk,k)
6074         gradxorr(m,i)=gradxorr(m,i)-gx(m)
6075         gradxorr(m,j)=gradxorr(m,j)+gx(m)
6076         gradxorr(m,k)=gradxorr(m,k)-gx1(m)
6077         gradxorr(m,l)=gradxorr(m,l)+gx1(m)
6078       enddo
6079       do m=i,j-1
6080         do ll=1,3
6081           gradcorr(ll,m)=gradcorr(ll,m)+gx(ll)
6082         enddo
6083       enddo
6084       do m=k,l-1
6085         do ll=1,3
6086           gradcorr(ll,m)=gradcorr(ll,m)+gx1(ll)
6087         enddo
6088       enddo
6089       esccorr=-eij*ekl
6090       return
6091       end
6092 c------------------------------------------------------------------------------
6093       subroutine multibody_hb(ecorr,ecorr5,ecorr6,n_corr,n_corr1)
6094 C This subroutine calculates multi-body contributions to hydrogen-bonding
6095       implicit real*8 (a-h,o-z)
6096       include 'DIMENSIONS'
6097       include 'COMMON.IOUNITS'
6098 #ifdef MPI
6099       include "mpif.h"
6100       parameter (max_cont=maxconts)
6101       parameter (max_dim=26)
6102       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6103       double precision zapas(max_dim,maxconts,max_fg_procs),
6104      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6105       common /przechowalnia/ zapas
6106       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6107      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6108 #endif
6109       include 'COMMON.SETUP'
6110       include 'COMMON.FFIELD'
6111       include 'COMMON.DERIV'
6112       include 'COMMON.INTERACT'
6113       include 'COMMON.CONTACTS'
6114       include 'COMMON.CONTROL'
6115       include 'COMMON.LOCAL'
6116       double precision gx(3),gx1(3),time00
6117       logical lprn,ldone
6118
6119 C Set lprn=.true. for debugging
6120       lprn=.false.
6121 #ifdef MPI
6122       n_corr=0
6123       n_corr1=0
6124       if (nfgtasks.le.1) goto 30
6125       if (lprn) then
6126         write (iout,'(a)') 'Contact function values before RECEIVE:'
6127         do i=nnt,nct-2
6128           write (iout,'(2i3,50(1x,i2,f5.2))')
6129      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6130      &    j=1,num_cont_hb(i))
6131         enddo
6132       endif
6133       call flush(iout)
6134       do i=1,ntask_cont_from
6135         ncont_recv(i)=0
6136       enddo
6137       do i=1,ntask_cont_to
6138         ncont_sent(i)=0
6139       enddo
6140 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6141 c     & ntask_cont_to
6142 C Make the list of contacts to send to send to other procesors
6143 c      write (iout,*) "limits",max0(iturn4_end-1,iatel_s),iturn3_end
6144 c      call flush(iout)
6145       do i=iturn3_start,iturn3_end
6146 c        write (iout,*) "make contact list turn3",i," num_cont",
6147 c     &    num_cont_hb(i)
6148         call add_hb_contact(i,i+2,iturn3_sent_local(1,i))
6149       enddo
6150       do i=iturn4_start,iturn4_end
6151 c        write (iout,*) "make contact list turn4",i," num_cont",
6152 c     &   num_cont_hb(i)
6153         call add_hb_contact(i,i+3,iturn4_sent_local(1,i))
6154       enddo
6155       do ii=1,nat_sent
6156         i=iat_sent(ii)
6157 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6158 c     &    num_cont_hb(i)
6159         do j=1,num_cont_hb(i)
6160         do k=1,4
6161           jjc=jcont_hb(j,i)
6162           iproc=iint_sent_local(k,jjc,ii)
6163 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6164           if (iproc.gt.0) then
6165             ncont_sent(iproc)=ncont_sent(iproc)+1
6166             nn=ncont_sent(iproc)
6167             zapas(1,nn,iproc)=i
6168             zapas(2,nn,iproc)=jjc
6169             zapas(3,nn,iproc)=facont_hb(j,i)
6170             zapas(4,nn,iproc)=ees0p(j,i)
6171             zapas(5,nn,iproc)=ees0m(j,i)
6172             zapas(6,nn,iproc)=gacont_hbr(1,j,i)
6173             zapas(7,nn,iproc)=gacont_hbr(2,j,i)
6174             zapas(8,nn,iproc)=gacont_hbr(3,j,i)
6175             zapas(9,nn,iproc)=gacontm_hb1(1,j,i)
6176             zapas(10,nn,iproc)=gacontm_hb1(2,j,i)
6177             zapas(11,nn,iproc)=gacontm_hb1(3,j,i)
6178             zapas(12,nn,iproc)=gacontp_hb1(1,j,i)
6179             zapas(13,nn,iproc)=gacontp_hb1(2,j,i)
6180             zapas(14,nn,iproc)=gacontp_hb1(3,j,i)
6181             zapas(15,nn,iproc)=gacontm_hb2(1,j,i)
6182             zapas(16,nn,iproc)=gacontm_hb2(2,j,i)
6183             zapas(17,nn,iproc)=gacontm_hb2(3,j,i)
6184             zapas(18,nn,iproc)=gacontp_hb2(1,j,i)
6185             zapas(19,nn,iproc)=gacontp_hb2(2,j,i)
6186             zapas(20,nn,iproc)=gacontp_hb2(3,j,i)
6187             zapas(21,nn,iproc)=gacontm_hb3(1,j,i)
6188             zapas(22,nn,iproc)=gacontm_hb3(2,j,i)
6189             zapas(23,nn,iproc)=gacontm_hb3(3,j,i)
6190             zapas(24,nn,iproc)=gacontp_hb3(1,j,i)
6191             zapas(25,nn,iproc)=gacontp_hb3(2,j,i)
6192             zapas(26,nn,iproc)=gacontp_hb3(3,j,i)
6193           endif
6194         enddo
6195         enddo
6196       enddo
6197       if (lprn) then
6198       write (iout,*)
6199      &  "Numbers of contacts to be sent to other processors",
6200      &  (ncont_sent(i),i=1,ntask_cont_to)
6201       write (iout,*) "Contacts sent"
6202       do ii=1,ntask_cont_to
6203         nn=ncont_sent(ii)
6204         iproc=itask_cont_to(ii)
6205         write (iout,*) nn," contacts to processor",iproc,
6206      &   " of CONT_TO_COMM group"
6207         do i=1,nn
6208           write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6209         enddo
6210       enddo
6211       call flush(iout)
6212       endif
6213       CorrelType=477
6214       CorrelID=fg_rank+1
6215       CorrelType1=478
6216       CorrelID1=nfgtasks+fg_rank+1
6217       ireq=0
6218 C Receive the numbers of needed contacts from other processors
6219       do ii=1,ntask_cont_from
6220         iproc=itask_cont_from(ii)
6221         ireq=ireq+1
6222         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6223      &    FG_COMM,req(ireq),IERR)
6224       enddo
6225 c      write (iout,*) "IRECV ended"
6226 c      call flush(iout)
6227 C Send the number of contacts needed by other processors
6228       do ii=1,ntask_cont_to
6229         iproc=itask_cont_to(ii)
6230         ireq=ireq+1
6231         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6232      &    FG_COMM,req(ireq),IERR)
6233       enddo
6234 c      write (iout,*) "ISEND ended"
6235 c      write (iout,*) "number of requests (nn)",ireq
6236       call flush(iout)
6237       if (ireq.gt.0)
6238      &  call MPI_Waitall(ireq,req,status_array,ierr)
6239 c      write (iout,*)
6240 c     &  "Numbers of contacts to be received from other processors",
6241 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6242 c      call flush(iout)
6243 C Receive contacts
6244       ireq=0
6245       do ii=1,ntask_cont_from
6246         iproc=itask_cont_from(ii)
6247         nn=ncont_recv(ii)
6248 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6249 c     &   " of CONT_TO_COMM group"
6250         call flush(iout)
6251         if (nn.gt.0) then
6252           ireq=ireq+1
6253           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6254      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6255 c          write (iout,*) "ireq,req",ireq,req(ireq)
6256         endif
6257       enddo
6258 C Send the contacts to processors that need them
6259       do ii=1,ntask_cont_to
6260         iproc=itask_cont_to(ii)
6261         nn=ncont_sent(ii)
6262 c        write (iout,*) nn," contacts to processor",iproc,
6263 c     &   " of CONT_TO_COMM group"
6264         if (nn.gt.0) then
6265           ireq=ireq+1
6266           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6267      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6268 c          write (iout,*) "ireq,req",ireq,req(ireq)
6269 c          do i=1,nn
6270 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6271 c          enddo
6272         endif
6273       enddo
6274 c      write (iout,*) "number of requests (contacts)",ireq
6275 c      write (iout,*) "req",(req(i),i=1,4)
6276 c      call flush(iout)
6277       if (ireq.gt.0)
6278      & call MPI_Waitall(ireq,req,status_array,ierr)
6279       do iii=1,ntask_cont_from
6280         iproc=itask_cont_from(iii)
6281         nn=ncont_recv(iii)
6282         if (lprn) then
6283         write (iout,*) "Received",nn," contacts from processor",iproc,
6284      &   " of CONT_FROM_COMM group"
6285         call flush(iout)
6286         do i=1,nn
6287           write(iout,'(2f5.0,4f10.5)')(zapas_recv(j,i,iii),j=1,5)
6288         enddo
6289         call flush(iout)
6290         endif
6291         do i=1,nn
6292           ii=zapas_recv(1,i,iii)
6293 c Flag the received contacts to prevent double-counting
6294           jj=-zapas_recv(2,i,iii)
6295 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6296 c          call flush(iout)
6297           nnn=num_cont_hb(ii)+1
6298           num_cont_hb(ii)=nnn
6299           jcont_hb(nnn,ii)=jj
6300           facont_hb(nnn,ii)=zapas_recv(3,i,iii)
6301           ees0p(nnn,ii)=zapas_recv(4,i,iii)
6302           ees0m(nnn,ii)=zapas_recv(5,i,iii)
6303           gacont_hbr(1,nnn,ii)=zapas_recv(6,i,iii)
6304           gacont_hbr(2,nnn,ii)=zapas_recv(7,i,iii)
6305           gacont_hbr(3,nnn,ii)=zapas_recv(8,i,iii)
6306           gacontm_hb1(1,nnn,ii)=zapas_recv(9,i,iii)
6307           gacontm_hb1(2,nnn,ii)=zapas_recv(10,i,iii)
6308           gacontm_hb1(3,nnn,ii)=zapas_recv(11,i,iii)
6309           gacontp_hb1(1,nnn,ii)=zapas_recv(12,i,iii)
6310           gacontp_hb1(2,nnn,ii)=zapas_recv(13,i,iii)
6311           gacontp_hb1(3,nnn,ii)=zapas_recv(14,i,iii)
6312           gacontm_hb2(1,nnn,ii)=zapas_recv(15,i,iii)
6313           gacontm_hb2(2,nnn,ii)=zapas_recv(16,i,iii)
6314           gacontm_hb2(3,nnn,ii)=zapas_recv(17,i,iii)
6315           gacontp_hb2(1,nnn,ii)=zapas_recv(18,i,iii)
6316           gacontp_hb2(2,nnn,ii)=zapas_recv(19,i,iii)
6317           gacontp_hb2(3,nnn,ii)=zapas_recv(20,i,iii)
6318           gacontm_hb3(1,nnn,ii)=zapas_recv(21,i,iii)
6319           gacontm_hb3(2,nnn,ii)=zapas_recv(22,i,iii)
6320           gacontm_hb3(3,nnn,ii)=zapas_recv(23,i,iii)
6321           gacontp_hb3(1,nnn,ii)=zapas_recv(24,i,iii)
6322           gacontp_hb3(2,nnn,ii)=zapas_recv(25,i,iii)
6323           gacontp_hb3(3,nnn,ii)=zapas_recv(26,i,iii)
6324         enddo
6325       enddo
6326       call flush(iout)
6327       if (lprn) then
6328         write (iout,'(a)') 'Contact function values after receive:'
6329         do i=nnt,nct-2
6330           write (iout,'(2i3,50(1x,i3,f5.2))')
6331      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6332      &    j=1,num_cont_hb(i))
6333         enddo
6334         call flush(iout)
6335       endif
6336    30 continue
6337 #endif
6338       if (lprn) then
6339         write (iout,'(a)') 'Contact function values:'
6340         do i=nnt,nct-2
6341           write (iout,'(2i3,50(1x,i3,f5.2))')
6342      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6343      &    j=1,num_cont_hb(i))
6344         enddo
6345       endif
6346       ecorr=0.0D0
6347 C Remove the loop below after debugging !!!
6348       do i=nnt,nct
6349         do j=1,3
6350           gradcorr(j,i)=0.0D0
6351           gradxorr(j,i)=0.0D0
6352         enddo
6353       enddo
6354 C Calculate the local-electrostatic correlation terms
6355       do i=min0(iatel_s,iturn4_start),max0(iatel_e,iturn3_end)
6356         i1=i+1
6357         num_conti=num_cont_hb(i)
6358         num_conti1=num_cont_hb(i+1)
6359         do jj=1,num_conti
6360           j=jcont_hb(jj,i)
6361           jp=iabs(j)
6362           do kk=1,num_conti1
6363             j1=jcont_hb(kk,i1)
6364             jp1=iabs(j1)
6365 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6366 c     &         ' jj=',jj,' kk=',kk
6367             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6368      &          .or. j.lt.0 .and. j1.gt.0) .and.
6369      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6370 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6371 C The system gains extra energy.
6372               ecorr=ecorr+ehbcorr(i,jp,i+1,jp1,jj,kk,0.72D0,0.32D0)
6373               if (energy_dec) write (iout,'(a6,2i5,0pf7.3)')
6374      &            'ecorrh',i,j,ehbcorr(i,j,i+1,j1,jj,kk,0.72D0,0.32D0)
6375               n_corr=n_corr+1
6376             else if (j1.eq.j) then
6377 C Contacts I-J and I-(J+1) occur simultaneously.
6378 C The system loses extra energy.
6379 c             ecorr=ecorr+ehbcorr(i,j,i+1,j,jj,kk,0.60D0,-0.40D0)
6380             endif
6381           enddo ! kk
6382           do kk=1,num_conti
6383             j1=jcont_hb(kk,i)
6384 c           write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6385 c    &         ' jj=',jj,' kk=',kk
6386             if (j1.eq.j+1) then
6387 C Contacts I-J and (I+1)-J occur simultaneously.
6388 C The system loses extra energy.
6389 c             ecorr=ecorr+ehbcorr(i,j,i,j+1,jj,kk,0.60D0,-0.40D0)
6390             endif ! j1==j+1
6391           enddo ! kk
6392         enddo ! jj
6393       enddo ! i
6394       return
6395       end
6396 c------------------------------------------------------------------------------
6397       subroutine add_hb_contact(ii,jj,itask)
6398       implicit real*8 (a-h,o-z)
6399       include "DIMENSIONS"
6400       include "COMMON.IOUNITS"
6401       integer max_cont
6402       integer max_dim
6403       parameter (max_cont=maxconts)
6404       parameter (max_dim=26)
6405       include "COMMON.CONTACTS"
6406       double precision zapas(max_dim,maxconts,max_fg_procs),
6407      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6408       common /przechowalnia/ zapas
6409       integer i,j,ii,jj,iproc,itask(4),nn
6410 c      write (iout,*) "itask",itask
6411       do i=1,2
6412         iproc=itask(i)
6413         if (iproc.gt.0) then
6414           do j=1,num_cont_hb(ii)
6415             jjc=jcont_hb(j,ii)
6416 c            write (iout,*) "i",ii," j",jj," jjc",jjc
6417             if (jjc.eq.jj) then
6418               ncont_sent(iproc)=ncont_sent(iproc)+1
6419               nn=ncont_sent(iproc)
6420               zapas(1,nn,iproc)=ii
6421               zapas(2,nn,iproc)=jjc
6422               zapas(3,nn,iproc)=facont_hb(j,ii)
6423               zapas(4,nn,iproc)=ees0p(j,ii)
6424               zapas(5,nn,iproc)=ees0m(j,ii)
6425               zapas(6,nn,iproc)=gacont_hbr(1,j,ii)
6426               zapas(7,nn,iproc)=gacont_hbr(2,j,ii)
6427               zapas(8,nn,iproc)=gacont_hbr(3,j,ii)
6428               zapas(9,nn,iproc)=gacontm_hb1(1,j,ii)
6429               zapas(10,nn,iproc)=gacontm_hb1(2,j,ii)
6430               zapas(11,nn,iproc)=gacontm_hb1(3,j,ii)
6431               zapas(12,nn,iproc)=gacontp_hb1(1,j,ii)
6432               zapas(13,nn,iproc)=gacontp_hb1(2,j,ii)
6433               zapas(14,nn,iproc)=gacontp_hb1(3,j,ii)
6434               zapas(15,nn,iproc)=gacontm_hb2(1,j,ii)
6435               zapas(16,nn,iproc)=gacontm_hb2(2,j,ii)
6436               zapas(17,nn,iproc)=gacontm_hb2(3,j,ii)
6437               zapas(18,nn,iproc)=gacontp_hb2(1,j,ii)
6438               zapas(19,nn,iproc)=gacontp_hb2(2,j,ii)
6439               zapas(20,nn,iproc)=gacontp_hb2(3,j,ii)
6440               zapas(21,nn,iproc)=gacontm_hb3(1,j,ii)
6441               zapas(22,nn,iproc)=gacontm_hb3(2,j,ii)
6442               zapas(23,nn,iproc)=gacontm_hb3(3,j,ii)
6443               zapas(24,nn,iproc)=gacontp_hb3(1,j,ii)
6444               zapas(25,nn,iproc)=gacontp_hb3(2,j,ii)
6445               zapas(26,nn,iproc)=gacontp_hb3(3,j,ii)
6446               exit
6447             endif
6448           enddo
6449         endif
6450       enddo
6451       return
6452       end
6453 c------------------------------------------------------------------------------
6454       subroutine multibody_eello(ecorr,ecorr5,ecorr6,eturn6,n_corr,
6455      &  n_corr1)
6456 C This subroutine calculates multi-body contributions to hydrogen-bonding
6457       implicit real*8 (a-h,o-z)
6458       include 'DIMENSIONS'
6459       include 'COMMON.IOUNITS'
6460 #ifdef MPI
6461       include "mpif.h"
6462       parameter (max_cont=maxconts)
6463       parameter (max_dim=70)
6464       integer source,CorrelType,CorrelID,CorrelType1,CorrelID1,Error
6465       double precision zapas(max_dim,maxconts,max_fg_procs),
6466      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6467       common /przechowalnia/ zapas
6468       integer status(MPI_STATUS_SIZE),req(maxconts*2),
6469      &  status_array(MPI_STATUS_SIZE,maxconts*2)
6470 #endif
6471       include 'COMMON.SETUP'
6472       include 'COMMON.FFIELD'
6473       include 'COMMON.DERIV'
6474       include 'COMMON.LOCAL'
6475       include 'COMMON.INTERACT'
6476       include 'COMMON.CONTACTS'
6477       include 'COMMON.CHAIN'
6478       include 'COMMON.CONTROL'
6479       double precision gx(3),gx1(3)
6480       integer num_cont_hb_old(maxres)
6481       logical lprn,ldone
6482       double precision eello4,eello5,eelo6,eello_turn6
6483       external eello4,eello5,eello6,eello_turn6
6484 C Set lprn=.true. for debugging
6485       lprn=.false.
6486       eturn6=0.0d0
6487 #ifdef MPI
6488       do i=1,nres
6489         num_cont_hb_old(i)=num_cont_hb(i)
6490       enddo
6491       n_corr=0
6492       n_corr1=0
6493       if (nfgtasks.le.1) goto 30
6494       if (lprn) then
6495         write (iout,'(a)') 'Contact function values before RECEIVE:'
6496         do i=nnt,nct-2
6497           write (iout,'(2i3,50(1x,i2,f5.2))')
6498      &    i,num_cont_hb(i),(jcont_hb(j,i),facont_hb(j,i),
6499      &    j=1,num_cont_hb(i))
6500         enddo
6501       endif
6502       call flush(iout)
6503       do i=1,ntask_cont_from
6504         ncont_recv(i)=0
6505       enddo
6506       do i=1,ntask_cont_to
6507         ncont_sent(i)=0
6508       enddo
6509 c      write (iout,*) "ntask_cont_from",ntask_cont_from," ntask_cont_to",
6510 c     & ntask_cont_to
6511 C Make the list of contacts to send to send to other procesors
6512       do i=iturn3_start,iturn3_end
6513 c        write (iout,*) "make contact list turn3",i," num_cont",
6514 c     &    num_cont_hb(i)
6515         call add_hb_contact_eello(i,i+2,iturn3_sent_local(1,i))
6516       enddo
6517       do i=iturn4_start,iturn4_end
6518 c        write (iout,*) "make contact list turn4",i," num_cont",
6519 c     &   num_cont_hb(i)
6520         call add_hb_contact_eello(i,i+3,iturn4_sent_local(1,i))
6521       enddo
6522       do ii=1,nat_sent
6523         i=iat_sent(ii)
6524 c        write (iout,*) "make contact list longrange",i,ii," num_cont",
6525 c     &    num_cont_hb(i)
6526         do j=1,num_cont_hb(i)
6527         do k=1,4
6528           jjc=jcont_hb(j,i)
6529           iproc=iint_sent_local(k,jjc,ii)
6530 c          write (iout,*) "i",i," j",j," k",k," jjc",jjc," iproc",iproc
6531           if (iproc.ne.0) then
6532             ncont_sent(iproc)=ncont_sent(iproc)+1
6533             nn=ncont_sent(iproc)
6534             zapas(1,nn,iproc)=i
6535             zapas(2,nn,iproc)=jjc
6536             zapas(3,nn,iproc)=d_cont(j,i)
6537             ind=3
6538             do kk=1,3
6539               ind=ind+1
6540               zapas(ind,nn,iproc)=grij_hb_cont(kk,j,i)
6541             enddo
6542             do kk=1,2
6543               do ll=1,2
6544                 ind=ind+1
6545                 zapas(ind,nn,iproc)=a_chuj(ll,kk,j,i)
6546               enddo
6547             enddo
6548             do jj=1,5
6549               do kk=1,3
6550                 do ll=1,2
6551                   do mm=1,2
6552                     ind=ind+1
6553                     zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,i)
6554                   enddo
6555                 enddo
6556               enddo
6557             enddo
6558           endif
6559         enddo
6560         enddo
6561       enddo
6562       if (lprn) then
6563       write (iout,*)
6564      &  "Numbers of contacts to be sent to other processors",
6565      &  (ncont_sent(i),i=1,ntask_cont_to)
6566       write (iout,*) "Contacts sent"
6567       do ii=1,ntask_cont_to
6568         nn=ncont_sent(ii)
6569         iproc=itask_cont_to(ii)
6570         write (iout,*) nn," contacts to processor",iproc,
6571      &   " of CONT_TO_COMM group"
6572         do i=1,nn
6573           write(iout,'(2f5.0,10f10.5)')(zapas(j,i,ii),j=1,10)
6574         enddo
6575       enddo
6576       call flush(iout)
6577       endif
6578       CorrelType=477
6579       CorrelID=fg_rank+1
6580       CorrelType1=478
6581       CorrelID1=nfgtasks+fg_rank+1
6582       ireq=0
6583 C Receive the numbers of needed contacts from other processors
6584       do ii=1,ntask_cont_from
6585         iproc=itask_cont_from(ii)
6586         ireq=ireq+1
6587         call MPI_Irecv(ncont_recv(ii),1,MPI_INTEGER,iproc,CorrelType,
6588      &    FG_COMM,req(ireq),IERR)
6589       enddo
6590 c      write (iout,*) "IRECV ended"
6591 c      call flush(iout)
6592 C Send the number of contacts needed by other processors
6593       do ii=1,ntask_cont_to
6594         iproc=itask_cont_to(ii)
6595         ireq=ireq+1
6596         call MPI_Isend(ncont_sent(ii),1,MPI_INTEGER,iproc,CorrelType,
6597      &    FG_COMM,req(ireq),IERR)
6598       enddo
6599 c      write (iout,*) "ISEND ended"
6600 c      write (iout,*) "number of requests (nn)",ireq
6601       call flush(iout)
6602       if (ireq.gt.0)
6603      &  call MPI_Waitall(ireq,req,status_array,ierr)
6604 c      write (iout,*)
6605 c     &  "Numbers of contacts to be received from other processors",
6606 c     &  (ncont_recv(i),i=1,ntask_cont_from)
6607 c      call flush(iout)
6608 C Receive contacts
6609       ireq=0
6610       do ii=1,ntask_cont_from
6611         iproc=itask_cont_from(ii)
6612         nn=ncont_recv(ii)
6613 c        write (iout,*) "Receiving",nn," contacts from processor",iproc,
6614 c     &   " of CONT_TO_COMM group"
6615         call flush(iout)
6616         if (nn.gt.0) then
6617           ireq=ireq+1
6618           call MPI_Irecv(zapas_recv(1,1,ii),nn*max_dim,
6619      &    MPI_DOUBLE_PRECISION,iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6620 c          write (iout,*) "ireq,req",ireq,req(ireq)
6621         endif
6622       enddo
6623 C Send the contacts to processors that need them
6624       do ii=1,ntask_cont_to
6625         iproc=itask_cont_to(ii)
6626         nn=ncont_sent(ii)
6627 c        write (iout,*) nn," contacts to processor",iproc,
6628 c     &   " of CONT_TO_COMM group"
6629         if (nn.gt.0) then
6630           ireq=ireq+1
6631           call MPI_Isend(zapas(1,1,ii),nn*max_dim,MPI_DOUBLE_PRECISION,
6632      &      iproc,CorrelType1,FG_COMM,req(ireq),IERR)
6633 c          write (iout,*) "ireq,req",ireq,req(ireq)
6634 c          do i=1,nn
6635 c            write(iout,'(2f5.0,4f10.5)')(zapas(j,i,ii),j=1,5)
6636 c          enddo
6637         endif
6638       enddo
6639 c      write (iout,*) "number of requests (contacts)",ireq
6640 c      write (iout,*) "req",(req(i),i=1,4)
6641 c      call flush(iout)
6642       if (ireq.gt.0)
6643      & call MPI_Waitall(ireq,req,status_array,ierr)
6644       do iii=1,ntask_cont_from
6645         iproc=itask_cont_from(iii)
6646         nn=ncont_recv(iii)
6647         if (lprn) then
6648         write (iout,*) "Received",nn," contacts from processor",iproc,
6649      &   " of CONT_FROM_COMM group"
6650         call flush(iout)
6651         do i=1,nn
6652           write(iout,'(2f5.0,10f10.5)')(zapas_recv(j,i,iii),j=1,10)
6653         enddo
6654         call flush(iout)
6655         endif
6656         do i=1,nn
6657           ii=zapas_recv(1,i,iii)
6658 c Flag the received contacts to prevent double-counting
6659           jj=-zapas_recv(2,i,iii)
6660 c          write (iout,*) "iii",iii," i",i," ii",ii," jj",jj
6661 c          call flush(iout)
6662           nnn=num_cont_hb(ii)+1
6663           num_cont_hb(ii)=nnn
6664           jcont_hb(nnn,ii)=jj
6665           d_cont(nnn,ii)=zapas_recv(3,i,iii)
6666           ind=3
6667           do kk=1,3
6668             ind=ind+1
6669             grij_hb_cont(kk,nnn,ii)=zapas_recv(ind,i,iii)
6670           enddo
6671           do kk=1,2
6672             do ll=1,2
6673               ind=ind+1
6674               a_chuj(ll,kk,nnn,ii)=zapas_recv(ind,i,iii)
6675             enddo
6676           enddo
6677           do jj=1,5
6678             do kk=1,3
6679               do ll=1,2
6680                 do mm=1,2
6681                   ind=ind+1
6682                   a_chuj_der(mm,ll,kk,jj,nnn,ii)=zapas_recv(ind,i,iii)
6683                 enddo
6684               enddo
6685             enddo
6686           enddo
6687         enddo
6688       enddo
6689       call flush(iout)
6690       if (lprn) then
6691         write (iout,'(a)') 'Contact function values after receive:'
6692         do i=nnt,nct-2
6693           write (iout,'(2i3,50(1x,i3,5f6.3))')
6694      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6695      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6696         enddo
6697         call flush(iout)
6698       endif
6699    30 continue
6700 #endif
6701       if (lprn) then
6702         write (iout,'(a)') 'Contact function values:'
6703         do i=nnt,nct-2
6704           write (iout,'(2i3,50(1x,i2,5f6.3))')
6705      &    i,num_cont_hb(i),(jcont_hb(j,i),d_cont(j,i),
6706      &    ((a_chuj(ll,kk,j,i),ll=1,2),kk=1,2),j=1,num_cont_hb(i))
6707         enddo
6708       endif
6709       ecorr=0.0D0
6710       ecorr5=0.0d0
6711       ecorr6=0.0d0
6712 C Remove the loop below after debugging !!!
6713       do i=nnt,nct
6714         do j=1,3
6715           gradcorr(j,i)=0.0D0
6716           gradxorr(j,i)=0.0D0
6717         enddo
6718       enddo
6719 C Calculate the dipole-dipole interaction energies
6720       if (wcorr6.gt.0.0d0 .or. wturn6.gt.0.0d0) then
6721       do i=iatel_s,iatel_e+1
6722         num_conti=num_cont_hb(i)
6723         do jj=1,num_conti
6724           j=jcont_hb(jj,i)
6725 #ifdef MOMENT
6726           call dipole(i,j,jj)
6727 #endif
6728         enddo
6729       enddo
6730       endif
6731 C Calculate the local-electrostatic correlation terms
6732 c                write (iout,*) "gradcorr5 in eello5 before loop"
6733 c                do iii=1,nres
6734 c                  write (iout,'(i5,3f10.5)')
6735 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6736 c                enddo
6737       do i=min0(iatel_s,iturn4_start),max0(iatel_e+1,iturn3_end+1)
6738 c        write (iout,*) "corr loop i",i
6739         i1=i+1
6740         num_conti=num_cont_hb(i)
6741         num_conti1=num_cont_hb(i+1)
6742         do jj=1,num_conti
6743           j=jcont_hb(jj,i)
6744           jp=iabs(j)
6745           do kk=1,num_conti1
6746             j1=jcont_hb(kk,i1)
6747             jp1=iabs(j1)
6748 c            write (iout,*) 'i=',i,' j=',j,' i1=',i1,' j1=',j1,
6749 c     &         ' jj=',jj,' kk=',kk
6750 c            if (j1.eq.j+1 .or. j1.eq.j-1) then
6751             if ((j.gt.0 .and. j1.gt.0 .or. j.gt.0 .and. j1.lt.0
6752      &          .or. j.lt.0 .and. j1.gt.0) .and.
6753      &         (jp1.eq.jp+1 .or. jp1.eq.jp-1)) then
6754 C Contacts I-J and (I+1)-(J+1) or (I+1)-(J-1) occur simultaneously.
6755 C The system gains extra energy.
6756               n_corr=n_corr+1
6757               sqd1=dsqrt(d_cont(jj,i))
6758               sqd2=dsqrt(d_cont(kk,i1))
6759               sred_geom = sqd1*sqd2
6760               IF (sred_geom.lt.cutoff_corr) THEN
6761                 call gcont(sred_geom,r0_corr,1.0D0,delt_corr,
6762      &            ekont,fprimcont)
6763 cd               write (iout,*) 'i=',i,' j=',jp,' i1=',i1,' j1=',jp1,
6764 cd     &         ' jj=',jj,' kk=',kk
6765                 fac_prim1=0.5d0*sqd2/sqd1*fprimcont
6766                 fac_prim2=0.5d0*sqd1/sqd2*fprimcont
6767                 do l=1,3
6768                   g_contij(l,1)=fac_prim1*grij_hb_cont(l,jj,i)
6769                   g_contij(l,2)=fac_prim2*grij_hb_cont(l,kk,i1)
6770                 enddo
6771                 n_corr1=n_corr1+1
6772 cd               write (iout,*) 'sred_geom=',sred_geom,
6773 cd     &          ' ekont=',ekont,' fprim=',fprimcont,
6774 cd     &          ' fac_prim1',fac_prim1,' fac_prim2',fac_prim2
6775 cd               write (iout,*) "g_contij",g_contij
6776 cd               write (iout,*) "grij_hb_cont i",grij_hb_cont(:,jj,i)
6777 cd               write (iout,*) "grij_hb_cont i1",grij_hb_cont(:,jj,i1)
6778                 call calc_eello(i,jp,i+1,jp1,jj,kk)
6779                 if (wcorr4.gt.0.0d0)
6780      &            ecorr=ecorr+eello4(i,jp,i+1,jp1,jj,kk)
6781                   if (energy_dec.and.wcorr4.gt.0.0d0)
6782      1                 write (iout,'(a6,4i5,0pf7.3)')
6783      2                'ecorr4',i,j,i+1,j1,eello4(i,jp,i+1,jp1,jj,kk)
6784 c                write (iout,*) "gradcorr5 before eello5"
6785 c                do iii=1,nres
6786 c                  write (iout,'(i5,3f10.5)')
6787 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6788 c                enddo
6789                 if (wcorr5.gt.0.0d0)
6790      &            ecorr5=ecorr5+eello5(i,jp,i+1,jp1,jj,kk)
6791 c                write (iout,*) "gradcorr5 after eello5"
6792 c                do iii=1,nres
6793 c                  write (iout,'(i5,3f10.5)')
6794 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6795 c                enddo
6796                   if (energy_dec.and.wcorr5.gt.0.0d0)
6797      1                 write (iout,'(a6,4i5,0pf7.3)')
6798      2                'ecorr5',i,j,i+1,j1,eello5(i,jp,i+1,jp1,jj,kk)
6799 cd                write(2,*)'wcorr6',wcorr6,' wturn6',wturn6
6800 cd                write(2,*)'ijkl',i,jp,i+1,jp1
6801                 if (wcorr6.gt.0.0d0 .and. (jp.ne.i+4 .or. jp1.ne.i+3
6802      &               .or. wturn6.eq.0.0d0))then
6803 cd                  write (iout,*) '******ecorr6: i,j,i+1,j1',i,j,i+1,j1
6804                   ecorr6=ecorr6+eello6(i,jp,i+1,jp1,jj,kk)
6805                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6806      1                'ecorr6',i,j,i+1,j1,eello6(i,jp,i+1,jp1,jj,kk)
6807 cd                write (iout,*) 'ecorr',ecorr,' ecorr5=',ecorr5,
6808 cd     &            'ecorr6=',ecorr6
6809 cd                write (iout,'(4e15.5)') sred_geom,
6810 cd     &          dabs(eello4(i,jp,i+1,jp1,jj,kk)),
6811 cd     &          dabs(eello5(i,jp,i+1,jp1,jj,kk)),
6812 cd     &          dabs(eello6(i,jp,i+1,jp1,jj,kk))
6813                 else if (wturn6.gt.0.0d0
6814      &            .and. (jp.eq.i+4 .and. jp1.eq.i+3)) then
6815 cd                  write (iout,*) '******eturn6: i,j,i+1,j1',i,jip,i+1,jp1
6816                   eturn6=eturn6+eello_turn6(i,jj,kk)
6817                   if (energy_dec) write (iout,'(a6,4i5,0pf7.3)')
6818      1                 'eturn6',i,j,i+1,j1,eello_turn6(i,jj,kk)
6819 cd                  write (2,*) 'multibody_eello:eturn6',eturn6
6820                 endif
6821               ENDIF
6822 1111          continue
6823             endif
6824           enddo ! kk
6825         enddo ! jj
6826       enddo ! i
6827       do i=1,nres
6828         num_cont_hb(i)=num_cont_hb_old(i)
6829       enddo
6830 c                write (iout,*) "gradcorr5 in eello5"
6831 c                do iii=1,nres
6832 c                  write (iout,'(i5,3f10.5)')
6833 c     &             iii,(gradcorr5(jjj,iii),jjj=1,3)
6834 c                enddo
6835       return
6836       end
6837 c------------------------------------------------------------------------------
6838       subroutine add_hb_contact_eello(ii,jj,itask)
6839       implicit real*8 (a-h,o-z)
6840       include "DIMENSIONS"
6841       include "COMMON.IOUNITS"
6842       integer max_cont
6843       integer max_dim
6844       parameter (max_cont=maxconts)
6845       parameter (max_dim=70)
6846       include "COMMON.CONTACTS"
6847       double precision zapas(max_dim,maxconts,max_fg_procs),
6848      &  zapas_recv(max_dim,maxconts,max_fg_procs)
6849       common /przechowalnia/ zapas
6850       integer i,j,ii,jj,iproc,itask(4),nn
6851 c      write (iout,*) "itask",itask
6852       do i=1,2
6853         iproc=itask(i)
6854         if (iproc.gt.0) then
6855           do j=1,num_cont_hb(ii)
6856             jjc=jcont_hb(j,ii)
6857 c            write (iout,*) "send turns i",ii," j",jj," jjc",jjc
6858             if (jjc.eq.jj) then
6859               ncont_sent(iproc)=ncont_sent(iproc)+1
6860               nn=ncont_sent(iproc)
6861               zapas(1,nn,iproc)=ii
6862               zapas(2,nn,iproc)=jjc
6863               zapas(3,nn,iproc)=d_cont(j,ii)
6864               ind=3
6865               do kk=1,3
6866                 ind=ind+1
6867                 zapas(ind,nn,iproc)=grij_hb_cont(kk,j,ii)
6868               enddo
6869               do kk=1,2
6870                 do ll=1,2
6871                   ind=ind+1
6872                   zapas(ind,nn,iproc)=a_chuj(ll,kk,j,ii)
6873                 enddo
6874               enddo
6875               do jj=1,5
6876                 do kk=1,3
6877                   do ll=1,2
6878                     do mm=1,2
6879                       ind=ind+1
6880                       zapas(ind,nn,iproc)=a_chuj_der(mm,ll,kk,jj,j,ii)
6881                     enddo
6882                   enddo
6883                 enddo
6884               enddo
6885               exit
6886             endif
6887           enddo
6888         endif
6889       enddo
6890       return
6891       end
6892 c------------------------------------------------------------------------------
6893       double precision function ehbcorr(i,j,k,l,jj,kk,coeffp,coeffm)
6894       implicit real*8 (a-h,o-z)
6895       include 'DIMENSIONS'
6896       include 'COMMON.IOUNITS'
6897       include 'COMMON.DERIV'
6898       include 'COMMON.INTERACT'
6899       include 'COMMON.CONTACTS'
6900       double precision gx(3),gx1(3)
6901       logical lprn
6902       lprn=.false.
6903       eij=facont_hb(jj,i)
6904       ekl=facont_hb(kk,k)
6905       ees0pij=ees0p(jj,i)
6906       ees0pkl=ees0p(kk,k)
6907       ees0mij=ees0m(jj,i)
6908       ees0mkl=ees0m(kk,k)
6909       ekont=eij*ekl
6910       ees=-(coeffp*ees0pij*ees0pkl+coeffm*ees0mij*ees0mkl)
6911 cd    ees=-(coeffp*ees0pkl+coeffm*ees0mkl)
6912 C Following 4 lines for diagnostics.
6913 cd    ees0pkl=0.0D0
6914 cd    ees0pij=1.0D0
6915 cd    ees0mkl=0.0D0
6916 cd    ees0mij=1.0D0
6917 c      write (iout,'(2(a,2i3,a,f10.5,a,2f10.5),a,f10.5,a,$)')
6918 c     & 'Contacts ',i,j,
6919 c     & ' eij',eij,' eesij',ees0pij,ees0mij,' and ',k,l
6920 c     & ,' fcont ',ekl,' eeskl',ees0pkl,ees0mkl,' energy=',ekont*ees,
6921 c     & 'gradcorr_long'
6922 C Calculate the multi-body contribution to energy.
6923 c      ecorr=ecorr+ekont*ees
6924 C Calculate multi-body contributions to the gradient.
6925       coeffpees0pij=coeffp*ees0pij
6926       coeffmees0mij=coeffm*ees0mij
6927       coeffpees0pkl=coeffp*ees0pkl
6928       coeffmees0mkl=coeffm*ees0mkl
6929       do ll=1,3
6930 cgrad        ghalfi=ees*ekl*gacont_hbr(ll,jj,i)
6931         gradcorr(ll,i)=gradcorr(ll,i)!+0.5d0*ghalfi
6932      &  -ekont*(coeffpees0pkl*gacontp_hb1(ll,jj,i)+
6933      &  coeffmees0mkl*gacontm_hb1(ll,jj,i))
6934         gradcorr(ll,j)=gradcorr(ll,j)!+0.5d0*ghalfi
6935      &  -ekont*(coeffpees0pkl*gacontp_hb2(ll,jj,i)+
6936      &  coeffmees0mkl*gacontm_hb2(ll,jj,i))
6937 cgrad        ghalfk=ees*eij*gacont_hbr(ll,kk,k)
6938         gradcorr(ll,k)=gradcorr(ll,k)!+0.5d0*ghalfk
6939      &  -ekont*(coeffpees0pij*gacontp_hb1(ll,kk,k)+
6940      &  coeffmees0mij*gacontm_hb1(ll,kk,k))
6941         gradcorr(ll,l)=gradcorr(ll,l)!+0.5d0*ghalfk
6942      &  -ekont*(coeffpees0pij*gacontp_hb2(ll,kk,k)+
6943      &  coeffmees0mij*gacontm_hb2(ll,kk,k))
6944         gradlongij=ees*ekl*gacont_hbr(ll,jj,i)-
6945      &     ekont*(coeffpees0pkl*gacontp_hb3(ll,jj,i)+
6946      &     coeffmees0mkl*gacontm_hb3(ll,jj,i))
6947         gradcorr_long(ll,j)=gradcorr_long(ll,j)+gradlongij
6948         gradcorr_long(ll,i)=gradcorr_long(ll,i)-gradlongij
6949         gradlongkl=ees*eij*gacont_hbr(ll,kk,k)-
6950      &     ekont*(coeffpees0pij*gacontp_hb3(ll,kk,k)+
6951      &     coeffmees0mij*gacontm_hb3(ll,kk,k))
6952         gradcorr_long(ll,l)=gradcorr_long(ll,l)+gradlongkl
6953         gradcorr_long(ll,k)=gradcorr_long(ll,k)-gradlongkl
6954 c        write (iout,'(2f10.5,2x,$)') gradlongij,gradlongkl
6955       enddo
6956 c      write (iout,*)
6957 cgrad      do m=i+1,j-1
6958 cgrad        do ll=1,3
6959 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6960 cgrad     &     ees*ekl*gacont_hbr(ll,jj,i)-
6961 cgrad     &     ekont*(coeffp*ees0pkl*gacontp_hb3(ll,jj,i)+
6962 cgrad     &     coeffm*ees0mkl*gacontm_hb3(ll,jj,i))
6963 cgrad        enddo
6964 cgrad      enddo
6965 cgrad      do m=k+1,l-1
6966 cgrad        do ll=1,3
6967 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+
6968 cgrad     &     ees*eij*gacont_hbr(ll,kk,k)-
6969 cgrad     &     ekont*(coeffp*ees0pij*gacontp_hb3(ll,kk,k)+
6970 cgrad     &     coeffm*ees0mij*gacontm_hb3(ll,kk,k))
6971 cgrad        enddo
6972 cgrad      enddo
6973 c      write (iout,*) "ehbcorr",ekont*ees
6974       ehbcorr=ekont*ees
6975       return
6976       end
6977 #ifdef MOMENT
6978 C---------------------------------------------------------------------------
6979       subroutine dipole(i,j,jj)
6980       implicit real*8 (a-h,o-z)
6981       include 'DIMENSIONS'
6982       include 'COMMON.IOUNITS'
6983       include 'COMMON.CHAIN'
6984       include 'COMMON.FFIELD'
6985       include 'COMMON.DERIV'
6986       include 'COMMON.INTERACT'
6987       include 'COMMON.CONTACTS'
6988       include 'COMMON.TORSION'
6989       include 'COMMON.VAR'
6990       include 'COMMON.GEO'
6991       dimension dipi(2,2),dipj(2,2),dipderi(2),dipderj(2),auxvec(2),
6992      &  auxmat(2,2)
6993       iti1 = itortyp(itype(i+1))
6994       if (j.lt.nres-1) then
6995         itj1 = itortyp(itype(j+1))
6996       else
6997         itj1=ntortyp+1
6998       endif
6999       do iii=1,2
7000         dipi(iii,1)=Ub2(iii,i)
7001         dipderi(iii)=Ub2der(iii,i)
7002         dipi(iii,2)=b1(iii,iti1)
7003         dipj(iii,1)=Ub2(iii,j)
7004         dipderj(iii)=Ub2der(iii,j)
7005         dipj(iii,2)=b1(iii,itj1)
7006       enddo
7007       kkk=0
7008       do iii=1,2
7009         call matvec2(a_chuj(1,1,jj,i),dipj(1,iii),auxvec(1))
7010         do jjj=1,2
7011           kkk=kkk+1
7012           dip(kkk,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7013         enddo
7014       enddo
7015       do kkk=1,5
7016         do lll=1,3
7017           mmm=0
7018           do iii=1,2
7019             call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),dipj(1,iii),
7020      &        auxvec(1))
7021             do jjj=1,2
7022               mmm=mmm+1
7023               dipderx(lll,kkk,mmm,jj,i)=scalar2(dipi(1,jjj),auxvec(1))
7024             enddo
7025           enddo
7026         enddo
7027       enddo
7028       call transpose2(a_chuj(1,1,jj,i),auxmat(1,1))
7029       call matvec2(auxmat(1,1),dipderi(1),auxvec(1))
7030       do iii=1,2
7031         dipderg(iii,jj,i)=scalar2(auxvec(1),dipj(1,iii))
7032       enddo
7033       call matvec2(a_chuj(1,1,jj,i),dipderj(1),auxvec(1))
7034       do iii=1,2
7035         dipderg(iii+2,jj,i)=scalar2(auxvec(1),dipi(1,iii))
7036       enddo
7037       return
7038       end
7039 #endif
7040 C---------------------------------------------------------------------------
7041       subroutine calc_eello(i,j,k,l,jj,kk)
7042 C
7043 C This subroutine computes matrices and vectors needed to calculate
7044 C the fourth-, fifth-, and sixth-order local-electrostatic terms.
7045 C
7046       implicit real*8 (a-h,o-z)
7047       include 'DIMENSIONS'
7048       include 'COMMON.IOUNITS'
7049       include 'COMMON.CHAIN'
7050       include 'COMMON.DERIV'
7051       include 'COMMON.INTERACT'
7052       include 'COMMON.CONTACTS'
7053       include 'COMMON.TORSION'
7054       include 'COMMON.VAR'
7055       include 'COMMON.GEO'
7056       include 'COMMON.FFIELD'
7057       double precision aa1(2,2),aa2(2,2),aa1t(2,2),aa2t(2,2),
7058      &  aa1tder(2,2,3,5),aa2tder(2,2,3,5),auxmat(2,2)
7059       logical lprn
7060       common /kutas/ lprn
7061 cd      write (iout,*) 'calc_eello: i=',i,' j=',j,' k=',k,' l=',l,
7062 cd     & ' jj=',jj,' kk=',kk
7063 cd      if (i.ne.2 .or. j.ne.4 .or. k.ne.3 .or. l.ne.5) return
7064 cd      write (iout,*) "a_chujij",((a_chuj(iii,jjj,jj,i),iii=1,2),jjj=1,2)
7065 cd      write (iout,*) "a_chujkl",((a_chuj(iii,jjj,kk,k),iii=1,2),jjj=1,2)
7066       do iii=1,2
7067         do jjj=1,2
7068           aa1(iii,jjj)=a_chuj(iii,jjj,jj,i)
7069           aa2(iii,jjj)=a_chuj(iii,jjj,kk,k)
7070         enddo
7071       enddo
7072       call transpose2(aa1(1,1),aa1t(1,1))
7073       call transpose2(aa2(1,1),aa2t(1,1))
7074       do kkk=1,5
7075         do lll=1,3
7076           call transpose2(a_chuj_der(1,1,lll,kkk,jj,i),
7077      &      aa1tder(1,1,lll,kkk))
7078           call transpose2(a_chuj_der(1,1,lll,kkk,kk,k),
7079      &      aa2tder(1,1,lll,kkk))
7080         enddo
7081       enddo
7082       if (l.eq.j+1) then
7083 C parallel orientation of the two CA-CA-CA frames.
7084         if (i.gt.1) then
7085           iti=itortyp(itype(i))
7086         else
7087           iti=ntortyp+1
7088         endif
7089         itk1=itortyp(itype(k+1))
7090         itj=itortyp(itype(j))
7091         if (l.lt.nres-1) then
7092           itl1=itortyp(itype(l+1))
7093         else
7094           itl1=ntortyp+1
7095         endif
7096 C A1 kernel(j+1) A2T
7097 cd        do iii=1,2
7098 cd          write (iout,'(3f10.5,5x,3f10.5)')
7099 cd     &     (EUg(iii,jjj,k),jjj=1,2),(EUg(iii,jjj,l),jjj=1,2)
7100 cd        enddo
7101         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7102      &   aa2tder(1,1,1,1),1,.false.,EUg(1,1,l),EUgder(1,1,l),
7103      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7104 C Following matrices are needed only for 6-th order cumulants
7105         IF (wcorr6.gt.0.0d0) THEN
7106         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7107      &   aa2tder(1,1,1,1),1,.false.,EUgC(1,1,l),EUgCder(1,1,l),
7108      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7109         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7110      &   aa2tder(1,1,1,1),2,.false.,Ug2DtEUg(1,1,l),
7111      &   Ug2DtEUgder(1,1,1,l),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7112      &   ADtEAderx(1,1,1,1,1,1))
7113         lprn=.false.
7114         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7115      &   aa2tder(1,1,1,1),2,.false.,DtUg2EUg(1,1,l),
7116      &   DtUg2EUgder(1,1,1,l),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7117      &   ADtEA1derx(1,1,1,1,1,1))
7118         ENDIF
7119 C End 6-th order cumulants
7120 cd        lprn=.false.
7121 cd        if (lprn) then
7122 cd        write (2,*) 'In calc_eello6'
7123 cd        do iii=1,2
7124 cd          write (2,*) 'iii=',iii
7125 cd          do kkk=1,5
7126 cd            write (2,*) 'kkk=',kkk
7127 cd            do jjj=1,2
7128 cd              write (2,'(3(2f10.5),5x)')
7129 cd     &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
7130 cd            enddo
7131 cd          enddo
7132 cd        enddo
7133 cd        endif
7134         call transpose2(EUgder(1,1,k),auxmat(1,1))
7135         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7136         call transpose2(EUg(1,1,k),auxmat(1,1))
7137         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7138         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7139         do iii=1,2
7140           do kkk=1,5
7141             do lll=1,3
7142               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7143      &          EAEAderx(1,1,lll,kkk,iii,1))
7144             enddo
7145           enddo
7146         enddo
7147 C A1T kernel(i+1) A2
7148         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7149      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUg(1,1,k),EUgder(1,1,k),
7150      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7151 C Following matrices are needed only for 6-th order cumulants
7152         IF (wcorr6.gt.0.0d0) THEN
7153         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7154      &   a_chuj_der(1,1,1,1,kk,k),1,.false.,EUgC(1,1,k),EUgCder(1,1,k),
7155      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7156         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7157      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,Ug2DtEUg(1,1,k),
7158      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7159      &   ADtEAderx(1,1,1,1,1,2))
7160         call kernel(aa1t(1,1),aa2(1,1),aa1tder(1,1,1,1),
7161      &   a_chuj_der(1,1,1,1,kk,k),2,.false.,DtUg2EUg(1,1,k),
7162      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7163      &   ADtEA1derx(1,1,1,1,1,2))
7164         ENDIF
7165 C End 6-th order cumulants
7166         call transpose2(EUgder(1,1,l),auxmat(1,1))
7167         call matmat2(auxmat(1,1),AEA(1,1,2),EAEAderg(1,1,1,2))
7168         call transpose2(EUg(1,1,l),auxmat(1,1))
7169         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7170         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7171         do iii=1,2
7172           do kkk=1,5
7173             do lll=1,3
7174               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7175      &          EAEAderx(1,1,lll,kkk,iii,2))
7176             enddo
7177           enddo
7178         enddo
7179 C AEAb1 and AEAb2
7180 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7181 C They are needed only when the fifth- or the sixth-order cumulants are
7182 C indluded.
7183         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0) THEN
7184         call transpose2(AEA(1,1,1),auxmat(1,1))
7185         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7186         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7187         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7188         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7189         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7190         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7191         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7192         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7193         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7194         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7195         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7196         call transpose2(AEA(1,1,2),auxmat(1,1))
7197         call matvec2(auxmat(1,1),b1(1,itj),AEAb1(1,1,2))
7198         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2(1,1,2))
7199         call matvec2(auxmat(1,1),Ub2der(1,j),AEAb2derg(1,2,1,2))
7200         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7201         call matvec2(auxmat(1,1),b1(1,itj),AEAb1derg(1,1,2))
7202         call matvec2(auxmat(1,1),Ub2(1,j),AEAb2derg(1,1,1,2))
7203         call matvec2(AEA(1,1,2),b1(1,itl1),AEAb1(1,2,2))
7204         call matvec2(AEAderg(1,1,2),b1(1,itl1),AEAb1derg(1,2,2))
7205         call matvec2(AEA(1,1,2),Ub2(1,l+1),AEAb2(1,2,2))
7206         call matvec2(AEAderg(1,1,2),Ub2(1,l+1),AEAb2derg(1,1,2,2))
7207         call matvec2(AEA(1,1,2),Ub2der(1,l+1),AEAb2derg(1,2,2,2))
7208 C Calculate the Cartesian derivatives of the vectors.
7209         do iii=1,2
7210           do kkk=1,5
7211             do lll=1,3
7212               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7213               call matvec2(auxmat(1,1),b1(1,iti),
7214      &          AEAb1derx(1,lll,kkk,iii,1,1))
7215               call matvec2(auxmat(1,1),Ub2(1,i),
7216      &          AEAb2derx(1,lll,kkk,iii,1,1))
7217               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7218      &          AEAb1derx(1,lll,kkk,iii,2,1))
7219               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7220      &          AEAb2derx(1,lll,kkk,iii,2,1))
7221               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7222               call matvec2(auxmat(1,1),b1(1,itj),
7223      &          AEAb1derx(1,lll,kkk,iii,1,2))
7224               call matvec2(auxmat(1,1),Ub2(1,j),
7225      &          AEAb2derx(1,lll,kkk,iii,1,2))
7226               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
7227      &          AEAb1derx(1,lll,kkk,iii,2,2))
7228               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,l+1),
7229      &          AEAb2derx(1,lll,kkk,iii,2,2))
7230             enddo
7231           enddo
7232         enddo
7233         ENDIF
7234 C End vectors
7235       else
7236 C Antiparallel orientation of the two CA-CA-CA frames.
7237         if (i.gt.1) then
7238           iti=itortyp(itype(i))
7239         else
7240           iti=ntortyp+1
7241         endif
7242         itk1=itortyp(itype(k+1))
7243         itl=itortyp(itype(l))
7244         itj=itortyp(itype(j))
7245         if (j.lt.nres-1) then
7246           itj1=itortyp(itype(j+1))
7247         else
7248           itj1=ntortyp+1
7249         endif
7250 C A2 kernel(j-1)T A1T
7251         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7252      &   aa2tder(1,1,1,1),1,.true.,EUg(1,1,j),EUgder(1,1,j),
7253      &   AEA(1,1,1),AEAderg(1,1,1),AEAderx(1,1,1,1,1,1))
7254 C Following matrices are needed only for 6-th order cumulants
7255         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7256      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7257         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7258      &   aa2tder(1,1,1,1),1,.true.,EUgC(1,1,j),EUgCder(1,1,j),
7259      &   AECA(1,1,1),AECAderg(1,1,1),AECAderx(1,1,1,1,1,1))
7260         call kernel(aa2(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7261      &   aa2tder(1,1,1,1),2,.true.,Ug2DtEUg(1,1,j),
7262      &   Ug2DtEUgder(1,1,1,j),ADtEA(1,1,1),ADtEAderg(1,1,1,1),
7263      &   ADtEAderx(1,1,1,1,1,1))
7264         call kernel(aa1(1,1),aa2t(1,1),a_chuj_der(1,1,1,1,jj,i),
7265      &   aa2tder(1,1,1,1),2,.true.,DtUg2EUg(1,1,j),
7266      &   DtUg2EUgder(1,1,1,j),ADtEA1(1,1,1),ADtEA1derg(1,1,1,1),
7267      &   ADtEA1derx(1,1,1,1,1,1))
7268         ENDIF
7269 C End 6-th order cumulants
7270         call transpose2(EUgder(1,1,k),auxmat(1,1))
7271         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,1,1))
7272         call transpose2(EUg(1,1,k),auxmat(1,1))
7273         call matmat2(auxmat(1,1),AEA(1,1,1),EAEA(1,1,1))
7274         call matmat2(auxmat(1,1),AEAderg(1,1,1),EAEAderg(1,1,2,1))
7275         do iii=1,2
7276           do kkk=1,5
7277             do lll=1,3
7278               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7279      &          EAEAderx(1,1,lll,kkk,iii,1))
7280             enddo
7281           enddo
7282         enddo
7283 C A2T kernel(i+1)T A1
7284         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7285      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUg(1,1,k),EUgder(1,1,k),
7286      &   AEA(1,1,2),AEAderg(1,1,2),AEAderx(1,1,1,1,1,2))
7287 C Following matrices are needed only for 6-th order cumulants
7288         IF (wcorr6.gt.0.0d0 .or. (wturn6.gt.0.0d0 .and.
7289      &     j.eq.i+4 .and. l.eq.i+3)) THEN
7290         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7291      &   a_chuj_der(1,1,1,1,jj,i),1,.true.,EUgC(1,1,k),EUgCder(1,1,k),
7292      &   AECA(1,1,2),AECAderg(1,1,2),AECAderx(1,1,1,1,1,2))
7293         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7294      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,Ug2DtEUg(1,1,k),
7295      &   Ug2DtEUgder(1,1,1,k),ADtEA(1,1,2),ADtEAderg(1,1,1,2),
7296      &   ADtEAderx(1,1,1,1,1,2))
7297         call kernel(aa2t(1,1),aa1(1,1),aa2tder(1,1,1,1),
7298      &   a_chuj_der(1,1,1,1,jj,i),2,.true.,DtUg2EUg(1,1,k),
7299      &   DtUg2EUgder(1,1,1,k),ADtEA1(1,1,2),ADtEA1derg(1,1,1,2),
7300      &   ADtEA1derx(1,1,1,1,1,2))
7301         ENDIF
7302 C End 6-th order cumulants
7303         call transpose2(EUgder(1,1,j),auxmat(1,1))
7304         call matmat2(auxmat(1,1),AEA(1,1,1),EAEAderg(1,1,2,2))
7305         call transpose2(EUg(1,1,j),auxmat(1,1))
7306         call matmat2(auxmat(1,1),AEA(1,1,2),EAEA(1,1,2))
7307         call matmat2(auxmat(1,1),AEAderg(1,1,2),EAEAderg(1,1,2,2))
7308         do iii=1,2
7309           do kkk=1,5
7310             do lll=1,3
7311               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7312      &          EAEAderx(1,1,lll,kkk,iii,2))
7313             enddo
7314           enddo
7315         enddo
7316 C AEAb1 and AEAb2
7317 C Calculate the vectors and their derivatives in virtual-bond dihedral angles.
7318 C They are needed only when the fifth- or the sixth-order cumulants are
7319 C indluded.
7320         IF (wcorr5.gt.0.0d0 .or. wcorr6.gt.0.0d0 .or.
7321      &    (wturn6.gt.0.0d0 .and. j.eq.i+4 .and. l.eq.i+3)) THEN
7322         call transpose2(AEA(1,1,1),auxmat(1,1))
7323         call matvec2(auxmat(1,1),b1(1,iti),AEAb1(1,1,1))
7324         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2(1,1,1))
7325         call matvec2(auxmat(1,1),Ub2der(1,i),AEAb2derg(1,2,1,1))
7326         call transpose2(AEAderg(1,1,1),auxmat(1,1))
7327         call matvec2(auxmat(1,1),b1(1,iti),AEAb1derg(1,1,1))
7328         call matvec2(auxmat(1,1),Ub2(1,i),AEAb2derg(1,1,1,1))
7329         call matvec2(AEA(1,1,1),b1(1,itk1),AEAb1(1,2,1))
7330         call matvec2(AEAderg(1,1,1),b1(1,itk1),AEAb1derg(1,2,1))
7331         call matvec2(AEA(1,1,1),Ub2(1,k+1),AEAb2(1,2,1))
7332         call matvec2(AEAderg(1,1,1),Ub2(1,k+1),AEAb2derg(1,1,2,1))
7333         call matvec2(AEA(1,1,1),Ub2der(1,k+1),AEAb2derg(1,2,2,1))
7334         call transpose2(AEA(1,1,2),auxmat(1,1))
7335         call matvec2(auxmat(1,1),b1(1,itj1),AEAb1(1,1,2))
7336         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2(1,1,2))
7337         call matvec2(auxmat(1,1),Ub2der(1,l),AEAb2derg(1,2,1,2))
7338         call transpose2(AEAderg(1,1,2),auxmat(1,1))
7339         call matvec2(auxmat(1,1),b1(1,itl),AEAb1(1,1,2))
7340         call matvec2(auxmat(1,1),Ub2(1,l),AEAb2derg(1,1,1,2))
7341         call matvec2(AEA(1,1,2),b1(1,itj1),AEAb1(1,2,2))
7342         call matvec2(AEAderg(1,1,2),b1(1,itj1),AEAb1derg(1,2,2))
7343         call matvec2(AEA(1,1,2),Ub2(1,j),AEAb2(1,2,2))
7344         call matvec2(AEAderg(1,1,2),Ub2(1,j),AEAb2derg(1,1,2,2))
7345         call matvec2(AEA(1,1,2),Ub2der(1,j),AEAb2derg(1,2,2,2))
7346 C Calculate the Cartesian derivatives of the vectors.
7347         do iii=1,2
7348           do kkk=1,5
7349             do lll=1,3
7350               call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1))
7351               call matvec2(auxmat(1,1),b1(1,iti),
7352      &          AEAb1derx(1,lll,kkk,iii,1,1))
7353               call matvec2(auxmat(1,1),Ub2(1,i),
7354      &          AEAb2derx(1,lll,kkk,iii,1,1))
7355               call matvec2(AEAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
7356      &          AEAb1derx(1,lll,kkk,iii,2,1))
7357               call matvec2(AEAderx(1,1,lll,kkk,iii,1),Ub2(1,k+1),
7358      &          AEAb2derx(1,lll,kkk,iii,2,1))
7359               call transpose2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1))
7360               call matvec2(auxmat(1,1),b1(1,itl),
7361      &          AEAb1derx(1,lll,kkk,iii,1,2))
7362               call matvec2(auxmat(1,1),Ub2(1,l),
7363      &          AEAb2derx(1,lll,kkk,iii,1,2))
7364               call matvec2(AEAderx(1,1,lll,kkk,iii,2),b1(1,itj1),
7365      &          AEAb1derx(1,lll,kkk,iii,2,2))
7366               call matvec2(AEAderx(1,1,lll,kkk,iii,2),Ub2(1,j),
7367      &          AEAb2derx(1,lll,kkk,iii,2,2))
7368             enddo
7369           enddo
7370         enddo
7371         ENDIF
7372 C End vectors
7373       endif
7374       return
7375       end
7376 C---------------------------------------------------------------------------
7377       subroutine kernel(aa1,aa2t,aa1derx,aa2tderx,nderg,transp,
7378      &  KK,KKderg,AKA,AKAderg,AKAderx)
7379       implicit none
7380       integer nderg
7381       logical transp
7382       double precision aa1(2,2),aa2t(2,2),aa1derx(2,2,3,5),
7383      &  aa2tderx(2,2,3,5),KK(2,2),KKderg(2,2,nderg),AKA(2,2),
7384      &  AKAderg(2,2,nderg),AKAderx(2,2,3,5,2)
7385       integer iii,kkk,lll
7386       integer jjj,mmm
7387       logical lprn
7388       common /kutas/ lprn
7389       call prodmat3(aa1(1,1),aa2t(1,1),KK(1,1),transp,AKA(1,1))
7390       do iii=1,nderg
7391         call prodmat3(aa1(1,1),aa2t(1,1),KKderg(1,1,iii),transp,
7392      &    AKAderg(1,1,iii))
7393       enddo
7394 cd      if (lprn) write (2,*) 'In kernel'
7395       do kkk=1,5
7396 cd        if (lprn) write (2,*) 'kkk=',kkk
7397         do lll=1,3
7398           call prodmat3(aa1derx(1,1,lll,kkk),aa2t(1,1),
7399      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,1))
7400 cd          if (lprn) then
7401 cd            write (2,*) 'lll=',lll
7402 cd            write (2,*) 'iii=1'
7403 cd            do jjj=1,2
7404 cd              write (2,'(3(2f10.5),5x)')
7405 cd     &        (AKAderx(jjj,mmm,lll,kkk,1),mmm=1,2)
7406 cd            enddo
7407 cd          endif
7408           call prodmat3(aa1(1,1),aa2tderx(1,1,lll,kkk),
7409      &      KK(1,1),transp,AKAderx(1,1,lll,kkk,2))
7410 cd          if (lprn) then
7411 cd            write (2,*) 'lll=',lll
7412 cd            write (2,*) 'iii=2'
7413 cd            do jjj=1,2
7414 cd              write (2,'(3(2f10.5),5x)')
7415 cd     &        (AKAderx(jjj,mmm,lll,kkk,2),mmm=1,2)
7416 cd            enddo
7417 cd          endif
7418         enddo
7419       enddo
7420       return
7421       end
7422 C---------------------------------------------------------------------------
7423       double precision function eello4(i,j,k,l,jj,kk)
7424       implicit real*8 (a-h,o-z)
7425       include 'DIMENSIONS'
7426       include 'COMMON.IOUNITS'
7427       include 'COMMON.CHAIN'
7428       include 'COMMON.DERIV'
7429       include 'COMMON.INTERACT'
7430       include 'COMMON.CONTACTS'
7431       include 'COMMON.TORSION'
7432       include 'COMMON.VAR'
7433       include 'COMMON.GEO'
7434       double precision pizda(2,2),ggg1(3),ggg2(3)
7435 cd      if (i.ne.1 .or. j.ne.5 .or. k.ne.2 .or.l.ne.4) then
7436 cd        eello4=0.0d0
7437 cd        return
7438 cd      endif
7439 cd      print *,'eello4:',i,j,k,l,jj,kk
7440 cd      write (2,*) 'i',i,' j',j,' k',k,' l',l
7441 cd      call checkint4(i,j,k,l,jj,kk,eel4_num)
7442 cold      eij=facont_hb(jj,i)
7443 cold      ekl=facont_hb(kk,k)
7444 cold      ekont=eij*ekl
7445       eel4=-EAEA(1,1,1)-EAEA(2,2,1)
7446 cd      eel41=-EAEA(1,1,2)-EAEA(2,2,2)
7447       gcorr_loc(k-1)=gcorr_loc(k-1)
7448      &   -ekont*(EAEAderg(1,1,1,1)+EAEAderg(2,2,1,1))
7449       if (l.eq.j+1) then
7450         gcorr_loc(l-1)=gcorr_loc(l-1)
7451      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7452       else
7453         gcorr_loc(j-1)=gcorr_loc(j-1)
7454      &     -ekont*(EAEAderg(1,1,2,1)+EAEAderg(2,2,2,1))
7455       endif
7456       do iii=1,2
7457         do kkk=1,5
7458           do lll=1,3
7459             derx(lll,kkk,iii)=-EAEAderx(1,1,lll,kkk,iii,1)
7460      &                        -EAEAderx(2,2,lll,kkk,iii,1)
7461 cd            derx(lll,kkk,iii)=0.0d0
7462           enddo
7463         enddo
7464       enddo
7465 cd      gcorr_loc(l-1)=0.0d0
7466 cd      gcorr_loc(j-1)=0.0d0
7467 cd      gcorr_loc(k-1)=0.0d0
7468 cd      eel4=1.0d0
7469 cd      write (iout,*)'Contacts have occurred for peptide groups',
7470 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l,
7471 cd     &  ' fcont ',ekl,' eel4=',eel4,' eel4_num',16*eel4_num
7472       if (j.lt.nres-1) then
7473         j1=j+1
7474         j2=j-1
7475       else
7476         j1=j-1
7477         j2=j-2
7478       endif
7479       if (l.lt.nres-1) then
7480         l1=l+1
7481         l2=l-1
7482       else
7483         l1=l-1
7484         l2=l-2
7485       endif
7486       do ll=1,3
7487 cgrad        ggg1(ll)=eel4*g_contij(ll,1)
7488 cgrad        ggg2(ll)=eel4*g_contij(ll,2)
7489         glongij=eel4*g_contij(ll,1)+ekont*derx(ll,1,1)
7490         glongkl=eel4*g_contij(ll,2)+ekont*derx(ll,1,2)
7491 cgrad        ghalf=0.5d0*ggg1(ll)
7492         gradcorr(ll,i)=gradcorr(ll,i)+ekont*derx(ll,2,1)
7493         gradcorr(ll,i+1)=gradcorr(ll,i+1)+ekont*derx(ll,3,1)
7494         gradcorr(ll,j)=gradcorr(ll,j)+ekont*derx(ll,4,1)
7495         gradcorr(ll,j1)=gradcorr(ll,j1)+ekont*derx(ll,5,1)
7496         gradcorr_long(ll,j)=gradcorr_long(ll,j)+glongij
7497         gradcorr_long(ll,i)=gradcorr_long(ll,i)-glongij
7498 cgrad        ghalf=0.5d0*ggg2(ll)
7499         gradcorr(ll,k)=gradcorr(ll,k)+ekont*derx(ll,2,2)
7500         gradcorr(ll,k+1)=gradcorr(ll,k+1)+ekont*derx(ll,3,2)
7501         gradcorr(ll,l)=gradcorr(ll,l)+ekont*derx(ll,4,2)
7502         gradcorr(ll,l1)=gradcorr(ll,l1)+ekont*derx(ll,5,2)
7503         gradcorr_long(ll,l)=gradcorr_long(ll,l)+glongkl
7504         gradcorr_long(ll,k)=gradcorr_long(ll,k)-glongkl
7505       enddo
7506 cgrad      do m=i+1,j-1
7507 cgrad        do ll=1,3
7508 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg1(ll)
7509 cgrad        enddo
7510 cgrad      enddo
7511 cgrad      do m=k+1,l-1
7512 cgrad        do ll=1,3
7513 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ggg2(ll)
7514 cgrad        enddo
7515 cgrad      enddo
7516 cgrad      do m=i+2,j2
7517 cgrad        do ll=1,3
7518 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,1)
7519 cgrad        enddo
7520 cgrad      enddo
7521 cgrad      do m=k+2,l2
7522 cgrad        do ll=1,3
7523 cgrad          gradcorr(ll,m)=gradcorr(ll,m)+ekont*derx(ll,1,2)
7524 cgrad        enddo
7525 cgrad      enddo
7526 cd      do iii=1,nres-3
7527 cd        write (2,*) iii,gcorr_loc(iii)
7528 cd      enddo
7529       eello4=ekont*eel4
7530 cd      write (2,*) 'ekont',ekont
7531 cd      write (iout,*) 'eello4',ekont*eel4
7532       return
7533       end
7534 C---------------------------------------------------------------------------
7535       double precision function eello5(i,j,k,l,jj,kk)
7536       implicit real*8 (a-h,o-z)
7537       include 'DIMENSIONS'
7538       include 'COMMON.IOUNITS'
7539       include 'COMMON.CHAIN'
7540       include 'COMMON.DERIV'
7541       include 'COMMON.INTERACT'
7542       include 'COMMON.CONTACTS'
7543       include 'COMMON.TORSION'
7544       include 'COMMON.VAR'
7545       include 'COMMON.GEO'
7546       double precision pizda(2,2),auxmat(2,2),auxmat1(2,2),vv(2)
7547       double precision ggg1(3),ggg2(3)
7548 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7549 C                                                                              C
7550 C                            Parallel chains                                   C
7551 C                                                                              C
7552 C          o             o                   o             o                   C
7553 C         /l\           / \             \   / \           / \   /              C
7554 C        /   \         /   \             \ /   \         /   \ /               C
7555 C       j| o |l1       | o |              o| o |         | o |o                C
7556 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7557 C      \i/   \         /   \ /             /   \         /   \                 C
7558 C       o    k1             o                                                  C
7559 C         (I)          (II)                (III)          (IV)                 C
7560 C                                                                              C
7561 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7562 C                                                                              C
7563 C                            Antiparallel chains                               C
7564 C                                                                              C
7565 C          o             o                   o             o                   C
7566 C         /j\           / \             \   / \           / \   /              C
7567 C        /   \         /   \             \ /   \         /   \ /               C
7568 C      j1| o |l        | o |              o| o |         | o |o                C
7569 C     \  |/k\|         |/ \|  /            |/ \|         |/ \|                 C
7570 C      \i/   \         /   \ /             /   \         /   \                 C
7571 C       o     k1            o                                                  C
7572 C         (I)          (II)                (III)          (IV)                 C
7573 C                                                                              C
7574 C      eello5_1        eello5_2            eello5_3       eello5_4             C
7575 C                                                                              C
7576 C o denotes a local interaction, vertical lines an electrostatic interaction.  C
7577 C                                                                              C
7578 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
7579 cd      if (i.ne.2 .or. j.ne.6 .or. k.ne.3 .or. l.ne.5) then
7580 cd        eello5=0.0d0
7581 cd        return
7582 cd      endif
7583 cd      write (iout,*)
7584 cd     &   'EELLO5: Contacts have occurred for peptide groups',i,j,
7585 cd     &   ' and',k,l
7586       itk=itortyp(itype(k))
7587       itl=itortyp(itype(l))
7588       itj=itortyp(itype(j))
7589       eello5_1=0.0d0
7590       eello5_2=0.0d0
7591       eello5_3=0.0d0
7592       eello5_4=0.0d0
7593 cd      call checkint5(i,j,k,l,jj,kk,eel5_1_num,eel5_2_num,
7594 cd     &   eel5_3_num,eel5_4_num)
7595       do iii=1,2
7596         do kkk=1,5
7597           do lll=1,3
7598             derx(lll,kkk,iii)=0.0d0
7599           enddo
7600         enddo
7601       enddo
7602 cd      eij=facont_hb(jj,i)
7603 cd      ekl=facont_hb(kk,k)
7604 cd      ekont=eij*ekl
7605 cd      write (iout,*)'Contacts have occurred for peptide groups',
7606 cd     &  i,j,' fcont:',eij,' eij',' and ',k,l
7607 cd      goto 1111
7608 C Contribution from the graph I.
7609 cd      write (2,*) 'AEA  ',AEA(1,1,1),AEA(2,1,1),AEA(1,2,1),AEA(2,2,1)
7610 cd      write (2,*) 'AEAb2',AEAb2(1,1,1),AEAb2(2,1,1)
7611       call transpose2(EUg(1,1,k),auxmat(1,1))
7612       call matmat2(AEA(1,1,1),auxmat(1,1),pizda(1,1))
7613       vv(1)=pizda(1,1)-pizda(2,2)
7614       vv(2)=pizda(1,2)+pizda(2,1)
7615       eello5_1=scalar2(AEAb2(1,1,1),Ub2(1,k))
7616      & +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7617 C Explicit gradient in virtual-dihedral angles.
7618       if (i.gt.1) g_corr5_loc(i-1)=g_corr5_loc(i-1)
7619      & +ekont*(scalar2(AEAb2derg(1,2,1,1),Ub2(1,k))
7620      & +0.5d0*scalar2(vv(1),Dtobr2der(1,i)))
7621       call transpose2(EUgder(1,1,k),auxmat1(1,1))
7622       call matmat2(AEA(1,1,1),auxmat1(1,1),pizda(1,1))
7623       vv(1)=pizda(1,1)-pizda(2,2)
7624       vv(2)=pizda(1,2)+pizda(2,1)
7625       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7626      & +ekont*(scalar2(AEAb2(1,1,1),Ub2der(1,k))
7627      & +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7628       call matmat2(AEAderg(1,1,1),auxmat(1,1),pizda(1,1))
7629       vv(1)=pizda(1,1)-pizda(2,2)
7630       vv(2)=pizda(1,2)+pizda(2,1)
7631       if (l.eq.j+1) then
7632         if (l.lt.nres-1) g_corr5_loc(l-1)=g_corr5_loc(l-1)
7633      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7634      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7635       else
7636         if (j.lt.nres-1) g_corr5_loc(j-1)=g_corr5_loc(j-1)
7637      &   +ekont*(scalar2(AEAb2derg(1,1,1,1),Ub2(1,k))
7638      &   +0.5d0*scalar2(vv(1),Dtobr2(1,i)))
7639       endif
7640 C Cartesian gradient
7641       do iii=1,2
7642         do kkk=1,5
7643           do lll=1,3
7644             call matmat2(AEAderx(1,1,lll,kkk,iii,1),auxmat(1,1),
7645      &        pizda(1,1))
7646             vv(1)=pizda(1,1)-pizda(2,2)
7647             vv(2)=pizda(1,2)+pizda(2,1)
7648             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7649      &       +scalar2(AEAb2derx(1,lll,kkk,iii,1,1),Ub2(1,k))
7650      &       +0.5d0*scalar2(vv(1),Dtobr2(1,i))
7651           enddo
7652         enddo
7653       enddo
7654 c      goto 1112
7655 c1111  continue
7656 C Contribution from graph II
7657       call transpose2(EE(1,1,itk),auxmat(1,1))
7658       call matmat2(auxmat(1,1),AEA(1,1,1),pizda(1,1))
7659       vv(1)=pizda(1,1)+pizda(2,2)
7660       vv(2)=pizda(2,1)-pizda(1,2)
7661       eello5_2=scalar2(AEAb1(1,2,1),b1(1,itk))
7662      & -0.5d0*scalar2(vv(1),Ctobr(1,k))
7663 C Explicit gradient in virtual-dihedral angles.
7664       g_corr5_loc(k-1)=g_corr5_loc(k-1)
7665      & -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,k))
7666       call matmat2(auxmat(1,1),AEAderg(1,1,1),pizda(1,1))
7667       vv(1)=pizda(1,1)+pizda(2,2)
7668       vv(2)=pizda(2,1)-pizda(1,2)
7669       if (l.eq.j+1) then
7670         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7671      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7672      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7673       else
7674         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7675      &   +ekont*(scalar2(AEAb1derg(1,2,1),b1(1,itk))
7676      &   -0.5d0*scalar2(vv(1),Ctobr(1,k)))
7677       endif
7678 C Cartesian gradient
7679       do iii=1,2
7680         do kkk=1,5
7681           do lll=1,3
7682             call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,1),
7683      &        pizda(1,1))
7684             vv(1)=pizda(1,1)+pizda(2,2)
7685             vv(2)=pizda(2,1)-pizda(1,2)
7686             derx(lll,kkk,iii)=derx(lll,kkk,iii)
7687      &       +scalar2(AEAb1derx(1,lll,kkk,iii,2,1),b1(1,itk))
7688      &       -0.5d0*scalar2(vv(1),Ctobr(1,k))
7689           enddo
7690         enddo
7691       enddo
7692 cd      goto 1112
7693 cd1111  continue
7694       if (l.eq.j+1) then
7695 cd        goto 1110
7696 C Parallel orientation
7697 C Contribution from graph III
7698         call transpose2(EUg(1,1,l),auxmat(1,1))
7699         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7700         vv(1)=pizda(1,1)-pizda(2,2)
7701         vv(2)=pizda(1,2)+pizda(2,1)
7702         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,l))
7703      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7704 C Explicit gradient in virtual-dihedral angles.
7705         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7706      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,l))
7707      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,j)))
7708         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7709         vv(1)=pizda(1,1)-pizda(2,2)
7710         vv(2)=pizda(1,2)+pizda(2,1)
7711         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7712      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,l))
7713      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7714         call transpose2(EUgder(1,1,l),auxmat1(1,1))
7715         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7716         vv(1)=pizda(1,1)-pizda(2,2)
7717         vv(2)=pizda(1,2)+pizda(2,1)
7718         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7719      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,l))
7720      &   +0.5d0*scalar2(vv(1),Dtobr2(1,j)))
7721 C Cartesian gradient
7722         do iii=1,2
7723           do kkk=1,5
7724             do lll=1,3
7725               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7726      &          pizda(1,1))
7727               vv(1)=pizda(1,1)-pizda(2,2)
7728               vv(2)=pizda(1,2)+pizda(2,1)
7729               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7730      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,l))
7731      &         +0.5d0*scalar2(vv(1),Dtobr2(1,j))
7732             enddo
7733           enddo
7734         enddo
7735 cd        goto 1112
7736 C Contribution from graph IV
7737 cd1110    continue
7738         call transpose2(EE(1,1,itl),auxmat(1,1))
7739         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7740         vv(1)=pizda(1,1)+pizda(2,2)
7741         vv(2)=pizda(2,1)-pizda(1,2)
7742         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itl))
7743      &   -0.5d0*scalar2(vv(1),Ctobr(1,l))
7744 C Explicit gradient in virtual-dihedral angles.
7745         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7746      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,l))
7747         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7748         vv(1)=pizda(1,1)+pizda(2,2)
7749         vv(2)=pizda(2,1)-pizda(1,2)
7750         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7751      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itl))
7752      &   -0.5d0*scalar2(vv(1),Ctobr(1,l)))
7753 C Cartesian gradient
7754         do iii=1,2
7755           do kkk=1,5
7756             do lll=1,3
7757               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7758      &          pizda(1,1))
7759               vv(1)=pizda(1,1)+pizda(2,2)
7760               vv(2)=pizda(2,1)-pizda(1,2)
7761               derx(lll,kkk,iii)=derx(lll,kkk,iii)
7762      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itl))
7763      &         -0.5d0*scalar2(vv(1),Ctobr(1,l))
7764             enddo
7765           enddo
7766         enddo
7767       else
7768 C Antiparallel orientation
7769 C Contribution from graph III
7770 c        goto 1110
7771         call transpose2(EUg(1,1,j),auxmat(1,1))
7772         call matmat2(AEA(1,1,2),auxmat(1,1),pizda(1,1))
7773         vv(1)=pizda(1,1)-pizda(2,2)
7774         vv(2)=pizda(1,2)+pizda(2,1)
7775         eello5_3=scalar2(AEAb2(1,1,2),Ub2(1,j))
7776      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7777 C Explicit gradient in virtual-dihedral angles.
7778         g_corr5_loc(l-1)=g_corr5_loc(l-1)
7779      &   +ekont*(scalar2(AEAb2derg(1,2,1,2),Ub2(1,j))
7780      &   +0.5d0*scalar2(vv(1),Dtobr2der(1,l)))
7781         call matmat2(AEAderg(1,1,2),auxmat(1,1),pizda(1,1))
7782         vv(1)=pizda(1,1)-pizda(2,2)
7783         vv(2)=pizda(1,2)+pizda(2,1)
7784         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7785      &   +ekont*(scalar2(AEAb2derg(1,1,1,2),Ub2(1,j))
7786      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7787         call transpose2(EUgder(1,1,j),auxmat1(1,1))
7788         call matmat2(AEA(1,1,2),auxmat1(1,1),pizda(1,1))
7789         vv(1)=pizda(1,1)-pizda(2,2)
7790         vv(2)=pizda(1,2)+pizda(2,1)
7791         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7792      &   +ekont*(scalar2(AEAb2(1,1,2),Ub2der(1,j))
7793      &   +0.5d0*scalar2(vv(1),Dtobr2(1,l)))
7794 C Cartesian gradient
7795         do iii=1,2
7796           do kkk=1,5
7797             do lll=1,3
7798               call matmat2(AEAderx(1,1,lll,kkk,iii,2),auxmat(1,1),
7799      &          pizda(1,1))
7800               vv(1)=pizda(1,1)-pizda(2,2)
7801               vv(2)=pizda(1,2)+pizda(2,1)
7802               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7803      &         +scalar2(AEAb2derx(1,lll,kkk,iii,1,2),Ub2(1,j))
7804      &         +0.5d0*scalar2(vv(1),Dtobr2(1,l))
7805             enddo
7806           enddo
7807         enddo
7808 cd        goto 1112
7809 C Contribution from graph IV
7810 1110    continue
7811         call transpose2(EE(1,1,itj),auxmat(1,1))
7812         call matmat2(auxmat(1,1),AEA(1,1,2),pizda(1,1))
7813         vv(1)=pizda(1,1)+pizda(2,2)
7814         vv(2)=pizda(2,1)-pizda(1,2)
7815         eello5_4=scalar2(AEAb1(1,2,2),b1(1,itj))
7816      &   -0.5d0*scalar2(vv(1),Ctobr(1,j))
7817 C Explicit gradient in virtual-dihedral angles.
7818         g_corr5_loc(j-1)=g_corr5_loc(j-1)
7819      &   -0.5d0*ekont*scalar2(vv(1),Ctobrder(1,j))
7820         call matmat2(auxmat(1,1),AEAderg(1,1,2),pizda(1,1))
7821         vv(1)=pizda(1,1)+pizda(2,2)
7822         vv(2)=pizda(2,1)-pizda(1,2)
7823         g_corr5_loc(k-1)=g_corr5_loc(k-1)
7824      &   +ekont*(scalar2(AEAb1derg(1,2,2),b1(1,itj))
7825      &   -0.5d0*scalar2(vv(1),Ctobr(1,j)))
7826 C Cartesian gradient
7827         do iii=1,2
7828           do kkk=1,5
7829             do lll=1,3
7830               call matmat2(auxmat(1,1),AEAderx(1,1,lll,kkk,iii,2),
7831      &          pizda(1,1))
7832               vv(1)=pizda(1,1)+pizda(2,2)
7833               vv(2)=pizda(2,1)-pizda(1,2)
7834               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)
7835      &         +scalar2(AEAb1derx(1,lll,kkk,iii,2,2),b1(1,itj))
7836      &         -0.5d0*scalar2(vv(1),Ctobr(1,j))
7837             enddo
7838           enddo
7839         enddo
7840       endif
7841 1112  continue
7842       eel5=eello5_1+eello5_2+eello5_3+eello5_4
7843 cd      if (i.eq.2 .and. j.eq.8 .and. k.eq.3 .and. l.eq.7) then
7844 cd        write (2,*) 'ijkl',i,j,k,l
7845 cd        write (2,*) 'eello5_1',eello5_1,' eello5_2',eello5_2,
7846 cd     &     ' eello5_3',eello5_3,' eello5_4',eello5_4
7847 cd      endif
7848 cd      write(iout,*) 'eello5_1',eello5_1,' eel5_1_num',16*eel5_1_num
7849 cd      write(iout,*) 'eello5_2',eello5_2,' eel5_2_num',16*eel5_2_num
7850 cd      write(iout,*) 'eello5_3',eello5_3,' eel5_3_num',16*eel5_3_num
7851 cd      write(iout,*) 'eello5_4',eello5_4,' eel5_4_num',16*eel5_4_num
7852       if (j.lt.nres-1) then
7853         j1=j+1
7854         j2=j-1
7855       else
7856         j1=j-1
7857         j2=j-2
7858       endif
7859       if (l.lt.nres-1) then
7860         l1=l+1
7861         l2=l-1
7862       else
7863         l1=l-1
7864         l2=l-2
7865       endif
7866 cd      eij=1.0d0
7867 cd      ekl=1.0d0
7868 cd      ekont=1.0d0
7869 cd      write (2,*) 'eij',eij,' ekl',ekl,' ekont',ekont
7870 C 2/11/08 AL Gradients over DC's connecting interacting sites will be
7871 C        summed up outside the subrouine as for the other subroutines
7872 C        handling long-range interactions. The old code is commented out
7873 C        with "cgrad" to keep track of changes.
7874       do ll=1,3
7875 cgrad        ggg1(ll)=eel5*g_contij(ll,1)
7876 cgrad        ggg2(ll)=eel5*g_contij(ll,2)
7877         gradcorr5ij=eel5*g_contij(ll,1)+ekont*derx(ll,1,1)
7878         gradcorr5kl=eel5*g_contij(ll,2)+ekont*derx(ll,1,2)
7879 c        write (iout,'(a,3i3,a,5f8.3,2i3,a,5f8.3,a,f8.3)')
7880 c     &   "ecorr5",ll,i,j," derx",derx(ll,2,1),derx(ll,3,1),derx(ll,4,1),
7881 c     &   derx(ll,5,1),k,l," derx",derx(ll,2,2),derx(ll,3,2),
7882 c     &   derx(ll,4,2),derx(ll,5,2)," ekont",ekont
7883 c        write (iout,'(a,3i3,a,3f8.3,2i3,a,3f8.3)')
7884 c     &   "ecorr5",ll,i,j," gradcorr5",g_contij(ll,1),derx(ll,1,1),
7885 c     &   gradcorr5ij,
7886 c     &   k,l," gradcorr5",g_contij(ll,2),derx(ll,1,2),gradcorr5kl
7887 cold        ghalf=0.5d0*eel5*ekl*gacont_hbr(ll,jj,i)
7888 cgrad        ghalf=0.5d0*ggg1(ll)
7889 cd        ghalf=0.0d0
7890         gradcorr5(ll,i)=gradcorr5(ll,i)+ekont*derx(ll,2,1)
7891         gradcorr5(ll,i+1)=gradcorr5(ll,i+1)+ekont*derx(ll,3,1)
7892         gradcorr5(ll,j)=gradcorr5(ll,j)+ekont*derx(ll,4,1)
7893         gradcorr5(ll,j1)=gradcorr5(ll,j1)+ekont*derx(ll,5,1)
7894         gradcorr5_long(ll,j)=gradcorr5_long(ll,j)+gradcorr5ij
7895         gradcorr5_long(ll,i)=gradcorr5_long(ll,i)-gradcorr5ij
7896 cold        ghalf=0.5d0*eel5*eij*gacont_hbr(ll,kk,k)
7897 cgrad        ghalf=0.5d0*ggg2(ll)
7898 cd        ghalf=0.0d0
7899         gradcorr5(ll,k)=gradcorr5(ll,k)+ekont*derx(ll,2,2)
7900         gradcorr5(ll,k+1)=gradcorr5(ll,k+1)+ekont*derx(ll,3,2)
7901         gradcorr5(ll,l)=gradcorr5(ll,l)+ekont*derx(ll,4,2)
7902         gradcorr5(ll,l1)=gradcorr5(ll,l1)+ekont*derx(ll,5,2)
7903         gradcorr5_long(ll,l)=gradcorr5_long(ll,l)+gradcorr5kl
7904         gradcorr5_long(ll,k)=gradcorr5_long(ll,k)-gradcorr5kl
7905       enddo
7906 cd      goto 1112
7907 cgrad      do m=i+1,j-1
7908 cgrad        do ll=1,3
7909 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*ekl*gacont_hbr(ll,jj,i)
7910 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg1(ll)
7911 cgrad        enddo
7912 cgrad      enddo
7913 cgrad      do m=k+1,l-1
7914 cgrad        do ll=1,3
7915 cold          gradcorr5(ll,m)=gradcorr5(ll,m)+eel5*eij*gacont_hbr(ll,kk,k)
7916 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ggg2(ll)
7917 cgrad        enddo
7918 cgrad      enddo
7919 c1112  continue
7920 cgrad      do m=i+2,j2
7921 cgrad        do ll=1,3
7922 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,1)
7923 cgrad        enddo
7924 cgrad      enddo
7925 cgrad      do m=k+2,l2
7926 cgrad        do ll=1,3
7927 cgrad          gradcorr5(ll,m)=gradcorr5(ll,m)+ekont*derx(ll,1,2)
7928 cgrad        enddo
7929 cgrad      enddo
7930 cd      do iii=1,nres-3
7931 cd        write (2,*) iii,g_corr5_loc(iii)
7932 cd      enddo
7933       eello5=ekont*eel5
7934 cd      write (2,*) 'ekont',ekont
7935 cd      write (iout,*) 'eello5',ekont*eel5
7936       return
7937       end
7938 c--------------------------------------------------------------------------
7939       double precision function eello6(i,j,k,l,jj,kk)
7940       implicit real*8 (a-h,o-z)
7941       include 'DIMENSIONS'
7942       include 'COMMON.IOUNITS'
7943       include 'COMMON.CHAIN'
7944       include 'COMMON.DERIV'
7945       include 'COMMON.INTERACT'
7946       include 'COMMON.CONTACTS'
7947       include 'COMMON.TORSION'
7948       include 'COMMON.VAR'
7949       include 'COMMON.GEO'
7950       include 'COMMON.FFIELD'
7951       double precision ggg1(3),ggg2(3)
7952 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
7953 cd        eello6=0.0d0
7954 cd        return
7955 cd      endif
7956 cd      write (iout,*)
7957 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
7958 cd     &   ' and',k,l
7959       eello6_1=0.0d0
7960       eello6_2=0.0d0
7961       eello6_3=0.0d0
7962       eello6_4=0.0d0
7963       eello6_5=0.0d0
7964       eello6_6=0.0d0
7965 cd      call checkint6(i,j,k,l,jj,kk,eel6_1_num,eel6_2_num,
7966 cd     &   eel6_3_num,eel6_4_num,eel6_5_num,eel6_6_num)
7967       do iii=1,2
7968         do kkk=1,5
7969           do lll=1,3
7970             derx(lll,kkk,iii)=0.0d0
7971           enddo
7972         enddo
7973       enddo
7974 cd      eij=facont_hb(jj,i)
7975 cd      ekl=facont_hb(kk,k)
7976 cd      ekont=eij*ekl
7977 cd      eij=1.0d0
7978 cd      ekl=1.0d0
7979 cd      ekont=1.0d0
7980       if (l.eq.j+1) then
7981         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7982         eello6_2=eello6_graph1(j,i,l,k,2,.false.)
7983         eello6_3=eello6_graph2(i,j,k,l,jj,kk,.false.)
7984         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7985         eello6_5=eello6_graph4(j,i,l,k,jj,kk,2,.false.)
7986         eello6_6=eello6_graph3(i,j,k,l,jj,kk,.false.)
7987       else
7988         eello6_1=eello6_graph1(i,j,k,l,1,.false.)
7989         eello6_2=eello6_graph1(l,k,j,i,2,.true.)
7990         eello6_3=eello6_graph2(i,l,k,j,jj,kk,.true.)
7991         eello6_4=eello6_graph4(i,j,k,l,jj,kk,1,.false.)
7992         if (wturn6.eq.0.0d0 .or. j.ne.i+4) then
7993           eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
7994         else
7995           eello6_5=0.0d0
7996         endif
7997         eello6_6=eello6_graph3(i,l,k,j,jj,kk,.true.)
7998       endif
7999 C If turn contributions are considered, they will be handled separately.
8000       eel6=eello6_1+eello6_2+eello6_3+eello6_4+eello6_5+eello6_6
8001 cd      write(iout,*) 'eello6_1',eello6_1!,' eel6_1_num',16*eel6_1_num
8002 cd      write(iout,*) 'eello6_2',eello6_2!,' eel6_2_num',16*eel6_2_num
8003 cd      write(iout,*) 'eello6_3',eello6_3!,' eel6_3_num',16*eel6_3_num
8004 cd      write(iout,*) 'eello6_4',eello6_4!,' eel6_4_num',16*eel6_4_num
8005 cd      write(iout,*) 'eello6_5',eello6_5!,' eel6_5_num',16*eel6_5_num
8006 cd      write(iout,*) 'eello6_6',eello6_6!,' eel6_6_num',16*eel6_6_num
8007 cd      goto 1112
8008       if (j.lt.nres-1) then
8009         j1=j+1
8010         j2=j-1
8011       else
8012         j1=j-1
8013         j2=j-2
8014       endif
8015       if (l.lt.nres-1) then
8016         l1=l+1
8017         l2=l-1
8018       else
8019         l1=l-1
8020         l2=l-2
8021       endif
8022       do ll=1,3
8023 cgrad        ggg1(ll)=eel6*g_contij(ll,1)
8024 cgrad        ggg2(ll)=eel6*g_contij(ll,2)
8025 cold        ghalf=0.5d0*eel6*ekl*gacont_hbr(ll,jj,i)
8026 cgrad        ghalf=0.5d0*ggg1(ll)
8027 cd        ghalf=0.0d0
8028         gradcorr6ij=eel6*g_contij(ll,1)+ekont*derx(ll,1,1)
8029         gradcorr6kl=eel6*g_contij(ll,2)+ekont*derx(ll,1,2)
8030         gradcorr6(ll,i)=gradcorr6(ll,i)+ekont*derx(ll,2,1)
8031         gradcorr6(ll,i+1)=gradcorr6(ll,i+1)+ekont*derx(ll,3,1)
8032         gradcorr6(ll,j)=gradcorr6(ll,j)+ekont*derx(ll,4,1)
8033         gradcorr6(ll,j1)=gradcorr6(ll,j1)+ekont*derx(ll,5,1)
8034         gradcorr6_long(ll,j)=gradcorr6_long(ll,j)+gradcorr6ij
8035         gradcorr6_long(ll,i)=gradcorr6_long(ll,i)-gradcorr6ij
8036 cgrad        ghalf=0.5d0*ggg2(ll)
8037 cold        ghalf=0.5d0*eel6*eij*gacont_hbr(ll,kk,k)
8038 cd        ghalf=0.0d0
8039         gradcorr6(ll,k)=gradcorr6(ll,k)+ekont*derx(ll,2,2)
8040         gradcorr6(ll,k+1)=gradcorr6(ll,k+1)+ekont*derx(ll,3,2)
8041         gradcorr6(ll,l)=gradcorr6(ll,l)+ekont*derx(ll,4,2)
8042         gradcorr6(ll,l1)=gradcorr6(ll,l1)+ekont*derx(ll,5,2)
8043         gradcorr6_long(ll,l)=gradcorr6_long(ll,l)+gradcorr6kl
8044         gradcorr6_long(ll,k)=gradcorr6_long(ll,k)-gradcorr6kl
8045       enddo
8046 cd      goto 1112
8047 cgrad      do m=i+1,j-1
8048 cgrad        do ll=1,3
8049 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*ekl*gacont_hbr(ll,jj,i)
8050 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg1(ll)
8051 cgrad        enddo
8052 cgrad      enddo
8053 cgrad      do m=k+1,l-1
8054 cgrad        do ll=1,3
8055 cold          gradcorr6(ll,m)=gradcorr6(ll,m)+eel6*eij*gacont_hbr(ll,kk,k)
8056 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ggg2(ll)
8057 cgrad        enddo
8058 cgrad      enddo
8059 cgrad1112  continue
8060 cgrad      do m=i+2,j2
8061 cgrad        do ll=1,3
8062 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,1)
8063 cgrad        enddo
8064 cgrad      enddo
8065 cgrad      do m=k+2,l2
8066 cgrad        do ll=1,3
8067 cgrad          gradcorr6(ll,m)=gradcorr6(ll,m)+ekont*derx(ll,1,2)
8068 cgrad        enddo
8069 cgrad      enddo
8070 cd      do iii=1,nres-3
8071 cd        write (2,*) iii,g_corr6_loc(iii)
8072 cd      enddo
8073       eello6=ekont*eel6
8074 cd      write (2,*) 'ekont',ekont
8075 cd      write (iout,*) 'eello6',ekont*eel6
8076       return
8077       end
8078 c--------------------------------------------------------------------------
8079       double precision function eello6_graph1(i,j,k,l,imat,swap)
8080       implicit real*8 (a-h,o-z)
8081       include 'DIMENSIONS'
8082       include 'COMMON.IOUNITS'
8083       include 'COMMON.CHAIN'
8084       include 'COMMON.DERIV'
8085       include 'COMMON.INTERACT'
8086       include 'COMMON.CONTACTS'
8087       include 'COMMON.TORSION'
8088       include 'COMMON.VAR'
8089       include 'COMMON.GEO'
8090       double precision vv(2),vv1(2),pizda(2,2),auxmat(2,2),pizda1(2,2)
8091       logical swap
8092       logical lprn
8093       common /kutas/ lprn
8094 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8095 C                                                                              C
8096 C      Parallel       Antiparallel                                             C
8097 C                                                                              C
8098 C          o             o                                                     C
8099 C         /l\           /j\                                                    C
8100 C        /   \         /   \                                                   C
8101 C       /| o |         | o |\                                                  C
8102 C     \ j|/k\|  /   \  |/k\|l /                                                C
8103 C      \ /   \ /     \ /   \ /                                                 C
8104 C       o     o       o     o                                                  C
8105 C       i             i                                                        C
8106 C                                                                              C
8107 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8108       itk=itortyp(itype(k))
8109       s1= scalar2(AEAb1(1,2,imat),CUgb2(1,i))
8110       s2=-scalar2(AEAb2(1,1,imat),Ug2Db1t(1,k))
8111       s3= scalar2(AEAb2(1,1,imat),CUgb2(1,k))
8112       call transpose2(EUgC(1,1,k),auxmat(1,1))
8113       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8114       vv1(1)=pizda1(1,1)-pizda1(2,2)
8115       vv1(2)=pizda1(1,2)+pizda1(2,1)
8116       s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8117       vv(1)=AEAb1(1,2,imat)*b1(1,itk)-AEAb1(2,2,imat)*b1(2,itk)
8118       vv(2)=AEAb1(1,2,imat)*b1(2,itk)+AEAb1(2,2,imat)*b1(1,itk)
8119       s5=scalar2(vv(1),Dtobr2(1,i))
8120 cd      write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4', s4,' s5',s5
8121       eello6_graph1=-0.5d0*(s1+s2+s3+s4+s5)
8122       if (i.gt.1) g_corr6_loc(i-1)=g_corr6_loc(i-1)
8123      & -0.5d0*ekont*(scalar2(AEAb1(1,2,imat),CUgb2der(1,i))
8124      & -scalar2(AEAb2derg(1,2,1,imat),Ug2Db1t(1,k))
8125      & +scalar2(AEAb2derg(1,2,1,imat),CUgb2(1,k))
8126      & +0.5d0*scalar2(vv1(1),Dtobr2der(1,i))
8127      & +scalar2(vv(1),Dtobr2der(1,i)))
8128       call matmat2(AEAderg(1,1,imat),auxmat(1,1),pizda1(1,1))
8129       vv1(1)=pizda1(1,1)-pizda1(2,2)
8130       vv1(2)=pizda1(1,2)+pizda1(2,1)
8131       vv(1)=AEAb1derg(1,2,imat)*b1(1,itk)-AEAb1derg(2,2,imat)*b1(2,itk)
8132       vv(2)=AEAb1derg(1,2,imat)*b1(2,itk)+AEAb1derg(2,2,imat)*b1(1,itk)
8133       if (l.eq.j+1) then
8134         g_corr6_loc(l-1)=g_corr6_loc(l-1)
8135      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8136      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8137      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8138      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8139       else
8140         g_corr6_loc(j-1)=g_corr6_loc(j-1)
8141      & +ekont*(-0.5d0*(scalar2(AEAb1derg(1,2,imat),CUgb2(1,i))
8142      & -scalar2(AEAb2derg(1,1,1,imat),Ug2Db1t(1,k))
8143      & +scalar2(AEAb2derg(1,1,1,imat),CUgb2(1,k))
8144      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))+scalar2(vv(1),Dtobr2(1,i))))
8145       endif
8146       call transpose2(EUgCder(1,1,k),auxmat(1,1))
8147       call matmat2(AEA(1,1,imat),auxmat(1,1),pizda1(1,1))
8148       vv1(1)=pizda1(1,1)-pizda1(2,2)
8149       vv1(2)=pizda1(1,2)+pizda1(2,1)
8150       if (k.gt.1) g_corr6_loc(k-1)=g_corr6_loc(k-1)
8151      & +ekont*(-0.5d0*(-scalar2(AEAb2(1,1,imat),Ug2Db1tder(1,k))
8152      & +scalar2(AEAb2(1,1,imat),CUgb2der(1,k))
8153      & +0.5d0*scalar2(vv1(1),Dtobr2(1,i))))
8154       do iii=1,2
8155         if (swap) then
8156           ind=3-iii
8157         else
8158           ind=iii
8159         endif
8160         do kkk=1,5
8161           do lll=1,3
8162             s1= scalar2(AEAb1derx(1,lll,kkk,iii,2,imat),CUgb2(1,i))
8163             s2=-scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),Ug2Db1t(1,k))
8164             s3= scalar2(AEAb2derx(1,lll,kkk,iii,1,imat),CUgb2(1,k))
8165             call transpose2(EUgC(1,1,k),auxmat(1,1))
8166             call matmat2(AEAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8167      &        pizda1(1,1))
8168             vv1(1)=pizda1(1,1)-pizda1(2,2)
8169             vv1(2)=pizda1(1,2)+pizda1(2,1)
8170             s4=0.5d0*scalar2(vv1(1),Dtobr2(1,i))
8171             vv(1)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(1,itk)
8172      &       -AEAb1derx(2,lll,kkk,iii,2,imat)*b1(2,itk)
8173             vv(2)=AEAb1derx(1,lll,kkk,iii,2,imat)*b1(2,itk)
8174      &       +AEAb1derx(2,lll,kkk,iii,2,imat)*b1(1,itk)
8175             s5=scalar2(vv(1),Dtobr2(1,i))
8176             derx(lll,kkk,ind)=derx(lll,kkk,ind)-0.5d0*(s1+s2+s3+s4+s5)
8177           enddo
8178         enddo
8179       enddo
8180       return
8181       end
8182 c----------------------------------------------------------------------------
8183       double precision function eello6_graph2(i,j,k,l,jj,kk,swap)
8184       implicit real*8 (a-h,o-z)
8185       include 'DIMENSIONS'
8186       include 'COMMON.IOUNITS'
8187       include 'COMMON.CHAIN'
8188       include 'COMMON.DERIV'
8189       include 'COMMON.INTERACT'
8190       include 'COMMON.CONTACTS'
8191       include 'COMMON.TORSION'
8192       include 'COMMON.VAR'
8193       include 'COMMON.GEO'
8194       logical swap
8195       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8196      & auxvec1(2),auxvec2(2),auxmat1(2,2)
8197       logical lprn
8198       common /kutas/ lprn
8199 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8200 C                                                                              C
8201 C      Parallel       Antiparallel                                             C
8202 C                                                                              C
8203 C          o             o                                                     C
8204 C     \   /l\           /j\   /                                                C
8205 C      \ /   \         /   \ /                                                 C
8206 C       o| o |         | o |o                                                  C
8207 C     \ j|/k\|      \  |/k\|l                                                  C
8208 C      \ /   \       \ /   \                                                   C
8209 C       o             o                                                        C
8210 C       i             i                                                        C
8211 C                                                                              C
8212 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8213 cd      write (2,*) 'eello6_graph2: i,',i,' j',j,' k',k,' l',l
8214 C AL 7/4/01 s1 would occur in the sixth-order moment,
8215 C           but not in a cluster cumulant
8216 #ifdef MOMENT
8217       s1=dip(1,jj,i)*dip(1,kk,k)
8218 #endif
8219       call matvec2(ADtEA1(1,1,1),Ub2(1,k),auxvec(1))
8220       s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8221       call matvec2(ADtEA(1,1,2),Ub2(1,l),auxvec1(1))
8222       s3=-0.5d0*scalar2(Ub2(1,j),auxvec1(1))
8223       call transpose2(EUg(1,1,k),auxmat(1,1))
8224       call matmat2(ADtEA1(1,1,1),auxmat(1,1),pizda(1,1))
8225       vv(1)=pizda(1,1)-pizda(2,2)
8226       vv(2)=pizda(1,2)+pizda(2,1)
8227       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8228 cd      write (2,*) 'eello6_graph2:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8229 #ifdef MOMENT
8230       eello6_graph2=-(s1+s2+s3+s4)
8231 #else
8232       eello6_graph2=-(s2+s3+s4)
8233 #endif
8234 c      eello6_graph2=-s3
8235 C Derivatives in gamma(i-1)
8236       if (i.gt.1) then
8237 #ifdef MOMENT
8238         s1=dipderg(1,jj,i)*dip(1,kk,k)
8239 #endif
8240         s2=-0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8241         call matvec2(ADtEAderg(1,1,1,2),Ub2(1,l),auxvec2(1))
8242         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8243         s4=-0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8244 #ifdef MOMENT
8245         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8246 #else
8247         g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8248 #endif
8249 c        g_corr6_loc(i-1)=g_corr6_loc(i-1)-s3
8250       endif
8251 C Derivatives in gamma(k-1)
8252 #ifdef MOMENT
8253       s1=dip(1,jj,i)*dipderg(1,kk,k)
8254 #endif
8255       call matvec2(ADtEA1(1,1,1),Ub2der(1,k),auxvec2(1))
8256       s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8257       call matvec2(ADtEAderg(1,1,2,2),Ub2(1,l),auxvec2(1))
8258       s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8259       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8260       call matmat2(ADtEA1(1,1,1),auxmat1(1,1),pizda(1,1))
8261       vv(1)=pizda(1,1)-pizda(2,2)
8262       vv(2)=pizda(1,2)+pizda(2,1)
8263       s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8264 #ifdef MOMENT
8265       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8266 #else
8267       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8268 #endif
8269 c      g_corr6_loc(k-1)=g_corr6_loc(k-1)-s3
8270 C Derivatives in gamma(j-1) or gamma(l-1)
8271       if (j.gt.1) then
8272 #ifdef MOMENT
8273         s1=dipderg(3,jj,i)*dip(1,kk,k)
8274 #endif
8275         call matvec2(ADtEA1derg(1,1,1,1),Ub2(1,k),auxvec2(1))
8276         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8277         s3=-0.5d0*scalar2(Ub2der(1,j),auxvec1(1))
8278         call matmat2(ADtEA1derg(1,1,1,1),auxmat(1,1),pizda(1,1))
8279         vv(1)=pizda(1,1)-pizda(2,2)
8280         vv(2)=pizda(1,2)+pizda(2,1)
8281         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8282 #ifdef MOMENT
8283         if (swap) then
8284           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8285         else
8286           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8287         endif
8288 #endif
8289         g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s3+s4)
8290 c        g_corr6_loc(j-1)=g_corr6_loc(j-1)-s3
8291       endif
8292 C Derivatives in gamma(l-1) or gamma(j-1)
8293       if (l.gt.1) then
8294 #ifdef MOMENT
8295         s1=dip(1,jj,i)*dipderg(3,kk,k)
8296 #endif
8297         call matvec2(ADtEA1derg(1,1,2,1),Ub2(1,k),auxvec2(1))
8298         s2=-0.5d0*scalar2(Ub2(1,i),auxvec2(1))
8299         call matvec2(ADtEA(1,1,2),Ub2der(1,l),auxvec2(1))
8300         s3=-0.5d0*scalar2(Ub2(1,j),auxvec2(1))
8301         call matmat2(ADtEA1derg(1,1,2,1),auxmat(1,1),pizda(1,1))
8302         vv(1)=pizda(1,1)-pizda(2,2)
8303         vv(2)=pizda(1,2)+pizda(2,1)
8304         s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8305 #ifdef MOMENT
8306         if (swap) then
8307           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*s1
8308         else
8309           g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*s1
8310         endif
8311 #endif
8312         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s3+s4)
8313 c        g_corr6_loc(l-1)=g_corr6_loc(l-1)-s3
8314       endif
8315 C Cartesian derivatives.
8316       if (lprn) then
8317         write (2,*) 'In eello6_graph2'
8318         do iii=1,2
8319           write (2,*) 'iii=',iii
8320           do kkk=1,5
8321             write (2,*) 'kkk=',kkk
8322             do jjj=1,2
8323               write (2,'(3(2f10.5),5x)')
8324      &        ((ADtEA1derx(jjj,mmm,lll,kkk,iii,1),mmm=1,2),lll=1,3)
8325             enddo
8326           enddo
8327         enddo
8328       endif
8329       do iii=1,2
8330         do kkk=1,5
8331           do lll=1,3
8332 #ifdef MOMENT
8333             if (iii.eq.1) then
8334               s1=dipderx(lll,kkk,1,jj,i)*dip(1,kk,k)
8335             else
8336               s1=dip(1,jj,i)*dipderx(lll,kkk,1,kk,k)
8337             endif
8338 #endif
8339             call matvec2(ADtEA1derx(1,1,lll,kkk,iii,1),Ub2(1,k),
8340      &        auxvec(1))
8341             s2=-0.5d0*scalar2(Ub2(1,i),auxvec(1))
8342             call matvec2(ADtEAderx(1,1,lll,kkk,iii,2),Ub2(1,l),
8343      &        auxvec(1))
8344             s3=-0.5d0*scalar2(Ub2(1,j),auxvec(1))
8345             call transpose2(EUg(1,1,k),auxmat(1,1))
8346             call matmat2(ADtEA1derx(1,1,lll,kkk,iii,1),auxmat(1,1),
8347      &        pizda(1,1))
8348             vv(1)=pizda(1,1)-pizda(2,2)
8349             vv(2)=pizda(1,2)+pizda(2,1)
8350             s4=-0.25d0*scalar2(vv(1),Dtobr2(1,i))
8351 cd            write (2,*) 's1',s1,' s2',s2,' s3',s3,' s4',s4
8352 #ifdef MOMENT
8353             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8354 #else
8355             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8356 #endif
8357             if (swap) then
8358               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8359             else
8360               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8361             endif
8362           enddo
8363         enddo
8364       enddo
8365       return
8366       end
8367 c----------------------------------------------------------------------------
8368       double precision function eello6_graph3(i,j,k,l,jj,kk,swap)
8369       implicit real*8 (a-h,o-z)
8370       include 'DIMENSIONS'
8371       include 'COMMON.IOUNITS'
8372       include 'COMMON.CHAIN'
8373       include 'COMMON.DERIV'
8374       include 'COMMON.INTERACT'
8375       include 'COMMON.CONTACTS'
8376       include 'COMMON.TORSION'
8377       include 'COMMON.VAR'
8378       include 'COMMON.GEO'
8379       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2)
8380       logical swap
8381 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8382 C                                                                              C
8383 C      Parallel       Antiparallel                                             C
8384 C                                                                              C
8385 C          o             o                                                     C
8386 C         /l\   /   \   /j\                                                    C
8387 C        /   \ /     \ /   \                                                   C
8388 C       /| o |o       o| o |\                                                  C
8389 C       j|/k\|  /      |/k\|l /                                                C
8390 C        /   \ /       /   \ /                                                 C
8391 C       /     o       /     o                                                  C
8392 C       i             i                                                        C
8393 C                                                                              C
8394 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8395 C
8396 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8397 C           energy moment and not to the cluster cumulant.
8398       iti=itortyp(itype(i))
8399       if (j.lt.nres-1) then
8400         itj1=itortyp(itype(j+1))
8401       else
8402         itj1=ntortyp+1
8403       endif
8404       itk=itortyp(itype(k))
8405       itk1=itortyp(itype(k+1))
8406       if (l.lt.nres-1) then
8407         itl1=itortyp(itype(l+1))
8408       else
8409         itl1=ntortyp+1
8410       endif
8411 #ifdef MOMENT
8412       s1=dip(4,jj,i)*dip(4,kk,k)
8413 #endif
8414       call matvec2(AECA(1,1,1),b1(1,itk1),auxvec(1))
8415       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8416       call matvec2(AECA(1,1,2),b1(1,itl1),auxvec(1))
8417       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8418       call transpose2(EE(1,1,itk),auxmat(1,1))
8419       call matmat2(auxmat(1,1),AECA(1,1,1),pizda(1,1))
8420       vv(1)=pizda(1,1)+pizda(2,2)
8421       vv(2)=pizda(2,1)-pizda(1,2)
8422       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8423 cd      write (2,*) 'eello6_graph3:','s1',s1,' s2',s2,' s3',s3,' s4',s4,
8424 cd     & "sum",-(s2+s3+s4)
8425 #ifdef MOMENT
8426       eello6_graph3=-(s1+s2+s3+s4)
8427 #else
8428       eello6_graph3=-(s2+s3+s4)
8429 #endif
8430 c      eello6_graph3=-s4
8431 C Derivatives in gamma(k-1)
8432       call matvec2(AECAderg(1,1,2),b1(1,itl1),auxvec(1))
8433       s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8434       s4=-0.25d0*scalar2(vv(1),Ctobrder(1,k))
8435       g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s3+s4)
8436 C Derivatives in gamma(l-1)
8437       call matvec2(AECAderg(1,1,1),b1(1,itk1),auxvec(1))
8438       s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8439       call matmat2(auxmat(1,1),AECAderg(1,1,1),pizda(1,1))
8440       vv(1)=pizda(1,1)+pizda(2,2)
8441       vv(2)=pizda(2,1)-pizda(1,2)
8442       s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8443       g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8444 C Cartesian derivatives.
8445       do iii=1,2
8446         do kkk=1,5
8447           do lll=1,3
8448 #ifdef MOMENT
8449             if (iii.eq.1) then
8450               s1=dipderx(lll,kkk,4,jj,i)*dip(4,kk,k)
8451             else
8452               s1=dip(4,jj,i)*dipderx(lll,kkk,4,kk,k)
8453             endif
8454 #endif
8455             call matvec2(AECAderx(1,1,lll,kkk,iii,1),b1(1,itk1),
8456      &        auxvec(1))
8457             s2=0.5d0*scalar2(b1(1,itk),auxvec(1))
8458             call matvec2(AECAderx(1,1,lll,kkk,iii,2),b1(1,itl1),
8459      &        auxvec(1))
8460             s3=0.5d0*scalar2(b1(1,itj1),auxvec(1))
8461             call matmat2(auxmat(1,1),AECAderx(1,1,lll,kkk,iii,1),
8462      &        pizda(1,1))
8463             vv(1)=pizda(1,1)+pizda(2,2)
8464             vv(2)=pizda(2,1)-pizda(1,2)
8465             s4=-0.25d0*scalar2(vv(1),Ctobr(1,k))
8466 #ifdef MOMENT
8467             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8468 #else
8469             derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8470 #endif
8471             if (swap) then
8472               derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8473             else
8474               derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8475             endif
8476 c            derx(lll,kkk,iii)=derx(lll,kkk,iii)-s4
8477           enddo
8478         enddo
8479       enddo
8480       return
8481       end
8482 c----------------------------------------------------------------------------
8483       double precision function eello6_graph4(i,j,k,l,jj,kk,imat,swap)
8484       implicit real*8 (a-h,o-z)
8485       include 'DIMENSIONS'
8486       include 'COMMON.IOUNITS'
8487       include 'COMMON.CHAIN'
8488       include 'COMMON.DERIV'
8489       include 'COMMON.INTERACT'
8490       include 'COMMON.CONTACTS'
8491       include 'COMMON.TORSION'
8492       include 'COMMON.VAR'
8493       include 'COMMON.GEO'
8494       include 'COMMON.FFIELD'
8495       double precision vv(2),pizda(2,2),auxmat(2,2),auxvec(2),
8496      & auxvec1(2),auxmat1(2,2)
8497       logical swap
8498 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8499 C                                                                              C
8500 C      Parallel       Antiparallel                                             C
8501 C                                                                              C
8502 C          o             o                                                     C
8503 C         /l\   /   \   /j\                                                    C
8504 C        /   \ /     \ /   \                                                   C
8505 C       /| o |o       o| o |\                                                  C
8506 C     \ j|/k\|      \  |/k\|l                                                  C
8507 C      \ /   \       \ /   \                                                   C
8508 C       o     \       o     \                                                  C
8509 C       i             i                                                        C
8510 C                                                                              C
8511 CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
8512 C
8513 C 4/7/01 AL Component s1 was removed, because it pertains to the respective
8514 C           energy moment and not to the cluster cumulant.
8515 cd      write (2,*) 'eello_graph4: wturn6',wturn6
8516       iti=itortyp(itype(i))
8517       itj=itortyp(itype(j))
8518       if (j.lt.nres-1) then
8519         itj1=itortyp(itype(j+1))
8520       else
8521         itj1=ntortyp+1
8522       endif
8523       itk=itortyp(itype(k))
8524       if (k.lt.nres-1) then
8525         itk1=itortyp(itype(k+1))
8526       else
8527         itk1=ntortyp+1
8528       endif
8529       itl=itortyp(itype(l))
8530       if (l.lt.nres-1) then
8531         itl1=itortyp(itype(l+1))
8532       else
8533         itl1=ntortyp+1
8534       endif
8535 cd      write (2,*) 'eello6_graph4:','i',i,' j',j,' k',k,' l',l
8536 cd      write (2,*) 'iti',iti,' itj',itj,' itj1',itj1,' itk',itk,
8537 cd     & ' itl',itl,' itl1',itl1
8538 #ifdef MOMENT
8539       if (imat.eq.1) then
8540         s1=dip(3,jj,i)*dip(3,kk,k)
8541       else
8542         s1=dip(2,jj,j)*dip(2,kk,l)
8543       endif
8544 #endif
8545       call matvec2(AECA(1,1,imat),Ub2(1,k),auxvec(1))
8546       s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8547       if (j.eq.l+1) then
8548         call matvec2(ADtEA1(1,1,3-imat),b1(1,itj1),auxvec1(1))
8549         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8550       else
8551         call matvec2(ADtEA1(1,1,3-imat),b1(1,itl1),auxvec1(1))
8552         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8553       endif
8554       call transpose2(EUg(1,1,k),auxmat(1,1))
8555       call matmat2(AECA(1,1,imat),auxmat(1,1),pizda(1,1))
8556       vv(1)=pizda(1,1)-pizda(2,2)
8557       vv(2)=pizda(2,1)+pizda(1,2)
8558       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8559 cd      write (2,*) 'eello6_graph4:','s1',s1,' s2',s2,' s3',s3,' s4',s4
8560 #ifdef MOMENT
8561       eello6_graph4=-(s1+s2+s3+s4)
8562 #else
8563       eello6_graph4=-(s2+s3+s4)
8564 #endif
8565 C Derivatives in gamma(i-1)
8566       if (i.gt.1) then
8567 #ifdef MOMENT
8568         if (imat.eq.1) then
8569           s1=dipderg(2,jj,i)*dip(3,kk,k)
8570         else
8571           s1=dipderg(4,jj,j)*dip(2,kk,l)
8572         endif
8573 #endif
8574         s2=0.5d0*scalar2(Ub2der(1,i),auxvec(1))
8575         if (j.eq.l+1) then
8576           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itj1),auxvec1(1))
8577           s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8578         else
8579           call matvec2(ADtEA1derg(1,1,1,3-imat),b1(1,itl1),auxvec1(1))
8580           s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8581         endif
8582         s4=0.25d0*scalar2(vv(1),Dtobr2der(1,i))
8583         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8584 cd          write (2,*) 'turn6 derivatives'
8585 #ifdef MOMENT
8586           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s1+s2+s3+s4)
8587 #else
8588           gel_loc_turn6(i-1)=gel_loc_turn6(i-1)-ekont*(s2+s3+s4)
8589 #endif
8590         else
8591 #ifdef MOMENT
8592           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s1+s2+s3+s4)
8593 #else
8594           g_corr6_loc(i-1)=g_corr6_loc(i-1)-ekont*(s2+s3+s4)
8595 #endif
8596         endif
8597       endif
8598 C Derivatives in gamma(k-1)
8599 #ifdef MOMENT
8600       if (imat.eq.1) then
8601         s1=dip(3,jj,i)*dipderg(2,kk,k)
8602       else
8603         s1=dip(2,jj,j)*dipderg(4,kk,l)
8604       endif
8605 #endif
8606       call matvec2(AECA(1,1,imat),Ub2der(1,k),auxvec1(1))
8607       s2=0.5d0*scalar2(Ub2(1,i),auxvec1(1))
8608       if (j.eq.l+1) then
8609         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itj1),auxvec1(1))
8610         s3=-0.5d0*scalar2(b1(1,itj),auxvec1(1))
8611       else
8612         call matvec2(ADtEA1derg(1,1,2,3-imat),b1(1,itl1),auxvec1(1))
8613         s3=-0.5d0*scalar2(b1(1,itl),auxvec1(1))
8614       endif
8615       call transpose2(EUgder(1,1,k),auxmat1(1,1))
8616       call matmat2(AECA(1,1,imat),auxmat1(1,1),pizda(1,1))
8617       vv(1)=pizda(1,1)-pizda(2,2)
8618       vv(2)=pizda(2,1)+pizda(1,2)
8619       s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8620       if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8621 #ifdef MOMENT
8622         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s1+s2+s3+s4)
8623 #else
8624         gel_loc_turn6(k-1)=gel_loc_turn6(k-1)-ekont*(s2+s3+s4)
8625 #endif
8626       else
8627 #ifdef MOMENT
8628         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s1+s2+s3+s4)
8629 #else
8630         g_corr6_loc(k-1)=g_corr6_loc(k-1)-ekont*(s2+s3+s4)
8631 #endif
8632       endif
8633 C Derivatives in gamma(j-1) or gamma(l-1)
8634       if (l.eq.j+1 .and. l.gt.1) then
8635         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8636         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8637         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8638         vv(1)=pizda(1,1)-pizda(2,2)
8639         vv(2)=pizda(2,1)+pizda(1,2)
8640         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8641         g_corr6_loc(l-1)=g_corr6_loc(l-1)-ekont*(s2+s4)
8642       else if (j.gt.1) then
8643         call matvec2(AECAderg(1,1,imat),Ub2(1,k),auxvec(1))
8644         s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8645         call matmat2(AECAderg(1,1,imat),auxmat(1,1),pizda(1,1))
8646         vv(1)=pizda(1,1)-pizda(2,2)
8647         vv(2)=pizda(2,1)+pizda(1,2)
8648         s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8649         if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8650           gel_loc_turn6(j-1)=gel_loc_turn6(j-1)-ekont*(s2+s4)
8651         else
8652           g_corr6_loc(j-1)=g_corr6_loc(j-1)-ekont*(s2+s4)
8653         endif
8654       endif
8655 C Cartesian derivatives.
8656       do iii=1,2
8657         do kkk=1,5
8658           do lll=1,3
8659 #ifdef MOMENT
8660             if (iii.eq.1) then
8661               if (imat.eq.1) then
8662                 s1=dipderx(lll,kkk,3,jj,i)*dip(3,kk,k)
8663               else
8664                 s1=dipderx(lll,kkk,2,jj,j)*dip(2,kk,l)
8665               endif
8666             else
8667               if (imat.eq.1) then
8668                 s1=dip(3,jj,i)*dipderx(lll,kkk,3,kk,k)
8669               else
8670                 s1=dip(2,jj,j)*dipderx(lll,kkk,2,kk,l)
8671               endif
8672             endif
8673 #endif
8674             call matvec2(AECAderx(1,1,lll,kkk,iii,imat),Ub2(1,k),
8675      &        auxvec(1))
8676             s2=0.5d0*scalar2(Ub2(1,i),auxvec(1))
8677             if (j.eq.l+1) then
8678               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8679      &          b1(1,itj1),auxvec(1))
8680               s3=-0.5d0*scalar2(b1(1,itj),auxvec(1))
8681             else
8682               call matvec2(ADtEA1derx(1,1,lll,kkk,iii,3-imat),
8683      &          b1(1,itl1),auxvec(1))
8684               s3=-0.5d0*scalar2(b1(1,itl),auxvec(1))
8685             endif
8686             call matmat2(AECAderx(1,1,lll,kkk,iii,imat),auxmat(1,1),
8687      &        pizda(1,1))
8688             vv(1)=pizda(1,1)-pizda(2,2)
8689             vv(2)=pizda(2,1)+pizda(1,2)
8690             s4=0.25d0*scalar2(vv(1),Dtobr2(1,i))
8691             if (swap) then
8692               if (wturn6.gt.0.0d0 .and. k.eq.l+4 .and. i.eq.j+2) then
8693 #ifdef MOMENT
8694                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8695      &             -(s1+s2+s4)
8696 #else
8697                 derx_turn(lll,kkk,3-iii)=derx_turn(lll,kkk,3-iii)
8698      &             -(s2+s4)
8699 #endif
8700                 derx_turn(lll,kkk,iii)=derx_turn(lll,kkk,iii)-s3
8701               else
8702 #ifdef MOMENT
8703                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s1+s2+s4)
8704 #else
8705                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-(s2+s4)
8706 #endif
8707                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8708               endif
8709             else
8710 #ifdef MOMENT
8711               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s1+s2+s4)
8712 #else
8713               derx(lll,kkk,iii)=derx(lll,kkk,iii)-(s2+s4)
8714 #endif
8715               if (l.eq.j+1) then
8716                 derx(lll,kkk,iii)=derx(lll,kkk,iii)-s3
8717               else
8718                 derx(lll,kkk,3-iii)=derx(lll,kkk,3-iii)-s3
8719               endif
8720             endif
8721           enddo
8722         enddo
8723       enddo
8724       return
8725       end
8726 c----------------------------------------------------------------------------
8727       double precision function eello_turn6(i,jj,kk)
8728       implicit real*8 (a-h,o-z)
8729       include 'DIMENSIONS'
8730       include 'COMMON.IOUNITS'
8731       include 'COMMON.CHAIN'
8732       include 'COMMON.DERIV'
8733       include 'COMMON.INTERACT'
8734       include 'COMMON.CONTACTS'
8735       include 'COMMON.TORSION'
8736       include 'COMMON.VAR'
8737       include 'COMMON.GEO'
8738       double precision vtemp1(2),vtemp2(2),vtemp3(2),vtemp4(2),
8739      &  atemp(2,2),auxmat(2,2),achuj_temp(2,2),gtemp(2,2),gvec(2),
8740      &  ggg1(3),ggg2(3)
8741       double precision vtemp1d(2),vtemp2d(2),vtemp3d(2),vtemp4d(2),
8742      &  atempd(2,2),auxmatd(2,2),achuj_tempd(2,2),gtempd(2,2),gvecd(2)
8743 C 4/7/01 AL Components s1, s8, and s13 were removed, because they pertain to
8744 C           the respective energy moment and not to the cluster cumulant.
8745       s1=0.0d0
8746       s8=0.0d0
8747       s13=0.0d0
8748 c
8749       eello_turn6=0.0d0
8750       j=i+4
8751       k=i+1
8752       l=i+3
8753       iti=itortyp(itype(i))
8754       itk=itortyp(itype(k))
8755       itk1=itortyp(itype(k+1))
8756       itl=itortyp(itype(l))
8757       itj=itortyp(itype(j))
8758 cd      write (2,*) 'itk',itk,' itk1',itk1,' itl',itl,' itj',itj
8759 cd      write (2,*) 'i',i,' k',k,' j',j,' l',l
8760 cd      if (i.ne.1 .or. j.ne.3 .or. k.ne.2 .or. l.ne.4) then
8761 cd        eello6=0.0d0
8762 cd        return
8763 cd      endif
8764 cd      write (iout,*)
8765 cd     &   'EELLO6: Contacts have occurred for peptide groups',i,j,
8766 cd     &   ' and',k,l
8767 cd      call checkint_turn6(i,jj,kk,eel_turn6_num)
8768       do iii=1,2
8769         do kkk=1,5
8770           do lll=1,3
8771             derx_turn(lll,kkk,iii)=0.0d0
8772           enddo
8773         enddo
8774       enddo
8775 cd      eij=1.0d0
8776 cd      ekl=1.0d0
8777 cd      ekont=1.0d0
8778       eello6_5=eello6_graph4(l,k,j,i,kk,jj,2,.true.)
8779 cd      eello6_5=0.0d0
8780 cd      write (2,*) 'eello6_5',eello6_5
8781 #ifdef MOMENT
8782       call transpose2(AEA(1,1,1),auxmat(1,1))
8783       call matmat2(EUg(1,1,i+1),auxmat(1,1),auxmat(1,1))
8784       ss1=scalar2(Ub2(1,i+2),b1(1,itl))
8785       s1 = (auxmat(1,1)+auxmat(2,2))*ss1
8786 #endif
8787       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8788       call matvec2(AEA(1,1,1),vtemp1(1),vtemp1(1))
8789       s2 = scalar2(b1(1,itk),vtemp1(1))
8790 #ifdef MOMENT
8791       call transpose2(AEA(1,1,2),atemp(1,1))
8792       call matmat2(atemp(1,1),EUg(1,1,i+4),atemp(1,1))
8793       call matvec2(Ug2(1,1,i+2),dd(1,1,itk1),vtemp2(1))
8794       s8 = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8795 #endif
8796       call matmat2(EUg(1,1,i+3),AEA(1,1,2),auxmat(1,1))
8797       call matvec2(auxmat(1,1),Ub2(1,i+4),vtemp3(1))
8798       s12 = scalar2(Ub2(1,i+2),vtemp3(1))
8799 #ifdef MOMENT
8800       call transpose2(a_chuj(1,1,kk,i+1),achuj_temp(1,1))
8801       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtemp(1,1))
8802       call matmat2(gtemp(1,1),EUg(1,1,i+3),gtemp(1,1))
8803       call matvec2(a_chuj(1,1,jj,i),Ub2(1,i+4),vtemp4(1))
8804       ss13 = scalar2(b1(1,itk),vtemp4(1))
8805       s13 = (gtemp(1,1)+gtemp(2,2))*ss13
8806 #endif
8807 c      write (2,*) 's1,s2,s8,s12,s13',s1,s2,s8,s12,s13
8808 c      s1=0.0d0
8809 c      s2=0.0d0
8810 c      s8=0.0d0
8811 c      s12=0.0d0
8812 c      s13=0.0d0
8813       eel_turn6 = eello6_5 - 0.5d0*(s1+s2+s12+s8+s13)
8814 C Derivatives in gamma(i+2)
8815       s1d =0.0d0
8816       s8d =0.0d0
8817 #ifdef MOMENT
8818       call transpose2(AEA(1,1,1),auxmatd(1,1))
8819       call matmat2(EUgder(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8820       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8821       call transpose2(AEAderg(1,1,2),atempd(1,1))
8822       call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8823       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8824 #endif
8825       call matmat2(EUg(1,1,i+3),AEAderg(1,1,2),auxmatd(1,1))
8826       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8827       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8828 c      s1d=0.0d0
8829 c      s2d=0.0d0
8830 c      s8d=0.0d0
8831 c      s12d=0.0d0
8832 c      s13d=0.0d0
8833       gel_loc_turn6(i)=gel_loc_turn6(i)-0.5d0*ekont*(s1d+s8d+s12d)
8834 C Derivatives in gamma(i+3)
8835 #ifdef MOMENT
8836       call transpose2(AEA(1,1,1),auxmatd(1,1))
8837       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8838       ss1d=scalar2(Ub2der(1,i+2),b1(1,itl))
8839       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1d
8840 #endif
8841       call matvec2(EUgder(1,1,i+2),b1(1,itl),vtemp1d(1))
8842       call matvec2(AEA(1,1,1),vtemp1d(1),vtemp1d(1))
8843       s2d = scalar2(b1(1,itk),vtemp1d(1))
8844 #ifdef MOMENT
8845       call matvec2(Ug2der(1,1,i+2),dd(1,1,itk1),vtemp2d(1))
8846       s8d = -(atemp(1,1)+atemp(2,2))*scalar2(cc(1,1,itl),vtemp2d(1))
8847 #endif
8848       s12d = scalar2(Ub2der(1,i+2),vtemp3(1))
8849 #ifdef MOMENT
8850       call matmat2(achuj_temp(1,1),EUgder(1,1,i+2),gtempd(1,1))
8851       call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8852       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8853 #endif
8854 c      s1d=0.0d0
8855 c      s2d=0.0d0
8856 c      s8d=0.0d0
8857 c      s12d=0.0d0
8858 c      s13d=0.0d0
8859 #ifdef MOMENT
8860       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8861      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8862 #else
8863       gel_loc_turn6(i+1)=gel_loc_turn6(i+1)
8864      &               -0.5d0*ekont*(s2d+s12d)
8865 #endif
8866 C Derivatives in gamma(i+4)
8867       call matmat2(EUgder(1,1,i+3),AEA(1,1,2),auxmatd(1,1))
8868       call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8869       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8870 #ifdef MOMENT
8871       call matmat2(achuj_temp(1,1),EUg(1,1,i+2),gtempd(1,1))
8872       call matmat2(gtempd(1,1),EUgder(1,1,i+3),gtempd(1,1))
8873       s13d = (gtempd(1,1)+gtempd(2,2))*ss13
8874 #endif
8875 c      s1d=0.0d0
8876 c      s2d=0.0d0
8877 c      s8d=0.0d0
8878 C      s12d=0.0d0
8879 c      s13d=0.0d0
8880 #ifdef MOMENT
8881       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d+s13d)
8882 #else
8883       gel_loc_turn6(i+2)=gel_loc_turn6(i+2)-0.5d0*ekont*(s12d)
8884 #endif
8885 C Derivatives in gamma(i+5)
8886 #ifdef MOMENT
8887       call transpose2(AEAderg(1,1,1),auxmatd(1,1))
8888       call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8889       s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8890 #endif
8891       call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1d(1))
8892       call matvec2(AEAderg(1,1,1),vtemp1d(1),vtemp1d(1))
8893       s2d = scalar2(b1(1,itk),vtemp1d(1))
8894 #ifdef MOMENT
8895       call transpose2(AEA(1,1,2),atempd(1,1))
8896       call matmat2(atempd(1,1),EUgder(1,1,i+4),atempd(1,1))
8897       s8d = -(atempd(1,1)+atempd(2,2))*scalar2(cc(1,1,itl),vtemp2(1))
8898 #endif
8899       call matvec2(auxmat(1,1),Ub2der(1,i+4),vtemp3d(1))
8900       s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8901 #ifdef MOMENT
8902       call matvec2(a_chuj(1,1,jj,i),Ub2der(1,i+4),vtemp4d(1))
8903       ss13d = scalar2(b1(1,itk),vtemp4d(1))
8904       s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8905 #endif
8906 c      s1d=0.0d0
8907 c      s2d=0.0d0
8908 c      s8d=0.0d0
8909 c      s12d=0.0d0
8910 c      s13d=0.0d0
8911 #ifdef MOMENT
8912       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8913      &               -0.5d0*ekont*(s1d+s2d+s8d+s12d+s13d)
8914 #else
8915       gel_loc_turn6(i+3)=gel_loc_turn6(i+3)
8916      &               -0.5d0*ekont*(s2d+s12d)
8917 #endif
8918 C Cartesian derivatives
8919       do iii=1,2
8920         do kkk=1,5
8921           do lll=1,3
8922 #ifdef MOMENT
8923             call transpose2(AEAderx(1,1,lll,kkk,iii,1),auxmatd(1,1))
8924             call matmat2(EUg(1,1,i+1),auxmatd(1,1),auxmatd(1,1))
8925             s1d = (auxmatd(1,1)+auxmatd(2,2))*ss1
8926 #endif
8927             call matvec2(EUg(1,1,i+2),b1(1,itl),vtemp1(1))
8928             call matvec2(AEAderx(1,1,lll,kkk,iii,1),vtemp1(1),
8929      &          vtemp1d(1))
8930             s2d = scalar2(b1(1,itk),vtemp1d(1))
8931 #ifdef MOMENT
8932             call transpose2(AEAderx(1,1,lll,kkk,iii,2),atempd(1,1))
8933             call matmat2(atempd(1,1),EUg(1,1,i+4),atempd(1,1))
8934             s8d = -(atempd(1,1)+atempd(2,2))*
8935      &           scalar2(cc(1,1,itl),vtemp2(1))
8936 #endif
8937             call matmat2(EUg(1,1,i+3),AEAderx(1,1,lll,kkk,iii,2),
8938      &           auxmatd(1,1))
8939             call matvec2(auxmatd(1,1),Ub2(1,i+4),vtemp3d(1))
8940             s12d = scalar2(Ub2(1,i+2),vtemp3d(1))
8941 c      s1d=0.0d0
8942 c      s2d=0.0d0
8943 c      s8d=0.0d0
8944 c      s12d=0.0d0
8945 c      s13d=0.0d0
8946 #ifdef MOMENT
8947             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8948      &        - 0.5d0*(s1d+s2d)
8949 #else
8950             derx_turn(lll,kkk,iii) = derx_turn(lll,kkk,iii)
8951      &        - 0.5d0*s2d
8952 #endif
8953 #ifdef MOMENT
8954             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8955      &        - 0.5d0*(s8d+s12d)
8956 #else
8957             derx_turn(lll,kkk,3-iii) = derx_turn(lll,kkk,3-iii)
8958      &        - 0.5d0*s12d
8959 #endif
8960           enddo
8961         enddo
8962       enddo
8963 #ifdef MOMENT
8964       do kkk=1,5
8965         do lll=1,3
8966           call transpose2(a_chuj_der(1,1,lll,kkk,kk,i+1),
8967      &      achuj_tempd(1,1))
8968           call matmat2(achuj_tempd(1,1),EUg(1,1,i+2),gtempd(1,1))
8969           call matmat2(gtempd(1,1),EUg(1,1,i+3),gtempd(1,1))
8970           s13d=(gtempd(1,1)+gtempd(2,2))*ss13
8971           derx_turn(lll,kkk,2) = derx_turn(lll,kkk,2)-0.5d0*s13d
8972           call matvec2(a_chuj_der(1,1,lll,kkk,jj,i),Ub2(1,i+4),
8973      &      vtemp4d(1))
8974           ss13d = scalar2(b1(1,itk),vtemp4d(1))
8975           s13d = (gtemp(1,1)+gtemp(2,2))*ss13d
8976           derx_turn(lll,kkk,1) = derx_turn(lll,kkk,1)-0.5d0*s13d
8977         enddo
8978       enddo
8979 #endif
8980 cd      write(iout,*) 'eel6_turn6',eel_turn6,' eel_turn6_num',
8981 cd     &  16*eel_turn6_num
8982 cd      goto 1112
8983       if (j.lt.nres-1) then
8984         j1=j+1
8985         j2=j-1
8986       else
8987         j1=j-1
8988         j2=j-2
8989       endif
8990       if (l.lt.nres-1) then
8991         l1=l+1
8992         l2=l-1
8993       else
8994         l1=l-1
8995         l2=l-2
8996       endif
8997       do ll=1,3
8998 cgrad        ggg1(ll)=eel_turn6*g_contij(ll,1)
8999 cgrad        ggg2(ll)=eel_turn6*g_contij(ll,2)
9000 cgrad        ghalf=0.5d0*ggg1(ll)
9001 cd        ghalf=0.0d0
9002         gturn6ij=eel_turn6*g_contij(ll,1)+ekont*derx_turn(ll,1,1)
9003         gturn6kl=eel_turn6*g_contij(ll,2)+ekont*derx_turn(ll,1,2)
9004         gcorr6_turn(ll,i)=gcorr6_turn(ll,i)!+ghalf
9005      &    +ekont*derx_turn(ll,2,1)
9006         gcorr6_turn(ll,i+1)=gcorr6_turn(ll,i+1)+ekont*derx_turn(ll,3,1)
9007         gcorr6_turn(ll,j)=gcorr6_turn(ll,j)!+ghalf
9008      &    +ekont*derx_turn(ll,4,1)
9009         gcorr6_turn(ll,j1)=gcorr6_turn(ll,j1)+ekont*derx_turn(ll,5,1)
9010         gcorr6_turn_long(ll,j)=gcorr6_turn_long(ll,j)+gturn6ij
9011         gcorr6_turn_long(ll,i)=gcorr6_turn_long(ll,i)-gturn6ij
9012 cgrad        ghalf=0.5d0*ggg2(ll)
9013 cd        ghalf=0.0d0
9014         gcorr6_turn(ll,k)=gcorr6_turn(ll,k)!+ghalf
9015      &    +ekont*derx_turn(ll,2,2)
9016         gcorr6_turn(ll,k+1)=gcorr6_turn(ll,k+1)+ekont*derx_turn(ll,3,2)
9017         gcorr6_turn(ll,l)=gcorr6_turn(ll,l)!+ghalf
9018      &    +ekont*derx_turn(ll,4,2)
9019         gcorr6_turn(ll,l1)=gcorr6_turn(ll,l1)+ekont*derx_turn(ll,5,2)
9020         gcorr6_turn_long(ll,l)=gcorr6_turn_long(ll,l)+gturn6kl
9021         gcorr6_turn_long(ll,k)=gcorr6_turn_long(ll,k)-gturn6kl
9022       enddo
9023 cd      goto 1112
9024 cgrad      do m=i+1,j-1
9025 cgrad        do ll=1,3
9026 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg1(ll)
9027 cgrad        enddo
9028 cgrad      enddo
9029 cgrad      do m=k+1,l-1
9030 cgrad        do ll=1,3
9031 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ggg2(ll)
9032 cgrad        enddo
9033 cgrad      enddo
9034 cgrad1112  continue
9035 cgrad      do m=i+2,j2
9036 cgrad        do ll=1,3
9037 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,1)
9038 cgrad        enddo
9039 cgrad      enddo
9040 cgrad      do m=k+2,l2
9041 cgrad        do ll=1,3
9042 cgrad          gcorr6_turn(ll,m)=gcorr6_turn(ll,m)+ekont*derx_turn(ll,1,2)
9043 cgrad        enddo
9044 cgrad      enddo
9045 cd      do iii=1,nres-3
9046 cd        write (2,*) iii,g_corr6_loc(iii)
9047 cd      enddo
9048       eello_turn6=ekont*eel_turn6
9049 cd      write (2,*) 'ekont',ekont
9050 cd      write (2,*) 'eel_turn6',ekont*eel_turn6
9051       return
9052       end
9053
9054 C-----------------------------------------------------------------------------
9055       double precision function scalar(u,v)
9056 !DIR$ INLINEALWAYS scalar
9057 #ifndef OSF
9058 cDEC$ ATTRIBUTES FORCEINLINE::scalar
9059 #endif
9060       implicit none
9061       double precision u(3),v(3)
9062 cd      double precision sc
9063 cd      integer i
9064 cd      sc=0.0d0
9065 cd      do i=1,3
9066 cd        sc=sc+u(i)*v(i)
9067 cd      enddo
9068 cd      scalar=sc
9069
9070       scalar=u(1)*v(1)+u(2)*v(2)+u(3)*v(3)
9071       return
9072       end
9073 crc-------------------------------------------------
9074       SUBROUTINE MATVEC2(A1,V1,V2)
9075 !DIR$ INLINEALWAYS MATVEC2
9076 #ifndef OSF
9077 cDEC$ ATTRIBUTES FORCEINLINE::MATVEC2
9078 #endif
9079       implicit real*8 (a-h,o-z)
9080       include 'DIMENSIONS'
9081       DIMENSION A1(2,2),V1(2),V2(2)
9082 c      DO 1 I=1,2
9083 c        VI=0.0
9084 c        DO 3 K=1,2
9085 c    3     VI=VI+A1(I,K)*V1(K)
9086 c        Vaux(I)=VI
9087 c    1 CONTINUE
9088
9089       vaux1=a1(1,1)*v1(1)+a1(1,2)*v1(2)
9090       vaux2=a1(2,1)*v1(1)+a1(2,2)*v1(2)
9091
9092       v2(1)=vaux1
9093       v2(2)=vaux2
9094       END
9095 C---------------------------------------
9096       SUBROUTINE MATMAT2(A1,A2,A3)
9097 #ifndef OSF
9098 cDEC$ ATTRIBUTES FORCEINLINE::MATMAT2
9099 #endif
9100       implicit real*8 (a-h,o-z)
9101       include 'DIMENSIONS'
9102       DIMENSION A1(2,2),A2(2,2),A3(2,2)
9103 c      DIMENSION AI3(2,2)
9104 c        DO  J=1,2
9105 c          A3IJ=0.0
9106 c          DO K=1,2
9107 c           A3IJ=A3IJ+A1(I,K)*A2(K,J)
9108 c          enddo
9109 c          A3(I,J)=A3IJ
9110 c       enddo
9111 c      enddo
9112
9113       ai3_11=a1(1,1)*a2(1,1)+a1(1,2)*a2(2,1)
9114       ai3_12=a1(1,1)*a2(1,2)+a1(1,2)*a2(2,2)
9115       ai3_21=a1(2,1)*a2(1,1)+a1(2,2)*a2(2,1)
9116       ai3_22=a1(2,1)*a2(1,2)+a1(2,2)*a2(2,2)
9117
9118       A3(1,1)=AI3_11
9119       A3(2,1)=AI3_21
9120       A3(1,2)=AI3_12
9121       A3(2,2)=AI3_22
9122       END
9123
9124 c-------------------------------------------------------------------------
9125       double precision function scalar2(u,v)
9126 !DIR$ INLINEALWAYS scalar2
9127       implicit none
9128       double precision u(2),v(2)
9129       double precision sc
9130       integer i
9131       scalar2=u(1)*v(1)+u(2)*v(2)
9132       return
9133       end
9134
9135 C-----------------------------------------------------------------------------
9136
9137       subroutine transpose2(a,at)
9138 !DIR$ INLINEALWAYS transpose2
9139 #ifndef OSF
9140 cDEC$ ATTRIBUTES FORCEINLINE::transpose2
9141 #endif
9142       implicit none
9143       double precision a(2,2),at(2,2)
9144       at(1,1)=a(1,1)
9145       at(1,2)=a(2,1)
9146       at(2,1)=a(1,2)
9147       at(2,2)=a(2,2)
9148       return
9149       end
9150 c--------------------------------------------------------------------------
9151       subroutine transpose(n,a,at)
9152       implicit none
9153       integer n,i,j
9154       double precision a(n,n),at(n,n)
9155       do i=1,n
9156         do j=1,n
9157           at(j,i)=a(i,j)
9158         enddo
9159       enddo
9160       return
9161       end
9162 C---------------------------------------------------------------------------
9163       subroutine prodmat3(a1,a2,kk,transp,prod)
9164 !DIR$ INLINEALWAYS prodmat3
9165 #ifndef OSF
9166 cDEC$ ATTRIBUTES FORCEINLINE::prodmat3
9167 #endif
9168       implicit none
9169       integer i,j
9170       double precision a1(2,2),a2(2,2),a2t(2,2),kk(2,2),prod(2,2)
9171       logical transp
9172 crc      double precision auxmat(2,2),prod_(2,2)
9173
9174       if (transp) then
9175 crc        call transpose2(kk(1,1),auxmat(1,1))
9176 crc        call matmat2(a1(1,1),auxmat(1,1),auxmat(1,1))
9177 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9178
9179            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,1)
9180      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,1)
9181            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(1,2))*a2(1,2)
9182      & +(a1(1,1)*kk(2,1)+a1(1,2)*kk(2,2))*a2(2,2)
9183            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,1)
9184      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,1)
9185            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(1,2))*a2(1,2)
9186      & +(a1(2,1)*kk(2,1)+a1(2,2)*kk(2,2))*a2(2,2)
9187
9188       else
9189 crc        call matmat2(a1(1,1),kk(1,1),auxmat(1,1))
9190 crc        call matmat2(auxmat(1,1),a2(1,1),prod_(1,1))
9191
9192            prod(1,1)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,1)
9193      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,1)
9194            prod(1,2)=(a1(1,1)*kk(1,1)+a1(1,2)*kk(2,1))*a2(1,2)
9195      &  +(a1(1,1)*kk(1,2)+a1(1,2)*kk(2,2))*a2(2,2)
9196            prod(2,1)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,1)
9197      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,1)
9198            prod(2,2)=(a1(2,1)*kk(1,1)+a1(2,2)*kk(2,1))*a2(1,2)
9199      &  +(a1(2,1)*kk(1,2)+a1(2,2)*kk(2,2))*a2(2,2)
9200
9201       endif
9202 c      call transpose2(a2(1,1),a2t(1,1))
9203
9204 crc      print *,transp
9205 crc      print *,((prod_(i,j),i=1,2),j=1,2)
9206 crc      print *,((prod(i,j),i=1,2),j=1,2)
9207
9208       return
9209       end
9210