source/unres/src_CSA/initialize_p.F

   1       block data
   2       implicit real*8 (a-h,o-z)
   3       include 'DIMENSIONS'
   4       include 'COMMON.MCM'
   5 c      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 c      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      &   "DFA DIS","DFA TOR","DFA NEI","DFA BET"/
 269       data wname /
 270      &   "WSC","WSCP","WELEC","WCORR","WCORR5","WCORR6","WEL_LOC",
 271      &   "WTURN3","WTURN4","WTURN6","WANG","WSCLOC","WTOR","WTORD",
 272      &   "WSTRAIN","WVDWPP","WBOND","SCAL14","     ","    ","WSCCOR",
 273      &   " "," ","WDFAD","WDFAT","WDFAN","WDFAB"/
 274       data nprint_ene /24/
 275       data print_order/1,2,3,11,12,13,14,4,5,6,7,8,9,10,19,18,15,17,16,
 276      & 21,24,25,26,27,0,0,0/
 277       end
 278 c---------------------------------------------------------------------------
 279       subroutine init_int_table
 280       implicit real*8 (a-h,o-z)
 281       include 'DIMENSIONS'
 282 #ifdef MPI
 283       include 'mpif.h'
 284       integer blocklengths(15),displs(15)
 285 #endif
 286       include 'COMMON.CONTROL'
 287       include 'COMMON.SETUP'
 288       include 'COMMON.CHAIN'
 289       include 'COMMON.INTERACT'
 290       include 'COMMON.LOCAL'
 291       include 'COMMON.SBRIDGE'
 292       include 'COMMON.TORCNSTR'
 293       include 'COMMON.IOUNITS'
 294       include 'COMMON.DERIV'
 295       include 'COMMON.CONTACTS'
 296       common /przechowalnia/ iturn3_start_all(0:MaxProcs),
 297      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
 298      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
 299      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
 300      & ielend_all(maxres,0:MaxProcs-1),
 301      & ntask_cont_from_all(0:max_fg_procs-1),
 302      & itask_cont_from_all(0:max_fg_procs-1,0:max_fg_procs-1),
 303      & ntask_cont_to_all(0:max_fg_procs-1),
 304      & itask_cont_to_all(0:max_fg_procs-1,0:max_fg_procs-1)
 305       integer FG_GROUP,CONT_FROM_GROUP,CONT_TO_GROUP
 306       logical scheck,lprint,flag
 307 #ifdef MPI
 308       integer my_sc_int(0:max_fg_Procs-1),my_sc_intt(0:max_fg_Procs),
 309      & my_ele_int(0:max_fg_Procs-1),my_ele_intt(0:max_fg_Procs)
 310 C... Determine the numbers of start and end SC-SC interaction
 311 C... to deal with by current processor.
 312       do i=0,nfgtasks-1
 313         itask_cont_from(i)=fg_rank
 314         itask_cont_to(i)=fg_rank
 315       enddo
 316       lprint=.false.
 317       if (lprint)
 318      &write (iout,*) 'INIT_INT_TABLE nres=',nres,' nnt=',nnt,' nct=',nct
 319       n_sc_int_tot=(nct-nnt+1)*(nct-nnt)/2-nss
 320       call int_bounds(n_sc_int_tot,my_sc_inds,my_sc_inde)
 321       if (lprint)
 322      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
 323      &  ' absolute rank',MyRank,
 324      &  ' n_sc_int_tot',n_sc_int_tot,' my_sc_inds=',my_sc_inds,
 325      &  ' my_sc_inde',my_sc_inde
 326       ind_sctint=0
 327       iatsc_s=0
 328       iatsc_e=0
 329 #endif
 330 c      lprint=.false.
 331       do i=1,maxres
 332         nint_gr(i)=0
 333         nscp_gr(i)=0
 334         do j=1,maxint_gr
 335           istart(i,1)=0
 336           iend(i,1)=0
 337           ielstart(i)=0
 338           ielend(i)=0
 339           iscpstart(i,1)=0
 340           iscpend(i,1)=0
 341         enddo
 342       enddo
 343       ind_scint=0
 344       ind_scint_old=0
 345 cd    write (iout,*) 'ns=',ns,' nss=',nss,' ihpb,jhpb',
 346 cd   &   (ihpb(i),jhpb(i),i=1,nss)
 347       do i=nnt,nct-1
 348         scheck=.false.
 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,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       ibond_start=2
