Changeset 6393 for trunk/NEMOGCM/TOOLS/SIREN/src/mpp.f90
- Timestamp:
- 2016-03-17T10:16:03+01:00 (8 years ago)
- File:
-
- 1 edited
-
trunk/NEMOGCM/TOOLS/SIREN/src/mpp.f90 (modified) (50 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMOGCM/TOOLS/SIREN/src/mpp.f90
r5617 r6393 196 196 ! REVISION HISTORY: 197 197 !> @date November, 2013 - Initial Version 198 !> @date November, 2014 - Fix memory leaks bug 198 !> @date November, 2014 199 !> - Fix memory leaks bug 200 !> @date October, 2015 201 !> - improve way to compute domain layout 202 !> @date January, 2016 203 !> - allow to print layout file (use lm_layout, hard coded) 204 !> - add mpp__compute_halo and mpp__read_halo 199 205 ! 200 206 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) … … 214 220 215 221 ! type and variable 216 PUBLIC :: TMPP !< mpp structure 222 PUBLIC :: TMPP !< mpp structure 223 PRIVATE :: TLAY !< domain layout structure 217 224 218 225 ! function and subroutine … … 239 246 PUBLIC :: mpp_get_proc_size !< get processor domain size 240 247 241 PRIVATE :: mpp__add_proc ! add one proc strucutre in mpp structure 248 PRIVATE :: mpp__add_proc ! add proc strucutre in mpp structure 249 PRIVATE :: mpp__add_proc_unit ! add one proc strucutre in mpp structure 242 250 PRIVATE :: mpp__del_proc ! delete one proc strucutre in mpp structure 243 251 PRIVATE :: mpp__del_proc_id ! delete one proc strucutre in mpp structure, given procesor id 244 252 PRIVATE :: mpp__del_proc_str ! delete one proc strucutre in mpp structure, given procesor file structure 245 253 PRIVATE :: mpp__move_proc ! overwrite proc strucutre in mpp structure 246 PRIVATE :: mpp__compute ! compute domain decomposition 247 PRIVATE :: mpp__del_land ! remove land sub domain from domain decomposition 254 PRIVATE :: mpp__create_layout ! create mpp structure using domain layout 248 255 PRIVATE :: mpp__optimiz ! compute optimum domain decomposition 249 PRIVATE :: mpp__land_proc ! check if processor is a land processor250 256 PRIVATE :: mpp__check_dim ! check mpp structure dimension with proc or variable dimension 251 257 PRIVATE :: mpp__check_proc_dim ! check if processor and mpp structure use same dimension … … 267 273 PRIVATE :: mpp__clean_unit ! clean mpp strcuture 268 274 PRIVATE :: mpp__clean_arr ! clean array of mpp strcuture 275 PRIVATE :: mpp__compute_halo ! compute subdomain indices defined with halo 276 PRIVATE :: mpp__read_halo ! read subdomain indices defined with halo 277 278 PRIVATE :: layout__init ! initialise domain layout structure 279 PRIVATE :: layout__copy ! clean domain layout structure 280 PRIVATE :: layout__clean ! copy domain layout structure 269 281 270 282 TYPE TMPP !< mpp structure 271 272 283 ! general 273 284 CHARACTER(LEN=lc) :: c_name = '' !< base name … … 284 295 285 296 CHARACTER(LEN=lc) :: c_type = '' !< type of the files (cdf, cdf4, dimg) 286 CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, overlap, nooverlap)297 CHARACTER(LEN=lc) :: c_dom = '' !< type of domain (full, noextra, nooverlap) 287 298 288 299 INTEGER(i4) :: i_ndim = 0 !< number of dimensions used in mpp … … 290 301 291 302 TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp 292 293 303 END TYPE 304 305 TYPE TLAY !< domain layout structure 306 INTEGER(i4) :: i_niproc = 0 !< number of processors following i 307 INTEGER(i4) :: i_njproc = 0 !< number of processors following j 308 INTEGER(i4) :: i_nland = 0 !< number of land processors 309 INTEGER(i4) :: i_nsea = 0 !< number of sea processors 310 INTEGER(i4) :: i_mean = 0 !< mean sea point per proc 311 INTEGER(i4) :: i_min = 0 !< min sea point per proc 312 INTEGER(i4) :: i_max = 0 !< max sea point per proc 313 INTEGER(i4), DIMENSION(:,:), POINTER :: i_msk => NULL() !< sea/land processor mask 314 INTEGER(i4), DIMENSION(:,:), POINTER :: i_impp => NULL() !< i-indexes for mpp-subdomain left bottom 315 INTEGER(i4), DIMENSION(:,:), POINTER :: i_jmpp => NULL() !< j-indexes for mpp-subdomain left bottom 316 INTEGER(i4), DIMENSION(:,:), POINTER :: i_lci => NULL() !< i-dimensions of subdomain 317 INTEGER(i4), DIMENSION(:,:), POINTER :: i_lcj => NULL() !< j-dimensions of subdomain 318 END TYPE 319 320 ! module variable 321 INTEGER(i4) :: im_iumout = 44 322 LOGICAL :: lm_layout =.FALSE. 294 323 295 324 INTERFACE mpp_get_use 296 325 MODULE PROCEDURE mpp__get_use_unit 297 326 END INTERFACE mpp_get_use 327 328 INTERFACE mpp__add_proc 329 MODULE PROCEDURE mpp__add_proc_unit 330 END INTERFACE mpp__add_proc 298 331 299 332 INTERFACE mpp_clean … … 560 593 ALLOCATE( il_lci(td_mpp%i_niproc,td_mpp%i_njproc) ) 561 594 ALLOCATE( il_lcj(td_mpp%i_niproc,td_mpp%i_njproc) ) 595 il_proc(:,:)=-1 596 il_lci(:,:) =-1 597 il_lcj(:,:) =-1 562 598 563 599 DO jk=1,td_mpp%i_nproc 564 600 ji=td_mpp%t_proc(jk)%i_iind 565 601 jj=td_mpp%t_proc(jk)%i_jind 566 il_proc(ji,jj)=jk 602 il_proc(ji,jj)=jk-1 567 603 il_lci(ji,jj)=td_mpp%t_proc(jk)%i_lci 568 604 il_lcj(ji,jj)=td_mpp%t_proc(jk)%i_lcj … … 594 630 ENDIF 595 631 596 597 632 9400 FORMAT(' ***',20('*************',a3)) 598 633 9403 FORMAT(' * ',20(' * ',a3)) … … 615 650 !> @author J.Paul 616 651 !> @date November, 2013 - Initial version 652 !> @date September, 2015 653 !> - allow to define dimension with array of dimension structure 654 !> @date January, 2016 655 !> - use RESULT to rename output 656 !> - mismatch with "halo" indices 617 657 ! 618 658 !> @param[in] cd_file file name of one file composing mpp domain … … 627 667 !> @param[in] id_perio NEMO periodicity index 628 668 !> @param[in] id_pivot NEMO pivot point index F(0),T(1) 669 !> @param[in] td_dim array of dimension structure 629 670 !> @return mpp structure 630 671 !------------------------------------------------------------------- 631 TYPE(TMPP) FUNCTION mpp__init_mask(cd_file, id_mask, & 632 & id_niproc, id_njproc, id_nproc,& 633 & id_preci, id_precj, & 634 cd_type, id_ew, id_perio, id_pivot) 672 FUNCTION mpp__init_mask(cd_file, id_mask, & 673 & id_niproc, id_njproc, id_nproc, & 674 & id_preci, id_precj, & 675 & cd_type, id_ew, id_perio, id_pivot, & 676 & td_dim ) & 677 & RESULT(td_mpp) 635 678 IMPLICIT NONE 636 679 ! Argument 637 CHARACTER(LEN=*), INTENT(IN) :: cd_file 638 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 639 INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc 640 INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc 641 INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc 642 INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci 643 INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj 644 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type 645 INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew 646 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 647 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 680 CHARACTER(LEN=*), INTENT(IN) :: cd_file 681 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 682 INTEGER(i4), INTENT(IN), OPTIONAL :: id_niproc 683 INTEGER(i4), INTENT(IN), OPTIONAL :: id_njproc 684 INTEGER(i4), INTENT(IN), OPTIONAL :: id_nproc 685 INTEGER(i4), INTENT(IN), OPTIONAL :: id_preci 686 INTEGER(i4), INTENT(IN), OPTIONAL :: id_precj 687 CHARACTER(LEN=*), INTENT(IN), OPTIONAL :: cd_type 688 INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew 689 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 690 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 691 TYPE(TDIM) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: td_dim 692 693 ! function 694 TYPE(TMPP) :: td_mpp 648 695 649 696 ! local variable 650 CHARACTER(LEN=lc) :: cl_type 651 652 INTEGER(i4) , DIMENSION(2) :: il_shape 653 654 TYPE(TDIM) :: tl_dim 655 656 TYPE(TATT) :: tl_att 697 CHARACTER(LEN=lc) :: cl_type 698 699 INTEGER(i4) , DIMENSION(2) :: il_shape 700 701 TYPE(TDIM) :: tl_dim 702 703 TYPE(TATT) :: tl_att 704 705 TYPE(TLAY) :: tl_lay 706 657 707 ! loop indices 658 708 INTEGER(i4) :: ji … … 660 710 661 711 ! clean mpp 662 CALL mpp_clean( mpp__init_mask)712 CALL mpp_clean(td_mpp) 663 713 664 714 ! check type … … 669 719 SELECT CASE(TRIM(cd_type)) 670 720 CASE('cdf') 671 mpp__init_mask%c_type='cdf'721 td_mpp%c_type='cdf' 672 722 CASE('dimg') 673 mpp__init_mask%c_type='dimg'723 td_mpp%c_type='dimg' 674 724 CASE DEFAULT 675 725 CALL logger_warn( "MPP INIT: type "//TRIM(cd_type)//& 676 726 & " unknown. type dimg will be used for mpp "//& 677 & TRIM( mpp__init_mask%c_name) )678 mpp__init_mask%c_type='dimg'727 & TRIM(td_mpp%c_name) ) 728 td_mpp%c_type='dimg' 679 729 END SELECT 680 730 ELSE 681 mpp__init_mask%c_type=TRIM(file_get_type(cd_file))731 td_mpp%c_type=TRIM(file_get_type(cd_file)) 682 732 ENDIF 683 733 684 734 ! get mpp name 685 mpp__init_mask%c_name=TRIM(file_rename(cd_file))735 td_mpp%c_name=TRIM(file_rename(cd_file)) 686 736 687 737 ! get global domain dimension 688 738 il_shape(:)=SHAPE(id_mask) 689 739 690 tl_dim=dim_init('X',il_shape(1)) 691 CALL mpp_add_dim(mpp__init_mask, tl_dim) 692 693 tl_dim=dim_init('Y',il_shape(2)) 694 CALL mpp_add_dim(mpp__init_mask, tl_dim) 695 696 ! clean 697 CALL dim_clean(tl_dim) 740 IF( PRESENT(td_dim) )THEN 741 DO ji=1,ip_maxdim 742 IF( td_dim(ji)%l_use )THEN 743 CALL mpp_add_dim(td_mpp, td_dim(ji)) 744 ENDIF 745 ENDDO 746 ELSE 747 tl_dim=dim_init('X',il_shape(1)) 748 CALL mpp_add_dim(td_mpp, tl_dim) 749 750 tl_dim=dim_init('Y',il_shape(2)) 751 CALL mpp_add_dim(td_mpp, tl_dim) 752 753 ! clean 754 CALL dim_clean(tl_dim) 755 ENDIF 698 756 699 757 IF( ( PRESENT(id_niproc) .AND. (.NOT. PRESENT(id_njproc))) .OR. & … … 703 761 ELSE 704 762 ! get number of processors following I and J 705 IF( PRESENT(id_niproc) ) mpp__init_mask%i_niproc=id_niproc706 IF( PRESENT(id_njproc) ) mpp__init_mask%i_njproc=id_njproc763 IF( PRESENT(id_niproc) ) td_mpp%i_niproc=id_niproc 764 IF( PRESENT(id_njproc) ) td_mpp%i_njproc=id_njproc 707 765 ENDIF 708 766 709 767 ! get maximum number of processors to be used 710 IF( PRESENT(id_nproc) ) mpp__init_mask%i_nproc = id_nproc768 IF( PRESENT(id_nproc) ) td_mpp%i_nproc = id_nproc 711 769 712 770 ! get overlap region length 713 IF( PRESENT(id_preci) ) mpp__init_mask%i_preci= id_preci714 IF( PRESENT(id_precj) ) mpp__init_mask%i_precj= id_precj771 IF( PRESENT(id_preci) ) td_mpp%i_preci= id_preci 772 IF( PRESENT(id_precj) ) td_mpp%i_precj= id_precj 715 773 716 774 ! east-west overlap 717 IF( PRESENT(id_ew) ) mpp__init_mask%i_ew= id_ew775 IF( PRESENT(id_ew) ) td_mpp%i_ew= id_ew 718 776 ! NEMO periodicity 719 IF( PRESENT(id_perio) ) mpp__init_mask%i_perio= id_perio720 IF( PRESENT(id_pivot) ) mpp__init_mask%i_pivot= id_pivot721 722 IF( mpp__init_mask%i_nproc /= 0 .AND. &723 & mpp__init_mask%i_niproc /= 0 .AND. &724 & mpp__init_mask%i_njproc /= 0 .AND. &725 & mpp__init_mask%i_nproc > &726 & mpp__init_mask%i_niproc * mpp__init_mask%i_njproc )THEN777 IF( PRESENT(id_perio) ) td_mpp%i_perio= id_perio 778 IF( PRESENT(id_pivot) ) td_mpp%i_pivot= id_pivot 779 780 IF( td_mpp%i_nproc /= 0 .AND. & 781 & td_mpp%i_niproc /= 0 .AND. & 782 & td_mpp%i_njproc /= 0 .AND. & 783 & td_mpp%i_nproc > & 784 & td_mpp%i_niproc * td_mpp%i_njproc )THEN 727 785 728 786 CALL logger_error("MPP INIT: invalid domain decomposition ") 729 787 CALL logger_debug("MPP INIT: "// & 730 & TRIM(fct_str( mpp__init_mask%i_nproc))//" > "//&731 & TRIM(fct_str( mpp__init_mask%i_niproc))//" x "//&732 & TRIM(fct_str( mpp__init_mask%i_njproc)) )788 & TRIM(fct_str(td_mpp%i_nproc))//" > "//& 789 & TRIM(fct_str(td_mpp%i_niproc))//" x "//& 790 & TRIM(fct_str(td_mpp%i_njproc)) ) 733 791 734 792 ELSE 735 736 IF( mpp__init_mask%i_niproc /= 0 .AND. & 737 & mpp__init_mask%i_njproc /= 0 )THEN 738 ! compute domain decomposition 739 CALL mpp__compute( mpp__init_mask ) 740 ! remove land sub domain 741 CALL mpp__del_land( mpp__init_mask, id_mask ) 742 ELSEIF( mpp__init_mask%i_nproc /= 0 )THEN 793 IF( lm_layout )THEN 794 OPEN(im_iumout,FILE='processor.layout') 795 WRITE(im_iumout,*) 796 WRITE(im_iumout,*) ' optimisation de la partition' 797 WRITE(im_iumout,*) ' ----------------------------' 798 WRITE(im_iumout,*) 799 ENDIF 800 801 IF( td_mpp%i_niproc /= 0 .AND. & 802 & td_mpp%i_njproc /= 0 )THEN 803 ! compute domain layout 804 tl_lay=layout__init( td_mpp, id_mask, td_mpp%i_niproc, td_mpp%i_njproc ) 805 ! create mpp domain layout 806 CALL mpp__create_layout( td_mpp, tl_lay ) 807 ! clean 808 CALL layout__clean( tl_lay ) 809 ELSEIF( td_mpp%i_nproc /= 0 )THEN 743 810 ! optimiz 744 CALL mpp__optimiz( mpp__init_mask, id_mask)811 CALL mpp__optimiz( td_mpp, id_mask, td_mpp%i_nproc ) 745 812 746 813 ELSE 747 814 CALL logger_warn("MPP INIT: number of processor to be used "//& 748 815 & "not specify. force to one.") 749 mpp__init_mask%i_nproc = 1750 816 ! optimiz 751 CALL mpp__optimiz( mpp__init_mask, id_mask)817 CALL mpp__optimiz( td_mpp, id_mask, 1 ) 752 818 ENDIF 819 820 753 821 CALL logger_info("MPP INIT: domain decoposition : "//& 754 & 'niproc('//TRIM(fct_str( mpp__init_mask%i_niproc))//') * '//&755 & 'njproc('//TRIM(fct_str( mpp__init_mask%i_njproc))//') = '//&756 & 'nproc('//TRIM(fct_str( mpp__init_mask%i_nproc))//')' )822 & 'niproc('//TRIM(fct_str(td_mpp%i_niproc))//') * '//& 823 & 'njproc('//TRIM(fct_str(td_mpp%i_njproc))//') = '//& 824 & 'nproc('//TRIM(fct_str(td_mpp%i_nproc))//')' ) 757 825 758 826 ! get domain type 759 CALL mpp_get_dom( mpp__init_mask)760 761 DO ji=1, mpp__init_mask%i_nproc827 CALL mpp_get_dom( td_mpp ) 828 829 DO ji=1,td_mpp%i_nproc 762 830 763 831 ! get processor size 764 il_shape(:)=mpp_get_proc_size( mpp__init_mask, ji )832 il_shape(:)=mpp_get_proc_size( td_mpp, ji ) 765 833 766 834 tl_dim=dim_init('X',il_shape(1)) 767 CALL file_move_dim( mpp__init_mask%t_proc(ji), tl_dim)835 CALL file_move_dim(td_mpp%t_proc(ji), tl_dim) 768 836 769 837 tl_dim=dim_init('Y',il_shape(2)) 770 CALL file_move_dim(mpp__init_mask%t_proc(ji), tl_dim) 771 838 CALL file_move_dim(td_mpp%t_proc(ji), tl_dim) 839 840 IF( PRESENT(td_dim) )THEN 841 IF( td_dim(jp_K)%l_use )THEN 842 CALL file_move_dim(td_mpp%t_proc(ji), td_dim(jp_K)) 843 ENDIF 844 IF( td_dim(jp_L)%l_use )THEN 845 CALL file_move_dim(td_mpp%t_proc(ji), td_dim(jp_L)) 846 ENDIF 847 ENDIF 772 848 ! add type 773 mpp__init_mask%t_proc(ji)%c_type=TRIM(mpp__init_mask%c_type)849 td_mpp%t_proc(ji)%c_type=TRIM(td_mpp%c_type) 774 850 775 851 ! clean 776 852 CALL dim_clean(tl_dim) 853 777 854 ENDDO 778 855 779 856 ! add global attribute 780 tl_att=att_init("DOMAIN_number_total",mpp__init_mask%i_nproc) 781 CALL mpp_add_att(mpp__init_mask, tl_att) 782 783 tl_att=att_init("DOMAIN_I_number_total",mpp__init_mask%i_niproc) 784 CALL mpp_add_att(mpp__init_mask, tl_att) 785 786 tl_att=att_init("DOMAIN_J_number_total",mpp__init_mask%i_njproc) 787 CALL mpp_add_att(mpp__init_mask, tl_att) 788 789 tl_att=att_init("DOMAIN_size_global",mpp__init_mask%t_dim(1:2)%i_len) 790 CALL mpp_add_att(mpp__init_mask, tl_att) 791 792 tl_att=att_init( "DOMAIN_I_position_first", & 793 & mpp__init_mask%t_proc(:)%i_impp ) 794 CALL mpp_add_att(mpp__init_mask, tl_att) 795 796 tl_att=att_init( "DOMAIN_J_position_first", & 797 & mpp__init_mask%t_proc(:)%i_jmpp ) 798 CALL mpp_add_att(mpp__init_mask, tl_att) 799 800 tl_att=att_init( "DOMAIN_I_position_last", & 801 & mpp__init_mask%t_proc(:)%i_lci ) 802 CALL mpp_add_att(mpp__init_mask, tl_att) 803 804 tl_att=att_init( "DOMAIN_J_position_last", & 805 & mpp__init_mask%t_proc(:)%i_lcj ) 806 CALL mpp_add_att(mpp__init_mask, tl_att) 807 808 tl_att=att_init( "DOMAIN_I_halo_size_start", & 809 & mpp__init_mask%t_proc(:)%i_ldi ) 810 CALL mpp_add_att(mpp__init_mask, tl_att) 811 812 tl_att=att_init( "DOMAIN_J_halo_size_start", & 813 & mpp__init_mask%t_proc(:)%i_ldj ) 814 CALL mpp_add_att(mpp__init_mask, tl_att) 815 816 tl_att=att_init( "DOMAIN_I_halo_size_end", & 817 & mpp__init_mask%t_proc(:)%i_lei ) 818 CALL mpp_add_att(mpp__init_mask, tl_att) 819 820 tl_att=att_init( "DOMAIN_J_halo_size_end", & 821 & mpp__init_mask%t_proc(:)%i_lej ) 822 CALL mpp_add_att(mpp__init_mask, tl_att) 823 824 ! clean 825 CALL att_clean(tl_att) 857 tl_att=att_init("DOMAIN_number_total",td_mpp%i_nproc) 858 CALL mpp_add_att(td_mpp, tl_att) 859 860 tl_att=att_init("DOMAIN_LOCAL",TRIM(td_mpp%c_dom)) 861 CALL mpp_add_att(td_mpp, tl_att) 862 863 tl_att=att_init("DOMAIN_I_number_total",td_mpp%i_niproc) 864 CALL mpp_add_att(td_mpp, tl_att) 865 866 tl_att=att_init("DOMAIN_J_number_total",td_mpp%i_njproc) 867 CALL mpp_add_att(td_mpp, tl_att) 868 869 tl_att=att_init("DOMAIN_size_global",td_mpp%t_dim(1:2)%i_len) 870 CALL mpp_add_att(td_mpp, tl_att) 871 872 CALL mpp__compute_halo(td_mpp) 826 873 ENDIF 827 874 … … 880 927 il_mask(:,:,:)=var_get_mask(td_var) 881 928 929 CALL logger_info("MPP INIT: mask compute from variable "//& 930 & TRIM(td_var%c_name)) 882 931 mpp__init_var=mpp_init( cd_file, il_mask(:,:,1), & 883 932 & id_niproc, id_njproc, id_nproc,& … … 907 956 !> - DOMAIN_halo_size_end 908 957 !> or the file is assume to be no mpp file. 909 !>910 !>911 958 !> 912 959 !> @author J.Paul 913 960 !> @date November, 2013 - Initial Version 961 !> @date January, 2016 962 !> - mismatch with "halo" indices, use mpp__compute_halo 914 963 ! 915 964 !> @param[in] td_file file strcuture … … 929 978 930 979 ! local variable 931 TYPE(TMPP) :: tl_mpp 932 933 TYPE(TFILE) :: tl_file 934 935 TYPE(TDIM) :: tl_dim 936 937 TYPE(TATT) :: tl_att 938 939 INTEGER(i4) :: il_nproc 940 INTEGER(i4) :: il_attid 941 980 INTEGER(i4) :: il_nproc 981 INTEGER(i4) :: il_attid 942 982 INTEGER(i4), DIMENSION(2) :: il_shape 983 984 TYPE(TDIM) :: tl_dim 985 986 TYPE(TATT) :: tl_att 987 988 TYPE(TFILE) :: tl_file 989 990 TYPE(TMPP) :: tl_mpp 991 943 992 ! loop indices 944 993 INTEGER(i4) :: ji … … 956 1005 ! open file 957 1006 CALL iom_open(tl_file) 958 959 1007 ! read first file domain decomposition 960 1008 tl_mpp=mpp__init_file_cdf(tl_file) … … 1029 1077 CALL mpp_move_att(mpp__init_file, tl_att) 1030 1078 1031 tl_att=att_init( "DOMAIN_I_position_first", mpp__init_file%t_proc(:)%i_impp ) 1032 CALL mpp_move_att(mpp__init_file, tl_att) 1033 1034 tl_att=att_init( "DOMAIN_J_position_first", mpp__init_file%t_proc(:)%i_jmpp ) 1035 CALL mpp_move_att(mpp__init_file, tl_att) 1036 1037 tl_att=att_init( "DOMAIN_I_position_last", mpp__init_file%t_proc(:)%i_lci ) 1038 CALL mpp_move_att(mpp__init_file, tl_att) 1039 1040 tl_att=att_init( "DOMAIN_J_position_last", mpp__init_file%t_proc(:)%i_lcj ) 1041 CALL mpp_move_att(mpp__init_file, tl_att) 1042 1043 tl_att=att_init( "DOMAIN_I_halo_size_start", mpp__init_file%t_proc(:)%i_ldi ) 1044 CALL mpp_move_att(mpp__init_file, tl_att) 1045 1046 tl_att=att_init( "DOMAIN_J_halo_size_start", mpp__init_file%t_proc(:)%i_ldj ) 1047 CALL mpp_move_att(mpp__init_file, tl_att) 1048 1049 tl_att=att_init( "DOMAIN_I_halo_size_end", mpp__init_file%t_proc(:)%i_lei ) 1050 CALL mpp_move_att(mpp__init_file, tl_att) 1051 1052 tl_att=att_init( "DOMAIN_J_halo_size_end", mpp__init_file%t_proc(:)%i_lej ) 1053 CALL mpp_move_att(mpp__init_file, tl_att) 1054 1079 CALL mpp__compute_halo(mpp__init_file) 1080 1055 1081 ! clean 1056 1082 CALL mpp_clean(tl_mpp) … … 1130 1156 !> @author J.Paul 1131 1157 !> @date November, 2013 - Initial Version 1132 !> @date July, 2015 - add only use dimension in MPP structure 1158 !> @date July, 2015 1159 !> - add only use dimension in MPP structure 1160 !> @date January, 2016 1161 !> - mismatch with "halo" indices, use mpp__read_halo 1133 1162 !> 1134 1163 !> @param[in] td_file file strcuture … … 1218 1247 tl_proc%t_dim(:)=dim_copy(td_file%t_dim(:)) 1219 1248 1220 ! DOMAIN_position_first 1221 il_attid = 0 1222 IF( ASSOCIATED(td_file%t_att) )THEN 1223 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_first" ) 1224 ENDIF 1225 IF( il_attid /= 0 )THEN 1226 tl_proc%i_impp = INT(td_file%t_att(il_attid)%d_value(1)) 1227 tl_proc%i_jmpp = INT(td_file%t_att(il_attid)%d_value(2)) 1228 ELSE 1229 tl_proc%i_impp = 1 1230 tl_proc%i_jmpp = 1 1231 ENDIF 1232 1233 ! DOMAIN_position_last 1234 il_attid = 0 1235 IF( ASSOCIATED(td_file%t_att) )THEN 1236 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_last" ) 1237 ENDIF 1238 IF( il_attid /= 0 )THEN 1239 tl_proc%i_lci = INT(td_file%t_att(il_attid)%d_value(1)) + tl_proc%i_impp 1240 tl_proc%i_lcj = INT(td_file%t_att(il_attid)%d_value(2)) + tl_proc%i_jmpp 1241 ELSE 1242 tl_proc%i_lci = mpp__init_file_cdf%t_dim(1)%i_len 1243 tl_proc%i_lcj = mpp__init_file_cdf%t_dim(2)%i_len 1244 ENDIF 1245 1246 ! DOMAIN_halo_size_start 1247 il_attid = 0 1248 IF( ASSOCIATED(td_file%t_att) )THEN 1249 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_start" ) 1250 ENDIF 1251 IF( il_attid /= 0 )THEN 1252 tl_proc%i_ldi = INT(td_file%t_att(il_attid)%d_value(1)) 1253 tl_proc%i_ldj = INT(td_file%t_att(il_attid)%d_value(2)) 1254 ELSE 1255 tl_proc%i_ldi = 1 1256 tl_proc%i_ldj = 1 1257 ENDIF 1258 1259 ! DOMAIN_halo_size_end 1260 il_attid = 0 1261 IF( ASSOCIATED(td_file%t_att) )THEN 1262 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_end" ) 1263 ENDIF 1264 IF( il_attid /= 0 )THEN 1265 tl_proc%i_lei = INT(td_file%t_att(il_attid)%d_value(1)) 1266 tl_proc%i_lej = INT(td_file%t_att(il_attid)%d_value(2)) 1267 ELSE 1268 tl_proc%i_lei = mpp__init_file_cdf%t_dim(1)%i_len 1269 tl_proc%i_lej = mpp__init_file_cdf%t_dim(2)%i_len 1270 ENDIF 1249 CALL mpp__read_halo(tl_proc, mpp__init_file_cdf%t_dim(:) ) 1271 1250 1272 1251 ! add attributes … … 1278 1257 CALL file_move_att(tl_proc, tl_att) 1279 1258 1280 tl_att=att_init( "DOMAIN_position_first", &1281 & (/tl_proc%i_impp, tl_proc%i_jmpp /) )1282 CALL file_move_att(tl_proc, tl_att)1283 1284 tl_att=att_init( "DOMAIN_position_last", &1285 & (/tl_proc%i_lci, tl_proc%i_lcj /) )1286 CALL file_move_att(tl_proc, tl_att)1287 1288 tl_att=att_init( "DOMAIN_halo_size_start", &1289 & (/tl_proc%i_ldi, tl_proc%i_ldj /) )1290 CALL file_move_att(tl_proc, tl_att)1291 1292 tl_att=att_init( "DOMAIN_halo_size_end", &1293 & (/tl_proc%i_lei, tl_proc%i_lej /) )1294 CALL file_move_att(tl_proc, tl_att)1295 1296 1259 ! add processor to mpp structure 1297 1260 CALL mpp__add_proc(mpp__init_file_cdf, tl_proc) … … 1299 1262 ! clean 1300 1263 CALL file_clean(tl_proc) 1264 CALL dim_clean(tl_dim) 1301 1265 CALL att_clean(tl_att) 1302 1266 ENDIF … … 1307 1271 & " do not exist") 1308 1272 1309 ENDIF 1273 ENDIF 1274 1310 1275 END FUNCTION mpp__init_file_cdf 1311 1276 !------------------------------------------------------------------- … … 1317 1282 !> @author J.Paul 1318 1283 !> @date November, 2013 - Initial Version 1319 ! 1284 !> @date January, 2016 1285 !> - mismatch with "halo" indices, use mpp__compute_halo 1286 !> 1320 1287 !> @param[in] td_file file strcuture 1321 1288 !> @return mpp structure … … 1336 1303 INTEGER(i4) :: il_pni, il_pnj, il_pnij ! domain decomposition 1337 1304 INTEGER(i4) :: il_area ! domain index 1305 1306 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lci 1307 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldi 1308 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lei 1309 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_impp 1310 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lcj 1311 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ldj 1312 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_lej 1313 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jmpp 1338 1314 1339 1315 LOGICAL :: ll_exist … … 1389 1365 ALLOCATE( mpp__init_file_rstdimg%t_proc(il_pnij) , stat=il_status ) 1390 1366 1367 ALLOCATE(il_lci (il_pnij)) 1368 ALLOCATE(il_lcj (il_pnij)) 1369 ALLOCATE(il_ldi (il_pnij)) 1370 ALLOCATE(il_ldj (il_pnij)) 1371 ALLOCATE(il_lei (il_pnij)) 1372 ALLOCATE(il_lej (il_pnij)) 1373 ALLOCATE(il_impp(il_pnij)) 1374 ALLOCATE(il_jmpp(il_pnij)) 1375 1391 1376 tl_proc=file_copy(td_file) 1392 1377 ! remove dimension from file … … 1411 1396 & il_area, & 1412 1397 & il_iglo, il_jglo, & 1413 & mpp__init_file_rstdimg%t_proc(:)%i_lci, &1414 & mpp__init_file_rstdimg%t_proc(:)%i_lcj, &1415 & mpp__init_file_rstdimg%t_proc(:)%i_ldi, &1416 & mpp__init_file_rstdimg%t_proc(:)%i_ldj, &1417 & mpp__init_file_rstdimg%t_proc(:)%i_lei, &1418 & mpp__init_file_rstdimg%t_proc(:)%i_lej, &1419 & mpp__init_file_rstdimg%t_proc(:)%i_impp, &1420 & mpp__init_file_rstdimg%t_proc(:)%i_jmpp1398 & il_lci(1:il_pnij), & 1399 & il_lcj(1:il_pnij), & 1400 & il_ldi(1:il_pnij), & 1401 & il_ldj(1:il_pnij), & 1402 & il_lei(1:il_pnij), & 1403 & il_lej(1:il_pnij), & 1404 & il_impp(1:il_pnij), & 1405 & il_jmpp(1:il_pnij) 1421 1406 CALL fct_err(il_status) 1422 1407 IF( il_status /= 0 )THEN … … 1424 1409 & TRIM(td_file%c_name)) 1425 1410 ENDIF 1411 1412 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lci = il_lci (1:il_pnij) 1413 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lcj = il_lcj (1:il_pnij) 1414 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_ldi = il_ldi (1:il_pnij) 1415 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_ldj = il_ldj (1:il_pnij) 1416 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lei = il_lei (1:il_pnij) 1417 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_lej = il_lej (1:il_pnij) 1418 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_impp= il_impp(1:il_pnij) 1419 mpp__init_file_rstdimg%t_proc(1:il_pnij)%i_jmpp= il_jmpp(1:il_pnij) 1420 1421 DEALLOCATE(il_lci) 1422 DEALLOCATE(il_lcj) 1423 DEALLOCATE(il_ldi) 1424 DEALLOCATE(il_ldj) 1425 DEALLOCATE(il_lei) 1426 DEALLOCATE(il_lej) 1427 DEALLOCATE(il_impp) 1428 DEALLOCATE(il_jmpp) 1426 1429 1427 1430 ! global domain size … … 1435 1438 1436 1439 DO ji=1,mpp__init_file_rstdimg%i_nproc 1440 1437 1441 ! get file name 1438 1442 cl_file = file_rename(td_file%c_name,ji) … … 1445 1449 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att) 1446 1450 1447 tl_att=att_init( "DOMAIN_position_first", &1448 & (/mpp__init_file_rstdimg%t_proc(ji)%i_impp, &1449 & mpp__init_file_rstdimg%t_proc(ji)%i_jmpp /) )1450 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1451 1452 tl_att=att_init( "DOMAIN_position_last", &1453 & (/mpp__init_file_rstdimg%t_proc(ji)%i_lci, &1454 & mpp__init_file_rstdimg%t_proc(ji)%i_lcj /) )1455 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1456 1457 tl_att=att_init( "DOMAIN_halo_size_start", &1458 & (/mpp__init_file_rstdimg%t_proc(ji)%i_ldi, &1459 & mpp__init_file_rstdimg%t_proc(ji)%i_ldj /) )1460 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1461 1462 tl_att=att_init( "DOMAIN_halo_size_end", &1463 & (/mpp__init_file_rstdimg%t_proc(ji)%i_lei, &1464 & mpp__init_file_rstdimg%t_proc(ji)%i_lej /) )1465 CALL file_move_att(mpp__init_file_rstdimg%t_proc(ji), tl_att)1466 1451 ENDDO 1467 1452 … … 1486 1471 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1487 1472 1488 tl_att=att_init( "DOMAIN_I_position_first", & 1489 & mpp__init_file_rstdimg%t_proc(:)%i_impp ) 1490 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1491 1492 tl_att=att_init( "DOMAIN_J_position_first", & 1493 & mpp__init_file_rstdimg%t_proc(:)%i_jmpp ) 1494 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1495 1496 tl_att=att_init( "DOMAIN_I_position_last", & 1497 & mpp__init_file_rstdimg%t_proc(:)%i_lci ) 1498 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1499 1500 tl_att=att_init( "DOMAIN_J_position_last", & 1501 & mpp__init_file_rstdimg%t_proc(:)%i_lcj ) 1502 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1503 1504 tl_att=att_init( "DOMAIN_I_halo_size_start", & 1505 & mpp__init_file_rstdimg%t_proc(:)%i_ldi ) 1506 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1507 1508 tl_att=att_init( "DOMAIN_J_halo_size_start", & 1509 & mpp__init_file_rstdimg%t_proc(:)%i_ldj ) 1510 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1511 1512 tl_att=att_init( "DOMAIN_I_halo_size_end", & 1513 & mpp__init_file_rstdimg%t_proc(:)%i_lei ) 1514 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1515 1516 tl_att=att_init( "DOMAIN_J_halo_size_end", & 1517 & mpp__init_file_rstdimg%t_proc(:)%i_lej ) 1518 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1473 CALL mpp_get_dom( mpp__init_file_rstdimg ) 1474 1475 CALL mpp__compute_halo( mpp__init_file_rstdimg ) 1519 1476 1520 1477 ! clean … … 1598 1555 ! Argument 1599 1556 TYPE(TMPP), INTENT(INOUT) :: td_mpp 1600 TYPE(TVAR), INTENT(IN ):: td_var1557 TYPE(TVAR), INTENT(INOUT) :: td_var 1601 1558 1602 1559 ! local variable … … 1646 1603 ! check used dimension 1647 1604 IF( mpp__check_dim(td_mpp, td_var) )THEN 1605 1606 ! check variable dimension expected 1607 CALL var_check_dim(td_var) 1648 1608 1649 1609 ! update dimension if need be … … 1915 1875 TYPE(TVAR) :: tl_var 1916 1876 !---------------------------------------------------------------- 1917 ! copy variabl e1877 ! copy variablie 1918 1878 tl_var=var_copy(td_var) 1919 1879 … … 1942 1902 !> - check proc type 1943 1903 !------------------------------------------------------------------- 1944 SUBROUTINE mpp__add_proc ( td_mpp, td_proc )1904 SUBROUTINE mpp__add_proc_unit( td_mpp, td_proc ) 1945 1905 IMPLICIT NONE 1946 1906 ! Argument … … 1957 1917 CHARACTER(LEN=lc) :: cl_name 1958 1918 !---------------------------------------------------------------- 1919 1920 ! ALLOCATE(tl_proc(1)) 1921 ! tl_proc(1)=file_copy(td_proc) 1922 ! 1923 ! CALL mpp__add_proc(td_mpp, tl_proc(:)) 1924 ! 1925 ! CALL file_clean(tl_proc(:)) 1926 ! DEALLOCATE(tl_proc) 1959 1927 1960 1928 ! check file name … … 2056 2024 2057 2025 ENDIF 2058 END SUBROUTINE mpp__add_proc 2026 2027 END SUBROUTINE mpp__add_proc_unit 2059 2028 !------------------------------------------------------------------- 2060 2029 !> @brief … … 2575 2544 !------------------------------------------------------------------- 2576 2545 !> @brief 2577 !> This subroutine compute domain decomposition for niproc and njproc 2578 !> processors following I and J. 2579 !> 2546 !> This function initialise domain layout 2547 !> 2580 2548 !> @detail 2581 !> To do so, it need to know : 2582 !> - global domain dimension 2583 !> - overlap region length 2584 !> - number of processors following I and J 2549 !> Domain layout is first compute, with domain dimension, overlap between subdomain, 2550 !> and the number of processors following I and J. 2551 !> Then the number of sea/land processors is compute with mask 2585 2552 ! 2586 2553 !> @author J.Paul 2587 !> @date November, 2013 - Initial version 2554 !> @date October, 2015 - Initial version 2555 ! 2556 !> @param[in] td_mpp mpp strcuture 2557 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2558 !> @pâram[in] id_niproc number of processors following I 2559 !> @pâram[in] id_njproc number of processors following J 2560 !> @return domain layout structure 2561 !------------------------------------------------------------------- 2562 FUNCTION layout__init( td_mpp, id_mask, id_niproc, id_njproc ) RESULT(td_lay) 2563 IMPLICIT NONE 2564 ! Argument 2565 TYPE(TMPP) , INTENT(IN) :: td_mpp 2566 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 2567 INTEGER(i4) , INTENT(IN) :: id_niproc 2568 INTEGER(i4) , INTENT(IN) :: id_njproc 2569 2570 ! function 2571 TYPE(TLAY) :: td_lay 2572 2573 ! local variable 2574 INTEGER(i4) :: ii1, ii2 2575 INTEGER(i4) :: ij1, ij2 2576 2577 INTEGER(i4) :: il_ldi 2578 INTEGER(i4) :: il_ldj 2579 INTEGER(i4) :: il_lei 2580 INTEGER(i4) :: il_lej 2581 2582 INTEGER(i4) :: il_isize !< i-direction maximum sub domain size 2583 INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size 2584 INTEGER(i4) :: il_resti !< 2585 INTEGER(i4) :: il_restj !< 2586 2587 ! loop indices 2588 INTEGER(i4) :: ji 2589 INTEGER(i4) :: jj 2590 !---------------------------------------------------------------- 2591 2592 ! intialise 2593 td_lay%i_niproc=id_niproc 2594 td_lay%i_njproc=id_njproc 2595 2596 CALL logger_info( "MPP COMPUTE LAYOUT: compute domain layout with "//& 2597 & TRIM(fct_str(td_lay%i_niproc))//" x "//& 2598 & TRIM(fct_str(td_lay%i_njproc))//" processors") 2599 2600 ! maximum size of sub domain 2601 il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (td_lay%i_niproc-1))/ & 2602 & td_lay%i_niproc) + 2*td_mpp%i_preci 2603 il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (td_lay%i_njproc-1))/ & 2604 & td_lay%i_njproc) + 2*td_mpp%i_precj 2605 2606 il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, td_lay%i_niproc) 2607 il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, td_lay%i_njproc) 2608 IF( il_resti == 0 ) il_resti = td_lay%i_niproc 2609 IF( il_restj == 0 ) il_restj = td_lay%i_njproc 2610 2611 ! compute dimension of each sub domain 2612 ALLOCATE( td_lay%i_lci(td_lay%i_niproc,td_lay%i_njproc) ) 2613 ALLOCATE( td_lay%i_lcj(td_lay%i_niproc,td_lay%i_njproc) ) 2614 2615 td_lay%i_lci( 1 : il_resti , : ) = il_isize 2616 td_lay%i_lci( il_resti+1 : td_lay%i_niproc, : ) = il_isize-1 2617 2618 td_lay%i_lcj( : , 1 : il_restj ) = il_jsize 2619 td_lay%i_lcj( : , il_restj+1 : td_lay%i_njproc) = il_jsize-1 2620 2621 ! compute first index of each sub domain 2622 ALLOCATE( td_lay%i_impp(td_lay%i_niproc,td_lay%i_njproc) ) 2623 ALLOCATE( td_lay%i_jmpp(td_lay%i_niproc,td_lay%i_njproc) ) 2624 2625 td_lay%i_impp(:,:)=1 2626 td_lay%i_jmpp(:,:)=1 2627 2628 IF( td_lay%i_niproc > 1 )THEN 2629 DO jj=1,td_lay%i_njproc 2630 DO ji=2,td_lay%i_niproc 2631 td_lay%i_impp(ji,jj) = td_lay%i_impp(ji-1,jj) + & 2632 & td_lay%i_lci (ji-1,jj) - 2*td_mpp%i_preci 2633 ENDDO 2634 ENDDO 2635 ENDIF 2636 2637 IF( td_lay%i_njproc > 1 )THEN 2638 DO jj=2,td_lay%i_njproc 2639 DO ji=1,td_lay%i_niproc 2640 td_lay%i_jmpp(ji,jj) = td_lay%i_jmpp(ji,jj-1) + & 2641 & td_lay%i_lcj (ji,jj-1) - 2*td_mpp%i_precj 2642 ENDDO 2643 ENDDO 2644 ENDIF 2645 2646 ALLOCATE(td_lay%i_msk(td_lay%i_niproc,td_lay%i_njproc)) 2647 td_lay%i_msk(:,:)=0 2648 ! init number of sea/land proc 2649 td_lay%i_nsea=0 2650 td_lay%i_nland=td_lay%i_njproc*td_lay%i_niproc 2651 2652 ! check if processor is land or sea 2653 DO jj = 1,td_lay%i_njproc 2654 DO ji = 1,td_lay%i_niproc 2655 2656 ! compute first and last indoor indices 2657 ! west boundary 2658 IF( ji == 1 )THEN 2659 il_ldi = 1 2660 ELSE 2661 il_ldi = 1 + td_mpp%i_preci 2662 ENDIF 2663 2664 ! south boundary 2665 IF( jj == 1 )THEN 2666 il_ldj = 1 2667 ELSE 2668 il_ldj = 1 + td_mpp%i_precj 2669 ENDIF 2670 2671 ! east boundary 2672 IF( ji == td_mpp%i_niproc )THEN 2673 il_lei = td_lay%i_lci(ji,jj) 2674 ELSE 2675 il_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci 2676 ENDIF 2677 2678 ! north boundary 2679 IF( jj == td_mpp%i_njproc )THEN 2680 il_lej = td_lay%i_lcj(ji,jj) 2681 ELSE 2682 il_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj 2683 ENDIF 2684 2685 ii1=td_lay%i_impp(ji,jj) + il_ldi - 1 2686 ii2=td_lay%i_impp(ji,jj) + il_lei - 1 2687 2688 ij1=td_lay%i_jmpp(ji,jj) + il_ldj - 1 2689 ij2=td_lay%i_jmpp(ji,jj) + il_lej - 1 2690 2691 td_lay%i_msk(ji,jj)=SUM( id_mask(ii1:ii2,ij1:ij2) ) 2692 IF( td_lay%i_msk(ji,jj) > 0 )THEN ! sea 2693 td_lay%i_nsea =td_lay%i_nsea +1 2694 td_lay%i_nland=td_lay%i_nland-1 2695 ENDIF 2696 2697 ENDDO 2698 ENDDO 2699 2700 CALL logger_info( "MPP COMPUTE LAYOUT: sea proc "//TRIM(fct_str(td_lay%i_nsea))) 2701 CALL logger_info( "MPP COMPUTE LAYOUT: land proc "//TRIM(fct_str(td_lay%i_nland))) 2702 CALL logger_info( "MPP COMPUTE LAYOUT: sum "//TRIM(fct_str( SUM(td_lay%i_msk(:,:))))) 2703 2704 td_lay%i_mean= SUM(td_lay%i_msk(:,:)) / td_lay%i_nsea 2705 td_lay%i_min = MINVAL(td_lay%i_msk(:,:),td_lay%i_msk(:,:)/=0) 2706 td_lay%i_max = MAXVAL(td_lay%i_msk(:,:)) 2707 2708 IF( lm_layout )THEN 2709 ! print info 2710 WRITE(im_iumout,*) ' ' 2711 WRITE(im_iumout,*) " jpni=",td_lay%i_niproc ," jpnj=",td_lay%i_njproc 2712 WRITE(im_iumout,*) " jpi= ",il_isize," jpj= ",il_jsize 2713 WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj 2714 2715 2716 WRITE(im_iumout,*) ' nombre de processeurs ',td_lay%i_niproc*td_lay%i_njproc 2717 WRITE(im_iumout,*) ' nombre de processeurs mer ',td_lay%i_nsea 2718 WRITE(im_iumout,*) ' nombre de processeurs terre ',td_lay%i_nland 2719 WRITE(im_iumout,*) ' moyenne de recouvrement ',td_lay%i_mean 2720 WRITE(im_iumout,*) ' minimum de recouvrement ',td_lay%i_min 2721 WRITE(im_iumout,*) ' maximum de recouvrement ',td_lay%i_max 2722 ENDIF 2723 2724 END FUNCTION layout__init 2725 !------------------------------------------------------------------- 2726 !> @brief 2727 !> This subroutine clean domain layout strcuture. 2728 !> 2729 !> @author J.Paul 2730 !> @date October, 2015 - Initial version 2731 !> 2732 !> @param[inout] td_lay domain layout strcuture 2733 !------------------------------------------------------------------- 2734 SUBROUTINE layout__clean( td_lay ) 2735 IMPLICIT NONE 2736 ! Argument 2737 TYPE(TLAY), INTENT(INOUT) :: td_lay 2738 !---------------------------------------------------------------- 2739 2740 IF( ASSOCIATED(td_lay%i_msk) )THEN 2741 DEALLOCATE(td_lay%i_msk) 2742 ENDIF 2743 IF( ASSOCIATED(td_lay%i_impp) )THEN 2744 DEALLOCATE(td_lay%i_impp) 2745 ENDIF 2746 IF( ASSOCIATED(td_lay%i_jmpp) )THEN 2747 DEALLOCATE(td_lay%i_jmpp) 2748 ENDIF 2749 IF( ASSOCIATED(td_lay%i_lci) )THEN 2750 DEALLOCATE(td_lay%i_lci) 2751 ENDIF 2752 IF( ASSOCIATED(td_lay%i_lcj) )THEN 2753 DEALLOCATE(td_lay%i_lcj) 2754 ENDIF 2755 2756 td_lay%i_niproc=0 2757 td_lay%i_njproc=0 2758 td_lay%i_nland =0 2759 td_lay%i_nsea =0 2760 2761 td_lay%i_mean =0 2762 td_lay%i_min =0 2763 td_lay%i_max =0 2764 2765 END SUBROUTINE layout__clean 2766 !------------------------------------------------------------------- 2767 !> @brief 2768 !> This subroutine copy domain layout structure in another one. 2769 !> 2770 !> @warning do not use on the output of a function who create or read a 2771 !> structure (ex: tl_seg=seg__copy(seg__init()) is forbidden). 2772 !> This will create memory leaks. 2773 !> @warning to avoid infinite loop, do not use any function inside 2774 !> this subroutine 2775 !> 2776 !> @author J.Paul 2777 !> @date October, 2015 - Initial Version 2778 ! 2779 !> @param[in] td_lay domain layout structure 2780 !> @return copy of input domain layout structure 2781 !------------------------------------------------------------------- 2782 FUNCTION layout__copy( td_lay ) 2783 IMPLICIT NONE 2784 ! Argument 2785 TYPE(TLAY), INTENT(IN) :: td_lay 2786 ! function 2787 TYPE(TLAY) :: layout__copy 2788 2789 ! local variable 2790 INTEGER(i4), DIMENSION(2) :: il_shape 2791 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_tmp 2792 ! loop indices 2793 !---------------------------------------------------------------- 2794 2795 ! copy scalar 2796 layout__copy%i_niproc = td_lay%i_niproc 2797 layout__copy%i_njproc = td_lay%i_njproc 2798 layout__copy%i_nland = td_lay%i_nland 2799 layout__copy%i_nsea = td_lay%i_nsea 2800 layout__copy%i_mean = td_lay%i_mean 2801 layout__copy%i_min = td_lay%i_min 2802 layout__copy%i_max = td_lay%i_max 2803 2804 ! copy pointers 2805 IF( ASSOCIATED(layout__copy%i_msk) )THEN 2806 DEALLOCATE(layout__copy%i_msk) 2807 ENDIF 2808 IF( ASSOCIATED(td_lay%i_msk) )THEN 2809 il_shape(:)=SHAPE(td_lay%i_msk(:,:)) 2810 ALLOCATE( layout__copy%i_msk(il_shape(jp_I),il_shape(jp_J)) ) 2811 layout__copy%i_msk(:,:)=td_lay%i_msk(:,:) 2812 ENDIF 2813 2814 IF( ASSOCIATED(layout__copy%i_msk) ) DEALLOCATE(layout__copy%i_msk) 2815 IF( ASSOCIATED(td_lay%i_msk) )THEN 2816 il_shape(:)=SHAPE(td_lay%i_msk(:,:)) 2817 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2818 il_tmp(:,:)=td_lay%i_msk(:,:) 2819 2820 ALLOCATE( layout__copy%i_msk(il_shape(jp_I),il_shape(jp_J)) ) 2821 layout__copy%i_msk(:,:)=il_tmp(:,:) 2822 2823 DEALLOCATE(il_tmp) 2824 ENDIF 2825 2826 IF( ASSOCIATED(layout__copy%i_impp) ) DEALLOCATE(layout__copy%i_impp) 2827 IF( ASSOCIATED(td_lay%i_impp) )THEN 2828 il_shape(:)=SHAPE(td_lay%i_impp(:,:)) 2829 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2830 il_tmp(:,:)=td_lay%i_impp(:,:) 2831 2832 ALLOCATE( layout__copy%i_impp(il_shape(jp_I),il_shape(jp_J)) ) 2833 layout__copy%i_impp(:,:)=il_tmp(:,:) 2834 2835 DEALLOCATE(il_tmp) 2836 ENDIF 2837 2838 IF( ASSOCIATED(layout__copy%i_jmpp) ) DEALLOCATE(layout__copy%i_jmpp) 2839 IF( ASSOCIATED(td_lay%i_jmpp) )THEN 2840 il_shape(:)=SHAPE(td_lay%i_jmpp(:,:)) 2841 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2842 il_tmp(:,:)=td_lay%i_jmpp(:,:) 2843 2844 ALLOCATE( layout__copy%i_jmpp(il_shape(jp_I),il_shape(jp_J)) ) 2845 layout__copy%i_jmpp(:,:)=il_tmp(:,:) 2846 2847 DEALLOCATE(il_tmp) 2848 ENDIF 2849 2850 IF( ASSOCIATED(layout__copy%i_lci) ) DEALLOCATE(layout__copy%i_lci) 2851 IF( ASSOCIATED(td_lay%i_lci) )THEN 2852 il_shape(:)=SHAPE(td_lay%i_lci(:,:)) 2853 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2854 il_tmp(:,:)=td_lay%i_lci(:,:) 2855 2856 ALLOCATE( layout__copy%i_lci(il_shape(jp_I),il_shape(jp_J)) ) 2857 layout__copy%i_lci(:,:)=il_tmp(:,:) 2858 2859 DEALLOCATE(il_tmp) 2860 ENDIF 2861 2862 IF( ASSOCIATED(layout__copy%i_lcj) ) DEALLOCATE(layout__copy%i_lcj) 2863 IF( ASSOCIATED(td_lay%i_lcj) )THEN 2864 il_shape(:)=SHAPE(td_lay%i_lcj(:,:)) 2865 ALLOCATE(il_tmp(il_shape(jp_I),il_shape(jp_J))) 2866 il_tmp(:,:)=td_lay%i_lcj(:,:) 2867 2868 ALLOCATE( layout__copy%i_lcj(il_shape(jp_I),il_shape(jp_J)) ) 2869 layout__copy%i_lcj(:,:)=il_tmp(:,:) 2870 2871 DEALLOCATE(il_tmp) 2872 ENDIF 2873 2874 END FUNCTION layout__copy 2875 !------------------------------------------------------------------- 2876 !> @brief 2877 !> This subroutine create mpp structure using domain layout 2878 !> 2879 !> @detail 2880 ! 2881 !> @author J.Paul 2882 !> @date October, 2015 - Initial version 2588 2883 ! 2589 2884 !> @param[inout] td_mpp mpp strcuture 2590 !------------------------------------------------------------------- 2591 SUBROUTINE mpp__compute( td_mpp ) 2885 !> @param[in] td_lay domain layout structure 2886 !------------------------------------------------------------------- 2887 SUBROUTINE mpp__create_layout( td_mpp, td_lay ) 2592 2888 IMPLICIT NONE 2593 2889 ! Argument 2594 2890 TYPE(TMPP), INTENT(INOUT) :: td_mpp 2891 TYPE(TLAY), INTENT(IN ) :: td_lay 2595 2892 2596 2893 ! local variable 2597 INTEGER(i4) :: il_isize !< i-direction maximum sub domain size2598 INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size2599 INTEGER(i4) :: il_resti !<2600 INTEGER(i4) :: il_restj !<2601 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_nlci2602 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_nlcj2603 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_impp2604 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_jmpp2605 2606 2894 CHARACTER(LEN=lc) :: cl_file 2607 2895 TYPE(TFILE) :: tl_proc … … 2617 2905 td_mpp%i_nproc=0 2618 2906 2619 CALL logger_trace( "MPP COMPUTE: compute domain decomposition with "//& 2620 & TRIM(fct_str(td_mpp%i_niproc))//" x "//& 2621 & TRIM(fct_str(td_mpp%i_njproc))//" processors") 2622 ! maximum size of sub domain 2623 il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (td_mpp%i_niproc-1))/ & 2624 & td_mpp%i_niproc) + 2*td_mpp%i_preci 2625 il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (td_mpp%i_njproc-1))/ & 2626 & td_mpp%i_njproc) + 2*td_mpp%i_precj 2627 2628 il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, td_mpp%i_niproc) 2629 il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, td_mpp%i_njproc) 2630 IF( il_resti == 0 ) il_resti = td_mpp%i_niproc 2631 IF( il_restj == 0 ) il_restj = td_mpp%i_njproc 2632 2633 ! compute dimension of each sub domain 2634 ALLOCATE( il_nlci(td_mpp%i_niproc,td_mpp%i_njproc) ) 2635 ALLOCATE( il_nlcj(td_mpp%i_niproc,td_mpp%i_njproc) ) 2636 2637 il_nlci( 1 : il_resti , : ) = il_isize 2638 il_nlci( il_resti+1 : td_mpp%i_niproc, : ) = il_isize-1 2639 2640 il_nlcj( : , 1 : il_restj ) = il_jsize 2641 il_nlcj( : , il_restj+1 : td_mpp%i_njproc) = il_jsize-1 2642 2643 ! compute first index of each sub domain 2644 ALLOCATE( il_impp(td_mpp%i_niproc,td_mpp%i_njproc) ) 2645 ALLOCATE( il_jmpp(td_mpp%i_niproc,td_mpp%i_njproc) ) 2646 2647 il_impp(:,:)=1 2648 il_jmpp(:,:)=1 2649 2650 DO jj=1,td_mpp%i_njproc 2651 DO ji=2,td_mpp%i_niproc 2652 il_impp(ji,jj)=il_impp(ji-1,jj)+il_nlci(ji-1,jj)-2*td_mpp%i_preci 2907 CALL logger_debug( "MPP CREATE LAYOUT: create domain decomposition with "//& 2908 & TRIM(fct_str(td_lay%i_niproc))//" x "//& 2909 & TRIM(fct_str(td_lay%i_njproc))//" = "//& 2910 & TRIM(fct_str(td_lay%i_nsea))//" processors") 2911 2912 IF( lm_layout )THEN 2913 WRITE(im_iumout,*) ' choix optimum' 2914 WRITE(im_iumout,*) ' =============' 2915 WRITE(im_iumout,*) 2916 ! print info 2917 WRITE(im_iumout,*) ' ' 2918 WRITE(im_iumout,*) " jpni=",td_lay%i_niproc ," jpnj=",td_lay%i_njproc 2919 WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj 2920 2921 2922 WRITE(im_iumout,*) ' nombre de processeurs ',td_lay%i_niproc*td_lay%i_njproc 2923 WRITE(im_iumout,*) ' nombre de processeurs mer ',td_lay%i_nsea 2924 WRITE(im_iumout,*) ' nombre de processeurs terre ',td_lay%i_nland 2925 WRITE(im_iumout,*) ' moyenne de recouvrement ',td_lay%i_mean 2926 WRITE(im_iumout,*) ' minimum de recouvrement ',td_lay%i_min 2927 WRITE(im_iumout,*) ' maximum de recouvrement ',td_lay%i_max 2928 ENDIF 2929 2930 td_mpp%i_niproc=td_lay%i_niproc 2931 td_mpp%i_njproc=td_lay%i_njproc 2932 !td_mpp%i_nproc =td_lay%i_nsea 2933 2934 IF( td_mpp%i_niproc*td_mpp%i_njproc == td_lay%i_nsea )THEN 2935 IF( td_lay%i_nsea == 1 )THEN 2936 td_mpp%c_dom='full' 2937 ELSE 2938 td_mpp%c_dom='nooverlap' 2939 ENDIF 2940 ELSE 2941 td_mpp%c_dom='noextra' 2942 ENDIF 2943 2944 jk=0 2945 DO jj=1,td_lay%i_njproc 2946 DO ji=1,td_lay%i_niproc 2947 2948 IF( td_lay%i_msk(ji,jj) >= 1 )THEN 2949 2950 ! get processor file name 2951 cl_file=file_rename(td_mpp%c_name,jk) 2952 ! initialise file structure 2953 tl_proc=file_init(cl_file,td_mpp%c_type) 2954 2955 ! procesor id 2956 tl_proc%i_pid=jk 2957 2958 tl_att=att_init("DOMAIN_number",tl_proc%i_pid) 2959 CALL file_add_att(tl_proc, tl_att) 2960 2961 ! processor indices 2962 tl_proc%i_iind=ji 2963 tl_proc%i_jind=jj 2964 2965 ! fill processor dimension and first indices 2966 tl_proc%i_impp = td_lay%i_impp(ji,jj) 2967 tl_proc%i_jmpp = td_lay%i_jmpp(ji,jj) 2968 2969 tl_proc%i_lci = td_lay%i_lci(ji,jj) 2970 tl_proc%i_lcj = td_lay%i_lcj(ji,jj) 2971 2972 ! compute first and last indoor indices 2973 2974 ! west boundary 2975 IF( ji == 1 )THEN 2976 tl_proc%i_ldi = 1 2977 tl_proc%l_ctr = .TRUE. 2978 ELSE 2979 tl_proc%i_ldi = 1 + td_mpp%i_preci 2980 ENDIF 2981 2982 ! south boundary 2983 IF( jj == 1 )THEN 2984 tl_proc%i_ldj = 1 2985 tl_proc%l_ctr = .TRUE. 2986 ELSE 2987 tl_proc%i_ldj = 1 + td_mpp%i_precj 2988 ENDIF 2989 2990 ! east boundary 2991 IF( ji == td_mpp%i_niproc )THEN 2992 tl_proc%i_lei = td_lay%i_lci(ji,jj) 2993 tl_proc%l_ctr = .TRUE. 2994 ELSE 2995 tl_proc%i_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci 2996 ENDIF 2997 2998 ! north boundary 2999 IF( jj == td_mpp%i_njproc )THEN 3000 tl_proc%i_lej = td_lay%i_lcj(ji,jj) 3001 tl_proc%l_ctr = .TRUE. 3002 ELSE 3003 tl_proc%i_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj 3004 ENDIF 3005 3006 ! add processor to mpp structure 3007 CALL mpp__add_proc(td_mpp, tl_proc) 3008 3009 ! clean 3010 CALL att_clean(tl_att) 3011 CALL file_clean(tl_proc) 3012 3013 ! update proc number 3014 jk=jk+1 !ji+(jj-1)*td_lay%i_niproc 3015 3016 ENDIF 2653 3017 ENDDO 2654 3018 ENDDO 2655 3019 2656 DO jj=2,td_mpp%i_njproc 2657 DO ji=1,td_mpp%i_niproc 2658 il_jmpp(ji,jj)=il_jmpp(ji,jj-1)+il_nlcj(ji,jj-1)-2*td_mpp%i_precj 2659 ENDDO 2660 ENDDO 2661 2662 DO jj=1,td_mpp%i_njproc 2663 DO ji=1,td_mpp%i_niproc 2664 2665 jk=ji+(jj-1)*td_mpp%i_niproc 2666 2667 ! get processor file name 2668 cl_file=file_rename(td_mpp%c_name,jk) 2669 ! initialise file structure 2670 tl_proc=file_init(cl_file,td_mpp%c_type) 2671 2672 ! procesor id 2673 tl_proc%i_pid=jk 2674 2675 tl_att=att_init("DOMAIN_number",tl_proc%i_pid) 2676 CALL file_add_att(tl_proc, tl_att) 2677 2678 ! processor indices 2679 tl_proc%i_iind=ji 2680 tl_proc%i_jind=jj 2681 2682 ! fill processor dimension and first indices 2683 tl_proc%i_impp = il_impp(ji,jj) 2684 tl_proc%i_jmpp = il_jmpp(ji,jj) 2685 2686 tl_att=att_init( "DOMAIN_poistion_first", & 2687 & (/tl_proc%i_impp, tl_proc%i_jmpp/) ) 2688 CALL file_add_att(tl_proc, tl_att) 2689 2690 tl_proc%i_lci = il_nlci(ji,jj) 2691 tl_proc%i_lcj = il_nlcj(ji,jj) 2692 2693 tl_att=att_init( "DOMAIN_poistion_last", & 2694 & (/tl_proc%i_lci, tl_proc%i_lcj/) ) 2695 CALL file_add_att(tl_proc, tl_att) 2696 2697 ! compute first and last indoor indices 2698 2699 ! west boundary 2700 IF( ji == 1 )THEN 2701 tl_proc%i_ldi = 1 2702 tl_proc%l_ctr = .TRUE. 2703 ELSE 2704 tl_proc%i_ldi = 1 + td_mpp%i_preci 2705 ENDIF 2706 2707 ! south boundary 2708 IF( jj == 1 )THEN 2709 tl_proc%i_ldj = 1 2710 tl_proc%l_ctr = .TRUE. 2711 ELSE 2712 tl_proc%i_ldj = 1 + td_mpp%i_precj 2713 ENDIF 2714 2715 ! east boundary 2716 IF( ji == td_mpp%i_niproc )THEN 2717 tl_proc%i_lei = il_nlci(ji,jj) 2718 tl_proc%l_ctr = .TRUE. 2719 ELSE 2720 tl_proc%i_lei = il_nlci(ji,jj) - td_mpp%i_preci 2721 ENDIF 2722 2723 ! north boundary 2724 IF( jj == td_mpp%i_njproc )THEN 2725 tl_proc%i_lej = il_nlcj(ji,jj) 2726 tl_proc%l_ctr = .TRUE. 2727 ELSE 2728 tl_proc%i_lej = il_nlcj(ji,jj) - td_mpp%i_precj 2729 ENDIF 2730 2731 tl_att=att_init( "DOMAIN_halo_size_start", & 2732 & (/tl_proc%i_ldi, tl_proc%i_ldj/) ) 2733 CALL file_add_att(tl_proc, tl_att) 2734 tl_att=att_init( "DOMAIN_halo_size_end", & 2735 & (/tl_proc%i_ldi, tl_proc%i_ldj/) ) 2736 CALL file_add_att(tl_proc, tl_att) 2737 2738 ! add processor to mpp structure 2739 CALL mpp__add_proc(td_mpp, tl_proc) 2740 2741 ! clean 2742 CALL att_clean(tl_att) 2743 CALL file_clean(tl_proc) 2744 2745 ENDDO 2746 ENDDO 2747 2748 DEALLOCATE( il_impp, il_jmpp ) 2749 DEALLOCATE( il_nlci, il_nlcj ) 2750 2751 END SUBROUTINE mpp__compute 3020 END SUBROUTINE mpp__create_layout 2752 3021 !------------------------------------------------------------------- 2753 3022 !> @brief 2754 !> This subroutine remove land processor from domain decomposition. 2755 !> 3023 !> This subroutine optimize the number of sub domain to be used, given mask. 3024 !> @details 3025 !> Actually it get the domain decomposition with the most land 3026 !> processors removed. 3027 !> If no land processor could be removed, it get the decomposition with the 3028 !> most sea processors. 3029 ! 2756 3030 !> @author J.Paul 2757 3031 !> @date November, 2013 - Initial version 2758 !> 3032 !> @date October, 2015 3033 !> - improve way to compute domain layout 3034 !> @date February, 2016 3035 !> - new criteria for domain layout in case no land proc 3036 ! 2759 3037 !> @param[inout] td_mpp mpp strcuture 2760 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2761 !------------------------------------------------------------------- 2762 SUBROUTINE mpp__del_land( td_mpp, id_mask ) 3038 !> @param[in] id_mask sub domain mask (sea=1, land=0) 3039 !> @pram[in] id_nproc maximum number of processor to be used 3040 !------------------------------------------------------------------- 3041 SUBROUTINE mpp__optimiz( td_mpp, id_mask, id_nproc ) 2763 3042 IMPLICIT NONE 2764 3043 ! Argument 2765 3044 TYPE(TMPP), INTENT(INOUT) :: td_mpp 2766 3045 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 2767 2768 ! loop indices 2769 INTEGER(i4) :: jk 2770 !---------------------------------------------------------------- 2771 2772 IF( ASSOCIATED(td_mpp%t_proc) )THEN 2773 jk=1 2774 DO WHILE( jk <= td_mpp%i_nproc ) 2775 IF( mpp__land_proc(td_mpp, jk, id_mask(:,:)) )THEN 2776 CALL mpp__del_proc(td_mpp, jk) 2777 ELSE 2778 jk=jk+1 2779 ENDIF 2780 ENDDO 2781 ELSE 2782 CALL logger_error("MPP DEL LAND: domain decomposition not define.") 2783 ENDIF 2784 2785 END SUBROUTINE mpp__del_land 2786 !------------------------------------------------------------------- 2787 !> @brief 2788 !> This subroutine optimize the number of sub domain to be used, given mask. 2789 !> @details 2790 !> Actually it get the domain decomposition with the most land 2791 !> processor removed. 2792 ! 2793 !> @author J.Paul 2794 !> @date November, 2013 - Initial version 2795 ! 2796 !> @param[inout] td_mpp mpp strcuture 2797 !> @param[in] id_mask sub domain mask (sea=1, land=0) 2798 !------------------------------------------------------------------- 2799 SUBROUTINE mpp__optimiz( td_mpp, id_mask ) 2800 IMPLICIT NONE 2801 ! Argument 2802 TYPE(TMPP), INTENT(INOUT) :: td_mpp 2803 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask 3046 INTEGER(i4) , INTENT(IN) :: id_nproc 2804 3047 2805 3048 ! local variable 2806 TYPE(TMPP) :: tl_mpp 2807 INTEGER(i4) :: il_maxproc 2808 2809 TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc 3049 TYPE(TLAY) :: tl_lay 3050 TYPE(TLAY) :: tl_sav 3051 3052 REAL(dp) :: dl_min 3053 REAL(dp) :: dl_max 3054 REAL(dp) :: dl_ratio 3055 REAL(dp) :: dl_sav 3056 2810 3057 ! loop indices 2811 3058 INTEGER(i4) :: ji … … 2814 3061 2815 3062 CALL logger_trace("MPP OPTIMIZ: look for best domain decomposition") 2816 tl_mpp=mpp_copy(td_mpp) 2817 2818 ! save maximum number of processor to be used 2819 il_maxproc=td_mpp%i_nproc 3063 dl_sav=0 2820 3064 ! 2821 td_mpp%i_nproc=0 2822 DO ji=1,il_maxproc 2823 DO jj=1,il_maxproc 2824 2825 ! clean mpp processor 2826 IF( ASSOCIATED(tl_mpp%t_proc) )THEN 2827 CALL file_clean(tl_mpp%t_proc(:)) 2828 DEALLOCATE(tl_mpp%t_proc) 2829 ENDIF 2830 2831 ! compute domain decomposition 2832 tl_mpp%i_niproc=ji 2833 tl_mpp%i_njproc=jj 2834 2835 CALL mpp__compute( tl_mpp ) 2836 2837 ! remove land sub domain 2838 CALL mpp__del_land( tl_mpp, id_mask ) 2839 2840 CALL logger_info("MPP OPTIMIZ: number of processor "//& 2841 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 2842 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2843 IF( tl_mpp%i_nproc > td_mpp%i_nproc .AND. & 2844 & tl_mpp%i_nproc <= il_maxproc )THEN 2845 ! save optimiz decomposition 2846 2847 CALL logger_info("MPP OPTIMIZ:save this decomposition "//& 2848 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 2849 & TRIM(fct_str(tl_mpp%i_nproc)) ) 2850 2851 ! clean mpp 2852 CALL mpp_clean(td_mpp) 2853 2854 ! save processor array 2855 ALLOCATE( tl_proc(tl_mpp%i_nproc) ) 2856 tl_proc(:)=file_copy(tl_mpp%t_proc(:)) 2857 2858 ! remove pointer on processor array 2859 CALL file_clean(tl_mpp%t_proc(:)) 2860 DEALLOCATE(tl_mpp%t_proc) 2861 2862 ! save data except processor array 2863 td_mpp=mpp_copy(tl_mpp) 2864 2865 ! save processor array 2866 ALLOCATE( td_mpp%t_proc(td_mpp%i_nproc) ) 2867 td_mpp%t_proc(:)=file_copy(tl_proc(:)) 2868 2869 ! clean 2870 CALL file_clean( tl_proc(:) ) 2871 DEALLOCATE(tl_proc) 2872 2873 ENDIF 2874 3065 DO ji=1,id_nproc 3066 DO jj=1,id_nproc 3067 3068 ! compute domain layout 3069 tl_lay=layout__init( td_mpp, id_mask, ji,jj ) 3070 IF( tl_lay%i_nsea <= id_nproc )THEN 3071 3072 IF( ASSOCIATED(tl_sav%i_lci) )THEN 3073 IF( tl_sav%i_nland /= 0 )THEN 3074 ! look for layout with most land proc 3075 IF( tl_lay%i_nland > tl_sav%i_nland .OR. & 3076 & ( tl_lay%i_nland == tl_sav%i_nland .AND. & 3077 & tl_lay%i_min > tl_sav%i_min ) )THEN 3078 ! save optimiz layout 3079 CALL logger_info("MPP OPTIMIZ:save this decomposition "//& 3080 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 3081 & TRIM(fct_str(tl_lay%i_nsea)) ) 3082 3083 tl_sav=layout__copy(tl_lay) 3084 ENDIF 3085 ELSE ! tl_sav%i_nland == 0 3086 ! look for layout with most sea proc 3087 ! and "square" cell 3088 dl_min=MIN(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1)) 3089 dl_max=MAX(tl_lay%i_lci(1,1),tl_lay%i_lcj(1,1)) 3090 dl_ratio=dl_min/dl_max 3091 IF( tl_lay%i_nsea > tl_sav%i_nsea .OR. & 3092 & ( tl_lay%i_nsea == tl_sav%i_nsea .AND. & 3093 & dl_ratio > dl_sav ) )THEN 3094 ! save optimiz layout 3095 CALL logger_info("MPP OPTIMIZ:save this decomposition "//& 3096 & TRIM(fct_str(ji))//"x"//TRIM(fct_str(jj))//"="//& 3097 & TRIM(fct_str(tl_lay%i_nsea)) ) 3098 3099 tl_sav=layout__copy(tl_lay) 3100 dl_sav=dl_ratio 3101 ENDIF 3102 ENDIF 3103 ELSE 3104 ! init tl_sav 3105 tl_sav=layout__copy(tl_lay) 3106 3107 dl_min=MIN(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1)) 3108 dl_max=MAX(tl_sav%i_lci(1,1),tl_sav%i_lcj(1,1)) 3109 dl_sav=dl_min/dl_max 3110 ENDIF 3111 3112 ENDIF 3113 3114 ! clean 3115 CALL layout__clean( tl_lay ) 3116 2875 3117 ENDDO 2876 3118 ENDDO 2877 3119 3120 ! create mpp domain layout 3121 CALL mpp__create_layout(td_mpp, tl_sav) 3122 2878 3123 ! clean 2879 CALL mpp_clean(tl_mpp)3124 CALL layout__clean( tl_sav ) 2880 3125 2881 3126 END SUBROUTINE mpp__optimiz 2882 !-------------------------------------------------------------------2883 !> @brief2884 !> This function check if processor is a land processor.2885 !>2886 !> @author J.Paul2887 !> @date November, 2013 - Initial version2888 !>2889 !> @param[in] td_mpp mpp strcuture2890 !> @param[in] id_proc processor id2891 !> @param[in] id_mask sub domain mask (sea=1, land=0)2892 !-------------------------------------------------------------------2893 LOGICAL FUNCTION mpp__land_proc( td_mpp , id_proc, id_mask )2894 IMPLICIT NONE2895 ! Argument2896 TYPE(TMPP), INTENT(IN) :: td_mpp2897 INTEGER(i4), INTENT(IN) :: id_proc2898 INTEGER(i4), DIMENSION(:,:), INTENT(IN) :: id_mask2899 2900 ! local variable2901 INTEGER(i4), DIMENSION(2) :: il_shape2902 !----------------------------------------------------------------2903 2904 CALL logger_trace("MPP LAND PROC: check processor "//TRIM(fct_str(id_proc))//&2905 & " of mpp "//TRIM(td_mpp%c_name) )2906 mpp__land_proc=.FALSE.2907 IF( ASSOCIATED(td_mpp%t_proc) )THEN2908 2909 il_shape(:)=SHAPE(id_mask)2910 IF( il_shape(1) /= td_mpp%t_dim(1)%i_len .OR. &2911 & il_shape(2) /= td_mpp%t_dim(2)%i_len )THEN2912 CALL logger_debug("MPP LAND PROC: mask size ("//&2913 & TRIM(fct_str(il_shape(1)))//","//&2914 & TRIM(fct_str(il_shape(2)))//")")2915 CALL logger_debug("MPP LAND PROC: domain size ("//&2916 & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//&2917 & TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")")2918 CALL logger_error("MPP LAND PROC: mask and domain size differ")2919 ELSE2920 IF( ALL(id_mask( td_mpp%t_proc(id_proc)%i_impp + &2921 & td_mpp%t_proc(id_proc)%i_ldi - 1 : &2922 & td_mpp%t_proc(id_proc)%i_impp + &2923 & td_mpp%t_proc(id_proc)%i_lei - 1, &2924 & td_mpp%t_proc(id_proc)%i_jmpp + &2925 & td_mpp%t_proc(id_proc)%i_ldj - 1 : &2926 & td_mpp%t_proc(id_proc)%i_jmpp + &2927 & td_mpp%t_proc(id_proc)%i_lej - 1) &2928 & /= 1 ) )THEN2929 ! land domain2930 CALL logger_info("MPP LAND PROC: processor "//TRIM(fct_str(id_proc))//&2931 & " is land processor")2932 mpp__land_proc=.TRUE.2933 ENDIF2934 ENDIF2935 2936 ELSE2937 CALL logger_error("MPP LAND PROC: domain decomposition not define.")2938 ENDIF2939 2940 END FUNCTION mpp__land_proc2941 3127 !------------------------------------------------------------------- 2942 3128 !> @brief … … 3195 3381 SELECT CASE(TRIM(td_mpp%c_dom)) 3196 3382 CASE('full') 3197 il_i1 = 1 ; il_i2 = td_mpp%t_dim(1)%i_len 3198 il_j1 = 1 ; il_j2 = td_mpp%t_dim(2)%i_len 3199 CASE('overlap') 3200 il_i1 = td_mpp%t_proc(id_procid)%i_impp 3201 il_j1 = td_mpp%t_proc(id_procid)%i_jmpp 3202 3203 il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1 3204 il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1 3383 il_i1 = 1 3384 il_j1 = 1 3385 3386 il_i2 = td_mpp%t_dim(1)%i_len 3387 il_j2 = td_mpp%t_dim(2)%i_len 3388 CASE('noextra') 3389 il_i1 = td_mpp%t_proc(id_procid)%i_impp 3390 il_j1 = td_mpp%t_proc(id_procid)%i_jmpp 3391 3392 il_i2 = il_i1 + td_mpp%t_proc(id_procid)%i_lci - 1 3393 il_j2 = il_j1 + td_mpp%t_proc(id_procid)%i_lcj - 1 3205 3394 CASE('nooverlap') 3206 3395 il_i1 = td_mpp%t_proc(id_procid)%i_impp + & … … 3214 3403 & td_mpp%t_proc(id_procid)%i_lej - 1 3215 3404 CASE DEFAULT 3216 CALL logger_error("MPP GET PROC INDEX: invalid decomposition type.") 3405 CALL logger_error("MPP GET PROC INDEX: invalid "//& 3406 & "decomposition type.") 3217 3407 END SELECT 3218 3408 … … 3264 3454 il_jsize = td_mpp%t_dim(2)%i_len 3265 3455 3266 CASE(' overlap')3456 CASE('noextra') 3267 3457 3268 3458 il_isize = td_mpp%t_proc(id_procid)%i_lci … … 3308 3498 IF( ASSOCIATED(td_mpp%t_proc) )THEN 3309 3499 3310 IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_n iproc == 0 )THEN3500 IF( td_mpp%i_niproc == 0 .AND. td_mpp%i_njproc == 0 )THEN 3311 3501 CALL logger_info("MPP GET DOM: use indoor indices to get domain "//& 3312 3502 & "decomposition type.") … … 3323 3513 & td_mpp%t_proc(1)%i_lcj ) )THEN 3324 3514 3325 td_mpp%c_dom=' overlap'3515 td_mpp%c_dom='noextra' 3326 3516 3327 3517 ELSEIF((td_mpp%t_proc(1)%t_dim(1)%i_len == & … … 3368 3558 td_mpp%c_dom='nooverlap' 3369 3559 ELSE 3370 td_mpp%c_dom=' overlap'3560 td_mpp%c_dom='noextra' 3371 3561 ENDIF 3372 3562 … … 3386 3576 !> @author J.Paul 3387 3577 !> @date November, 2013 - Initial Version 3578 !> @date September 2015 3579 !> - do not check used dimension here 3388 3580 !> 3389 3581 !> @param[in] td_mpp mpp structure … … 3398 3590 3399 3591 ! local variable 3592 CHARACTER(LEN=lc) :: cl_dim 3593 LOGICAL :: ll_error 3594 LOGICAL :: ll_warn 3595 3596 INTEGER(i4) :: il_ind 3400 3597 3401 3598 ! loop indices … … 3403 3600 !---------------------------------------------------------------- 3404 3601 mpp__check_var_dim=.TRUE. 3602 3405 3603 ! check used dimension 3406 IF( ANY( td_var%t_dim(:)%l_use .AND. & 3407 & td_var%t_dim(:)%i_len /= td_mpp%t_dim(:)%i_len) )THEN 3604 ll_error=.FALSE. 3605 ll_warn=.FALSE. 3606 DO ji=1,ip_maxdim 3607 il_ind=dim_get_index( td_mpp%t_dim(:), & 3608 & TRIM(td_var%t_dim(ji)%c_name), & 3609 & TRIM(td_var%t_dim(ji)%c_sname)) 3610 IF( il_ind /= 0 )THEN 3611 IF( td_var%t_dim(ji)%l_use .AND. & 3612 & td_mpp%t_dim(il_ind)%l_use .AND. & 3613 & td_var%t_dim(ji)%i_len /= td_mpp%t_dim(il_ind)%i_len )THEN 3614 IF( INDEX( TRIM(td_var%c_axis), & 3615 & TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN 3616 ll_warn=.TRUE. 3617 ELSE 3618 ll_error=.TRUE. 3619 ENDIF 3620 ENDIF 3621 ENDIF 3622 ENDDO 3623 3624 IF( ll_error )THEN 3625 3626 cl_dim='(/' 3627 DO ji = 1, td_mpp%i_ndim 3628 IF( td_mpp%t_dim(ji)%l_use )THEN 3629 cl_dim=TRIM(cl_dim)//& 3630 & TRIM(fct_upper(td_mpp%t_dim(ji)%c_sname))//':'//& 3631 & TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//',' 3632 ENDIF 3633 ENDDO 3634 cl_dim=TRIM(cl_dim)//'/)' 3635 CALL logger_debug( " mpp dimension: "//TRIM(cl_dim) ) 3636 3637 cl_dim='(/' 3638 DO ji = 1, td_var%i_ndim 3639 IF( td_var%t_dim(ji)%l_use )THEN 3640 cl_dim=TRIM(cl_dim)//& 3641 & TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//& 3642 & TRIM(fct_str(td_var%t_dim(ji)%i_len))//',' 3643 ENDIF 3644 ENDDO 3645 cl_dim=TRIM(cl_dim)//'/)' 3646 CALL logger_debug( " variable dimension: "//TRIM(cl_dim) ) 3408 3647 3409 3648 mpp__check_var_dim=.FALSE. 3410 3649 3411 CALL logger_debug( &3412 & " mpp dimension: "//TRIM(fct_str(td_mpp%i_ndim))//&3413 & " variable dimension: "//TRIM(fct_str(td_var%i_ndim)) )3414 DO ji = 1, ip_maxdim3415 CALL logger_debug( &3416 & "MPP CHECK DIM: for dimension "//&3417 & TRIM(td_mpp%t_dim(ji)%c_name)//&3418 & ", mpp length: "//&3419 & TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//&3420 & ", variable length: "//&3421 & TRIM(fct_str(td_var%t_dim(ji)%i_len))//&3422 & ", variable used "//TRIM(fct_str(td_var%t_dim(ji)%l_use)))3423 ENDDO3424 3425 3650 CALL logger_error( & 3426 & " MPP CHECK DIM: variable and mppdimension differ"//&3651 & " MPP CHECK VAR DIM: variable and file dimension differ"//& 3427 3652 & " for variable "//TRIM(td_var%c_name)//& 3428 & " and mpp "//TRIM(td_mpp%c_name)) 3653 & " and file "//TRIM(td_mpp%c_name)) 3654 3655 ELSEIF( ll_warn )THEN 3656 CALL logger_warn( & 3657 & " MPP CHECK VAR DIM: variable and file dimension differ"//& 3658 & " for variable "//TRIM(td_var%c_name)//& 3659 & " and file "//TRIM(td_mpp%c_name)//". you should use"//& 3660 & " var_check_dim to remove useless dimension.") 3661 ELSE 3662 3663 IF( td_var%i_ndim > td_mpp%i_ndim )THEN 3664 CALL logger_info("MPP CHECK VAR DIM: variable "//& 3665 & TRIM(td_var%c_name)//" use more dimension than file "//& 3666 & TRIM(td_mpp%c_name)//" do until now.") 3667 ENDIF 3429 3668 3430 3669 ENDIF … … 3583 3822 ENDIF 3584 3823 END FUNCTION mpp_recombine_var 3824 !------------------------------------------------------------------- 3825 !> @brief This subroutine read subdomain indices defined with halo 3826 !> (NEMO netcdf way) 3827 !> 3828 !> @author J.Paul 3829 !> @date January, 2016 - Initial Version 3830 !> 3831 !> @param[inout] td_file mpp structure 3832 !------------------------------------------------------------------- 3833 SUBROUTINE mpp__read_halo(td_file, td_dimglo) 3834 IMPLICIT NONE 3835 ! Argument 3836 TYPE(TFILE) , INTENT(INOUT) :: td_file 3837 TYPE(TDIM) , DIMENSION(:), INTENT(IN ) :: td_dimglo 3838 3839 ! local variable 3840 INTEGER(i4) :: il_attid 3841 INTEGER(i4) :: il_ifirst 3842 INTEGER(i4) :: il_jfirst 3843 INTEGER(i4) :: il_ilast 3844 INTEGER(i4) :: il_jlast 3845 INTEGER(i4) :: il_ihalostart 3846 INTEGER(i4) :: il_jhalostart 3847 INTEGER(i4) :: il_ihaloend 3848 INTEGER(i4) :: il_jhaloend 3849 3850 CHARACTER(LEN=lc) :: cl_dom 3851 !---------------------------------------------------------------- 3852 3853 ! DOMAIN_position_first 3854 il_attid = 0 3855 IF( ASSOCIATED(td_file%t_att) )THEN 3856 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_first" ) 3857 ENDIF 3858 IF( il_attid /= 0 )THEN 3859 il_ifirst = INT(td_file%t_att(il_attid)%d_value(1)) 3860 il_jfirst = INT(td_file%t_att(il_attid)%d_value(2)) 3861 ELSE 3862 il_ifirst = 1 3863 il_jfirst = 1 3864 ENDIF 3865 3866 ! DOMAIN_position_last 3867 il_attid = 0 3868 IF( ASSOCIATED(td_file%t_att) )THEN 3869 il_attid=att_get_id( td_file%t_att, "DOMAIN_position_last" ) 3870 ENDIF 3871 IF( il_attid /= 0 )THEN 3872 il_ilast = INT(td_file%t_att(il_attid)%d_value(1)) 3873 il_jlast = INT(td_file%t_att(il_attid)%d_value(2)) 3874 ELSE 3875 il_ilast = td_file%t_dim(1)%i_len 3876 il_jlast = td_file%t_dim(2)%i_len 3877 ENDIF 3878 3879 ! DOMAIN_halo_size_start 3880 il_attid = 0 3881 IF( ASSOCIATED(td_file%t_att) )THEN 3882 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_start" ) 3883 ENDIF 3884 IF( il_attid /= 0 )THEN 3885 il_ihalostart = INT(td_file%t_att(il_attid)%d_value(1)) 3886 il_jhalostart = INT(td_file%t_att(il_attid)%d_value(2)) 3887 ELSE 3888 il_ihalostart = 0 3889 il_jhalostart = 0 3890 ENDIF 3891 3892 ! DOMAIN_halo_size_end 3893 il_attid = 0 3894 IF( ASSOCIATED(td_file%t_att) )THEN 3895 il_attid=att_get_id( td_file%t_att, "DOMAIN_halo_size_end" ) 3896 ENDIF 3897 IF( il_attid /= 0 )THEN 3898 il_ihaloend = INT(td_file%t_att(il_attid)%d_value(1)) 3899 il_jhaloend = INT(td_file%t_att(il_attid)%d_value(2)) 3900 ELSE 3901 il_ihaloend = 0 3902 il_jhaloend = 0 3903 ENDIF 3904 3905 IF( (td_dimglo(jp_I)%i_len == td_file%t_dim(jp_I)%i_len) .AND. & 3906 & (td_dimglo(jp_J)%i_len == td_file%t_dim(jp_J)%i_len) )THEN 3907 cl_dom='full' 3908 ELSEIF( il_ihalostart == 0 .AND. il_jhalostart == 0 .AND. & 3909 & il_ihaloend == 0 .AND. il_jhaloend == 0 )THEN 3910 cl_dom='nooverlap' 3911 ELSE 3912 cl_dom='noextra' 3913 ENDIF 3914 3915 SELECT CASE(TRIM(cl_dom)) 3916 CASE('full') 3917 td_file%i_impp = il_ifirst 3918 td_file%i_jmpp = il_jfirst 3919 td_file%i_lci = td_file%t_dim(jp_I)%i_len 3920 td_file%i_lcj = td_file%t_dim(jp_J)%i_len 3921 td_file%i_ldi = il_ihalostart + 1 3922 td_file%i_ldj = il_jhalostart + 1 3923 td_file%i_lei = td_file%t_dim(jp_I)%i_len - il_ihaloend 3924 td_file%i_lej = td_file%t_dim(jp_J)%i_len - il_jhaloend 3925 CASE('noextra') 3926 td_file%i_impp = il_ifirst 3927 td_file%i_jmpp = il_jfirst 3928 td_file%i_lci = td_file%t_dim(jp_I)%i_len 3929 td_file%i_lcj = td_file%t_dim(jp_J)%i_len 3930 td_file%i_ldi = il_ihalostart + 1 3931 td_file%i_ldj = il_jhalostart + 1 3932 td_file%i_lei = td_file%i_lci - il_ihaloend 3933 td_file%i_lej = td_file%i_lcj - il_jhaloend 3934 CASE('nooverlap') !!!????? 3935 td_file%i_impp = il_ifirst 3936 td_file%i_jmpp = il_jfirst 3937 td_file%i_lci = td_file%t_dim(jp_I)%i_len 3938 td_file%i_lcj = td_file%t_dim(jp_J)%i_len 3939 td_file%i_ldi = 1 3940 td_file%i_ldj = 1 3941 td_file%i_lei = td_file%t_dim(jp_I)%i_len 3942 td_file%i_lej = td_file%t_dim(jp_J)%i_len 3943 END SELECT 3944 3945 END SUBROUTINE mpp__read_halo 3946 !------------------------------------------------------------------- 3947 !> @brief This subroutine compute subdomain indices defined with halo 3948 !> (NEMO netcdf way) 3949 !> 3950 !> @author J.Paul 3951 !> @date January, 2016 - Initial Version 3952 !> 3953 !> @param[inout] td_mpp mpp structure 3954 !------------------------------------------------------------------- 3955 SUBROUTINE mpp__compute_halo(td_mpp) 3956 IMPLICIT NONE 3957 ! Argument 3958 TYPE(TMPP) , INTENT(INOUT) :: td_mpp 3959 3960 ! local variable 3961 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ifirst 3962 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jfirst 3963 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ilast 3964 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jlast 3965 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihalostart 3966 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhalostart 3967 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_ihaloend 3968 INTEGER(i4), DIMENSION(:), ALLOCATABLE :: il_jhaloend 3969 3970 TYPE(TATT) :: tl_att 3971 3972 ! loop indices 3973 INTEGER(i4) :: ji 3974 !---------------------------------------------------------------- 3975 3976 ALLOCATE( il_ifirst (td_mpp%i_nproc) ) 3977 ALLOCATE( il_jfirst (td_mpp%i_nproc) ) 3978 3979 ALLOCATE( il_ilast (td_mpp%i_nproc) ) 3980 ALLOCATE( il_jlast (td_mpp%i_nproc) ) 3981 3982 ALLOCATE( il_ihalostart(td_mpp%i_nproc) ) 3983 ALLOCATE( il_jhalostart(td_mpp%i_nproc) ) 3984 3985 ALLOCATE( il_ihaloend (td_mpp%i_nproc) ) 3986 ALLOCATE( il_jhaloend (td_mpp%i_nproc) ) 3987 3988 SELECT CASE(TRIM(td_mpp%c_dom)) 3989 CASE('full') 3990 3991 il_ifirst(:)=td_mpp%t_proc(:)%i_impp 3992 il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp 3993 3994 il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%t_dim(jp_I)%i_len - 1 3995 il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%t_dim(jp_J)%i_len - 1 3996 3997 il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1 3998 il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1 3999 4000 il_ihaloend(:)=td_mpp%t_proc(:)%t_dim(jp_I)%i_len - td_mpp%t_proc(:)%i_lei 4001 il_jhaloend(:)=td_mpp%t_proc(:)%t_dim(jp_J)%i_len - td_mpp%t_proc(:)%i_lej 4002 4003 CASE('noextra') 4004 4005 il_ifirst(:)=td_mpp%t_proc(:)%i_impp 4006 il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp 4007 4008 il_ilast(:) =td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lci - 1 4009 il_jlast(:) =td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lcj - 1 4010 4011 il_ihalostart(:)=td_mpp%t_proc(:)%i_ldi-1 4012 il_jhalostart(:)=td_mpp%t_proc(:)%i_ldj-1 4013 4014 il_ihaloend(:)=td_mpp%t_proc(:)%i_lci - td_mpp%t_proc(:)%i_lei 4015 il_jhaloend(:)=td_mpp%t_proc(:)%i_lcj - td_mpp%t_proc(:)%i_lej 4016 4017 CASE('nooverlap') 4018 4019 il_ifirst(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_ldi - 1 4020 il_jfirst(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_ldj - 1 4021 4022 il_ilast(:)=td_mpp%t_proc(:)%i_impp + td_mpp%t_proc(:)%i_lei - 1 4023 il_jlast(:)=td_mpp%t_proc(:)%i_jmpp + td_mpp%t_proc(:)%i_lej - 1 4024 4025 il_ihalostart(:)=0 4026 il_jhalostart(:)=0 4027 4028 il_ihaloend(:)=0 4029 il_jhaloend(:)=0 4030 4031 CASE DEFAULT 4032 CALL logger_fatal("MPP INIT: invalid "//& 4033 & "decomposition type.") 4034 END SELECT 4035 4036 DO ji=1,td_mpp%i_nproc 4037 tl_att=att_init( "DOMAIN_position_first", & 4038 & (/ il_ifirst(ji), il_jfirst(ji) /) ) 4039 CALL file_move_att(td_mpp%t_proc(ji), tl_att) 4040 4041 tl_att=att_init( "DOMAIN_position_last", & 4042 & (/ il_ilast(ji), il_jlast(ji) /) ) 4043 CALL file_move_att(td_mpp%t_proc(ji), tl_att) 4044 4045 tl_att=att_init( "DOMAIN_halo_size_start", & 4046 & (/ il_ihalostart(ji), il_jhalostart(ji) /) ) 4047 CALL file_move_att( td_mpp%t_proc(ji), tl_att) 4048 4049 tl_att=att_init( "DOMAIN_halo_size_end", & 4050 & (/ il_ihaloend(ji), il_jhaloend(ji) /) ) 4051 CALL file_move_att( td_mpp%t_proc(ji), tl_att) 4052 ENDDO 4053 4054 DEALLOCATE( il_ifirst ) 4055 DEALLOCATE( il_jfirst ) 4056 4057 DEALLOCATE( il_ilast ) 4058 DEALLOCATE( il_jlast ) 4059 4060 DEALLOCATE( il_ihalostart) 4061 DEALLOCATE( il_jhalostart) 4062 4063 DEALLOCATE( il_ihaloend ) 4064 DEALLOCATE( il_jhaloend ) 4065 4066 !impp 4067 tl_att=att_init( "SUBDOMAIN_I_left_bottom_indices", td_mpp%t_proc(:)%i_impp) 4068 CALL mpp_move_att(td_mpp, tl_att) 4069 4070 tl_att=att_init( "SUBDOMAIN_J_left_bottom_indices", td_mpp%t_proc(:)%i_jmpp) 4071 CALL mpp_move_att(td_mpp, tl_att) 4072 4073 ! lci 4074 tl_att=att_init( "SUBDOMAIN_I_dimensions", td_mpp%t_proc(:)%i_lci) 4075 CALL mpp_move_att(td_mpp, tl_att) 4076 4077 tl_att=att_init( "SUBDOMAIN_J_dimensions", td_mpp%t_proc(:)%i_lcj) 4078 CALL mpp_move_att(td_mpp, tl_att) 4079 4080 ! ldi 4081 tl_att=att_init( "SUBDOMAIN_I_first_indoor_indices", td_mpp%t_proc(:)%i_ldi) 4082 CALL mpp_move_att(td_mpp, tl_att) 4083 4084 tl_att=att_init( "SUBDOMAIN_J_first_indoor_indices", td_mpp%t_proc(:)%i_ldj) 4085 CALL mpp_move_att(td_mpp, tl_att) 4086 4087 ! lei 4088 tl_att=att_init( "SUBDOMAIN_I_last_indoor_indices", td_mpp%t_proc(:)%i_lei) 4089 CALL mpp_move_att(td_mpp, tl_att) 4090 4091 tl_att=att_init( "SUBDOMAIN_J_last_indoor_indices", td_mpp%t_proc(:)%i_lej) 4092 CALL mpp_move_att(td_mpp, tl_att) 4093 4094 ! clean 4095 CALL att_clean(tl_att) 4096 4097 END SUBROUTINE mpp__compute_halo 3585 4098 END MODULE mpp 3586 4099
Note: See TracChangeset
for help on using the changeset viewer.
