source/unres/src_MD/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       arg=100.0d0
  51       rr=dacos(arg)
  52 #ifdef WINPGI
  53       idumm=proc_proc(rr,i)
  54 #else
  55       call proc_proc(rr,i)
  56 #endif
  57 #endif
  58
  59       kdiag=0
  60       icorfl=0
  61       iw=2
  62 C
  63 C The following is just to define auxiliary variables used in angle conversion
  64 C
  65       pi=4.0D0*datan(1.0D0)
  66       dwapi=2.0D0*pi
  67       dwapi3=dwapi/3.0D0
  68       pipol=0.5D0*pi
  69       deg2rad=pi/180.0D0
  70       rad2deg=1.0D0/deg2rad
  71       angmin=10.0D0*deg2rad
  72 C
  73 C Define I/O units.
  74 C
  75       inp=    1
  76       iout=   2
  77       ipdbin= 3
  78       ipdb=   7
  79       icart = 30
  80       imol2=  4
  81       igeom=  8
  82       intin=  9
  83       ithep= 11
  84       ithep_pdb=51
  85       irotam=12
  86       irotam_pdb=52
  87       itorp= 13
  88       itordp= 23
  89       ielep= 14
  90       isidep=15
  91       iscpp=25
  92       icbase=16
  93       ifourier=20
  94       istat= 17
  95       irest1=55
  96       irest2=56
  97       iifrag=57
  98       ientin=18
  99       ientout=19
 100       ibond = 28
 101       isccor = 29
 102 crc for write_rmsbank1
 103       izs1=21
 104 cdr  include secondary structure prediction bias
 105       isecpred=27
 106 C
 107 C CSA I/O units (separated from others especially for Jooyoung)
 108 C
 109       icsa_rbank=30
 110       icsa_seed=31
 111       icsa_history=32
 112       icsa_bank=33
 113       icsa_bank1=34
 114       icsa_alpha=35
 115       icsa_alpha1=36
 116       icsa_bankt=37
 117       icsa_int=39
 118       icsa_bank_reminimized=38
 119       icsa_native_int=41
 120       icsa_in=40
 121 crc for ifc error 118
 122       icsa_pdb=42
 123 C
 124 C Set default weights of the energy terms.
 125 C
 126       wlong=1.0D0
 127       welec=1.0D0
 128       wtor =1.0D0
 129       wang =1.0D0
 130       wscloc=1.0D0
 131       wstrain=1.0D0
 132 C
 133 C Zero out tables.
 134 C
 135       print '(a,$)','Inside initialize'
 136 c      call memmon_print_usage()
 137       do i=1,maxres2
 138         do j=1,3
 139           c(j,i)=0.0D0
 140           dc(j,i)=0.0D0
 141         enddo
 142       enddo
 143       do i=1,maxres
 144         do j=1,3
 145           xloc(j,i)=0.0D0
 146         enddo
 147       enddo
 148       do i=1,ntyp
 149         do j=1,ntyp
 150           aa(i,j)=0.0D0
 151           bb(i,j)=0.0D0
 152           augm(i,j)=0.0D0
 153           sigma(i,j)=0.0D0
 154           r0(i,j)=0.0D0
 155           chi(i,j)=0.0D0
 156         enddo
 157         do j=1,2
 158           bad(i,j)=0.0D0
 159         enddo
 160         chip(i)=0.0D0
 161         alp(i)=0.0D0
 162         sigma0(i)=0.0D0
 163         sigii(i)=0.0D0
 164         rr0(i)=0.0D0
 165         a0thet(i)=0.0D0
 166         do j=1,2
 167           athet(j,i)=0.0D0
 168           bthet(j,i)=0.0D0
 169         enddo
 170         do j=0,3
 171           polthet(j,i)=0.0D0
 172         enddo
 173         do j=1,3
 174           gthet(j,i)=0.0D0
 175         enddo
 176         theta0(i)=0.0D0
 177         sig0(i)=0.0D0
 178         sigc0(i)=0.0D0
 179         do j=1,maxlob
 180           bsc(j,i)=0.0D0
 181           do k=1,3
 182             censc(k,j,i)=0.0D0
 183           enddo
 184           do k=1,3
 185             do l=1,3
 186               gaussc(l,k,j,i)=0.0D0
 187             enddo
 188           enddo
 189           nlob(i)=0
 190         enddo
 191       enddo
 192       nlob(ntyp1)=0
 193       dsc(ntyp1)=0.0D0
 194       do i=1,maxtor
 195         itortyp(i)=0
 196         do j=1,maxtor
 197           do k=1,maxterm
 198             v1(k,j,i)=0.0D0
 199             v2(k,j,i)=0.0D0
 200           enddo
 201         enddo
 202       enddo
 203       do i=1,maxres
 204         itype(i)=0
 205         itel(i)=0
 206       enddo
 207 C Initialize the bridge arrays
 208       ns=0
 209       nss=0
 210       nhpb=0
 211       do i=1,maxss
 212         iss(i)=0
 213       enddo
 214       do i=1,maxdim
 215         dhpb(i)=0.0D0
 216       enddo
 217       do i=1,maxres
 218         ihpb(i)=0
 219         jhpb(i)=0
 220       enddo
 221 C
 222 C Initialize timing.
 223 C
 224       call set_timers
 225 C
 226 C Initialize variables used in minimization.
 227 C
 228 c     maxfun=5000
 229 c     maxit=2000
 230       maxfun=500
 231       maxit=200
 232       tolf=1.0D-2
 233       rtolf=5.0D-4
 234 C
 235 C Initialize the variables responsible for the mode of gradient storage.
 236 C
 237       nfl=0
 238       icg=1
 239 C
 240 C Initialize constants used to split the energy into long- and short-range
 241 C components
 242 C
 243       r_cut=2.0d0
 244       rlamb=0.3d0
 245 #ifndef SPLITELE
 246       nprint_ene=nprint_ene-1
 247 #endif
 248       return
 249       end
 250 c-------------------------------------------------------------------------
 251       block data nazwy
 252       implicit real*8 (a-h,o-z)
 253       include 'DIMENSIONS'
 254       include 'COMMON.NAMES'
 255       include 'COMMON.FFIELD'
 256       data restyp /
 257      &'CYS','MET','PHE','ILE','LEU','VAL','TRP','TYR','ALA','GLY','THR',
 258      &'SER','GLN','ASN','GLU','ASP','HIS','ARG','LYS','PRO','D'/
 259       data onelet /
 260      &'C','M','F','I','L','V','W','Y','A','G','T',
 261      &'S','Q','N','E','D','H','R','K','P','X'/
 262       data potname /'LJ','LJK','BP','GB','GBV'/
 263       data ename /
 264      &   "EVDW SC-SC","EVDW2 SC-p","EES p-p","ECORR4 ","ECORR5 ",
 265      &   "ECORR6 ","EELLO ","ETURN3 ","ETURN4 ","ETURN6 ",
 266      &   "EBE bend","ESC SCloc","ETORS ","ETORSD ","EHPB ","EVDWPP ",
 267      &   "ESTR ","EVDW2_14 ","UCONST ", "      ","ESCCOR"," "," "/
 268       data wname /
 269      &   "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
 270      &   "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD",
 271      &   "WSTRAIN","WVDWPP","WBOND","SCAL14","     ","    ","WSCCOR",
 272      &   " "," "/
 273       data nprint_ene /20/
 274       data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,
 275      & 21,0,0,0/
 276       end
 277 c---------------------------------------------------------------------------
 278       subroutine init_int_table
 279       implicit real*8 (a-h,o-z)
 280       include 'DIMENSIONS'
 281 #ifdef MPI
 282       include 'mpif.h'
 283       integer blocklengths(15),displs(15)
 284 #endif
 285       include 'COMMON.CONTROL'
 286       include 'COMMON.SETUP'
 287       include 'COMMON.CHAIN'
 288       include 'COMMON.INTERACT'
 289       include 'COMMON.LOCAL'
 290       include 'COMMON.SBRIDGE'
 291       include 'COMMON.TORCNSTR'
 292       include 'COMMON.IOUNITS'
 293       include 'COMMON.DERIV'
 294       include 'COMMON.CONTACTS'
 295       common /przechowalnia/ iturn3_start_all(0:max_fg_procs),
 296      & iturn3_end_all(0:max_fg_procs),iturn4_start_all(0:max_fg_procs),
 297      & iturn4_end_all(0:max_fg_procs),iatel_s_all(0:max_fg_procs),
 298      &iatel_e_all(0:max_fg_procs),ielstart_all(maxres,0:max_fg_procs-1),
 299      & ielend_all(maxres,0:max_fg_procs-1),
 300      & ntask_cont_from_all(0:max_fg_procs-1),
 301      & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1),
 302      & ntask_cont_to_all(0:max_fg_procs-1),
 303      & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1)
 304       integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
 305       logical scheck,lprint,flag
 306 #ifdef MPI
 307       integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs),
 308      & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs)
 309 C... Determine the numbers of start and end SC-SC interaction
 310 C... to deal with by current processor.
 311       do i=0,nfgtasks-1
 312         itask_cont_from(i)=fg_rank
 313         itask_cont_to(i)=fg_rank
 314       enddo
 315       lprint=.false.
 316       if (lprint)
 317      &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
 318       n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
 319       call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
 320       if (lprint)
 321      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 322      &  ' absolute rank',MyRank,
 323      &  ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,
 324      &  ' my_sc_inde',my_sc_inde
 325       ind_sctint=0
 326       iatsc_s=0
 327       iatsc_e=0
 328 #endif
 329 c      lprint=.false.
 330       do i=1,maxres
 331         nint_gr(i)=0
 332         nscp_gr(i)=0
 333         do j=1,maxint_gr
 334           istart(i,1)=0
 335           iend(i,1)=0
 336           ielstart(i)=0
 337           ielend(i)=0
 338           iscpstart(i,1)=0
 339           iscpend(i,1)=0
 340         enddo
 341       enddo
 342       ind_scint=0
 343       ind_scint_old=0
 344 cd    write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
 345 cd   &   (ihpb(i),jhpb(i),i=1,nss)
 346       do i=nnt,nct-1
 347         scheck=.false.
 348         if (dyn_ss) goto 10
 349         do ii=1,nss
 350           if (ihpb(ii).eq.i+nres) then
 351             scheck=.true.
 352             jj=jhpb(ii)-nres
 353             goto 10
 354           endif
 355         enddo
 356    10   continue
 357 cd      write (iout,*) 'i=',i,' scheck=',scheck,' jj=',jj
 358         if (scheck) then
 359           if (jj.eq.i+1) then
 360 #ifdef MPI
 361 c            write (iout,*) 'jj=i+1'
 362             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 363      & iatsc_s,iatsc_e,i+2,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 364 #else
 365             nint_gr(i)=1
 366             istart(i,1)=i+2
 367             iend(i,1)=nct
 368 #endif
 369           else if (jj.eq.nct) then
 370 #ifdef MPI
 371 c            write (iout,*) 'jj=nct'
 372             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 373      &  iatsc_s,iatsc_e,i+1,nct-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 374 #else
 375             nint_gr(i)=1
 376             istart(i,1)=i+1
 377             iend(i,1)=nct-1
 378 #endif
 379           else
 380 #ifdef MPI
 381             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 382      & iatsc_s,iatsc_e,i+1,jj-1,nint_gr(i),istart(i,1),iend(i,1),*12)
 383             ii=nint_gr(i)+1
 384             call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 385      & iatsc_s,iatsc_e,jj+1,nct,nint_gr(i),istart(i,ii),iend(i,ii),*12)
 386 #else
 387             nint_gr(i)=2
 388             istart(i,1)=i+1
 389             iend(i,1)=jj-1
 390             istart(i,2)=jj+1
 391             iend(i,2)=nct
 392 #endif
 393           endif
 394         else
 395 #ifdef MPI
 396           call int_partition(ind_scint,my_sc_inds,my_sc_inde,i,
 397      &    iatsc_s,iatsc_e,i+1,nct,nint_gr(i),istart(i,1),iend(i,1),*12)
 398 #else
 399           nint_gr(i)=1
 400           istart(i,1)=i+1
 401           iend(i,1)=nct
 402           ind_scint=ind_scint+nct-i
 403 #endif
 404         endif
 405 #ifdef MPI
 406         ind_scint_old=ind_scint
 407 #endif
 408       enddo
 409    12 continue
 410 #ifndef MPI
 411       iatsc_s=nnt
 412       iatsc_e=nct-1
 413 #endif
 414 #ifdef MPI
 415       if (lprint) write (*,*) 'Processor',fg_rank,' CG Group',kolor,
 416      &   ' absolute rank',myrank,' iatsc_s=',iatsc_s,' iatsc_e=',iatsc_e
 417 #endif
 418       if (lprint) then
 419       write (iout,'(a)') 'Interaction array:'
 420       do i=iatsc_s,iatsc_e
 421         write (iout,'(i3,2(2x,2i3))')
 422      & i,(istart(i,iint),iend(i,iint),iint=1,nint_gr(i))
 423       enddo
 424       endif
 425       ispp=4
 426 #ifdef MPI
 427 C Now partition the electrostatic-interaction array
 428       npept=nct-nnt
 429       nele_int_tot=(npept-ispp)*(npept-ispp+1)/2
 430       call int_bounds(nele_int_tot,my_ele_inds,my_ele_inde)
 431       if (lprint)
 432      & write (*,*) 'Processor',fg_rank,' CG group',kolor,
 433      &  ' absolute rank',MyRank,
 434      &  ' nele_int_tot',nele_int_tot,' my_ele_inds=',my_ele_inds,
 435      &               ' my_ele_inde',my_ele_inde
 436       iatel_s=0
 437       iatel_e=0
 438       ind_eleint=0
 439       ind_eleint_old=0
 440       do i=nnt,nct-3
 441         ijunk=0
 442         call int_partition(ind_eleint,my_ele_inds,my_ele_inde,i,
 443      &    iatel_s,iatel_e,i+ispp,nct-1,ijunk,ielstart(i),ielend(i),*13)
 444       enddo ! i
 445    13 continue
 446       if (iatel_s.eq.0) iatel_s=1
 447       nele_int_tot_vdw=(npept-2)*(npept-2+1)/2
 448 c      write (iout,*) "nele_int_tot_vdw",nele_int_tot_vdw
 449       call int_bounds(nele_int_tot_vdw,my_ele_inds_vdw,my_ele_inde_vdw)
 450 c      write (iout,*) "my_ele_inds_vdw",my_ele_inds_vdw,
 451 c     & " my_ele_inde_vdw",my_ele_inde_vdw
 452       ind_eleint_vdw=0
 453       ind_eleint_vdw_old=0
 454       iatel_s_vdw=0
 455       iatel_e_vdw=0
 456       do i=nnt,nct-3
 457         ijunk=0
 458         call int_partition(ind_eleint_vdw,my_ele_inds_vdw,
 459      &    my_ele_inde_vdw,i,
 460      &    iatel_s_vdw,iatel_e_vdw,i+2,nct-1,ijunk,ielstart_vdw(i),
 461      &    ielend_vdw(i),*15)
 462 c        write (iout,*) i," ielstart_vdw",ielstart_vdw(i),
 463 c     &   " ielend_vdw",ielend_vdw(i)
 464       enddo ! i
 465       if (iatel_s_vdw.eq.0) iatel_s_vdw=1
 466    15 continue
 467 #else
 468       iatel_s=nnt
 469       iatel_e=nct-5
 470       do i=iatel_s,iatel_e
 471         ielstart(i)=i+4
 472         ielend(i)=nct-1
 473       enddo
 474       iatel_s_vdw=nnt
 475       iatel_e_vdw=nct-3
 476       do i=iatel_s_vdw,iatel_e_vdw
 477         ielstart_vdw(i)=i+2
 478         ielend_vdw(i)=nct-1
 479       enddo
 480 #endif
 481       if (lprint) then
 482         write (*,'(a)') 'Processor',fg_rank,' CG group',kolor,
 483      &  ' absolute rank',MyRank
 484         write (iout,*) 'Electrostatic interaction array:'
 485         do i=iatel_s,iatel_e
 486           write (iout,'(i3,2(2x,2i3))') i,ielstart(i),ielend(i)
 487         enddo
 488       endif ! lprint
 489 c     iscp=3
 490       iscp=2
 491 C Partition the SC-p interaction array
 492 #ifdef MPI
 493       nscp_int_tot=(npept-iscp+1)*(npept-iscp+1)
 494       call int_bounds(nscp_int_tot,my_scp_inds,my_scp_inde)
 495       if (lprint) write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 496      &  ' absolute rank',myrank,
 497      &  ' nscp_int_tot',nscp_int_tot,' my_scp_inds=',my_scp_inds,
 498      &               ' my_scp_inde',my_scp_inde
 499       iatscp_s=0
 500       iatscp_e=0
 501       ind_scpint=0
 502       ind_scpint_old=0
 503       do i=nnt,nct-1
 504         if (i.lt.nnt+iscp) then
 505 cd        write (iout,*) 'i.le.nnt+iscp'
 506           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 507      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,1),
 508      &      iscpend(i,1),*14)
 509         else if (i.gt.nct-iscp) then
 510 cd        write (iout,*) 'i.gt.nct-iscp'
 511           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 512      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 513      &      iscpend(i,1),*14)
 514         else
 515           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 516      &      iatscp_s,iatscp_e,nnt,i-iscp,nscp_gr(i),iscpstart(i,1),
 517      &      iscpend(i,1),*14)
 518           ii=nscp_gr(i)+1
 519           call int_partition(ind_scpint,my_scp_inds,my_scp_inde,i,
 520      &      iatscp_s,iatscp_e,i+iscp,nct,nscp_gr(i),iscpstart(i,ii),
 521      &      iscpend(i,ii),*14)
 522         endif
 523       enddo ! i
 524    14 continue
 525 #else
 526       iatscp_s=nnt
 527       iatscp_e=nct-1
 528       do i=nnt,nct-1
 529         if (i.lt.nnt+iscp) then
 530           nscp_gr(i)=1
 531           iscpstart(i,1)=i+iscp
 532           iscpend(i,1)=nct
 533         elseif (i.gt.nct-iscp) then
 534           nscp_gr(i)=1
 535           iscpstart(i,1)=nnt
 536           iscpend(i,1)=i-iscp
 537         else
 538           nscp_gr(i)=2
 539           iscpstart(i,1)=nnt
 540           iscpend(i,1)=i-iscp
 541           iscpstart(i,2)=i+iscp
 542           iscpend(i,2)=nct
 543         endif
 544       enddo ! i
 545 #endif
 546       if (lprint) then
 547         write (iout,'(a)') 'SC-p interaction array:'
 548         do i=iatscp_s,iatscp_e
 549           write (iout,'(i3,2(2x,2i3))')
 550      &         i,(iscpstart(i,j),iscpend(i,j),j=1,nscp_gr(i))
 551         enddo
 552       endif ! lprint
 553 C Partition local interactions
 554 #ifdef MPI
 555       call int_bounds(nres-2,loc_start,loc_end)
 556       loc_start=loc_start+1
 557       loc_end=loc_end+1
 558       call int_bounds(nres-2,ithet_start,ithet_end)
 559       ithet_start=ithet_start+2
 560       ithet_end=ithet_end+2
 561       call int_bounds(nct-nnt-2,iturn3_start,iturn3_end)
 562       iturn3_start=iturn3_start+nnt
 563       iphi_start=iturn3_start+2
 564       iturn3_end=iturn3_end+nnt
 565       iphi_end=iturn3_end+2
 566       iturn3_start=iturn3_start-1
 567       iturn3_end=iturn3_end-1
 568       call int_bounds(nres-3,itau_start,itau_end)
 569       itau_start=itau_start+3
 570       itau_end=itau_end+3
 571       call int_bounds(nres-3,iphi1_start,iphi1_end)
 572       iphi1_start=iphi1_start+3
 573       iphi1_end=iphi1_end+3
 574       call int_bounds(nct-nnt-3,iturn4_start,iturn4_end)
 575       iturn4_start=iturn4_start+nnt
 576       iphid_start=iturn4_start+2
 577       iturn4_end=iturn4_end+nnt
 578       iphid_end=iturn4_end+2
 579       iturn4_start=iturn4_start-1
 580       iturn4_end=iturn4_end-1
 581       call int_bounds(nres-2,ibond_start,ibond_end)
 582       ibond_start=ibond_start+1
 583       ibond_end=ibond_end+1
 584       call int_bounds(nct-nnt,ibondp_start,ibondp_end)
 585       ibondp_start=ibondp_start+nnt
 586       ibondp_end=ibondp_end+nnt
 587       call int_bounds1(nres-1,ivec_start,ivec_end)
 588       print *,"Processor",myrank,fg_rank,fg_rank1,
 589      &  " ivec_start",ivec_start," ivec_end",ivec_end
 590       iset_start=loc_start+2
 591       iset_end=loc_end+2
 592       if (ndih_constr.eq.0) then
 593         idihconstr_start=1
 594         idihconstr_end=0
 595       else
 596         call int_bounds(ndih_constr,idihconstr_start,idihconstr_end)
 597       endif
 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. 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+1
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),
1121      & ntask_cont_to,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       include 'COMMON.CONTROL'
1380 c      write(2,*)"hpb_partition: nhpb=",nhpb
1381 #ifdef MPI
1382       call int_bounds(nhpb,link_start,link_end)
1383       if (.not. out1file)
1384      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1385      &  ' absolute rank',MyRank,
1386      &  ' nhpb',nhpb,' link_start=',link_start,
1387      &  ' link_end',link_end
1388 #else
1389       link_start=1
1390       link_end=nhpb
1391 #endif
1392 c      write(2,*)"hpb_partition: link_start=",nhpb," link_end=",link_end
1393       return
1394       end