00001
00002
00003
00004
00005 module ice_distribution
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021 use ice_kinds_mod
00022 use ice_communicate
00023 use ice_communicate, only : my_task, master_task, lprint_stats
00024 use ice_domain_size
00025 use ice_blocks
00026 use ice_exit
00027 use ice_fileunits, only: nu_diag, nu_timing, ice_stdout
00028 use ice_spacecurve
00029 use ice_broadcast
00030
00031 use ice_probability_tools
00032
00033 implicit none
00034 private
00035 save
00036
00037
00038
00039 type, public :: distrb
00040 integer (int_kind) ::
00041 nprocs ,
00042 communicator ,
00043 numLocalBlocks
00044
00045
00046 integer (int_kind), dimension(:), pointer ::
00047 blockLocation ,
00048 blockLocalID ,
00049 blockGlobalID
00050
00051 integer (int_kind), dimension(:), pointer :: blockCnt
00052 integer (int_kind), dimension(:,:), pointer :: blockIndex
00053
00054 end type
00055
00056 integer (int_kind), public, parameter ::
00057 lndType = 0,
00058 icefreeType = 1,
00059 iceType = 2
00060
00061
00062
00063
00064
00065
00066
00067 public :: create_distribution, &
00068 ice_distributionGet, &
00069 ice_distributionGetBlockLoc, &
00070 ice_distributionGetBlockID, &
00071 create_local_block_ids
00072
00073
00074
00075 character (char_len), public ::
00076 processor_shape
00077
00078
00079
00080
00081
00082
00083
00084
00085
00086 contains
00087
00088
00089
00090
00091
00092
00093 function create_distribution(dist_type, nprocs, maxBlock, work_per_block, prob_per_block, blockType, bStats, FixMaxBlock)
00094
00095
00096
00097
00098
00099
00100
00101
00102
00103
00104
00105
00106
00107
00108 character (*), intent(in) ::
00109 dist_type
00110
00111
00112 integer (int_kind), intent(in) ::
00113 nprocs
00114
00115 integer (int_kind), intent(in) :: maxBlock
00116
00117 integer (int_kind), dimension(:), intent(in) ::
00118 work_per_block
00119
00120 real (dbl_kind), dimension(:), intent(in) ::
00121 prob_per_block
00122
00123 integer (int_kind), dimension(:), intent(in) ::
00124 blockType
00125
00126 real (dbl_kind), dimension(:,:), intent(in) :: bStats
00127
00128 logical, intent(in) :: FixMaxBlock
00129
00130
00131
00132 type (distrb) ::
00133 create_distribution
00134
00135
00136
00137
00138
00139
00140
00141
00142
00143
00144 select case (trim(dist_type))
00145
00146 case('cartesian')
00147
00148 create_distribution = create_distrb_cart(nprocs, work_per_block)
00149
00150 case('rake')
00151
00152 create_distribution = create_distrb_rake(nprocs, work_per_block)
00153
00154 case('spacecurve')
00155
00156
00157 create_distribution = create_distrb_spacecurve(nprocs, maxBlock, &
00158 work_per_block,prob_per_block,blockType,bStats, FixMaxBlock )
00159
00160
00161 case default
00162
00163 call abort_ice('ice distribution: unknown distribution type')
00164
00165 end select
00166 if(my_task == master_task) then
00167 write(nu_diag,*) 'Active processors: ',MAXVAL(create_distribution%blockLocation)
00168 endif
00169
00170
00171
00172
00173 end function create_distribution
00174
00175
00176
00177
00178
00179
00180 subroutine create_local_block_ids(block_ids, distribution)
00181
00182
00183
00184
00185
00186
00187
00188
00189
00190
00191
00192 type (distrb), intent(in) ::
00193 distribution
00194
00195
00196
00197
00198 integer (int_kind), dimension(:), pointer ::
00199 block_ids
00200
00201
00202
00203
00204
00205
00206
00207
00208
00209 integer (int_kind) ::
00210 n, bid, bcount
00211
00212 logical (log_kind) :: dbug
00213
00214
00215
00216
00217
00218
00219
00220 bcount = 0
00221 do n=1,size(distribution%blockLocation)
00222 if (distribution%blockLocation(n) == my_task+1) bcount = bcount + 1
00223 end do
00224
00225
00226 if (bcount > 0) allocate(block_ids(bcount))
00227
00228
00229
00230
00231
00232
00233
00234
00235 dbug = .false.
00236 if (bcount > 0) then
00237 do n=1,size(distribution%blockLocation)
00238 if (distribution%blockLocation(n) == my_task+1) then
00239 block_ids(distribution%blockLocalID(n)) = n
00240
00241 if (dbug) then
00242 write(nu_diag,*) 'block id, proc, local_block: ', &
00243 block_ids(distribution%blockLocalID(n)), &
00244 distribution%blockLocation(n), &
00245 distribution%blockLocalID(n)
00246 endif
00247 endif
00248 end do
00249 endif
00250
00251
00252
00253 end subroutine create_local_block_ids
00254
00255
00256
00257
00258
00259
00260 subroutine proc_decomposition(nprocs, nprocs_x, nprocs_y)
00261
00262
00263
00264
00265
00266
00267
00268
00269
00270
00271 use ice_domain_size
00272
00273
00274
00275 integer (int_kind), intent(in) ::
00276 nprocs
00277
00278
00279
00280 integer (int_kind), intent(out) ::
00281 nprocs_x, nprocs_y
00282
00283
00284
00285
00286
00287
00288
00289
00290
00291 integer (int_kind) ::
00292 iguess, jguess
00293
00294 real (real_kind) ::
00295 square
00296
00297
00298
00299
00300
00301
00302
00303 square = sqrt(real(nprocs,kind=real_kind))
00304 nprocs_x = 0
00305 nprocs_y = 0
00306
00307 if (processor_shape == 'square-pop') then
00308 iguess = nint(square)
00309 jguess = nprocs/iguess
00310 elseif (processor_shape == 'square-ice') then
00311 jguess = nint(square)
00312 iguess = nprocs/jguess
00313 elseif (processor_shape == 'slenderX1') then
00314 jguess = 1
00315 iguess = nprocs/jguess
00316 else
00317 jguess = min(2, nprocs)
00318 iguess = nprocs/jguess
00319 endif
00320
00321
00322
00323
00324
00325
00326
00327 proc_loop: do
00328 if (processor_shape == 'square-pop') then
00329 jguess = nprocs/iguess
00330 else
00331 iguess = nprocs/jguess
00332 endif
00333
00334 if (iguess*jguess == nprocs) then
00335
00336
00337
00338 if (mod(nblocks_x,iguess) == 0 .and. &
00339 mod(nblocks_y,jguess) == 0) then
00340 nprocs_x = iguess
00341 nprocs_y = jguess
00342 exit proc_loop
00343
00344
00345
00346 else if (mod(nblocks_x,jguess) == 0 .and. &
00347 mod(nblocks_y,iguess) == 0) then
00348 nprocs_x = jguess
00349 nprocs_y = iguess
00350 exit proc_loop
00351
00352
00353
00354 else
00355 if (nprocs_x == 0) then
00356 nprocs_x = iguess
00357 nprocs_y = jguess
00358 endif
00359 if (processor_shape == 'square-pop') then
00360 iguess = iguess - 1
00361 if (iguess == 0) then
00362 exit proc_loop
00363 else
00364 cycle proc_loop
00365 endif
00366 else
00367 jguess = jguess - 1
00368 if (jguess == 0) then
00369 exit proc_loop
00370 else
00371 cycle proc_loop
00372 endif
00373 endif
00374 endif
00375
00376 else
00377
00378 if (processor_shape == 'square-pop') then
00379 iguess = iguess - 1
00380 if (iguess == 0) then
00381 exit proc_loop
00382 else
00383 cycle proc_loop
00384 endif
00385 else
00386 jguess = jguess - 1
00387 if (jguess == 0) then
00388 exit proc_loop
00389 else
00390 cycle proc_loop
00391 endif
00392 endif
00393 endif
00394
00395 end do proc_loop
00396
00397 if (nprocs_x == 0) then
00398 call abort_ice('ice: Unable to find 2d processor config')
00399 endif
00400
00401 if (my_task == master_task) then
00402 write(nu_diag,'(a23,i4,a3,i4)') ' Processors (X x Y) = ', &
00403 nprocs_x,' x ',nprocs_y
00404 endif
00405
00406
00407
00408
00409 end subroutine proc_decomposition
00410
00411
00412
00413
00414
00415
00416 subroutine ice_distributionDestroy(distribution)
00417
00418
00419
00420
00421
00422
00423
00424
00425
00426
00427 type (distrb), intent(inout) ::
00428 distribution
00429
00430
00431
00432
00433
00434
00435
00436
00437
00438
00439
00440 integer (int_kind) :: istat
00441
00442
00443
00444
00445
00446
00447
00448 distribution%nprocs = 0
00449 distribution%communicator = 0
00450 distribution%numLocalBlocks = 0
00451
00452
00453
00454
00455
00456
00457
00458 deallocate(distribution%blockLocation, stat=istat)
00459 deallocate(distribution%blockLocalID , stat=istat)
00460 deallocate(distribution%blockGlobalID, stat=istat)
00461 deallocate(distribution%blockCnt, stat=istat)
00462
00463
00464
00465
00466 end subroutine ice_distributionDestroy
00467
00468
00469
00470
00471
00472
00473 subroutine ice_distributionGet(distribution,&
00474 nprocs, communicator, numLocalBlocks, &
00475 blockLocation, blockLocalID, blockGlobalID)
00476
00477
00478
00479
00480
00481
00482
00483
00484
00485
00486 type (distrb), intent(in) ::
00487 distribution
00488
00489
00490
00491
00492 integer (int_kind), intent(out), optional ::
00493 nprocs ,
00494 communicator ,
00495 numLocalBlocks
00496
00497
00498 integer (int_kind), dimension(:), pointer, optional ::
00499 blockLocation ,
00500 blockLocalID ,
00501 blockGlobalID
00502
00503
00504
00505
00506
00507
00508
00509
00510
00511
00512 if (present(nprocs)) nprocs = distribution%nprocs
00513 if (present(communicator)) communicator = distribution%communicator
00514 if (present(numLocalBlocks)) numLocalBlocks = distribution%numLocalBlocks
00515
00516 if (present(blockLocation)) then
00517 if (associated(distribution%blockLocation)) then
00518 blockLocation => distribution%blockLocation
00519 else
00520 call abort_ice( &
00521 'ice_distributionGet: blockLocation not allocated')
00522 return
00523 endif
00524 endif
00525
00526 if (present(blockLocalID)) then
00527 if (associated(distribution%blockLocalID)) then
00528 blockLocalID = distribution%blockLocalID
00529 else
00530 call abort_ice( &
00531 'ice_distributionGet: blockLocalID not allocated')
00532 return
00533 endif
00534 endif
00535
00536 if (present(blockGlobalID)) then
00537 if (associated(distribution%blockGlobalID)) then
00538 blockGlobalID = distribution%blockGlobalID
00539 else
00540 call abort_ice( &
00541 'ice_distributionGet: blockGlobalID not allocated')
00542 return
00543 endif
00544 endif
00545
00546
00547
00548
00549 end subroutine ice_distributionGet
00550
00551
00552
00553
00554
00555
00556 subroutine ice_distributionGetBlockLoc(distribution, blockID, &
00557 processor, localID)
00558
00559
00560
00561
00562
00563
00564
00565
00566
00567
00568
00569
00570
00571 type (distrb), intent(in) ::
00572 distribution
00573
00574
00575 integer (int_kind), intent(in) ::
00576 blockID
00577
00578
00579
00580 integer (int_kind), intent(out) ::
00581 processor,
00582 localID
00583
00584
00585
00586
00587
00588
00589
00590
00591
00592 if (blockID < 0 .or. blockID > nblocks_tot) then
00593 call abort_ice( &
00594 'ice_distributionGetBlockLoc: invalid block id')
00595 return
00596 endif
00597
00598
00599
00600
00601
00602
00603
00604 processor = distribution%blockLocation(blockID)
00605 localID = distribution%blockLocalID (blockID)
00606
00607
00608
00609
00610 end subroutine ice_distributionGetBlockLoc
00611
00612
00613
00614
00615
00616
00617 subroutine ice_distributionGetBlockID(distribution, localID, &
00618 blockID)
00619
00620
00621
00622
00623
00624
00625
00626
00627
00628
00629
00630 type (distrb), intent(in) ::
00631 distribution
00632
00633
00634 integer (int_kind), intent(in) ::
00635 localID
00636
00637
00638
00639 integer (int_kind), intent(out) ::
00640 blockID
00641
00642
00643
00644
00645
00646
00647
00648
00649
00650 if (localID < 0 .or. localID > distribution%numLocalBlocks) then
00651 call abort_ice( &
00652 'ice_distributionGetBlockID: invalid local id')
00653 return
00654 endif
00655
00656
00657
00658
00659
00660
00661
00662 blockID = distribution%blockGlobalID (localID)
00663
00664
00665
00666
00667 end subroutine ice_distributionGetBlockID
00668
00669
00670
00671
00672
00673
00674 function create_distrb_cart(nprocs, workPerBlock) result(newDistrb)
00675
00676
00677
00678
00679
00680
00681
00682
00683
00684
00685 integer (int_kind), intent(in) ::
00686 nprocs
00687
00688 integer (int_kind), dimension(:), intent(in) ::
00689 workPerBlock
00690
00691
00692
00693 type (distrb) ::
00694 newDistrb
00695
00696
00697
00698
00699
00700
00701
00702
00703
00704
00705 integer (int_kind) ::
00706 i, j,
00707 istat,
00708 iblock, jblock,
00709 is, ie, js, je,
00710 processor,
00711 globalID,
00712 localID,
00713 nprocsX,
00714 nprocsY,
00715 numBlocksXPerProc,
00716 numBlocksYPerProc
00717
00718 integer (int_kind), dimension(:), allocatable ::
00719 proc_tmp
00720
00721 integer (int_kind) :: pid,n
00722
00723
00724
00725
00726
00727
00728
00729 call create_communicator(newDistrb%communicator, nprocs)
00730
00731
00732
00733
00734
00735
00736
00737 newDistrb%nprocs = nprocs
00738
00739 call proc_decomposition(nprocs, nprocsX, nprocsY)
00740
00741
00742
00743
00744
00745
00746
00747
00748 allocate (newDistrb%blockLocation(nblocks_tot), &
00749 newDistrb%blockLocalID (nblocks_tot), stat=istat)
00750
00751 allocate (newDistrb%blockCnt(nprocs))
00752
00753
00754
00755
00756
00757
00758 numBlocksXPerProc = (nblocks_x-1)/nprocsX + 1
00759 numBlocksYPerProc = (nblocks_y-1)/nprocsY + 1
00760
00761 do j=1,nprocsY
00762 do i=1,nprocsX
00763 processor = (j-1)*nprocsX + i
00764
00765
00766 is = (i-1)*numBlocksXPerProc + 1
00767 ie = i *numBlocksXPerProc
00768 if (ie > nblocks_x) ie = nblocks_x
00769 js = (j-1)*numBlocksYPerProc + 1
00770 je = j *numBlocksYPerProc
00771 if (je > nblocks_y) je = nblocks_y
00772
00773 localID = 0
00774 do jblock = js,je
00775 do iblock = is,ie
00776 globalID = (jblock - 1)*nblocks_x + iblock
00777 if (workPerBlock(globalID) /= 0) then
00778 localID = localID + 1
00779 newDistrb%blockLocation(globalID) = processor
00780 newDistrb%blockLocalID (globalID) = localID
00781 else
00782 newDistrb%blockLocation(globalID) = 0
00783 newDistrb%blockLocalID (globalID) = 0
00784 endif
00785 end do
00786 end do
00787
00788
00789 if (my_task == processor - 1) then
00790 newDistrb%numLocalBlocks = localID
00791 endif
00792
00793 end do
00794 end do
00795
00796
00797
00798
00799
00800
00801
00802 if (newDistrb%numLocalBlocks > 0) then
00803 allocate (newDistrb%blockGlobalID(newDistrb%numLocalBlocks), &
00804 stat=istat)
00805
00806 do j=1,nprocsY
00807 do i=1,nprocsX
00808 processor = (j-1)*nprocsX + i
00809
00810 if (processor == my_task + 1) then
00811 is = (i-1)*numBlocksXPerProc + 1
00812 ie = i *numBlocksXPerProc
00813 if (ie > nblocks_x) ie = nblocks_x
00814 js = (j-1)*numBlocksYPerProc + 1
00815 je = j *numBlocksYPerProc
00816 if (je > nblocks_y) je = nblocks_y
00817
00818 localID = 0
00819 do jblock = js,je
00820 do iblock = is,ie
00821 globalID = (jblock - 1)*nblocks_x + iblock
00822 if (workPerBlock(globalID) /= 0) then
00823 localID = localID + 1
00824 newDistrb%blockGlobalID (localID) = globalID
00825 endif
00826 end do
00827 end do
00828
00829 endif
00830
00831 end do
00832 end do
00833
00834 endif
00835
00836 allocate(proc_tmp(nprocs))
00837 proc_tmp = 0
00838
00839 allocate(newDistrb%blockIndex(nprocs,max_blocks))
00840 newDistrb%blockIndex(:,:) = 0
00841
00842 do n=1,nblocks_tot
00843 pid = newDistrb%blockLocation(n)
00844 if(pid>0) then
00845 proc_tmp(pid) = proc_tmp(pid) + 1
00846 if(proc_tmp(pid) <= max_blocks) then
00847 newDistrb%blockIndex(pid,proc_tmp(pid)) = n
00848 endif
00849 endif
00850 enddo
00851
00852 newDistrb%blockCnt(:) = proc_tmp(:)
00853 deallocate(proc_tmp)
00854
00855
00856
00857
00858
00859 end function create_distrb_cart
00860
00861
00862
00863
00864
00865
00866 function create_distrb_rake(nprocs, workPerBlock) result(newDistrb)
00867
00868
00869
00870
00871
00872
00873
00874
00875
00876
00877
00878
00879
00880 integer (int_kind), intent(in) ::
00881 nprocs
00882
00883 integer (int_kind), dimension(:), intent(in) ::
00884 workPerBlock
00885
00886
00887
00888 type (distrb) ::
00889 newDistrb
00890
00891
00892
00893
00894
00895
00896
00897
00898
00899
00900 integer (int_kind) ::
00901 i,j,n ,
00902 pid ,
00903 istat ,
00904 localBlock ,
00905 numOcnBlocks ,
00906 maxWork ,
00907 nprocsX ,
00908 nprocsY
00909
00910 integer (int_kind), dimension(:), allocatable ::
00911 priority ,
00912 workTmp ,
00913 procTmp
00914
00915 type (distrb) :: dist
00916
00917
00918
00919
00920
00921
00922
00923 dist = create_distrb_cart(nprocs, workPerBlock)
00924
00925
00926
00927
00928
00929
00930
00931
00932 numOcnBlocks = count(workPerBlock /= 0)
00933
00934 if (numOcnBlocks <= 2*nprocs) then
00935
00936 allocate(priority(nblocks_tot), stat=istat)
00937
00938
00939
00940 do j=1,nblocks_y
00941 do i=1,nblocks_x
00942 n=(j-1)*nblocks_x + i
00943 if (workPerBlock(n) > 0) then
00944 priority(n) = maxWork + n - workPerBlock(n)
00945 else
00946 priority(n) = 0
00947 endif
00948 end do
00949 end do
00950
00951 allocate(workTmp(nblocks_tot), procTmp(nblocks_tot), stat=istat)
00952
00953 workTmp(:) = 0
00954 do i=1,nprocs
00955 procTmp(i) = i
00956 do n=1,nblocks_tot
00957 if (dist%blockLocation(n) == i) then
00958 workTmp(i) = workTmp(i) + workPerBlock(n)
00959 endif
00960 end do
00961 end do
00962
00963 call ice_distributionRake (workTmp, procTmp, workPerBlock, &
00964 priority, dist)
00965
00966 deallocate(workTmp, procTmp, stat=istat)
00967
00968
00969
00970
00971
00972
00973
00974 else
00975
00976 maxWork = maxval(workPerBlock)
00977
00978 call proc_decomposition(dist%nprocs, nprocsX, nprocsY)
00979
00980
00981
00982
00983
00984
00985
00986 allocate(priority(nblocks_tot), stat=istat)
00987
00988
00989
00990
00991
00992 do j=1,nblocks_y
00993 do i=1,nblocks_x
00994 n=(j-1)*nblocks_x + i
00995 if (workPerBlock(n) > 0) then
00996 priority(n) = (maxWork + 1)*(nblocks_x + i) - &
00997 workPerBlock(n)
00998 else
00999 priority(n) = 0
01000 endif
01001 end do
01002 end do
01003
01004 allocate(workTmp(nprocsX), procTmp(nprocsX), stat=istat)
01005
01006 do j=1,nprocsY
01007
01008 workTmp(:) = 0
01009 do i=1,nprocsX
01010 pid = (j-1)*nprocsX + i
01011 procTmp(i) = pid
01012 do n=1,nblocks_tot
01013 if (dist%blockLocation(n) == pid) then
01014 workTmp(i) = workTmp(i) + workPerBlock(n)
01015 endif
01016 end do
01017 end do
01018
01019 call ice_distributionRake (workTmp, procTmp, workPerBlock, &
01020 priority, dist)
01021 end do
01022
01023 deallocate(workTmp, procTmp, stat=istat)
01024
01025
01026
01027
01028
01029
01030
01031
01032
01033
01034 do j=1,nblocks_y
01035 do i=1,nblocks_x
01036 n=(j-1)*nblocks_x + i
01037 if (workPerBlock(n) > 0) then
01038 priority(n) = (maxWork + 1)*(nblocks_y + j) - &
01039 workPerBlock(n)
01040 else
01041 priority(n) = 0
01042 endif
01043 end do
01044 end do
01045
01046 allocate(workTmp(nprocsY), procTmp(nprocsY), stat=istat)
01047
01048 do i=1,nprocsX
01049
01050 workTmp(:) = 0
01051 do j=1,nprocsY
01052 pid = (j-1)*nprocsX + i
01053 procTmp(j) = pid
01054 do n=1,nblocks_tot
01055 if (dist%blockLocation(n) == pid) then
01056 workTmp(j) = workTmp(j) + workPerBlock(n)
01057 endif
01058 end do
01059 end do
01060
01061 call ice_distributionRake (workTmp, procTmp, workPerBlock, &
01062 priority, dist)
01063
01064 end do
01065
01066 deallocate(workTmp, procTmp, priority, stat=istat)
01067
01068 endif
01069
01070
01071
01072
01073
01074
01075
01076
01077 newDistrb%nprocs = nprocs
01078 newDistrb%communicator = dist%communicator
01079
01080 allocate(newDistrb%blockLocation(nblocks_tot), &
01081 newDistrb%blockLocalID(nblocks_tot), stat=istat)
01082 allocate (newDistrb%blockCnt(nprocs))
01083
01084 allocate(procTmp(nprocs), stat=istat)
01085
01086 allocate(newDistrb%blockIndex(nprocs,max_blocks))
01087 newDistrb%blockIndex(:,:) = 0
01088
01089 procTmp = 0
01090 do n=1,nblocks_tot
01091 pid = dist%blockLocation(n)
01092 newDistrb%blockLocation(n) = pid
01093
01094 if (pid > 0) then
01095 procTmp(pid) = procTmp(pid) + 1
01096 newDistrb%blockLocalID (n) = procTmp(pid)
01097 if(procTmp(pid) <= max_blocks) then
01098 newDistrb%blockIndex(pid,procTmp(pid)) = n
01099 endif
01100 else
01101 newDistrb%blockLocalID (n) = 0
01102 endif
01103 end do
01104
01105 newDistrb%numLocalBlocks = procTmp(my_task+1)
01106
01107 if (minval(procTmp) < 1) then
01108 call abort_ice( &
01109 'create_distrb_rake: processors left with no blocks')
01110 return
01111 endif
01112
01113 newDistrb%blockCnt(:) = procTmp(:)
01114
01115 deallocate(procTmp, stat=istat)
01116
01117 if (istat > 0) then
01118 call abort_ice( &
01119 'create_distrb_rake: error allocating last procTmp')
01120 return
01121 endif
01122
01123 allocate(newDistrb%blockGlobalID(newDistrb%numLocalBlocks), &
01124 stat=istat)
01125
01126 if (istat > 0) then
01127 call abort_ice( &
01128 'create_distrb_rake: error allocating blockGlobalID')
01129 return
01130 endif
01131
01132 localBlock = 0
01133 do n=1,nblocks_tot
01134 if (newDistrb%blockLocation(n) == my_task+1) then
01135 localBlock = localBlock + 1
01136 newDistrb%blockGlobalID(localBlock) = n
01137 endif
01138 end do
01139
01140
01141
01142
01143
01144 call ice_distributionDestroy(dist)
01145
01146
01147
01148
01149 end function create_distrb_rake
01150
01151
01152
01153
01154
01155
01156 function create_distrb_spacecurve(nprocs, maxBlock, work_per_block,prob_per_block,blockType, bStats, FixMaxBlock )
01157
01158
01159
01160
01161
01162
01163
01164
01165
01166
01167 integer (int_kind), intent(in) ::
01168 nprocs
01169
01170 integer (int_kind), intent(in) :: maxBlock
01171
01172 integer (int_kind), dimension(:), intent(in) ::
01173 work_per_block
01174
01175 real(dbl_kind), dimension(:), intent(in) ::
01176 prob_per_block
01177
01178 integer (int_kind), dimension(:), intent(in) ::
01179 blockType
01180
01181 real (dbl_kind), dimension(:,:), intent(in) :: bStats
01182
01183 logical, intent(in) :: FixMaxBlock
01184
01185
01186
01187 type (distrb) ::
01188 create_distrb_spacecurve
01189
01190
01191
01192
01193
01194
01195
01196
01197
01198
01199 integer (int_kind) ::
01200 i,j,k,n ,
01201 pid ,
01202 localID ,
01203 max_work ,
01204 nprocs_x ,
01205 nprocs_y
01206
01207 character(char_len) :: fname
01208
01209 integer (int_kind) :: maxB
01210
01211 integer (int_kind), dimension(:),allocatable ::
01212 idxT_i,idxT_j,Lindx,Lindx2
01213
01214 integer (int_kind), dimension(:,:),allocatable ::
01215 Mesh ,
01216 Mesh2
01217
01218 integer (int_kind) ::
01219 nblocksL,nblocks,
01220 ii,extra,tmp1,
01221 s1,ig
01222
01223 logical, parameter :: Debug = .FALSE.
01224
01225 integer (int_kind), dimension(:), allocatable ::
01226 priority ,
01227 work_tmp ,
01228 proc_tmp ,
01229 block_count
01230
01231 integer (int_kind), allocatable, dimension(:) ::
01232 blockLocation,
01233 distance,
01234 type_on_curve,
01235 work_on_curve
01236
01237 type (distrb) :: dist
01238
01239 integer (int_kind) :: numIce, minblocks
01240 type (factor_t) :: xdim, ydim
01241
01242 integer (int_kind) :: it,jj,i2,j2
01243 integer (int_kind) :: curveSize, sb_x, sb_y, itmp,numfac
01244 integer (int_kind) :: subNum,sfcNum
01245 logical (log_kind) :: foundX
01246
01247 integer (int_kind) :: ns,ntmp
01248 integer (int_kind) :: numLocalBlocks
01249
01250 real (dbl_kind), allocatable, dimension(:) ::
01251 Cost_per_proc ,
01252 Cost_per_block
01253
01254 real (dbl_kind), allocatable, dimension(:,:) :: cStats
01255
01256 integer (int_kind), allocatable, dimension(:) :: work_per_proc,work_per_block2
01257 integer (int_kind) :: ierr
01258
01259 character(len=char_len) :: partitioning_type
01260 logical, parameter :: verbose = .FALSE.
01261
01262
01263
01264
01265
01266
01267
01268 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #1: nblocks_x,nblocks_y: ',nblocks_x,nblocks_y
01269 if((.not. IsFactorable(nblocks_y)) .or. (.not. IsFactorable(nblocks_x))) then
01270 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #1.1'
01271 create_distrb_spacecurve = create_distrb_cart(nprocs, work_per_block)
01272 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #1.2'
01273 return
01274 endif
01275 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #1.3'
01276
01277
01278
01279
01280 xdim = Factor(nblocks_x)
01281 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #1.4'
01282 ydim = Factor(nblocks_y)
01283 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #1.5'
01284 numfac = xdim%numfact
01285 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #2'
01286
01287
01288
01289
01290 curveSize=1
01291 do it=1,numfac
01292 call MatchFactor(xdim,ydim,itmp,foundX)
01293 curveSize = itmp*curveSize
01294 enddo
01295 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #3'
01296
01297
01298
01299
01300 sb_x = ProdFactor(xdim)
01301 sb_y = ProdFactor(ydim)
01302
01303 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #4'
01304 call create_communicator(dist%communicator, nprocs)
01305
01306 dist%nprocs = nprocs
01307
01308
01309
01310
01311
01312
01313
01314 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #5'
01315 allocate(blockLocation(nblocks_tot),type_on_curve(nblocks_tot))
01316 allocate(distance(nblocks_tot))
01317 allocate(work_on_curve(nblocks_tot))
01318 allocate (dist%blockLocation(nblocks_tot), &
01319 dist%blockLocalID (nblocks_tot))
01320
01321 allocate (dist%blockCnt(nprocs))
01322
01323 blockLocation = 0
01324 dist%blockLocation=0
01325 dist%blockLocalID =0
01326 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #6'
01327
01328
01329
01330
01331 allocate(Mesh(curveSize,curveSize))
01332 allocate(Mesh2(nblocks_x,nblocks_y))
01333 allocate(idxT_i(nblocks_tot),idxT_j(nblocks_tot),Lindx(nblocks_tot))
01334 allocate(Lindx2(nblocks_tot))
01335 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #7'
01336
01337
01338 Mesh = 0
01339 Mesh2 = 0
01340
01341
01342
01343 allocate(Cost_per_proc(nblocks_tot))
01344 allocate(Cost_per_block(nblocks_tot))
01345 allocate(work_per_proc(nprocs))
01346 allocate(work_per_block2(nblocks_tot))
01347 call EstimateCost(bStats,nblocks_tot,Cost_per_block)
01348 blockLocation=0
01349
01350 do i=1,nblocks_tot
01351 work_per_block2(i) = NINT(10.0*ABS(Cost_per_block(i)),kind=int_kind)
01352 enddo
01353
01354 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #8'
01355
01356
01357
01358
01359
01360 call GenSpaceCurve(Mesh)
01361 Mesh = Mesh + 1
01362 if(Debug) then
01363 if(my_task ==0) call PrintCurve(Mesh)
01364 endif
01365
01366
01367
01368 do j=1,curveSize
01369 do i=1,curveSize
01370 sfcNum = (Mesh(i,j) - 1)*(sb_x*sb_y) + 1
01371 do jj=1,sb_y
01372 do ii=1,sb_x
01373 subNum = (jj-1)*sb_x + (ii-1)
01374 i2 = (i-1)*sb_x + ii
01375 j2 = (j-1)*sb_y + jj
01376 Mesh2(i2,j2) = sfcNum + subNum
01377 enddo
01378 enddo
01379 enddo
01380 enddo
01381 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #9'
01382
01383
01384
01385 idxT_i=0;idxT_j=0;Lindx=0;Lindx2=0
01386 do j=1,nblocks_y
01387 do i=1,nblocks_x
01388 n = (j-1)*nblocks_x + i
01389 ig = Mesh2(i,j)
01390 if(work_per_block(n) /= 0) then
01391 idxT_i(ig)=i;idxT_j(ig)=j
01392 endif
01393 Lindx(n) = ig
01394 enddo
01395 enddo
01396 do i=1,nblocks_tot
01397 type_on_curve(Lindx(i)) = blockType(i)
01398 enddo
01399 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #10'
01400
01401
01402
01403
01404 ii=0
01405 do i=1,nblocks_tot
01406 if(IdxT_i(i) .gt. 0) then
01407 ii=ii+1
01408
01409 n = (idxT_j(i)-1)*nblocks_x + idxT_i(i)
01410 Lindx2(n) = ii
01411 endif
01412 enddo
01413 nblocks=ii
01414
01415
01416
01417 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #11'
01418 allocate(cStats(numCoeff,nblocks))
01419 do i=1,nblocks_tot
01420 if(Lindx2(i)>0) then
01421 work_on_curve(Lindx2(i)) = work_per_block2(i)
01422 type_on_curve(Lindx2(i)) = blockType(i)
01423 cStats(:,Lindx2(i)) = bStats(:,i)
01424 distance(Lindx2(i)) = Lindx(i)
01425 endif
01426 enddo
01427 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #12'
01428
01429 if(lprint_stats) then
01430 fname = 'WorkPerBlock.bin'
01431 call WriteIntegerArray(fname,nblocks,work_on_curve)
01432
01433
01434
01435
01436
01437
01438 endif
01439
01440 if(lprint_stats) then
01441 call WriteProbabilityStats(bStats,nblocks_tot)
01442 endif
01443
01444 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #13'
01445
01446 maxB=MIN(max_blocks,maxBlock)
01447 partitioning_type = 'weight'
01448 select case(partitioning_type)
01449 case ('type')
01450
01451 numIce = COUNT(blockType .eq. iceType)
01452 minblocks = CEILING(REAL(numIce)/REAL(nprocs),kind=int_kind)
01453
01454 call TypePartition(type_on_curve,minblocks,maxB,blockLocation)
01455 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #14'
01456 if(MAXVAL(blockLocation) > nprocs) then
01457 print *,'ERROR: problem with partitioning: insufficient processors'
01458 endif
01459
01460 do i=1,nblocks_tot
01461 dist%blockLocation(i) = blockLocation(Lindx(i))
01462 enddo
01463 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #15'
01464 case ('weight')
01465 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #16'
01466 call PartitionCurve(work_on_curve(1:nblocks),work_per_proc, &
01467 blockLocation(1:nblocks),distance(1:nblocks), nprocs,maxB,cStats,FixMaxBlock, ierr)
01468 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #17'
01469
01470 if(ierr < 0) then
01471 call abort_ice('create_distrb_spacecurve: PartitionCurve failed')
01472 endif
01473
01474 call broadcast_array(blockLocation,master_task)
01475
01476
01477 numLocalBlocks=0
01478 do i=1,nblocks_tot
01479 if(Lindx2(i)>0) then
01480 dist%blockLocation(i) = blockLocation(Lindx2(i))
01481 numLocalBlocks=numLocalBlocks+1
01482 endif
01483 enddo
01484 end select
01485
01486
01487
01488
01489
01490
01491 call BuildProbabilityStats2(dist%blockLocation,cStats)
01492
01493
01494 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #19'
01495 call EstimateCost(cStats,nprocs,Cost_per_proc)
01496
01497
01498
01499 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #20'
01500 if(lprint_stats) then
01501 fname = 'Q.bin'
01502 call WriteIntegerArray(fname,nblocks_tot,dist%blockLocation)
01503
01504 fname = 'Cost.bin'
01505 call WriteDblArray(fname,nprocs,Cost_per_proc)
01506
01507 fname = 'perfm.bin'
01508 call WriteDblArray(fname,numCoeff,perfmodel)
01509 endif
01510
01511 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #21'
01512
01513
01514
01515
01516 allocate(proc_tmp(nprocs))
01517 proc_tmp = 0
01518
01519 allocate(dist%blockIndex(nprocs,max_blocks))
01520 dist%blockIndex(:,:) = 0
01521 do n=1,nblocks_tot
01522 pid = dist%blockLocation(n)
01523 if(pid>0) then
01524 proc_tmp(pid) = proc_tmp(pid) + 1
01525 dist%blockLocalID(n) = proc_tmp(pid)
01526 if(proc_tmp(pid) <= max_blocks) then
01527 dist%blockIndex(pid,proc_tmp(pid)) = n
01528 endif
01529 endif
01530 enddo
01531 dist%blockCnt(:) = proc_tmp(:)
01532
01533 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #22'
01534
01535
01536
01537 dist%numLocalBlocks = proc_tmp(my_task+1)
01538 if (dist%numLocalBlocks>0) then
01539 allocate(dist%blockGlobalID(dist%numLocalBlocks))
01540 localID=1
01541 do n=1,nblocks_tot
01542 pid = dist%blockLocation(n)
01543 if(pid == my_task+1) then
01544 dist%blockGlobalID(localID) = n
01545 localID=localID+1
01546 endif
01547 enddo
01548 endif
01549 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #23'
01550 if(Debug) then
01551 if(my_task==0) print *,'dist%blockLocation:= ',dist%blockLocation
01552 print *,'IAM: ',my_task,' SpaceCurve: Number of blocks {total,local} :=', &
01553 nblocks_tot,nblocks,proc_tmp(my_task+1)
01554 endif
01555
01556
01557
01558
01559
01560 deallocate(blockLocation)
01561
01562 deallocate(type_on_curve)
01563
01564 deallocate(work_on_curve)
01565
01566 deallocate(proc_tmp)
01567
01568 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #24'
01569 deallocate(Mesh,Mesh2)
01570
01571 deallocate(idxT_i,idxT_j,Lindx,Lindx2)
01572
01573 deallocate(Cost_per_proc)
01574
01575 deallocate(Cost_per_block)
01576
01577 deallocate(work_per_proc)
01578
01579 deallocate(work_per_block2)
01580
01581 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #25'
01582 if(verbose .and. my_task == 0) then
01583 print *,'create_distrb_spacecurve: blockCnt ',dist%blockCnt
01584 print *,'create_distrb_spacecurve: blockIndex ',dist%blockIndex
01585 endif
01586
01587
01588
01589 create_distrb_spacecurve = dist
01590
01591
01592 if (verbose .and. my_task==0) then
01593 print *,'create_distrb_spacecurve%blockGlobalID: ',create_distrb_spacecurve%blockGlobalID
01594 print *,'create_distrb_spacecurve%blockCnt: ',create_distrb_spacecurve%blockCnt
01595 endif
01596
01597 if(verbose) print *,'IAM: ',my_task,'create_distrb_spacecurve: point #26'
01598
01599
01600 end function create_distrb_spacecurve
01601
01602 subroutine TypePartition(blockType,minblocks,maxblocks,blockLocation)
01603
01604 integer(kind=int_kind), intent(in) :: blockType(nblocks_tot)
01605 integer, intent(in) :: minblocks,
01606 maxblocks
01607 integer(kind=int_kind), intent(inout) :: blockLocation(nblocks_tot)
01608
01609 integer :: i,ip,cur,next
01610 integer :: cntLnd,tcntLnd,
01611 cntIcefree,tcntIcefree,
01612 cntIce,tcntIce
01613
01614
01615 tcntIce = 0
01616 tcntLnd = 0
01617 tcntIcefree = 0
01618 cntIce = 0
01619 cntLnd = 0
01620 cntIcefree = 0
01621 ip = 1
01622 do i=1,nblocks_tot
01623 cur = blockType(i)
01624 if(i<nblocks_tot) then
01625 next = blockType(i+1)
01626 else
01627 next = cur
01628 endif
01629
01630
01631
01632
01633 if(cur == lndType) then
01634 tcntLnd = tcntLnd + 1
01635 endif
01636
01637
01638
01639
01640 if (cur == icefreeType) then
01641 tcntIcefree = tcntIcefree + 1
01642 cntIcefree = cntIcefree + 1
01643 blockLocation(i) = ip
01644 if ((cntIcefree == maxblocks) .or. (next /= cur)) then
01645 ip = ip + 1
01646 cntIcefree=0
01647 endif
01648 endif
01649
01650
01651
01652
01653
01654 if (cur == iceType) then
01655 tcntIce = tcntIce + 1
01656 cntIce = cntIce + 1
01657 blockLocation(i) = ip
01658 if ((cntIce == minblocks) .or. (next /= cur)) then
01659 ip = ip + 1
01660 cntIce=0
01661 endif
01662 endif
01663 enddo
01664
01665 if(my_task == 0) then
01666 write(*,23) tcntLnd+tcntIce+tcntIcefree, tcntIce, tcntIcefree, tcntLnd
01667
01668
01669 write(*,24) MAXVAL(blockLocation)
01670
01671 endif
01672
01673 23 format('Total blocks: ',i5,' Ice blocks: ',i5,' IceFree blocks: ',i5,' Land blocks: ',i5)
01674 24 format('Partitioned across ',i5,' processors')
01675
01676
01677 end subroutine TypePartition
01678
01679 subroutine PartitionCurve(work_per_block, work_per_proc, blockLocation, distance, &
01680 nproc, max_blocks, Stats, FixMaxBlock, ierr)
01681
01682 integer (int_kind), intent(inout) :: work_per_block(:)
01683 integer (int_kind), intent(inout) :: work_per_proc(:)
01684 integer (int_kind), intent(inout) :: blockLocation(:)
01685 integer (int_kind), intent(inout) :: distance(:)
01686 integer (int_kind), intent(in) :: nproc
01687 integer (int_kind), intent(in) :: max_blocks
01688 real (dbl_kind), intent(in) :: Stats(:,:)
01689 logical, intent(in) :: FixMaxBlock
01690 integer (int_kind), intent(inout) :: ierr
01691
01692 integer :: cnt
01693
01694 integer :: nb,anProc
01695 integer :: n,ip,i,imax
01696 real :: totalCost, avgCost, maxCost,dtCost
01697 integer, allocatable :: saveblockLocation(:)
01698 integer :: maxBlocks,minBlocks
01699 integer :: ivalue
01700 real (real_kind) :: maxValue
01701 real :: maxValue_save
01702 real :: minValue
01703 logical :: contLoop
01704
01705 integer :: maxB,minB
01706
01707 logical, parameter :: verbose = .FALSE.
01708 integer :: it,maxiter
01709 integer :: save_maxB
01710 real :: save_maxCost
01711
01712 integer :: amaxBlocks
01713
01714 real :: aWork,minWork,maxWork,maxWorkBlock
01715 real :: minCostBlock, maxCostBlock
01716 real :: maxCost_old
01717 real (real_kind) :: maxDil,amaxDil
01718 real (dbl_kind), allocatable, dimension(:) :: cost_per_proc
01719 real (dbl_kind), allocatable, dimension(:) :: cost_per_block
01720 real (dbl_kind), allocatable, dimension(:,:) :: pStats
01721
01722
01723 allocate(pStats(numCoeff,nblocks_tot))
01724
01725 maxB=max_blocks
01726 maxDil = 5.0
01727
01728 if ( my_task .eq. master_task) then
01729
01730 nb = SIZE(blockLocation)
01731 allocate(saveblockLocation(nb))
01732 allocate(cost_per_proc(nb))
01733 allocate(cost_per_block(nb))
01734
01735
01736
01737
01738 call EstimateCost(Stats,nb,cost_per_block)
01739
01740 totalCost = SUM(cost_per_block)
01741 save_maxCost = totalCost
01742 maxCostBlock = MAXVAL(cost_per_block)
01743 minCostBlock = MINVAL(cost_per_block)
01744 save_maxB = maxB
01745 avgCost = (totalCost/nproc)
01746
01747 print *,'PartitionCurve: nblocks,nproc ',nb,nproc
01748 write(nu_diag,213) totalCost, avgCost, minCostBlock, maxCostBlock
01749
01750
01751
01752
01753 minB = CEILING(real(nb)/real(nproc),kind=int_kind)
01754 if(maxB < minB ) then
01755 print *,'ERROR: unable to partition ',nb,' blocks across ',nproc,' processors'
01756 print *,'ERROR: Either increase max_blocks := ',maxB
01757 print *,'ERROR: Either increase number of processors'
01758 ierr = -2
01759 return
01760 endif
01761 if(FixMaxBlock) then
01762 minB = maxB
01763 endif
01764 do while (maxB >= minB )
01765
01766 dtCost = 1.0
01767 maxValue = maxCostBlock*real(maxB)
01768 minValue = maxCostBlock
01769 maxCost_old = maxValue
01770
01771 contLoop = .true.
01772 maxiter = 20
01773 it = 1
01774 do while(contLoop )
01775
01776 cost_per_proc=0.0
01777 call wPartition(cost_per_block,blockLocation, distance, nproc,maxB,maxValue,maxDil,amaxBlocks, amaxDil)
01778 anProc = MAXVAL(blockLocation)
01779 call ConvertStatsBlock2Proc(blockLocation,Stats,pStats)
01780 call EstimateCost(pStats,anProc,cost_per_proc)
01781 maxCost = MAXVAL(cost_per_proc)
01782
01783
01784 if(lprint_stats) then
01785 write(nu_diag,211) it,anProc,amaxBlocks,maxB,minValue, maxValue,maxCost, amaxDil
01786 endif
01787
01788 if(maxCost > maxValue) then
01789 minValue = maxValue
01790 dtCost = (maxCost_old-minValue)/2.0
01791 maxValue = maxCost_old - dtCost
01792 else
01793 dtCost = (maxCost-minValue)/2.0
01794 maxValue = maxCost - dtCost
01795 maxCost_old = maxCost
01796 endif
01797
01798 if(maxCost == maxCostBlock) contLoop = .false.
01799 if(dtCost < 1.0e-5) contLoop = .false.
01800 if( anProc == nproc .and. it >= maxiter) contLoop = .false.
01801 if ((save_maxCost > maxCost .and. amaxBlocks <= maxB) .or. &
01802 (save_maxCost == maxCost .and. save_maxB > maxB) ) then
01803 save_maxCost = maxCost
01804 save_maxB = maxB
01805 saveblockLocation = blockLocation
01806 endif
01807 it=it+1
01808 enddo
01809 maxB = maxB - 1
01810 enddo
01811 blockLocation = saveblockLocation
01812 write(nu_diag,214) perfmodel_name
01813
01814 print *,'-------------------------wSFC-----------------------'
01815 call PrintPartitionLB(blockLocation,nproc,Stats)
01816
01817 211 format('Partition loop: it: ',i4,' anProc: ',i4,' amaxBlocks ', &
01818 i4,' maxB: ',i4,' [min,max]Value: ',2(f14.4),' maxCost: ',f14.4,' maxDilation: ',f14.4 )
01819 213 format('PartitionCurve: TotalCost: ',f12.4,' avgCost: ',f12.4, &
01820 ' minBlockCost: ',f12.4,' maxBlockCost: ',f12.4 )
01821 214 format('Using performance model: ',a20)
01822
01823 deallocate(cost_per_proc)
01824 deallocate(cost_per_block)
01825 deallocate(saveblockLocation)
01826 endif
01827
01828 deallocate(pStats)
01829
01830 ierr = 0
01831
01832 end subroutine PartitionCurve
01833
01834 subroutine wPartition(cost_per_block, blockLocation, distance, nproc, max_blocks, maxValue, maxDil, amaxBlocks,amaxDil)
01835
01836 real (dbl_kind), intent(in) :: cost_per_block(:)
01837 integer (int_kind), intent(inout) :: blockLocation(:)
01838 integer (int_kind), intent(inout) :: distance(:)
01839 integer (int_kind), intent(in) :: nproc
01840 integer (int_kind), intent(in) :: max_blocks
01841 real (real_kind), intent(in) :: maxvalue
01842 real (real_kind), intent(in) :: maxDil
01843 integer (int_kind), intent(inout) :: amaxBlocks
01844 real (real_kind), intent(out) :: amaxDil
01845
01846 integer (int_kind) :: n,ip,i,numB
01847 real :: totalCost,avgCost,sumTMP,sumTMP2
01848
01849
01850
01851 integer :: minDist,Dist
01852 integer :: sloc
01853 real :: dilation, dilation2
01854
01855 logical, parameter :: Info = .FALSE.
01856 logical :: break_loop
01857
01858 n = SIZE(blockLocation)
01859
01860 totalCost = SUM(cost_per_block)
01861
01862 amaxBlocks = 0
01863 amaxDil = 1.0
01864 avgCost = (totalCost/nproc)
01865
01866
01867
01868 ip = 1
01869 i=1
01870
01871 do while (i<=n)
01872 sumTMP = 0
01873 numB = 0
01874 break_loop = .FALSE.
01875 sloc = distance(i)
01876 do while ( ((sumTMP<maxValue) .or. (ip == nproc)) &
01877 .and. (i<=n) &
01878 .and. (.not. break_loop))
01879 sumTMP2 = sumTMP + cost_per_block(i)
01880 minDist = numB + 1
01881 Dist = distance(i) - sloc + 1
01882 dilation2 = real(Dist)/real(minDist)
01883 if(((sumTMP2 <= maxValue) .and. (numB < max_blocks) .and. dilation2 <= maxDil) &
01884
01885 .or. (ip == nproc) ) then
01886 blockLocation(i) = ip
01887 i=i+1
01888 sumTMP = sumTMP2
01889 dilation = dilation2
01890 numB = numB+1
01891 else
01892 break_loop = .TRUE.
01893 endif
01894 enddo
01895 if(amaxBlocks < numB) amaxBlocks = numB
01896 if(amaxDil < dilation) amaxDil = dilation
01897 ip = ip+1
01898 enddo
01899
01900
01901
01902 end subroutine wPartition
01903
01904
01905
01906
01907
01908
01909 subroutine ice_distributionRake (procWork, procID, blockWork, &
01910 priority, distribution)
01911
01912
01913
01914
01915
01916
01917
01918
01919
01920
01921
01922
01923
01924
01925
01926
01927
01928
01929
01930 integer (int_kind), intent(in), dimension(:) ::
01931 blockWork ,
01932 procID
01933
01934
01935
01936 integer (int_kind), intent(inout), dimension(:) ::
01937 procWork ,
01938 priority
01939
01940 type (distrb), intent(inout) ::
01941 distribution
01942
01943
01944
01945
01946
01947
01948
01949
01950
01951
01952
01953 integer (int_kind) ::
01954 i, n,
01955 np1,
01956 iproc, inext,
01957 nprocs, numBlocks,
01958 lastPriority,
01959 minPriority,
01960 lastLoc,
01961 meanWork, maxWork,
01962 diffWork, residual,
01963 numTransfers
01964
01965
01966
01967
01968
01969
01970
01971 nprocs = size(procWork)
01972 numBlocks = size(blockWork)
01973
01974
01975
01976 meanWork = sum(procWork)/nprocs + 1
01977 maxWork = maxval(procWork)
01978 residual = mod(meanWork,nprocs)
01979
01980 minPriority = 1000000
01981 do n=1,nprocs
01982 iproc = procID(n)
01983 do i=1,numBlocks
01984 if (distribution%blockLocation(i) == iproc) then
01985 minPriority = min(minPriority,priority(i))
01986 endif
01987 end do
01988 end do
01989
01990
01991
01992
01993
01994
01995
01996 transferLoop: do
01997
01998
01999
02000
02001
02002
02003
02004 numTransfers = 0
02005 do n=1,nprocs
02006 if (n < nprocs) then
02007 np1 = n+1
02008 else
02009 np1 = 1
02010 endif
02011 iproc = procID(n)
02012 inext = procID(np1)
02013
02014 if (procWork(n) > meanWork) then
02015
02016 diffWork = procWork(n) - meanWork
02017
02018 rake1: do while (diffWork > 1)
02019
02020
02021
02022
02023
02024 lastPriority = 0
02025 lastLoc = 0
02026
02027 do i=1,numBlocks
02028 if (distribution%blockLocation(i) == iproc) then
02029 if (priority(i) > lastPriority ) then
02030 lastPriority = priority(i)
02031 lastLoc = i
02032 endif
02033 endif
02034 end do
02035 if (lastLoc == 0) exit rake1
02036
02037 numTransfers = numTransfers + 1
02038 distribution%blockLocation(lastLoc) = inext
02039 if (np1 == 1) priority(lastLoc) = minPriority
02040 diffWork = diffWork - blockWork(lastLoc)
02041
02042 procWork(n ) = procWork(n )-blockWork(lastLoc)
02043 procWork(np1) = procWork(np1)+blockWork(lastLoc)
02044 end do rake1
02045 endif
02046
02047 end do
02048
02049
02050
02051
02052
02053
02054
02055 meanWork = meanWork + 1
02056 if (numTransfers == 0 .or. meanWork > maxWork) exit transferLoop
02057
02058 end do transferLoop
02059
02060
02061
02062
02063 end subroutine ice_distributionRake
02064
02065
02066 subroutine PrintPartitionLB(Location,n,bStats)
02067
02068 integer :: Location(:)
02069 integer :: n
02070 real (dbl_kind), dimension(:,:) :: bStats
02071
02072 real :: maxCost,minCost
02073 integer :: anProc
02074 integer :: maxB
02075 real :: aCost
02076 real (dbl_kind), allocatable, dimension(:) :: cost_per_proc(:)
02077 integer :: i,ncnt
02078
02079 real (dbl_kind), allocatable, dimension(:,:) :: pStats
02080
02081 allocate(cost_per_proc(n))
02082 allocate(pStats(numCoeff,n))
02083
02084
02085 call ConvertStatsBlock2Proc(Location,bStats,pStats)
02086 call EstimateCost(pStats,n,cost_per_proc)
02087
02088
02089
02090
02091 maxCost = MAXVAL(cost_per_proc)
02092 minCost = MINVAL(cost_per_proc)
02093 aCost = SUM(cost_per_proc)/real(n)
02094 anProc=MAXVAL(Location)
02095 maxB=0;
02096 do i=1,n
02097 ncnt = COUNT(Location==i)
02098 maxB = MAX(ncnt,maxB)
02099 enddo
02100
02101
02102
02103
02104
02105
02106
02107 write(nu_diag,212) anProc, maxB,aCost,minCost,maxCost,ABS(aCost-maxCost)/aCost
02108 deallocate(cost_per_proc)
02109 deallocate(pStats)
02110
02111 212 format('PrintPartitionLB: on ',i4,' procs maxB: ',i4,' Avg,Min,Max Cost/proc: ',(3(f10.4)),' imbalance: ',f8.2)
02112
02113 end subroutine PrintPartitionLB
02114
02115 subroutine EstimateCost(coeffMatrix,n,Cost)
02116
02117 real (dbl_kind) :: coeffMatrix(:,:)
02118 integer (int_kind) :: n
02119 real (dbl_kind):: Cost(:)
02120
02121 real (dbl_kind) :: tmp
02122
02123 integer (int_kind) :: i,j
02124
02125 Cost=0.0_dbl_kind
02126 do i=1,n
02127 tmp = 0.0_dbl_kind
02128 do j=1,numCoeff
02129 tmp = tmp + coeffMatrix(j,i) *perfmodel(j)
02130 enddo
02131 Cost(i) = tmp
02132 enddo
02133
02134 end subroutine EstimateCost
02135
02136 subroutine ConvertStatsBlock2Proc(Location,bStats,pStats)
02137
02138 integer (int_kind) :: Location(:)
02139 real (dbl_kind), intent(in) :: bStats(:,:)
02140 real (dbl_kind), intent(out) :: pStats(:,:)
02141
02142 integer (int_kind) :: i,ip,n
02143
02144 n = size(Location)
02145 pStats = 0.0d0
02146 do i=1,n
02147 ip = Location(i)
02148 if(ip > 0) then
02149 pStats(:,ip) = pStats(:,ip) + bStats(:,i)
02150 endif
02151 enddo
02152
02153 end subroutine ConvertStatsBlock2Proc
02154
02155 subroutine WriteProbabilityStats(coeffMatrix,n)
02156
02157 real(dbl_kind) :: coeffMatrix(:,:)
02158 integer (int_kind) :: n
02159
02160
02161 if(my_task == master_task) then
02162 open(nu_timing,file='probStats.bin',recl=8*numCoeff*n, &
02163 form = 'unformatted', access = 'direct', status = 'unknown')
02164 write(nu_timing,rec=1) coeffMatrix(:,1:n)
02165 close(nu_timing)
02166 endif
02167
02168
02169 end subroutine WriteProbabilityStats
02170
02171 subroutine WriteIntegerArray(fname,n,array)
02172 character(char_len) :: fname
02173 integer (int_kind) :: n
02174 integer (int_kind) :: array(:)
02175
02176 if(my_task == master_task) then
02177 open(nu_timing,file=TRIM(fname),recl=4*n, &
02178 form = 'unformatted', access = 'direct', status = 'unknown')
02179 write(nu_timing,rec=1) array(1:n)
02180 close(nu_timing)
02181 endif
02182
02183 end subroutine WriteIntegerArray
02184
02185 subroutine WriteDblArray(fname,n,array)
02186 character(char_len) :: fname
02187 real (dbl_kind) :: array(:)
02188 integer (int_kind) :: n
02189
02190 if(my_task == master_task) then
02191 open(nu_timing,file=TRIM(fname),recl=8*n, &
02192 form = 'unformatted', access = 'direct', status = 'unknown')
02193 write(nu_timing,rec=1) array(1:n)
02194 close(nu_timing)
02195 endif
02196
02197 end subroutine WriteDblArray
02198
02199 end module ice_distribution
02200
02201