source/unres/src_MD-M/initialize_p.F

   1       block data
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'COMMON.MCM'
   5       include 'COMMON.MD'
   6       data MovTypID
   7      &  /'pool','chain regrow','multi-bond','phi','theta','side chain',
   8      &   'total'/
   9 c Conversion from poises to molecular unit and the gas constant
  10       data cPoise /2.9361d0/, Rb /0.001986d0/
  11       end
  12 c--------------------------------------------------------------------------
  13       subroutine initialize
  14 C
  15 C Define constants and zero out tables.
  16 C
  17       implicit real*8 (a-h,o-z)
  18       include 'DIMENSIONS'
  19 #ifdef MPI
  20       include 'mpif.h'
  21 #endif
  22 #ifndef ISNAN
  23       external proc_proc
  24 #ifdef WINPGI
  25 cMS$ATTRIBUTES C ::  proc_proc
  26 #endif
  27 #endif
  28       include 'COMMON.IOUNITS'
  29       include 'COMMON.CHAIN'
  30       include 'COMMON.INTERACT'
  31       include 'COMMON.GEO'
  32       include 'COMMON.LOCAL'
  33       include 'COMMON.TORSION'
  34       include 'COMMON.FFIELD'
  35       include 'COMMON.SBRIDGE'
  36       include 'COMMON.MCM'
  37       include 'COMMON.MINIM'
  38       include 'COMMON.DERIV'
  39       include 'COMMON.SPLITELE'
  40 c Common blocks from the diagonalization routines
  41       COMMON /IOFILE/ IR,IW,IP,IJK,IPK,IDAF,NAV,IODA(400)
  42       COMMON /MACHSW/ KDIAG,ICORFL,IXDR
  43       logical mask_r
  44 c      real*8 text1 /'initial_i'/
  45
  46       mask_r=.false.
  47 #ifndef ISNAN
  48 c NaNQ initialization
  49       i=-1
  50       rr=dacos(100.0d0)
  51 #ifdef WINPGI
  52       idumm=proc_proc(rr,i)
  53 #else
  54       call proc_proc(rr,i)
  55 #endif
  56 #endif
  57
  58       kdiag=0
  59       icorfl=0
  60       iw=2
  61 C
  62 C The following is just to define auxiliary variables used in angle conversion
  63 C
  64       pi=4.0D0*datan(1.0D0)
  65       dwapi=2.0D0*pi
  66       dwapi3=dwapi/3.0D0
  67       pipol=0.5D0*pi
  68       deg2rad=pi/180.0D0
  69       rad2deg=1.0D0/deg2rad
  70       angmin=10.0D0*deg2rad
  71 C
  72 C Define I/O units.
  73 C
  74       inp=    1
  75       iout=   2
  76       ipdbin= 3
  77       ipdb=   7
  78       icart = 30
  79       imol2=  4
  80       igeom=  8
  81       intin=  9
  82       ithep= 11
  83       ithep_pdb=51
  84       irotam=12
  85       irotam_pdb=52
  86       itorp= 13
  87       itordp= 23
  88       ielep= 14
  89       isidep=15
  90       iscpp=25
  91       icbase=16
  92       ifourier=20
  93       istat= 17
  94       irest1=55
  95       irest2=56
  96       iifrag=57
  97       ientin=18
  98       ientout=19
  99       ibond = 28
 100       isccor = 29
 101 crc for write_rmsbank1
 102       izs1=21
 103 cdr  include secondary structure prediction bias
 104       isecpred=27
 105 C
 106 C CSA I/O units (separated from others especially for Jooyoung)
 107 C
 108       icsa_rbank=30
 109       icsa_seed=31
 110       icsa_history=32
 111       icsa_bank=33
 112       icsa_bank1=34
 113       icsa_alpha=35
 114       icsa_alpha1=36
 115       icsa_bankt=37
 116       icsa_int=39
 117       icsa_bank_reminimized=38
 118       icsa_native_int=41
 119       icsa_in=40
 120 crc for ifc error 118
 121       icsa_pdb=42
 122 C
 123 C Set default weights of the energy terms.
 124 C
 125       wlong=1.0D0
 126       welec=1.0D0
 127       wtor =1.0D0
 128       wang =1.0D0
 129       wscloc=1.0D0
 130       wstrain=1.0D0
 131 C
 132 C Zero out tables.
 133 C
 134 c      print '(a,$)','Inside initialize'
 135 c      call memmon_print_usage()
 136       do i=1,maxres2
 137         do j=1,3
 138           c(j,i)=0.0D0
 139           dc(j,i)=0.0D0
 140         enddo
 141       enddo
 142       do i=1,maxres
 143         do j=1,3
 144           xloc(j,i)=0.0D0
 145         enddo
 146       enddo
 147       do i=1,ntyp
 148         do j=1,ntyp
 149           aa(i,j)=0.0D0
 150           bb(i,j)=0.0D0
 151           augm(i,j)=0.0D0
 152           sigma(i,j)=0.0D0
 153           r0(i,j)=0.0D0
 154           chi(i,j)=0.0D0
 155         enddo
 156         do j=1,2
 157           bad(i,j)=0.0D0
 158         enddo
 159         chip(i)=0.0D0
 160         alp(i)=0.0D0
 161         sigma0(i)=0.0D0
 162         sigii(i)=0.0D0
 163         rr0(i)=0.0D0
 164         a0thet(i)=0.0D0
 165         do j=1,2
 166           athet(j,i)=0.0D0
 167           bthet(j,i)=0.0D0
 168         enddo
 169         do j=0,3
 170           polthet(j,i)=0.0D0
 171         enddo
 172         do j=1,3
 173           gthet(j,i)=0.0D0
 174         enddo
 175         theta0(i)=0.0D0
 176         sig0(i)=0.0D0
 177         sigc0(i)=0.0D0
 178         do j=1,maxlob
 179           bsc(j,i)=0.0D0
 180           do k=1,3
 181             censc(k,j,i)=0.0D0
 182           enddo
 183           do k=1,3
 184             do l=1,3
 185               gaussc(l,k,j,i)=0.0D0
 186             enddo
 187           enddo
 188           nlob(i)=0
 189         enddo
 190       enddo
 191       nlob(ntyp1)=0
 192       dsc(ntyp1)=0.0D0
 193       do i=1,maxtor
 194         itortyp(i)=0
 195         do j=1,maxtor
 196           do k=1,maxterm
 197             v1(k,j,i)=0.0D0
 198             v2(k,j,i)=0.0D0
 199           enddo
 200         enddo
 201       enddo
 202       do i=1,maxres
 203         itype(i)=0
 204         itel(i)=0
 205       enddo
 206 C Initialize the bridge arrays
 207       ns=0
 208       nss=0
 209       nhpb=0
 210       do i=1,maxss
 211         iss(i)=0
 212       enddo
 213       do i=1,maxdim
 214         dhpb(i)=0.0D0
 215       enddo
 216       do i=1,maxres
 217         ihpb(i)=0
 218         jhpb(i)=0
 219       enddo
 220 C
 221 C Initialize timing.
 222 C
 223       call set_timers
 224 C
 225 C Initialize variables used in minimization.
 226 C
 227 c     maxfun=5000
 228 c     maxit=2000
 229       maxfun=500
 230       maxit=200
 231       tolf=1.0D-2
 232       rtolf=5.0D-4
 233 C
 234 C Initialize the variables responsible for the mode of gradient storage.
 235 C
 236       nfl=0
 237       icg=1
 238 C
 239 C Initialize constants used to split the energy into long- and short-range
 240 C components
 241 C
 242       r_cut=2.0d0
 243       rlamb=0.3d0
 244 #ifndef SPLITELE
 245       nprint_ene=nprint_ene-1
 246 #endif
 247       return
 248       end
 249 c-------------------------------------------------------------------------
 250       block data nazwy
 251       implicit real*8 (a-h,o-z)
 252       include 'DIMENSIONS'
 253       include 'COMMON.NAMES'
 254       include 'COMMON.FFIELD'
 255       data restyp /
 256      &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
 257      &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/
 258       data onelet /
 259      &'C','M','F','I','L','V','W','Y','A','G','T',
 260      &'S','Q','N','E','D','H','R','K','P','X'/
 261       data potname /'LJ','LJK','BP','GB','GBV'/
 262       data ename /
 263      &   "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ",
 264      &   "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",
 265      &   "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ",
 266      &   "ESTR ","EVDW2_14 ","UCONST ", "      ","ESCCOR"/
 267       data wname /
 268      &   "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
 269      &   "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD",
 270      &   "WSTRAIN","WVDWPP","WBOND","SCAL14","     ","    ","WSCCOR"/
 271       data nprint_ene /20/
 272       data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,
 273      & 21,0/
 274       end
 275 c---------------------------------------------------------------------------
 276       subroutine init_int_table
 277       implicit real*8 (a-h,o-z)
 278       include 'DIMENSIONS'
 279 #ifdef MPI
 280       include 'mpif.h'
 281       integer blocklengths(15),displs(15)
 282 #endif
 283       include 'COMMON.CONTROL'
 284       include 'COMMON.SETUP'
 285       include 'COMMON.CHAIN'
 286       include 'COMMON.INTERACT'
 287       include 'COMMON.LOCAL'
 288       include 'COMMON.SBRIDGE'
 289       include 'COMMON.TORCNSTR'
 290       include 'COMMON.IOUNITS'
 291       include 'COMMON.DERIV'
 292       include 'COMMON.CONTACTS'
 293       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
 294      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
 295      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
 296      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
 297      & ielend_all(maxres,0:max_fg_procs-1),
 298      & ntask_cont_from_all(0:max_fg_procs-1),
 299      & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1),
 300      & ntask_cont_to_all(0:max_fg_procs-1),
 301      & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1)
 302       integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
 303       logical scheck,lprint,flag
 304 #ifdef MPI
 305       integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs),
 306      & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs)
 307 C... Determine the numbers of start and end SC-SC interaction
 308 C... to deal with by current processor.
 309       do i=0,nfgtasks-1
 310         itask_cont_from(i)=fg_rank
 311         itask_cont_to(i)=fg_rank
 312       enddo
 313       lprint=.false.
 314       if (lprint)
 315      &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
 316       n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
 317       call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
 318       if (lprint)
 319      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 320      &  ' absolute rank',MyRank,
 321      &  ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,
 322      &  ' my_sc_inde',my_sc_inde
 323       ind_sctint=0
 324       iatsc_s=0
 325       iatsc_e=0
 326 #endif
 327 c      lprint=.false.
 328       do i=1,maxres
 329         nint_gr(i)=0
 330         nscp_gr(i)=0
 331         do j=1,maxint_gr
 332           istart(i,1)=0
 333           iend(i,1)=0
 334           ielstart(i)=0
 335           ielend(i)=0
 336           iscpstart(i,1)=0
 337           iscpend(i,1)=0
 338         enddo
 339       enddo
 340       ind_scint=0
 341       ind_scint_old=0
 342 cd    write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
 343 cd   &   (ihpb(i),jhpb(i),i=1,nss)
 344       do i=nnt,nct-1
 345         scheck=.false.
 346         if (dyn_ss) goto 10
 347         do ii=1,nss
 348           if (ihpb(ii).eq.i+nres) then
 349             scheck=.true.
 350             jj=jhpb(ii)-nres
 351             goto 10
 352           endif
 353         enddo
 354    10   continue
 355 cd      write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
 356         if (scheck) then
 357           if (jj.eq.i+1) then
 358 #ifdef MPI
 359 c            write (iout,*) 'jj=i+1'
 360             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 361      & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 362 #else
 363             nint_gr(i)=1
 364             istart(i,1)=i+2
 365             iend(i,1)=nct
 366 #endif
 367           else if (jj.eq.nct) then
 368 #ifdef MPI
 369 c            write (iout,*) 'jj=nct'
 370             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 371      &  iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 372 #else
 373             nint_gr(i)=1
 374             istart(i,1)=i+1
 375             iend(i,1)=nct-1
 376 #endif
 377           else
 378 #ifdef MPI
 379             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 380      & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 381             ii=nint_gr(i)+1
 382             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 383      & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
 384 #else
 385             nint_gr(i)=2
 386             istart(i,1)=i+1
 387             iend(i,1)=jj-1
 388             istart(i,2)=jj+1
 389             iend(i,2)=nct
 390 #endif
 391           endif
 392         else
 393 #ifdef MPI
 394           call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 395      &    iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 396 #else
 397           nint_gr(i)=1
 398           istart(i,1)=i+1
 399           iend(i,1)=nct
 400           ind_scint=ind_scint+nct-i
 401 #endif
 402         endif
 403 #ifdef MPI
 404         ind_scint_old=ind_scint
 405 #endif
 406       enddo
 407    12 continue
 408 #ifndef MPI
 409       iatsc_s=nnt
 410       iatsc_e=nct-1
 411 #endif
 412 #ifdef MPI
 413       if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
 414      &   ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
 415 #endif
 416       if (lprint) then
 417       write (iout,'(a)') 'Interaction array:'
 418       do i=iatsc_s,iatsc_e
 419         write (iout,'(i3,2(2x,2i3))')
 420      & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
 421       enddo
 422       endif
 423       ispp=4
 424 #ifdef MPI
 425 C Now partition the electrostatic-interaction array
 426       npept=nct-nnt
 427       nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
 428       call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
 429       if (lprint)
 430      & write (*,*) 'Processor',fg_rank,' CG group',kolor,
 431      &  ' absolute rank',MyRank,
 432      &  ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
 433      &               ' my_ele_inde',my_ele_inde
 434       iatel_s=0
 435       iatel_e=0
 436       ind_eleint=0
 437       ind_eleint_old=0
 438       do i=nnt,nct-3
 439         ijunk=0
 440         call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
 441      &    iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
 442       enddo ! i
 443    13 continue
 444       if (iatel_s.eq.0) iatel_s=1
 445       nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
 446 c      write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
 447       call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
 448 c      write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
 449 c     & " my_ele_inde_vdw",my_ele_inde_vdw
 450       ind_eleint_vdw=0
 451       ind_eleint_vdw_old=0
 452       iatel_s_vdw=0
 453       iatel_e_vdw=0
 454       do i=nnt,nct-3
 455         ijunk=0
 456         call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
 457      &    my_ele_inde_vdw,i,
 458      &    iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
 459      &    ielend_vdw(i),*15)
 460 c        write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
 461 c     &   " ielend_vdw",ielend_vdw(i)
 462       enddo ! i
 463       if (iatel_s_vdw.eq.0) iatel_s_vdw=1
 464    15 continue
 465 #else
 466       iatel_s=nnt
 467       iatel_e=nct-5
 468       do i=iatel_s,iatel_e
 469         ielstart(i)=i+4
 470         ielend(i)=nct-1
 471       enddo
 472       iatel_s_vdw=nnt
 473       iatel_e_vdw=nct-3
 474       do i=iatel_s_vdw,iatel_e_vdw
 475         ielstart_vdw(i)=i+2
 476         ielend_vdw(i)=nct-1
 477       enddo
 478 #endif
 479       if (lprint) then
 480         write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
 481      &  ' absolute rank',MyRank
 482         write (iout,*) 'Electrostatic interaction array:'
 483         do i=iatel_s,iatel_e
 484           write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
 485         enddo
 486       endif ! lprint
 487 c     iscp=3
 488       iscp=2
 489 C Partition the SC-p interaction array
 490 #ifdef MPI
 491       nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
 492       call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
 493       if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 494      &  ' absolute rank',myrank,
 495      &  ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
 496      &               ' my_scp_inde',my_scp_inde
 497       iatscp_s=0
 498       iatscp_e=0
 499       ind_scpint=0
 500       ind_scpint_old=0
 501       do i=nnt,nct-1
 502         if (i.lt.nnt+iscp) then
 503 cd        write (iout,*) 'i.le.nnt+iscp'
 504           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 505      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
 506      &      iscpend(i,1),*14)
 507         else if (i.gt.nct-iscp) then
 508 cd        write (iout,*) 'i.gt.nct-iscp'
 509           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 510      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 511      &      iscpend(i,1),*14)
 512         else
 513           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 514      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 515      &      iscpend(i,1),*14)
 516           ii=nscp_gr(i)+1
 517           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 518      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
 519      &      iscpend(i,ii),*14)
 520         endif
 521       enddo ! i
 522    14 continue
 523 #else
 524       iatscp_s=nnt
 525       iatscp_e=nct-1
 526       do i=nnt,nct-1
 527         if (i.lt.nnt+iscp) then
 528           nscp_gr(i)=1
 529           iscpstart(i,1)=i+iscp
 530           iscpend(i,1)=nct
 531         elseif (i.gt.nct-iscp) then
 532           nscp_gr(i)=1
 533           iscpstart(i,1)=nnt
 534           iscpend(i,1)=i-iscp
 535         else
 536           nscp_gr(i)=2
 537           iscpstart(i,1)=nnt
 538           iscpend(i,1)=i-iscp
 539           iscpstart(i,2)=i+iscp
 540           iscpend(i,2)=nct
 541         endif
 542       enddo ! i
 543 #endif
 544       if (lprint) then
 545         write (iout,'(a)') 'SC-p interaction array:'
 546         do i=iatscp_s,iatscp_e
 547           write (iout,'(i3,2(2x,2i3))')
 548      &         i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
 549         enddo
 550       endif ! lprint
 551 C Partition local interactions
 552 #ifdef MPI
 553       call int_bounds(nres-2,loc_start,loc_end)
 554       loc_start=loc_start+1
 555       loc_end=loc_end+1
 556       call int_bounds(nres-2,ithet_start,ithet_end)
 557       ithet_start=ithet_start+2
 558       ithet_end=ithet_end+2
 559       call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
 560       iturn3_start=iturn3_start+nnt
 561       iphi_start=iturn3_start+2
 562       iturn3_end=iturn3_end+nnt
 563       iphi_end=iturn3_end+2
 564       iturn3_start=iturn3_start-1
 565       iturn3_end=iturn3_end-1
 566       call int_bounds(nres-3,itau_start,itau_end)
 567       itau_start=itau_start+3
 568       itau_end=itau_end+3
 569       call int_bounds(nres-3,iphi1_start,iphi1_end)
 570       iphi1_start=iphi1_start+3
 571       iphi1_end=iphi1_end+3
 572       call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
 573       iturn4_start=iturn4_start+nnt
 574       iphid_start=iturn4_start+2
 575       iturn4_end=iturn4_end+nnt
 576       iphid_end=iturn4_end+2
 577       iturn4_start=iturn4_start-1
 578       iturn4_end=iturn4_end-1
 579       call int_bounds(nres-2,ibond_start,ibond_end)
 580       ibond_start=ibond_start+1
 581       ibond_end=ibond_end+1
 582       call int_bounds(nct-nnt,ibondp_start,ibondp_end)
 583       ibondp_start=ibondp_start+nnt
 584       ibondp_end=ibondp_end+nnt
 585       call int_bounds1(nres-1,ivec_start,ivec_end)
 586 c      print *,"Processor",myrank,fg_rank,fg_rank1,
 587 c     &  " ivec_start",ivec_start," ivec_end",ivec_end
 588       iset_start=loc_start+2
 589       iset_end=loc_end+2
 590       if (ndih_constr.eq.0) then
 591         idihconstr_start=1
 592         idihconstr_end=0
 593       else
 594         call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
 595       endif
 596 c      nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 597 c      nlen=nres-nnt+1
 598       nsumgrad=(nres-nnt)*(nres-nnt+1)/2
 599       nlen=nres-nnt+1
 600       call int_bounds(nsumgrad,ngrad_start,ngrad_end)
 601       igrad_start=((2*nlen+1)
 602      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_start-1))))/2
 603       jgrad_start(igrad_start)=
 604      &    ngrad_start-(2*nlen-igrad_start)*(igrad_start-1)/2
 605      &    +igrad_start
 606       jgrad_end(igrad_start)=nres
 607       igrad_end=((2*nlen+1)
 608      &    -sqrt(float((2*nlen-1)**2-8*(ngrad_end-1))))/2
 609       if (igrad_end.gt.igrad_start) jgrad_start(igrad_end)=igrad_end+1
 610       jgrad_end(igrad_end)=ngrad_end-(2*nlen-igrad_end)*(igrad_end-1)/2
 611      &    +igrad_end
 612       do i=igrad_start+1,igrad_end-1
 613         jgrad_start(i)=i+1
 614         jgrad_end(i)=nres
 615       enddo
 616       if (lprint) then
 617         write (*,*) 'Processor:',fg_rank,' CG group',kolor,
 618      & ' absolute rank',myrank,
 619      & ' loc_start',loc_start,' loc_end',loc_end,
 620      & ' ithet_start',ithet_start,' ithet_end',ithet_end,
 621      & ' iphi_start',iphi_start,' iphi_end',iphi_end,
 622      & ' iphid_start',iphid_start,' iphid_end',iphid_end,
 623      & ' ibond_start',ibond_start,' ibond_end',ibond_end,
 624      & ' ibondp_start',ibondp_start,' ibondp_end',ibondp_end,
 625      & ' iturn3_start',iturn3_start,' iturn3_end',iturn3_end,
 626      & ' iturn4_start',iturn4_start,' iturn4_end',iturn4_end,
 627      & ' ivec_start',ivec_start,' ivec_end',ivec_end,
 628      & ' iset_start',iset_start,' iset_end',iset_end,
 629      & ' idihconstr_start',idihconstr_start,' idihconstr_end',
 630      &   idihconstr_end
 631        write (*,*) 'Processor:',fg_rank,myrank,' igrad_start',
 632      &   igrad_start,' igrad_end',igrad_end,' ngrad_start',ngrad_start,
 633      &   ' ngrad_end',ngrad_end
 634        do i=igrad_start,igrad_end
 635          write(*,*) 'Processor:',fg_rank,myrank,i,
 636      &    jgrad_start(i),jgrad_end(i)
 637        enddo
 638       endif
 639       if (nfgtasks.gt.1) then
 640         call MPI_Allgather(ivec_start,1,MPI_INTEGER,ivec_displ(0),1,
 641      &    MPI_INTEGER,FG_COMM1,IERROR)
 642         iaux=ivec_end-ivec_start+1
 643         call MPI_Allgather(iaux,1,MPI_INTEGER,ivec_count(0),1,
 644      &    MPI_INTEGER,FG_COMM1,IERROR)
 645         call MPI_Allgather(iset_start-2,1,MPI_INTEGER,iset_displ(0),1,
 646      &    MPI_INTEGER,FG_COMM,IERROR)
 647         iaux=iset_end-iset_start+1
 648         call MPI_Allgather(iaux,1,MPI_INTEGER,iset_count(0),1,
 649      &    MPI_INTEGER,FG_COMM,IERROR)
 650         call MPI_Allgather(ibond_start,1,MPI_INTEGER,ibond_displ(0),1,
 651      &    MPI_INTEGER,FG_COMM,IERROR)
 652         iaux=ibond_end-ibond_start+1
 653         call MPI_Allgather(iaux,1,MPI_INTEGER,ibond_count(0),1,
 654      &    MPI_INTEGER,FG_COMM,IERROR)
 655         call MPI_Allgather(ithet_start,1,MPI_INTEGER,ithet_displ(0),1,
 656      &    MPI_INTEGER,FG_COMM,IERROR)
 657         iaux=ithet_end-ithet_start+1
 658         call MPI_Allgather(iaux,1,MPI_INTEGER,ithet_count(0),1,
 659      &    MPI_INTEGER,FG_COMM,IERROR)
 660         call MPI_Allgather(iphi_start,1,MPI_INTEGER,iphi_displ(0),1,
 661      &    MPI_INTEGER,FG_COMM,IERROR)
 662         iaux=iphi_end-iphi_start+1
 663         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi_count(0),1,
 664      &    MPI_INTEGER,FG_COMM,IERROR)
 665         call MPI_Allgather(iphi1_start,1,MPI_INTEGER,iphi1_displ(0),1,
 666      &    MPI_INTEGER,FG_COMM,IERROR)
 667         iaux=iphi1_end-iphi1_start+1
 668         call MPI_Allgather(iaux,1,MPI_INTEGER,iphi1_count(0),1,
 669      &    MPI_INTEGER,FG_COMM,IERROR)
 670         do i=0,maxprocs-1
 671           do j=1,maxres
 672             ielstart_all(j,i)=0
 673             ielend_all(j,i)=0
 674           enddo
 675         enddo
 676         call MPI_Allgather(iturn3_start,1,MPI_INTEGER,
 677      &    iturn3_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 678         call MPI_Allgather(iturn4_start,1,MPI_INTEGER,
 679      &    iturn4_start_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 680         call MPI_Allgather(iturn3_end,1,MPI_INTEGER,
 681      &    iturn3_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 682         call MPI_Allgather(iturn4_end,1,MPI_INTEGER,
 683      &    iturn4_end_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 684         call MPI_Allgather(iatel_s,1,MPI_INTEGER,
 685      &    iatel_s_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 686         call MPI_Allgather(iatel_e,1,MPI_INTEGER,
 687      &    iatel_e_all(0),1,MPI_INTEGER,FG_COMM,IERROR)
 688         call MPI_Allgather(ielstart(1),maxres,MPI_INTEGER,
 689      &    ielstart_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 690         call MPI_Allgather(ielend(1),maxres,MPI_INTEGER,
 691      &    ielend_all(1,0),maxres,MPI_INTEGER,FG_COMM,IERROR)
 692         if (lprint) then
 693         write (iout,*) "iatel_s_all",(iatel_s_all(i),i=0,nfgtasks)
 694         write (iout,*) "iatel_e_all",(iatel_e_all(i),i=0,nfgtasks)
 695         write (iout,*) "iturn3_start_all",
 696      &    (iturn3_start_all(i),i=0,nfgtasks-1)
 697         write (iout,*) "iturn3_end_all",
 698      &    (iturn3_end_all(i),i=0,nfgtasks-1)
 699         write (iout,*) "iturn4_start_all",
 700      &    (iturn4_start_all(i),i=0,nfgtasks-1)
 701         write (iout,*) "iturn4_end_all",
 702      &    (iturn4_end_all(i),i=0,nfgtasks-1)
 703         write (iout,*) "The ielstart_all array"
 704         do i=nnt,nct
 705           write (iout,'(20i4)') i,(ielstart_all(i,j),j=0,nfgtasks-1)
 706         enddo
 707         write (iout,*) "The ielend_all array"
 708         do i=nnt,nct
 709           write (iout,'(20i4)') i,(ielend_all(i,j),j=0,nfgtasks-1)
 710         enddo
 711         call flush(iout)
 712         endif
 713         ntask_cont_from=0
 714         ntask_cont_to=0
 715         itask_cont_from(0)=fg_rank
 716         itask_cont_to(0)=fg_rank
 717         flag=.false.
 718         do ii=iturn3_start,iturn3_end
 719           call add_int(ii,ii+2,iturn3_sent(1,ii),
 720      &                 ntask_cont_to,itask_cont_to,flag)
 721         enddo
 722         do ii=iturn4_start,iturn4_end
 723           call add_int(ii,ii+3,iturn4_sent(1,ii),
 724      &                 ntask_cont_to,itask_cont_to,flag)
 725         enddo
 726         do ii=iturn3_start,iturn3_end
 727           call add_int_from(ii,ii+2,ntask_cont_from,itask_cont_from)
 728         enddo
 729         do ii=iturn4_start,iturn4_end
 730           call add_int_from(ii,ii+3,ntask_cont_from,itask_cont_from)
 731         enddo
 732         if (lprint) then
 733         write (iout,*) "After turn3 ntask_cont_from",ntask_cont_from,
 734      &   " ntask_cont_to",ntask_cont_to
 735         write (iout,*) "itask_cont_from",
 736      &    (itask_cont_from(i),i=1,ntask_cont_from)
 737         write (iout,*) "itask_cont_to",
 738      &    (itask_cont_to(i),i=1,ntask_cont_to)
 739         call flush(iout)
 740         endif
 741 c        write (iout,*) "Loop forward"
 742 c        call flush(iout)
 743         do i=iatel_s,iatel_e
 744 c          write (iout,*) "from loop i=",i
 745 c          call flush(iout)
 746           do j=ielstart(i),ielend(i)
 747             call add_int_from(i,j,ntask_cont_from,itask_cont_from)
 748           enddo
 749         enddo
 750 c        write (iout,*) "Loop backward iatel_e-1",iatel_e-1,
 751 c     &     " iatel_e",iatel_e
 752 c        call flush(iout)
 753         nat_sent=0
 754         do i=iatel_s,iatel_e
 755 c          write (iout,*) "i",i," ielstart",ielstart(i),
 756 c     &      " ielend",ielend(i)
 757 c          call flush(iout)
 758           flag=.false.
 759           do j=ielstart(i),ielend(i)
 760             call add_int(i,j,iint_sent(1,j,nat_sent+1),ntask_cont_to,
 761      &                   itask_cont_to,flag)
 762           enddo
 763           if (flag) then
 764             nat_sent=nat_sent+1
 765             iat_sent(nat_sent)=i
 766           endif
 767         enddo
 768         if (lprint) then
 769         write (iout,*)"After longrange ntask_cont_from",ntask_cont_from,
 770      &   " ntask_cont_to",ntask_cont_to
 771         write (iout,*) "itask_cont_from",
 772      &    (itask_cont_from(i),i=1,ntask_cont_from)
 773         write (iout,*) "itask_cont_to",
 774      &    (itask_cont_to(i),i=1,ntask_cont_to)
 775         call flush(iout)
 776         write (iout,*) "iint_sent"
 777         do i=1,nat_sent
 778           ii=iat_sent(i)
 779           write (iout,'(20i4)') ii,(j,(iint_sent(k,j,i),k=1,4),
 780      &      j=ielstart(ii),ielend(ii))
 781         enddo
 782         write (iout,*) "iturn3_sent iturn3_start",iturn3_start,
 783      &    " iturn3_end",iturn3_end
 784         write (iout,'(20i4)') (i,(iturn3_sent(j,i),j=1,4),
 785      &      i=iturn3_start,iturn3_end)
 786         write (iout,*) "iturn4_sent iturn4_start",iturn4_start,
 787      &    " iturn4_end",iturn4_end
 788         write (iout,'(20i4)') (i,(iturn4_sent(j,i),j=1,4),
 789      &      i=iturn4_start,iturn4_end)
 790         call flush(iout)
 791         endif
 792         call MPI_Gather(ntask_cont_from,1,MPI_INTEGER,
 793      &   ntask_cont_from_all,1,MPI_INTEGER,king,FG_COMM,IERR)
 794 c        write (iout,*) "Gather ntask_cont_from ended"
 795 c        call flush(iout)
 796         call MPI_Gather(itask_cont_from(0),max_fg_procs,MPI_INTEGER,
 797      &   itask_cont_from_all(0,0),max_fg_procs,MPI_INTEGER,king,
 798      &   FG_COMM,IERR)
 799 c        write (iout,*) "Gather itask_cont_from ended"
 800 c        call flush(iout)
 801         call MPI_Gather(ntask_cont_to,1,MPI_INTEGER,ntask_cont_to_all,
 802      &   1,MPI_INTEGER,king,FG_COMM,IERR)
 803 c        write (iout,*) "Gather ntask_cont_to ended"
 804 c        call flush(iout)
 805         call MPI_Gather(itask_cont_to,max_fg_procs,MPI_INTEGER,
 806      &   itask_cont_to_all,max_fg_procs,MPI_INTEGER,king,FG_COMM,IERR)
 807 c        write (iout,*) "Gather itask_cont_to ended"
 808 c        call flush(iout)
 809         if (fg_rank.eq.king) then
 810           write (iout,*)"Contact receive task map (proc, #tasks, tasks)"
 811           do i=0,nfgtasks-1
 812             write (iout,'(20i4)') i,ntask_cont_from_all(i),
 813      &       (itask_cont_from_all(j,i),j=1,ntask_cont_from_all(i))
 814           enddo
 815           write (iout,*)
 816           call flush(iout)
 817           write (iout,*) "Contact send task map (proc, #tasks, tasks)"
 818           do i=0,nfgtasks-1
 819             write (iout,'(20i4)') i,ntask_cont_to_all(i),
 820      &       (itask_cont_to_all(j,i),j=1,ntask_cont_to_all(i))
 821           enddo
 822           write (iout,*)
 823           call flush(iout)
 824 C Check if every send will have a matching receive
 825           ncheck_to=0
 826           ncheck_from=0
 827           do i=0,nfgtasks-1
 828             ncheck_to=ncheck_to+ntask_cont_to_all(i)
 829             ncheck_from=ncheck_from+ntask_cont_from_all(i)
 830           enddo
 831           write (iout,*) "Control sums",ncheck_from,ncheck_to
 832           if (ncheck_from.ne.ncheck_to) then
 833             write (iout,*) "Error: #receive differs from #send."
 834             write (iout,*) "Terminating program...!"
 835             call flush(iout)
 836             flag=.false.
 837           else
 838             flag=.true.
 839             do i=0,nfgtasks-1
 840               do j=1,ntask_cont_to_all(i)
 841                 ii=itask_cont_to_all(j,i)
 842                 do k=1,ntask_cont_from_all(ii)
 843                   if (itask_cont_from_all(k,ii).eq.i) then
 844                     if(lprint)write(iout,*)"Matching send/receive",i,ii
 845                     exit
 846                   endif
 847                 enddo
 848                 if (k.eq.ntask_cont_from_all(ii)+1) then
 849                   flag=.false.
 850                   write (iout,*) "Error: send by",j," to",ii,
 851      &            " would have no matching receive"
 852                 endif
 853               enddo
 854             enddo
 855           endif
 856           if (.not.flag) then
 857             write (iout,*) "Unmatched sends; terminating program"
 858             call flush(iout)
 859           endif
 860         endif
 861         call MPI_Bcast(flag,1,MPI_LOGICAL,king,FG_COMM,IERROR)
 862 c        write (iout,*) "flag broadcast ended flag=",flag
 863 c        call flush(iout)
 864         if (.not.flag) then
 865           call MPI_Finalize(IERROR)
 866           stop "Error in INIT_INT_TABLE: unmatched send/receive."
 867         endif
 868         call MPI_Comm_group(FG_COMM,fg_group,IERR)
 869 c        write (iout,*) "MPI_Comm_group ended"
 870 c        call flush(iout)
 871         call MPI_Group_incl(fg_group,ntask_cont_from+1,
 872      &    itask_cont_from(0),CONT_FROM_GROUP,IERR)
 873         call MPI_Group_incl(fg_group,ntask_cont_to+1,itask_cont_to(0),
 874      &    CONT_TO_GROUP,IERR)
 875         do i=1,nat_sent
 876           ii=iat_sent(i)
 877           iaux=4*(ielend(ii)-ielstart(ii)+1)
 878           call MPI_Group_translate_ranks(fg_group,iaux,
 879      &      iint_sent(1,ielstart(ii),i),CONT_TO_GROUP,
 880      &      iint_sent_local(1,ielstart(ii),i),IERR )
 881 c          write (iout,*) "Ranks translated i=",i
 882 c          call flush(iout)
 883         enddo
 884         iaux=4*(iturn3_end-iturn3_start+1)
 885         call MPI_Group_translate_ranks(fg_group,iaux,
 886      &      iturn3_sent(1,iturn3_start),CONT_TO_GROUP,
 887      &      iturn3_sent_local(1,iturn3_start),IERR)
 888         iaux=4*(iturn4_end-iturn4_start+1)
 889         call MPI_Group_translate_ranks(fg_group,iaux,
 890      &      iturn4_sent(1,iturn4_start),CONT_TO_GROUP,
 891      &      iturn4_sent_local(1,iturn4_start),IERR)
 892         if (lprint) then
 893         write (iout,*) "iint_sent_local"
 894         do i=1,nat_sent
 895           ii=iat_sent(i)
 896           write (iout,'(20i4)') ii,(j,(iint_sent_local(k,j,i),k=1,4),
 897      &      j=ielstart(ii),ielend(ii))
 898           call flush(iout)
 899         enddo
 900         write (iout,*) "iturn3_sent_local iturn3_start",iturn3_start,
 901      &    " iturn3_end",iturn3_end
 902         write (iout,'(20i4)') (i,(iturn3_sent_local(j,i),j=1,4),
 903      &      i=iturn3_start,iturn3_end)
 904         write (iout,*) "iturn4_sent_local iturn4_start",iturn4_start,
 905      &    " iturn4_end",iturn4_end
 906         write (iout,'(20i4)') (i,(iturn4_sent_local(j,i),j=1,4),
 907      &      i=iturn4_start,iturn4_end)
 908         call flush(iout)
 909         endif
 910         call MPI_Group_free(fg_group,ierr)
 911         call MPI_Group_free(cont_from_group,ierr)
 912         call MPI_Group_free(cont_to_group,ierr)
 913         call MPI_Type_contiguous(3,MPI_DOUBLE_PRECISION,MPI_UYZ,IERROR)
 914         call MPI_Type_commit(MPI_UYZ,IERROR)
 915         call MPI_Type_contiguous(18,MPI_DOUBLE_PRECISION,MPI_UYZGRAD,
 916      &    IERROR)
 917         call MPI_Type_commit(MPI_UYZGRAD,IERROR)
 918         call MPI_Type_contiguous(2,MPI_DOUBLE_PRECISION,MPI_MU,IERROR)
 919         call MPI_Type_commit(MPI_MU,IERROR)
 920         call MPI_Type_contiguous(4,MPI_DOUBLE_PRECISION,MPI_MAT1,IERROR)
 921         call MPI_Type_commit(MPI_MAT1,IERROR)
 922         call MPI_Type_contiguous(8,MPI_DOUBLE_PRECISION,MPI_MAT2,IERROR)
 923         call MPI_Type_commit(MPI_MAT2,IERROR)
 924         call MPI_Type_contiguous(6,MPI_DOUBLE_PRECISION,MPI_THET,IERROR)
 925         call MPI_Type_commit(MPI_THET,IERROR)
 926         call MPI_Type_contiguous(9,MPI_DOUBLE_PRECISION,MPI_GAM,IERROR)
 927         call MPI_Type_commit(MPI_GAM,IERROR)
 928 #ifndef MATGATHER
 929 c 9/22/08 Derived types to send matrices which appear in correlation terms
 930         do i=0,nfgtasks-1
 931           if (ivec_count(i).eq.ivec_count(0)) then
 932             lentyp(i)=0
 933           else
 934             lentyp(i)=1
 935           endif
 936         enddo
 937         do ind_typ=lentyp(0),lentyp(nfgtasks-1)
 938         if (ind_typ.eq.0) then
 939           ichunk=ivec_count(0)
 940         else
 941           ichunk=ivec_count(1)
 942         endif
 943 c        do i=1,4
 944 c          blocklengths(i)=4
 945 c        enddo
 946 c        displs(1)=0
 947 c        do i=2,4
 948 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 949 c        enddo
 950 c        do i=1,4
 951 c          blocklengths(i)=blocklengths(i)*ichunk
 952 c        enddo
 953 c        write (iout,*) "blocklengths and displs"
 954 c        do i=1,4
 955 c          write (iout,*) i,blocklengths(i),displs(i)
 956 c        enddo
 957 c        call flush(iout)
 958 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
 959 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT1(ind_typ),IERROR)
 960 c        call MPI_Type_commit(MPI_ROTAT1(ind_typ),IERROR)
 961 c        write (iout,*) "MPI_ROTAT1",MPI_ROTAT1
 962 c        do i=1,4
 963 c          blocklengths(i)=2
 964 c        enddo
 965 c        displs(1)=0
 966 c        do i=2,4
 967 c          displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 968 c        enddo
 969 c        do i=1,4
 970 c          blocklengths(i)=blocklengths(i)*ichunk
 971 c        enddo
 972 c        write (iout,*) "blocklengths and displs"
 973 c        do i=1,4
 974 c          write (iout,*) i,blocklengths(i),displs(i)
 975 c        enddo
 976 c        call flush(iout)
 977 c        call MPI_Type_indexed(4,blocklengths(1),displs(1),
 978 c     &    MPI_DOUBLE_PRECISION,MPI_ROTAT2(ind_typ),IERROR)
 979 c        call MPI_Type_commit(MPI_ROTAT2(ind_typ),IERROR)
 980 c        write (iout,*) "MPI_ROTAT2",MPI_ROTAT2
 981         do i=1,8
 982           blocklengths(i)=2
 983         enddo
 984         displs(1)=0
 985         do i=2,8
 986           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
 987         enddo
 988         do i=1,15
 989           blocklengths(i)=blocklengths(i)*ichunk
 990         enddo
 991         call MPI_Type_indexed(8,blocklengths,displs,
 992      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP11(ind_typ),IERROR)
 993         call MPI_Type_commit(MPI_PRECOMP11(ind_typ),IERROR)
 994         do i=1,8
 995           blocklengths(i)=4
 996         enddo
 997         displs(1)=0
 998         do i=2,8
 999           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1000         enddo
1001         do i=1,15
1002           blocklengths(i)=blocklengths(i)*ichunk
1003         enddo
1004         call MPI_Type_indexed(8,blocklengths,displs,
1005      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP12(ind_typ),IERROR)
1006         call MPI_Type_commit(MPI_PRECOMP12(ind_typ),IERROR)
1007         do i=1,6
1008           blocklengths(i)=4
1009         enddo
1010         displs(1)=0
1011         do i=2,6
1012           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1013         enddo
1014         do i=1,6
1015           blocklengths(i)=blocklengths(i)*ichunk
1016         enddo
1017         call MPI_Type_indexed(6,blocklengths,displs,
1018      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP22(ind_typ),IERROR)
1019         call MPI_Type_commit(MPI_PRECOMP22(ind_typ),IERROR)
1020         do i=1,2
1021           blocklengths(i)=8
1022         enddo
1023         displs(1)=0
1024         do i=2,2
1025           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1026         enddo
1027         do i=1,2
1028           blocklengths(i)=blocklengths(i)*ichunk
1029         enddo
1030         call MPI_Type_indexed(2,blocklengths,displs,
1031      &    MPI_DOUBLE_PRECISION,MPI_PRECOMP23(ind_typ),IERROR)
1032         call MPI_Type_commit(MPI_PRECOMP23(ind_typ),IERROR)
1033         do i=1,4
1034           blocklengths(i)=1
1035         enddo
1036         displs(1)=0
1037         do i=2,4
1038           displs(i)=displs(i-1)+blocklengths(i-1)*maxres
1039         enddo
1040         do i=1,4
1041           blocklengths(i)=blocklengths(i)*ichunk
1042         enddo
1043         call MPI_Type_indexed(4,blocklengths,displs,
1044      &    MPI_DOUBLE_PRECISION,MPI_ROTAT_OLD(ind_typ),IERROR)
1045         call MPI_Type_commit(MPI_ROTAT_OLD(ind_typ),IERROR)
1046         enddo
1047 #endif
1048       endif
1049       iint_start=ivec_start+1
1050       iint_end=ivec_end+1
1051       do i=0,nfgtasks-1
1052           iint_count(i)=ivec_count(i)
1053           iint_displ(i)=ivec_displ(i)
1054           ivec_displ(i)=ivec_displ(i)-1
1055           iset_displ(i)=iset_displ(i)-1
1056           ithet_displ(i)=ithet_displ(i)-1
1057           iphi_displ(i)=iphi_displ(i)-1
1058           iphi1_displ(i)=iphi1_displ(i)-1
1059           ibond_displ(i)=ibond_displ(i)-1
1060       enddo
1061       if (nfgtasks.gt.1 .and. fg_rank.eq.king
1062      &     .and. (me.eq.0 .or. .not. out1file)) then
1063         write (iout,*) "IVEC_DISPL, IVEC_COUNT, ISET_START, ISET_COUNT"
1064         do i=0,nfgtasks-1
1065           write (iout,*) i,ivec_displ(i),ivec_count(i),iset_displ(i),
1066      &      iset_count(i)
1067         enddo
1068         write (iout,*) "iphi_start",iphi_start," iphi_end",iphi_end,
1069      &    " iphi1_start",iphi1_start," iphi1_end",iphi1_end
1070         write (iout,*)"IPHI_COUNT, IPHI_DISPL, IPHI1_COUNT, IPHI1_DISPL"
1071         do i=0,nfgtasks-1
1072           write (iout,*) i,iphi_count(i),iphi_displ(i),iphi1_count(i),
1073      &      iphi1_displ(i)
1074         enddo
1075         write(iout,'(i10,a,i10,a,i10,a/a,i3,a)') n_sc_int_tot,' SC-SC ',
1076      & nele_int_tot,' electrostatic and ',nscp_int_tot,
1077      & ' SC-p interactions','were distributed among',nfgtasks,
1078      & ' fine-grain processors.'
1079       endif
1080 #else
1081       loc_start=2
1082       loc_end=nres-1
1083       ithet_start=3
1084       ithet_end=nres
1085       iturn3_start=nnt
1086       iturn3_end=nct-3
1087       iturn4_start=nnt
1088       iturn4_end=nct-4
1089       iphi_start=nnt+3
1090       iphi_end=nct
1091       iphi1_start=4
1092       iphi1_end=nres
1093       idihconstr_start=1
1094       idihconstr_end=ndih_constr
1095       iphid_start=iphi_start
1096       iphid_end=iphi_end-1
1097       itau_start=4
1098       itau_end=nres
1099       ibond_start=2
1100       ibond_end=nres-1
1101       ibondp_start=nnt
1102       ibondp_end=nct
1103       ivec_start=1
1104       ivec_end=nres-1
1105       iset_start=3
1106       iset_end=nres+1
1107       iint_start=2
1108       iint_end=nres-1
1109 #endif
1110       return
1111       end
1112 #ifdef MPI
1113 c---------------------------------------------------------------------------
1114       subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1115       implicit none
1116       include "DIMENSIONS"
1117       include "COMMON.INTERACT"
1118       include "COMMON.SETUP"
1119       include "COMMON.IOUNITS"
1120       integer ii,jj,itask(4),ntask_cont_to,
1121      &itask_cont_to(0:max_fg_procs-1)
1122       logical flag
1123       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1124      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1125       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1126      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1127      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1128      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1129      & ielend_all(maxres,0:max_fg_procs-1)
1130       integer iproc,isent,k,l
1131 c Determines whether to send interaction ii,jj to other processors; a given
1132 c interaction can be sent to at most 2 processors.
1133 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1134 c one processor, otherwise flag is unchanged from the input value.
1135       isent=0
1136       itask(1)=fg_rank
1137       itask(2)=fg_rank
1138       itask(3)=fg_rank
1139       itask(4)=fg_rank
1140 c      write (iout,*) "ii",ii," jj",jj
1141 c Loop over processors to check if anybody could need interaction ii,jj
1142       do iproc=0,fg_rank-1
1143 c Check if the interaction matches any turn3 at iproc
1144         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1145           l=k+2
1146           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1147      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1148      &    then
1149 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1150 c            call flush(iout)
1151             flag=.true.
1152             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1153      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1154               isent=isent+1
1155               itask(isent)=iproc
1156               call add_task(iproc,ntask_cont_to,itask_cont_to)
1157             endif
1158           endif
1159         enddo
1160 C Check if the interaction matches any turn4 at iproc
1161         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1162           l=k+3
1163           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1164      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1165      &    then
1166 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1167 c            call flush(iout)
1168             flag=.true.
1169             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1170      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1171               isent=isent+1
1172               itask(isent)=iproc
1173               call add_task(iproc,ntask_cont_to,itask_cont_to)
1174             endif
1175           endif
1176         enddo
1177         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1178      &  iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1179           if (ielstart_all(ii-1,iproc).le.jj-1.and.
1180      &        ielend_all(ii-1,iproc).ge.jj-1) then
1181             flag=.true.
1182             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1183      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1184               isent=isent+1
1185               itask(isent)=iproc
1186               call add_task(iproc,ntask_cont_to,itask_cont_to)
1187             endif
1188           endif
1189           if (ielstart_all(ii-1,iproc).le.jj+1.and.
1190      &        ielend_all(ii-1,iproc).ge.jj+1) then
1191             flag=.true.
1192             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1193      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1194               isent=isent+1
1195               itask(isent)=iproc
1196               call add_task(iproc,ntask_cont_to,itask_cont_to)
1197             endif
1198           endif
1199         endif
1200       enddo
1201       return
1202       end
1203 c---------------------------------------------------------------------------
1204       subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1205       implicit none
1206       include "DIMENSIONS"
1207       include "COMMON.INTERACT"
1208       include "COMMON.SETUP"
1209       include "COMMON.IOUNITS"
1210       integer ii,jj,itask(2),ntask_cont_from,
1211      & itask_cont_from(0:max_fg_procs-1)
1212       logical flag
1213       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1214      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1215       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
1216      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
1217      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
1218      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
1219      & ielend_all(maxres,0:max_fg_procs-1)
1220       integer iproc,k,l
1221       do iproc=fg_rank+1,nfgtasks-1
1222         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1223           l=k+2
1224           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1225      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1226      &    then
1227 c            write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1228             call add_task(iproc,ntask_cont_from,itask_cont_from)
1229           endif
1230         enddo
1231         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1232           l=k+3
1233           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1234      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1235      &    then
1236 c            write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1237             call add_task(iproc,ntask_cont_from,itask_cont_from)
1238           endif
1239         enddo
1240         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1241           if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1242      &    then
1243             if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1244      &          jj+1.le.ielend_all(ii+1,iproc)) then
1245               call add_task(iproc,ntask_cont_from,itask_cont_from)
1246             endif
1247             if (jj-1.ge.ielstart_all(ii+1,iproc).and.
1248      &          jj-1.le.ielend_all(ii+1,iproc)) then
1249               call add_task(iproc,ntask_cont_from,itask_cont_from)
1250             endif
1251           endif
1252           if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1253      &    then
1254             if (jj-1.ge.ielstart_all(ii-1,iproc).and.
1255      &          jj-1.le.ielend_all(ii-1,iproc)) then
1256               call add_task(iproc,ntask_cont_from,itask_cont_from)
1257             endif
1258             if (jj+1.ge.ielstart_all(ii-1,iproc).and.
1259      &          jj+1.le.ielend_all(ii-1,iproc)) then
1260                call add_task(iproc,ntask_cont_from,itask_cont_from)
1261             endif
1262           endif
1263         endif
1264       enddo
1265       return
1266       end
1267 c---------------------------------------------------------------------------
1268       subroutine add_task(iproc,ntask_cont,itask_cont)
1269       implicit none
1270       include "DIMENSIONS"
1271       integer iproc,ntask_cont,itask_cont(0:max_fg_procs-1)
1272       integer ii
1273       do ii=1,ntask_cont
1274         if (itask_cont(ii).eq.iproc) return
1275       enddo
1276       ntask_cont=ntask_cont+1
1277       itask_cont(ntask_cont)=iproc
1278       return
1279       end
1280 c---------------------------------------------------------------------------
1281       subroutine int_bounds(total_ints,lower_bound,upper_bound)
1282       implicit real*8 (a-h,o-z)
1283       include 'DIMENSIONS'
1284       include 'mpif.h'
1285       include 'COMMON.SETUP'
1286       integer total_ints,lower_bound,upper_bound
1287       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1288       nint=total_ints/nfgtasks
1289       do i=1,nfgtasks
1290         int4proc(i-1)=nint
1291       enddo
1292       nexcess=total_ints-nint*nfgtasks
1293       do i=1,nexcess
1294         int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1295       enddo
1296       lower_bound=0
1297       do i=0,fg_rank-1
1298         lower_bound=lower_bound+int4proc(i)
1299       enddo
1300       upper_bound=lower_bound+int4proc(fg_rank)
1301       lower_bound=lower_bound+1
1302       return
1303       end
1304 c---------------------------------------------------------------------------
1305       subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1306       implicit real*8 (a-h,o-z)
1307       include 'DIMENSIONS'
1308       include 'mpif.h'
1309       include 'COMMON.SETUP'
1310       integer total_ints,lower_bound,upper_bound
1311       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1312       nint=total_ints/nfgtasks1
1313       do i=1,nfgtasks1
1314         int4proc(i-1)=nint
1315       enddo
1316       nexcess=total_ints-nint*nfgtasks1
1317       do i=1,nexcess
1318         int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1319       enddo
1320       lower_bound=0
1321       do i=0,fg_rank1-1
1322         lower_bound=lower_bound+int4proc(i)
1323       enddo
1324       upper_bound=lower_bound+int4proc(fg_rank1)
1325       lower_bound=lower_bound+1
1326       return
1327       end
1328 c---------------------------------------------------------------------------
1329       subroutine int_partition(int_index,lower_index,upper_index,atom,
1330      & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1331       implicit real*8 (a-h,o-z)
1332       include 'DIMENSIONS'
1333       include 'COMMON.IOUNITS'
1334       integer int_index,lower_index,upper_index,atom,at_start,at_end,
1335      & first_atom,last_atom,int_gr,jat_start,jat_end
1336       logical lprn
1337       lprn=.false.
1338       if (lprn) write (iout,*) 'int_index=',int_index
1339       int_index_old=int_index
1340       int_index=int_index+last_atom-first_atom+1
1341       if (lprn)
1342      &   write (iout,*) 'int_index=',int_index,
1343      &               ' int_index_old',int_index_old,
1344      &               ' lower_index=',lower_index,
1345      &               ' upper_index=',upper_index,
1346      &               ' atom=',atom,' first_atom=',first_atom,
1347      &               ' last_atom=',last_atom
1348       if (int_index.ge.lower_index) then
1349         int_gr=int_gr+1
1350         if (at_start.eq.0) then
1351           at_start=atom
1352           jat_start=first_atom-1+lower_index-int_index_old
1353         else
1354           jat_start=first_atom
1355         endif
1356         if (lprn) write (iout,*) 'jat_start',jat_start
1357         if (int_index.ge.upper_index) then
1358           at_end=atom
1359           jat_end=first_atom-1+upper_index-int_index_old
1360           return1
1361         else
1362           jat_end=last_atom
1363         endif
1364         if (lprn) write (iout,*) 'jat_end',jat_end
1365       endif
1366       return
1367       end
1368 #endif
1369 c------------------------------------------------------------------------------
1370       subroutine hpb_partition
1371       implicit real*8 (a-h,o-z)
1372       include 'DIMENSIONS'
1373 #ifdef MPI
1374       include 'mpif.h'
1375 #endif
1376       include 'COMMON.SBRIDGE'
1377       include 'COMMON.IOUNITS'
1378       include 'COMMON.SETUP'
1379 #ifdef MPI
1380       call int_bounds(nhpb,link_start,link_end)
1381       write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1382      &  ' absolute rank',MyRank,
1383      &  ' nhpb',nhpb,' link_start=',link_start,
1384      &  ' link_end',link_end
1385 #else
1386       link_start=1
1387       link_end=nhpb
1388 #endif
1389       return
1390       end