1095       ibond_end=nres-1
1096       ibondp_start=nnt+1
1097       ibondp_end=nct
1098       ivec_start=1
1099       ivec_end=nres-1
1100       iset_start=3
1101       iset_end=nres+1
1102       iint_start=2
1103       iint_end=nres-1
1104 #endif
1105       return
1106       end
1107 #ifdef MPI
1108 c---------------------------------------------------------------------------
1109       subroutine add_int(ii,jj,itask,ntask_cont_to,itask_cont_to,flag)
1110       implicit none
1111       include "DIMENSIONS"
1112       include "COMMON.INTERACT"
1113       include "COMMON.SETUP"
1114       include "COMMON.IOUNITS"
1115       integer ii,jj,itask(4),ntask_cont_to,itask_cont_to(0:MaxProcs-1)
1116       logical flag
1117       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1118      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1119       common /przechowalnia/ iturn3_start_all(0:MaxProcs),
1120      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
1121      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
1122      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
1123      & ielend_all(maxres,0:MaxProcs-1)
1124       integer iproc,isent,k,l
1125 c Determines whether to send interaction ii,jj to other processors; a given
1126 c interaction can be sent to at most 2 processors.
1127 c Sets flag=.true. if interaction ii,jj needs to be sent to at least
1128 c one processor, otherwise flag is unchanged from the input value.
1129       isent=0
1130       itask(1)=fg_rank
1131       itask(2)=fg_rank
1132       itask(3)=fg_rank
1133       itask(4)=fg_rank
1134 c      write (iout,*) "ii",ii," jj",jj
1135 c Loop over processors to check if anybody could need interaction ii,jj
1136       do iproc=0,fg_rank-1
1137 c Check if the interaction matches any turn3 at iproc
1138         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1139           l=k+2
1140           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1141      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1142      &    then
1143 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj,"kl",k,l
1144 c            call flush(iout)
1145             flag=.true.
1146             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1147      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1148               isent=isent+1
1149               itask(isent)=iproc
1150               call add_task(iproc,ntask_cont_to,itask_cont_to)
1151             endif
1152           endif
1153         enddo
1154 C Check if the interaction matches any turn4 at iproc
1155         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1156           l=k+3
1157           if (k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1
1158      &   .or. k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1 .and. l.eq.jj-1)
1159      &    then
1160 c            write (iout,*) "turn3 to iproc",iproc," ij",ii,jj," kl",k,l
1161 c            call flush(iout)
1162             flag=.true.
1163             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1164      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1165               isent=isent+1
1166               itask(isent)=iproc
1167               call add_task(iproc,ntask_cont_to,itask_cont_to)
1168             endif
1169           endif
1170         enddo
1171         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0 .and.
1172      &  iatel_s_all(iproc).le.ii-1 .and. iatel_e_all(iproc).ge.ii-1)then
1173           if (ielstart_all(ii-1,iproc).le.jj-1.and.
1174      &        ielend_all(ii-1,iproc).ge.jj-1) then
1175             flag=.true.
1176             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1177      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1178               isent=isent+1
1179               itask(isent)=iproc
1180               call add_task(iproc,ntask_cont_to,itask_cont_to)
1181             endif
1182           endif
1183           if (ielstart_all(ii-1,iproc).le.jj+1.and.
1184      &        ielend_all(ii-1,iproc).ge.jj+1) then
1185             flag=.true.
1186             if (iproc.ne.itask(1).and.iproc.ne.itask(2)
1187      &        .and.iproc.ne.itask(3).and.iproc.ne.itask(4)) then
1188               isent=isent+1
1189               itask(isent)=iproc
1190               call add_task(iproc,ntask_cont_to,itask_cont_to)
1191             endif
1192           endif
1193         endif
1194       enddo
1195       return
1196       end
1197 c---------------------------------------------------------------------------
1198       subroutine add_int_from(ii,jj,ntask_cont_from,itask_cont_from)
1199       implicit none
1200       include "DIMENSIONS"
1201       include "COMMON.INTERACT"
1202       include "COMMON.SETUP"
1203       include "COMMON.IOUNITS"
1204       integer ii,jj,itask(2),ntask_cont_from,
1205      & itask_cont_from(0:MaxProcs-1)
1206       logical flag
1207       integer iturn3_start_all,iturn3_end_all,iturn4_start_all,
1208      & iturn4_end_all,iatel_s_all,iatel_e_all,ielstart_all,ielend_all
1209       common /przechowalnia/ iturn3_start_all(0:MaxProcs),
1210      & iturn3_end_all(0:MaxProcs),iturn4_start_all(0:MaxProcs),
1211      & iturn4_end_all(0:MaxProcs),iatel_s_all(0:MaxProcs),
1212      & iatel_e_all(0:MaxProcs),ielstart_all(maxres,0:MaxProcs-1),
1213      & ielend_all(maxres,0:MaxProcs-1)
1214       integer iproc,k,l
1215       do iproc=fg_rank+1,nfgtasks-1
1216         do k=iturn3_start_all(iproc),iturn3_end_all(iproc)
1217           l=k+2
1218           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1219      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1220      &    then
1221 c            write (iout,*)"turn3 from iproc",iproc," ij",ii,jj," kl",k,l
1222             call add_task(iproc,ntask_cont_from,itask_cont_from)
1223           endif
1224         enddo
1225         do k=iturn4_start_all(iproc),iturn4_end_all(iproc)
1226           l=k+3
1227           if (k.eq.ii+1 .and. l.eq.jj+1 .or. k.eq.ii+1.and.l.eq.jj-1
1228      &   .or. k.eq.ii-1 .and. l.eq.jj-1 .or. k.eq.ii-1 .and. l.eq.jj+1)
1229      &    then
1230 c            write (iout,*)"turn4 from iproc",iproc," ij",ii,jj," kl",k,l
1231             call add_task(iproc,ntask_cont_from,itask_cont_from)
1232           endif
1233         enddo
1234         if (iatel_s_all(iproc).gt.0 .and. iatel_e_all(iproc).gt.0) then
1235           if (ii+1.ge.iatel_s_all(iproc).and.ii+1.le.iatel_e_all(iproc))
1236      &    then
1237             if (jj+1.ge.ielstart_all(ii+1,iproc).and.
1238      &          jj+1.le.ielend_all(ii+1,iproc)) then
1239               call add_task(iproc,ntask_cont_from,itask_cont_from)
1240             endif
1241             if (jj-1.ge.ielstart_all(ii+1,iproc).and.
1242      &          jj-1.le.ielend_all(ii+1,iproc)) then
1243               call add_task(iproc,ntask_cont_from,itask_cont_from)
1244             endif
1245           endif
1246           if (ii-1.ge.iatel_s_all(iproc).and.ii-1.le.iatel_e_all(iproc))
1247      &    then
1248             if (jj-1.ge.ielstart_all(ii-1,iproc).and.
1249      &          jj-1.le.ielend_all(ii-1,iproc)) then
1250               call add_task(iproc,ntask_cont_from,itask_cont_from)
1251             endif
1252             if (jj+1.ge.ielstart_all(ii-1,iproc).and.
1253      &          jj+1.le.ielend_all(ii-1,iproc)) then
1254                call add_task(iproc,ntask_cont_from,itask_cont_from)
1255             endif
1256           endif
1257         endif
1258       enddo
1259       return
1260       end
1261 c---------------------------------------------------------------------------
1262       subroutine add_task(iproc,ntask_cont,itask_cont)
1263       implicit none
1264       include "DIMENSIONS"
1265       integer iproc,ntask_cont,itask_cont(0:MaxProcs-1)
1266       integer ii
1267       do ii=1,ntask_cont
1268         if (itask_cont(ii).eq.iproc) return
1269       enddo
1270       ntask_cont=ntask_cont+1
1271       itask_cont(ntask_cont)=iproc
1272       return
1273       end
1274 c---------------------------------------------------------------------------
1275       subroutine int_bounds(total_ints,lower_bound,upper_bound)
1276       implicit real*8 (a-h,o-z)
1277       include 'DIMENSIONS'
1278       include 'mpif.h'
1279       include 'COMMON.SETUP'
1280       integer total_ints,lower_bound,upper_bound
1281       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1282       nint=total_ints/nfgtasks
1283       do i=1,nfgtasks
1284         int4proc(i-1)=nint
1285       enddo
1286       nexcess=total_ints-nint*nfgtasks
1287       do i=1,nexcess
1288         int4proc(nfgtasks-i)=int4proc(nfgtasks-i)+1
1289       enddo
1290       lower_bound=0
1291       do i=0,fg_rank-1
1292         lower_bound=lower_bound+int4proc(i)
1293       enddo
1294       upper_bound=lower_bound+int4proc(fg_rank)
1295       lower_bound=lower_bound+1
1296       return
1297       end
1298 c---------------------------------------------------------------------------
1299       subroutine int_bounds1(total_ints,lower_bound,upper_bound)
1300       implicit real*8 (a-h,o-z)
1301       include 'DIMENSIONS'
1302       include 'mpif.h'
1303       include 'COMMON.SETUP'
1304       integer total_ints,lower_bound,upper_bound
1305       integer int4proc(0:max_fg_procs),sint4proc(0:max_fg_procs)
1306       nint=total_ints/nfgtasks1
1307       do i=1,nfgtasks1
1308         int4proc(i-1)=nint
1309       enddo
1310       nexcess=total_ints-nint*nfgtasks1
1311       do i=1,nexcess
1312         int4proc(nfgtasks1-i)=int4proc(nfgtasks1-i)+1
1313       enddo
1314       lower_bound=0
1315       do i=0,fg_rank1-1
1316         lower_bound=lower_bound+int4proc(i)
1317       enddo
1318       upper_bound=lower_bound+int4proc(fg_rank1)
1319       lower_bound=lower_bound+1
1320       return
1321       end
1322 c---------------------------------------------------------------------------
1323       subroutine int_partition(int_index,lower_index,upper_index,atom,
1324      & at_start,at_end,first_atom,last_atom,int_gr,jat_start,jat_end,*)
1325       implicit real*8 (a-h,o-z)
1326       include 'DIMENSIONS'
1327       include 'COMMON.IOUNITS'
1328       integer int_index,lower_index,upper_index,atom,at_start,at_end,
1329      & first_atom,last_atom,int_gr,jat_start,jat_end
1330       logical lprn
1331       lprn=.false.
1332       if (lprn) write (iout,*) 'int_index=',int_index
1333       int_index_old=int_index
1334       int_index=int_index+last_atom-first_atom+1
1335       if (lprn)
1336      &   write (iout,*) 'int_index=',int_index,
1337      &               ' int_index_old',int_index_old,
1338      &               ' lower_index=',lower_index,
1339      &               ' upper_index=',upper_index,
1340      &               ' atom=',atom,' first_atom=',first_atom,
1341      &               ' last_atom=',last_atom
1342       if (int_index.ge.lower_index) then
1343         int_gr=int_gr+1
1344         if (at_start.eq.0) then
1345           at_start=atom
1346           jat_start=first_atom-1+lower_index-int_index_old
1347         else
1348           jat_start=first_atom
1349         endif
1350         if (lprn) write (iout,*) 'jat_start',jat_start
1351         if (int_index.ge.upper_index) then
1352           at_end=atom
1353           jat_end=first_atom-1+upper_index-int_index_old
1354           return1
1355         else
1356           jat_end=last_atom
1357         endif
1358         if (lprn) write (iout,*) 'jat_end',jat_end
1359       endif
1360       return
1361       end
1362 #endif
1363 c------------------------------------------------------------------------------
1364       subroutine hpb_partition
1365       implicit real*8 (a-h,o-z)
1366       include 'DIMENSIONS'
1367 #ifdef MPI
1368       include 'mpif.h'
1369 #endif
1370       include 'COMMON.SBRIDGE'
1371       include 'COMMON.IOUNITS'
1372       include 'COMMON.SETUP'
1373       include 'COMMON.CONTROL'
1374 #ifdef MPI
1375       call int_bounds(nhpb,link_start,link_end)
1376       if (.not. out1file)
1377      &  write (iout,*) 'Processor',fg_rank,' CG group',kolor,
1378      &  ' absolute rank',MyRank,
1379      &  ' nhpb',nhpb,' link_start=',link_start,
1380      &  ' link_end',link_end
1381 #else
1382       link_start=1
1383       link_end=nhpb
1384 #endif
1385       return
1386       end