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