Changeset 12080 for utils/tools/SIREN/src/mpp.f90
- Timestamp:
- 2019-12-06T10:30:14+01:00 (4 years ago)
- File:
-
- 1 edited
-
utils/tools/SIREN/src/mpp.f90 (modified) (176 diffs)
Legend:
- Unmodified
- Added
- Removed
-
utils/tools/SIREN/src/mpp.f90
r9598 r12080 3 3 !---------------------------------------------------------------------- 4 4 ! 5 ! MODULE: mpp6 !7 5 ! DESCRIPTION: 8 6 !> @brief 9 7 !> This module manage massively parallel processing. 10 ! 8 !> 11 9 !> @details 12 10 !> define type TMPP:<br/> … … 194 192 !> @author 195 193 !> J.Paul 196 ! REVISION HISTORY:194 !> 197 195 !> @date November, 2013 - Initial Version 198 196 !> @date November, 2014 … … 203 201 !> - allow to print layout file (use lm_layout, hard coded) 204 202 !> - add mpp__compute_halo and mpp__read_halo 205 ! 206 !> @note Software governed by the CeCILL licence (./LICENSE) 203 !> 204 !> @note Software governed by the CeCILL licence (NEMOGCM/NEMO_CeCILL.txt) 205 !> 206 !> @todo 207 !> - ECRIRE ET TESTER add_proc_array pour optimiser codes (voir old/MO_mpp.f90) 207 208 !---------------------------------------------------------------------- 208 209 MODULE mpp 210 209 211 USE global ! global parameter 210 212 USE kind ! F90 kind parameter … … 215 217 USE var ! variable manager 216 218 USE file ! file manager 217 USE iom ! I/O manager 219 USE iom ! I/O manager 220 218 221 IMPLICIT NONE 219 222 ! NOTE_avoid_public_variables_if_possible … … 248 251 PRIVATE :: mpp__add_proc ! add proc strucutre in mpp structure 249 252 PRIVATE :: mpp__add_proc_unit ! add one proc strucutre in mpp structure 253 PRIVATE :: mpp__add_proc_arr ! add array of proc strucutre in mpp structure 250 254 PRIVATE :: mpp__del_proc ! delete one proc strucutre in mpp structure 251 255 PRIVATE :: mpp__del_proc_id ! delete one proc strucutre in mpp structure, given procesor id … … 300 304 TYPE(TDIM), DIMENSION(ip_maxdim) :: t_dim !< global domain dimension 301 305 302 TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp 306 TYPE(TFILE), DIMENSION(:), POINTER :: t_proc => NULL() !< files/processors composing mpp 307 308 LOGICAL :: l_usempp = .TRUE. !< use mpp decomposition for writing netcdf 303 309 END TYPE 304 310 … … 319 325 320 326 ! module variable 327 INTEGER(i4) :: im_psize = 2000 !< processor dimension length for huge file 328 321 329 INTEGER(i4) :: im_iumout = 44 322 330 LOGICAL :: lm_layout =.FALSE. … … 328 336 INTERFACE mpp__add_proc 329 337 MODULE PROCEDURE mpp__add_proc_unit 338 MODULE PROCEDURE mpp__add_proc_arr 330 339 END INTERFACE mpp__add_proc 331 340 332 341 INTERFACE mpp_clean 333 342 MODULE PROCEDURE mpp__clean_unit 334 MODULE PROCEDURE mpp__clean_arr 343 MODULE PROCEDURE mpp__clean_arr 335 344 END INTERFACE mpp_clean 336 345 … … 368 377 369 378 CONTAINS 379 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 380 FUNCTION mpp__copy_unit(td_mpp) & 381 & RESULT(tf_mpp) 370 382 !------------------------------------------------------------------- 371 383 !> @brief … … 385 397 !> @date November, 2013 - Initial Version 386 398 !> @date November, 2014 387 !> 399 !> - use function instead of overload assignment operator 388 400 !> (to avoid memory leak) 389 ! 401 !> @date January, 2019 402 !> - clean file structure 403 !> 390 404 !> @param[in] td_mpp mpp structure 391 405 !> @return copy of input mpp structure 392 406 !------------------------------------------------------------------- 393 FUNCTION mpp__copy_unit( td_mpp ) 407 394 408 IMPLICIT NONE 409 395 410 ! Argument 396 411 TYPE(TMPP), INTENT(IN) :: td_mpp 412 397 413 ! function 398 TYPE(TMPP) :: mpp__copy_unit414 TYPE(TMPP) :: tf_mpp 399 415 400 416 ! local variable … … 406 422 407 423 CALL logger_trace("MPP COPY: "//TRIM(td_mpp%c_name)//" in "//& 408 & TRIM( mpp__copy_unit%c_name))424 & TRIM(tf_mpp%c_name)) 409 425 410 426 ! copy mpp variable 411 mpp__copy_unit%c_name = TRIM(td_mpp%c_name) 412 mpp__copy_unit%i_id = td_mpp%i_id 413 mpp__copy_unit%i_niproc = td_mpp%i_niproc 414 mpp__copy_unit%i_njproc = td_mpp%i_njproc 415 mpp__copy_unit%i_nproc = td_mpp%i_nproc 416 mpp__copy_unit%i_preci = td_mpp%i_preci 417 mpp__copy_unit%i_precj = td_mpp%i_precj 418 mpp__copy_unit%c_type = TRIM(td_mpp%c_type) 419 mpp__copy_unit%c_dom = TRIM(td_mpp%c_dom) 420 mpp__copy_unit%i_ndim = td_mpp%i_ndim 421 mpp__copy_unit%i_ew = td_mpp%i_ew 422 mpp__copy_unit%i_perio = td_mpp%i_perio 423 mpp__copy_unit%i_pivot = td_mpp%i_pivot 427 tf_mpp%c_name = TRIM(td_mpp%c_name) 428 tf_mpp%i_id = td_mpp%i_id 429 tf_mpp%i_niproc = td_mpp%i_niproc 430 tf_mpp%i_njproc = td_mpp%i_njproc 431 tf_mpp%i_nproc = td_mpp%i_nproc 432 tf_mpp%i_preci = td_mpp%i_preci 433 tf_mpp%i_precj = td_mpp%i_precj 434 tf_mpp%c_type = TRIM(td_mpp%c_type) 435 tf_mpp%c_dom = TRIM(td_mpp%c_dom) 436 tf_mpp%i_ndim = td_mpp%i_ndim 437 tf_mpp%i_ew = td_mpp%i_ew 438 tf_mpp%i_perio = td_mpp%i_perio 439 tf_mpp%i_pivot = td_mpp%i_pivot 440 tf_mpp%l_usempp = td_mpp%l_usempp 424 441 425 442 ! copy dimension 426 mpp__copy_unit%t_dim(:) = dim_copy(td_mpp%t_dim(:))443 tf_mpp%t_dim(:) = dim_copy(td_mpp%t_dim(:)) 427 444 428 445 ! copy file structure 429 IF( ASSOCIATED( mpp__copy_unit%t_proc) )THEN430 CALL file_clean( mpp__copy_unit%t_proc(:))431 DEALLOCATE( mpp__copy_unit%t_proc)432 ENDIF 433 IF( ASSOCIATED(td_mpp%t_proc) .AND. mpp__copy_unit%i_nproc > 0 )THEN434 ALLOCATE( mpp__copy_unit%t_proc(mpp__copy_unit%i_nproc) )435 DO ji=1, mpp__copy_unit%i_nproc446 IF( ASSOCIATED(tf_mpp%t_proc) )THEN 447 CALL file_clean(tf_mpp%t_proc(:)) 448 DEALLOCATE(tf_mpp%t_proc) 449 ENDIF 450 IF( ASSOCIATED(td_mpp%t_proc) .AND. tf_mpp%i_nproc > 0 )THEN 451 ALLOCATE( tf_mpp%t_proc(tf_mpp%i_nproc) ) 452 DO ji=1,tf_mpp%i_nproc 436 453 tl_file = file_copy(td_mpp%t_proc(ji)) 437 mpp__copy_unit%t_proc(ji) = file_copy(tl_file)454 tf_mpp%t_proc(ji) = file_copy(tl_file) 438 455 ENDDO 439 456 ! clean … … 442 459 443 460 END FUNCTION mpp__copy_unit 461 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 462 FUNCTION mpp__copy_arr(td_mpp) & 463 & RESULT(tf_mpp) 444 464 !------------------------------------------------------------------- 445 465 !> @brief … … 465 485 !> @return copy of input array of mpp structure 466 486 !------------------------------------------------------------------- 467 FUNCTION mpp__copy_arr( td_mpp ) 487 468 488 IMPLICIT NONE 489 469 490 ! Argument 470 TYPE(TMPP), DIMENSION(:), INTENT(IN) :: td_mpp 491 TYPE(TMPP), DIMENSION(:), INTENT(IN) :: td_mpp 492 471 493 ! function 472 TYPE(TMPP), DIMENSION(SIZE(td_mpp(:))) :: mpp__copy_arr494 TYPE(TMPP), DIMENSION(SIZE(td_mpp(:))) :: tf_mpp 473 495 474 496 ! local variable … … 478 500 479 501 DO ji=1,SIZE(td_mpp(:)) 480 mpp__copy_arr(ji)=mpp_copy(td_mpp(ji))502 tf_mpp(ji)=mpp_copy(td_mpp(ji)) 481 503 ENDDO 482 504 483 505 END FUNCTION mpp__copy_arr 506 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 507 SUBROUTINE mpp_print(td_mpp) 484 508 !------------------------------------------------------------------- 485 509 !> @brief This subroutine print some information about mpp strucutre. 486 ! 510 !> 487 511 !> @author J.Paul 488 512 !> @date November, 2013 - Initial Version 489 ! 513 !> 490 514 !> @param[in] td_mpp mpp structure 491 515 !------------------------------------------------------------------- 492 SUBROUTINE mpp_print(td_mpp) 516 493 517 IMPLICIT NONE 494 518 … … 497 521 498 522 ! local variable 499 INTEGER(i4), PARAMETER :: il_freq = 4 500 523 INTEGER(i4), PARAMETER :: ip_freq = 4 524 INTEGER(i4), PARAMETER :: ip_min = 5 525 526 INTEGER(i4) :: il_min 501 527 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_proc 502 528 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_lci … … 540 566 & ALL( td_mpp%t_proc(:)%i_jind==0 ) )THEN 541 567 542 DO ji=1,td_mpp%i_nproc 568 il_min=MIN(td_mpp%i_nproc,ip_min) 569 DO ji=1,il_min 543 570 CALL file_print(td_mpp%t_proc(ji)) 544 571 WRITE(*,'((a),(/3x,a,i0),2(/3x,a,a),4(/3x,a,i0,a,i0)/)')& … … 557 584 558 585 ENDDO 586 IF( td_mpp%i_nproc > ip_min )THEN 587 WRITE(*,'(a)') "...etc" 588 ENDIF 559 589 560 590 IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN … … 567 597 ELSE 568 598 569 DO ji=1,td_mpp%i_nproc 599 il_min=MIN(td_mpp%i_nproc,ip_min) 600 DO ji=1,il_min 601 CALL file_print(td_mpp%t_proc(ji)) 570 602 WRITE(*,'((a, a),(/3x,a,i0),(/3x,a,a),4(/3x,a,i0,a,i0)/)')& 571 603 & " Domain decomposition : ",TRIM(td_mpp%t_proc(ji)%c_name),& … … 582 614 583 615 ENDDO 616 IF( td_mpp%i_nproc > ip_min )THEN 617 WRITE(*,'(a)') "...etc" 618 ENDIF 584 619 585 620 IF( td_mpp%t_proc(1)%i_nvar > 0 )THEN 586 621 WRITE(*,'(/a)') " Variable(s) used : " 587 622 DO ji=1,td_mpp%t_proc(1)%i_nvar 588 WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name) 623 WRITE(*,'(3x,a)') TRIM(td_mpp%t_proc(1)%t_var(ji)%c_name) 589 624 ENDDO 590 625 ENDIF 591 626 592 ALLOCATE( il_proc(td_mpp%i_niproc,td_mpp%i_njproc) ) 593 ALLOCATE( il_lci(td_mpp%i_niproc,td_mpp%i_njproc) ) 594 ALLOCATE( il_lcj(td_mpp%i_niproc,td_mpp%i_njproc) ) 595 il_proc(:,:)=-1 596 il_lci(:,:) =-1 597 il_lcj(:,:) =-1 598 599 DO jk=1,td_mpp%i_nproc 600 ji=td_mpp%t_proc(jk)%i_iind 601 jj=td_mpp%t_proc(jk)%i_jind 602 il_proc(ji,jj)=jk-1 603 il_lci(ji,jj)=td_mpp%t_proc(jk)%i_lci 604 il_lcj(ji,jj)=td_mpp%t_proc(jk)%i_lcj 605 ENDDO 606 607 jl = 1 608 DO jk = 1,(td_mpp%i_niproc-1)/il_freq+1 609 jm = MIN(td_mpp%i_niproc, jl+il_freq-1) 610 WRITE(*,*) 611 WRITE(*,9401) (ji, ji = jl,jm) 612 WRITE(*,9400) ('***', ji = jl,jm-1) 613 DO jj = 1, td_mpp%i_njproc 614 WRITE(*,9403) (' ', ji = jl,jm-1) 615 WRITE(*,9402) jj, ( il_lci(ji,jj), il_lcj(ji,jj), ji = jl,jm) 616 WRITE(*,9404) (il_proc(ji,jj), ji= jl,jm) 617 WRITE(*,9403) (' ', ji = jl,jm-1) 627 IF( td_mpp%l_usempp )THEN 628 ALLOCATE( il_proc(td_mpp%i_niproc,td_mpp%i_njproc) ) 629 ALLOCATE( il_lci(td_mpp%i_niproc,td_mpp%i_njproc) ) 630 ALLOCATE( il_lcj(td_mpp%i_niproc,td_mpp%i_njproc) ) 631 il_proc(:,:)=-1 632 il_lci(:,:) =-1 633 il_lcj(:,:) =-1 634 635 DO jk=1,td_mpp%i_nproc 636 ji=td_mpp%t_proc(jk)%i_iind 637 jj=td_mpp%t_proc(jk)%i_jind 638 il_proc(ji,jj)=jk-1 639 il_lci(ji,jj)=td_mpp%t_proc(jk)%i_lci 640 il_lcj(ji,jj)=td_mpp%t_proc(jk)%i_lcj 641 ENDDO 642 643 jl = 1 644 DO jk = 1,(td_mpp%i_niproc-1)/ip_freq+1 645 jm = MIN(td_mpp%i_niproc, jl+ip_freq-1) 646 WRITE(*,*) 647 WRITE(*,9401) (ji, ji = jl,jm) 618 648 WRITE(*,9400) ('***', ji = jl,jm-1) 649 DO jj = 1, td_mpp%i_njproc 650 WRITE(*,9403) (' ', ji = jl,jm-1) 651 WRITE(*,9402) jj, ( il_lci(ji,jj), il_lcj(ji,jj), ji = jl,jm) 652 WRITE(*,9404) (il_proc(ji,jj), ji= jl,jm) 653 WRITE(*,9403) (' ', ji = jl,jm-1) 654 WRITE(*,9400) ('***', ji = jl,jm-1) 655 ENDDO 656 jl = jl+ip_freq 619 657 ENDDO 620 jl = jl+il_freq621 ENDDO622 658 623 DEALLOCATE( il_proc ) 624 DEALLOCATE( il_lci ) 625 DEALLOCATE( il_lcj ) 659 DEALLOCATE( il_proc ) 660 DEALLOCATE( il_lci ) 661 DEALLOCATE( il_lcj ) 662 ENDIF 626 663 627 664 ENDIF … … 633 670 9403 FORMAT(' * ',20(' * ',a3)) 634 671 9401 FORMAT(' ',20(' ',i3,' ')) 635 9402 FORMAT(' ',i3,' * ',20(i 0,' x',i0,' * '))672 9402 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ')) 636 673 9404 FORMAT(' * ',20(' ',i3,' * ')) 637 674 638 675 END SUBROUTINE mpp_print 676 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 677 FUNCTION mpp__init_mask(cd_file, id_mask, & 678 & id_niproc, id_njproc, id_nproc, & 679 & id_preci, id_precj, & 680 & cd_type, id_ew, id_perio, id_pivot, & 681 & td_dim, ld_usempp) & 682 & RESULT(tf_mpp) 639 683 !------------------------------------------------------------------- 640 684 !> @brief … … 647 691 !> - length of the overlap region (id_preci, id_precj) could be specify 648 692 !> in I and J direction (default value is 1) 649 ! 693 !> 650 694 !> @author J.Paul 651 695 !> @date November, 2013 - Initial version … … 655 699 !> - use RESULT to rename output 656 700 !> - mismatch with "halo" indices 657 ! 701 !> 658 702 !> @param[in] cd_file file name of one file composing mpp domain 659 703 !> @param[in] id_mask domain mask … … 670 714 !> @return mpp structure 671 715 !------------------------------------------------------------------- 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) 716 678 717 IMPLICIT NONE 718 679 719 ! Argument 680 720 CHARACTER(LEN=*), INTENT(IN) :: cd_file … … 690 730 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 691 731 TYPE(TDIM) , DIMENSION(ip_maxdim), INTENT(IN), OPTIONAL :: td_dim 732 LOGICAL , INTENT(IN), OPTIONAL :: ld_usempp 692 733 693 734 ! function 694 TYPE(TMPP) :: td_mpp735 TYPE(TMPP) :: tf_mpp 695 736 696 737 ! local variable … … 698 739 699 740 INTEGER(i4) , DIMENSION(2) :: il_shape 741 INTEGER(i4) :: il_niproc 742 INTEGER(i4) :: il_njproc 700 743 701 744 TYPE(TDIM) :: tl_dim … … 710 753 711 754 ! clean mpp 712 CALL mpp_clean(t d_mpp)755 CALL mpp_clean(tf_mpp) 713 756 714 757 ! check type … … 719 762 SELECT CASE(TRIM(cd_type)) 720 763 CASE('cdf') 721 t d_mpp%c_type='cdf'764 tf_mpp%c_type='cdf' 722 765 CASE('dimg') 723 t d_mpp%c_type='dimg'766 tf_mpp%c_type='dimg' 724 767 CASE DEFAULT 725 CALL logger_warn( 726 &" unknown. type dimg will be used for mpp "//&727 & TRIM(td_mpp%c_name) )728 t d_mpp%c_type='dimg'768 CALL logger_warn("MPP INIT: type "//TRIM(cd_type)//& 769 & " unknown. type dimg will be used for mpp "//& 770 & TRIM(tf_mpp%c_name) ) 771 tf_mpp%c_type='dimg' 729 772 END SELECT 730 773 ELSE 731 t d_mpp%c_type=TRIM(file_get_type(cd_file))774 tf_mpp%c_type=TRIM(file_get_type(cd_file)) 732 775 ENDIF 733 776 734 777 ! get mpp name 735 t d_mpp%c_name=TRIM(file_rename(cd_file))778 tf_mpp%c_name=TRIM(file_rename(cd_file)) 736 779 737 780 ! get global domain dimension … … 741 784 DO ji=1,ip_maxdim 742 785 IF( td_dim(ji)%l_use )THEN 743 CALL mpp_add_dim(t d_mpp, td_dim(ji))786 CALL mpp_add_dim(tf_mpp, td_dim(ji)) 744 787 ENDIF 745 788 ENDDO 746 789 ELSE 747 790 tl_dim=dim_init('X',il_shape(1)) 748 CALL mpp_add_dim(t d_mpp, tl_dim)791 CALL mpp_add_dim(tf_mpp, tl_dim) 749 792 750 793 tl_dim=dim_init('Y',il_shape(2)) 751 CALL mpp_add_dim(t d_mpp, tl_dim)794 CALL mpp_add_dim(tf_mpp, tl_dim) 752 795 753 796 ! clean … … 761 804 ELSE 762 805 ! get number of processors following I and J 763 IF( PRESENT(id_niproc) ) t d_mpp%i_niproc=id_niproc764 IF( PRESENT(id_njproc) ) t d_mpp%i_njproc=id_njproc806 IF( PRESENT(id_niproc) ) tf_mpp%i_niproc=id_niproc 807 IF( PRESENT(id_njproc) ) tf_mpp%i_njproc=id_njproc 765 808 ENDIF 766 809 767 810 ! get maximum number of processors to be used 768 IF( PRESENT(id_nproc) ) t d_mpp%i_nproc = id_nproc811 IF( PRESENT(id_nproc) ) tf_mpp%i_nproc = id_nproc 769 812 770 813 ! get overlap region length 771 IF( PRESENT(id_preci) ) t d_mpp%i_preci= id_preci772 IF( PRESENT(id_precj) ) t d_mpp%i_precj= id_precj814 IF( PRESENT(id_preci) ) tf_mpp%i_preci= id_preci 815 IF( PRESENT(id_precj) ) tf_mpp%i_precj= id_precj 773 816 774 817 ! east-west overlap 775 IF( PRESENT(id_ew) ) t d_mpp%i_ew= id_ew818 IF( PRESENT(id_ew) ) tf_mpp%i_ew= id_ew 776 819 ! NEMO periodicity 777 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 820 IF( PRESENT(id_perio) ) tf_mpp%i_perio= id_perio 821 IF( PRESENT(id_pivot) ) tf_mpp%i_pivot= id_pivot 822 ! 823 IF( PRESENT(ld_usempp) ) tf_mpp%l_usempp = ld_usempp 824 825 IF( tf_mpp%i_nproc /= 0 .AND. & 826 & tf_mpp%i_niproc /= 0 .AND. & 827 & tf_mpp%i_njproc /= 0 .AND. & 828 & tf_mpp%i_nproc > tf_mpp%i_niproc * tf_mpp%i_njproc )THEN 785 829 786 830 CALL logger_error("MPP INIT: invalid domain decomposition ") 787 831 CALL logger_debug("MPP INIT: "// & 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)) )832 & TRIM(fct_str(tf_mpp%i_nproc))//" > "//& 833 & TRIM(fct_str(tf_mpp%i_niproc))//" x "//& 834 & TRIM(fct_str(tf_mpp%i_njproc)) ) 791 835 792 836 ELSE … … 799 843 ENDIF 800 844 801 IF( td_mpp%i_niproc /= 0 .AND. & 802 & td_mpp%i_njproc /= 0 )THEN 845 IF( tf_mpp%i_niproc /= 0 .AND. tf_mpp%i_njproc /= 0 .AND. & 846 &(tf_mpp%i_niproc > 1 .OR. tf_mpp%i_njproc > 1) )THEN 847 803 848 ! compute domain layout 804 tl_lay=layout__init( td_mpp, id_mask, td_mpp%i_niproc, td_mpp%i_njproc ) 849 tl_lay=layout__init(tf_mpp, id_mask, & 850 & tf_mpp%i_niproc, tf_mpp%i_njproc) 805 851 ! create mpp domain layout 806 CALL mpp__create_layout( td_mpp, tl_lay ) 852 CALL mpp__create_layout( tf_mpp, tl_lay ) 853 807 854 ! clean 808 855 CALL layout__clean( tl_lay ) 809 ELSEIF( td_mpp%i_nproc /= 0 )THEN 856 857 ELSEIF( tf_mpp%i_nproc > 1 )THEN 858 810 859 ! optimiz 811 CALL mpp__optimiz( t d_mpp, id_mask, td_mpp%i_nproc )860 CALL mpp__optimiz( tf_mpp, id_mask, tf_mpp%i_nproc ) 812 861 813 862 ELSE 863 814 864 CALL logger_warn("MPP INIT: number of processor to be used "//& 815 & "not specify. force to one.") 816 ! optimiz 817 CALL mpp__optimiz( td_mpp, id_mask, 1 ) 865 & "not specify. force output on one file.") 866 ! number of proc to get proc size close to im_psize 867 il_niproc=INT(il_shape(jp_I)/im_psize)+1 868 il_njproc=INT(il_shape(jp_J)/im_psize)+1 869 870 tf_mpp%l_usempp=.FALSE. 871 tl_lay=layout__init( tf_mpp, id_mask, & 872 & il_niproc, il_njproc ) 873 874 ! create mpp domain layout 875 CALL mpp__create_layout( tf_mpp, tl_lay ) 876 877 ! clean 878 CALL layout__clean( tl_lay ) 879 818 880 ENDIF 819 881 820 821 882 CALL logger_info("MPP INIT: domain decoposition : "//& 822 & 'niproc('//TRIM(fct_str(t d_mpp%i_niproc))//') * '//&823 & 'njproc('//TRIM(fct_str(t d_mpp%i_njproc))//') = '//&824 & 'nproc('//TRIM(fct_str(t d_mpp%i_nproc))//')' )883 & 'niproc('//TRIM(fct_str(tf_mpp%i_niproc))//') * '//& 884 & 'njproc('//TRIM(fct_str(tf_mpp%i_njproc))//') = '//& 885 & 'nproc('//TRIM(fct_str(tf_mpp%i_nproc))//')' ) 825 886 826 887 ! get domain type 827 CALL mpp_get_dom( t d_mpp )828 829 DO ji=1,t d_mpp%i_nproc888 CALL mpp_get_dom( tf_mpp ) 889 890 DO ji=1,tf_mpp%i_nproc 830 891 831 892 ! get processor size 832 il_shape(:)=mpp_get_proc_size( t d_mpp, ji )893 il_shape(:)=mpp_get_proc_size( tf_mpp, ji ) 833 894 834 895 tl_dim=dim_init('X',il_shape(1)) 835 CALL file_move_dim(t d_mpp%t_proc(ji), tl_dim)896 CALL file_move_dim(tf_mpp%t_proc(ji), tl_dim) 836 897 837 898 tl_dim=dim_init('Y',il_shape(2)) 838 CALL file_move_dim(t d_mpp%t_proc(ji), tl_dim)899 CALL file_move_dim(tf_mpp%t_proc(ji), tl_dim) 839 900 840 901 IF( PRESENT(td_dim) )THEN 841 902 IF( td_dim(jp_K)%l_use )THEN 842 CALL file_move_dim(t d_mpp%t_proc(ji), td_dim(jp_K))903 CALL file_move_dim(tf_mpp%t_proc(ji), td_dim(jp_K)) 843 904 ENDIF 844 905 IF( td_dim(jp_L)%l_use )THEN 845 CALL file_move_dim(t d_mpp%t_proc(ji), td_dim(jp_L))906 CALL file_move_dim(tf_mpp%t_proc(ji), td_dim(jp_L)) 846 907 ENDIF 847 908 ENDIF 848 909 ! add type 849 t d_mpp%t_proc(ji)%c_type=TRIM(td_mpp%c_type)910 tf_mpp%t_proc(ji)%c_type=TRIM(tf_mpp%c_type) 850 911 851 912 ! clean … … 855 916 856 917 ! add global attribute 857 tl_att=att_init("DOMAIN_number_total",t d_mpp%i_nproc)858 CALL mpp_add_att(t d_mpp, tl_att)859 860 tl_att=att_init("DOMAIN_LOCAL",TRIM(t d_mpp%c_dom))861 CALL mpp_add_att(t d_mpp, tl_att)862 863 tl_att=att_init("DOMAIN_I_number_total",t d_mpp%i_niproc)864 CALL mpp_add_att(t d_mpp, tl_att)865 866 tl_att=att_init("DOMAIN_J_number_total",t d_mpp%i_njproc)867 CALL mpp_add_att(t d_mpp, tl_att)868 869 tl_att=att_init("DOMAIN_size_global",t d_mpp%t_dim(1:2)%i_len)870 CALL mpp_add_att(t d_mpp, tl_att)871 872 CALL mpp__compute_halo(t d_mpp)918 tl_att=att_init("DOMAIN_number_total",tf_mpp%i_nproc) 919 CALL mpp_add_att(tf_mpp, tl_att) 920 921 tl_att=att_init("DOMAIN_LOCAL",TRIM(tf_mpp%c_dom)) 922 CALL mpp_add_att(tf_mpp, tl_att) 923 924 tl_att=att_init("DOMAIN_I_number_total",tf_mpp%i_niproc) 925 CALL mpp_add_att(tf_mpp, tl_att) 926 927 tl_att=att_init("DOMAIN_J_number_total",tf_mpp%i_njproc) 928 CALL mpp_add_att(tf_mpp, tl_att) 929 930 tl_att=att_init("DOMAIN_size_global",tf_mpp%t_dim(1:2)%i_len) 931 CALL mpp_add_att(tf_mpp, tl_att) 932 933 CALL mpp__compute_halo(tf_mpp) 873 934 ENDIF 874 935 875 936 END FUNCTION mpp__init_mask 937 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 938 FUNCTION mpp__init_var(cd_file, td_var, & 939 & id_niproc, id_njproc, id_nproc,& 940 & id_preci, id_precj, cd_type, & 941 & id_perio, id_pivot, ld_usempp) & 942 & RESULT(tf_mpp) 876 943 !------------------------------------------------------------------- 877 944 !> @brief … … 884 951 !> - length of the overlap region (id_preci, id_precj) could be specify 885 952 !> in I and J direction (default value is 1) 886 ! 953 !> 887 954 !> @author J.Paul 888 955 !> @date November, 2013 - Initial version 889 ! 956 !> 890 957 !> @param[in] cd_file file name of one file composing mpp domain 891 958 !> @param[in] td_var variable structure … … 900 967 !> @return mpp structure 901 968 !------------------------------------------------------------------- 902 TYPE(TMPP) FUNCTION mpp__init_var( cd_file, td_var, & 903 & id_niproc, id_njproc, id_nproc,& 904 & id_preci, id_precj, cd_type, & 905 & id_perio, id_pivot ) 969 906 970 IMPLICIT NONE 971 907 972 ! Argument 908 973 CHARACTER(LEN=*), INTENT(IN) :: cd_file … … 916 981 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 917 982 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 983 LOGICAL, INTENT(IN), OPTIONAL :: ld_usempp 984 985 ! function 986 TYPE(TMPP) :: tf_mpp 918 987 919 988 ! local variable … … 929 998 CALL logger_info("MPP INIT: mask compute from variable "//& 930 999 & TRIM(td_var%c_name)) 931 mpp__init_var=mpp_init( cd_file, il_mask(:,:,1), & 932 & id_niproc, id_njproc, id_nproc,& 933 & id_preci, id_precj, cd_type, & 934 & id_ew=td_var%i_ew, & 935 & id_perio=id_perio, id_pivot=id_pivot) 1000 tf_mpp = mpp_init( cd_file, il_mask(:,:,1), & 1001 & id_niproc, id_njproc, id_nproc,& 1002 & id_preci, id_precj, cd_type, & 1003 & id_ew=td_var%i_ew, & 1004 & id_perio=id_perio, id_pivot=id_pivot,& 1005 & ld_usempp=ld_usempp) 936 1006 937 1007 DEALLOCATE(il_mask) … … 941 1011 942 1012 END FUNCTION mpp__init_var 1013 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1014 FUNCTION mpp__init_file(td_file, id_ew, id_perio, id_pivot) & 1015 & RESULT(tf_mpp) 943 1016 !------------------------------------------------------------------- 944 1017 !> @brief This function initalise a mpp structure given file structure. … … 961 1034 !> @date January, 2016 962 1035 !> - mismatch with "halo" indices, use mpp__compute_halo 963 ! 1036 !> @date Marsh, 2017 1037 !> - netcdf proc indices from zero to N-1 1038 !> - copy file periodicity to mpp structure 1039 !> @date August, 2017 1040 !> - force to use domain decomposition to enhance read of monoproc file 1041 !> 964 1042 !> @param[in] td_file file strcuture 965 1043 !> @param[in] id_ew east-west overlap … … 968 1046 !> @return mpp structure 969 1047 !------------------------------------------------------------------- 970 TYPE(TMPP) FUNCTION mpp__init_file( td_file, id_ew, id_perio, id_pivot ) 1048 971 1049 IMPLICIT NONE 972 1050 973 1051 ! Argument 974 TYPE(TFILE), INTENT(IN) :: td_file1052 TYPE(TFILE), INTENT(IN) :: td_file 975 1053 INTEGER(i4), INTENT(IN), OPTIONAL :: id_ew 976 1054 INTEGER(i4), INTENT(IN), OPTIONAL :: id_perio 977 1055 INTEGER(i4), INTENT(IN), OPTIONAL :: id_pivot 978 1056 1057 ! function 1058 TYPE(TMPP) :: tf_mpp 1059 979 1060 ! local variable 980 INTEGER(i4) :: il_nproc 981 INTEGER(i4) :: il_attid 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 1061 INTEGER(i4) :: il_nproc 1062 INTEGER(i4) :: il_attid 1063 INTEGER(i4), DIMENSION(2) :: il_shape 1064 1065 INTEGER(i4), DIMENSION(:,:), ALLOCATABLE :: il_mask 1066 INTEGER(i4), DIMENSION(ip_maxdim) :: il_dim 1067 INTEGER(i4) :: il_niproc 1068 INTEGER(i4) :: il_njproc 1069 1070 TYPE(TDIM) :: tl_dim 1071 1072 TYPE(TATT) :: tl_att 1073 1074 TYPE(TFILE) :: tl_file 1075 1076 TYPE(TMPP) :: tl_mpp 991 1077 992 1078 ! loop indices … … 995 1081 996 1082 ! clean mpp 997 CALL mpp_clean( mpp__init_file)1083 CALL mpp_clean(tf_mpp) 998 1084 999 1085 ! check file type … … 1005 1091 ! open file 1006 1092 CALL iom_open(tl_file) 1093 1007 1094 ! read first file domain decomposition 1008 1095 tl_mpp=mpp__init_file_cdf(tl_file) … … 1028 1115 CALL mpp_clean(tl_mpp) 1029 1116 1030 ! get filename 1031 tl_file=file_rename(td_file,ji )1117 ! get filename (from 0 to n-1) 1118 tl_file=file_rename(td_file,ji-1) 1032 1119 1033 1120 ! open file … … 1037 1124 tl_mpp = mpp__init_file_cdf(tl_file) 1038 1125 IF( ji == 1 )THEN 1039 mpp__init_file=mpp_copy(tl_mpp)1126 tf_mpp=mpp_copy(tl_mpp) 1040 1127 ELSE 1041 IF( ANY( mpp__init_file%t_dim(1:2)%i_len /= &1042 1128 IF( ANY( tf_mpp%t_dim(1:2)%i_len /= & 1129 tl_mpp%t_dim(1:2)%i_len) )THEN 1043 1130 1044 1131 CALL logger_error("MPP INIT READ: dimension from file "//& 1045 1132 & TRIM(tl_file%c_name)//" and mpp strcuture "//& 1046 & TRIM( mpp__init_file%c_name)//"differ ")1133 & TRIM(tf_mpp%c_name)//"differ ") 1047 1134 1048 1135 ELSE 1049 1136 1050 1137 ! add processor to mpp strcuture 1051 CALL mpp__add_proc( mpp__init_file, tl_mpp%t_proc(1))1138 CALL mpp__add_proc(tf_mpp, tl_mpp%t_proc(1)) 1052 1139 1053 1140 ENDIF … … 1058 1145 1059 1146 ENDDO 1060 IF( mpp__init_file%i_nproc /= il_nproc )THEN1147 IF( tf_mpp%i_nproc /= il_nproc )THEN 1061 1148 CALL logger_error("MPP INIT READ: some processors can't be added & 1062 1149 & to mpp structure") … … 1064 1151 1065 1152 ELSE 1066 mpp__init_file=mpp_copy(tl_mpp) 1153 1154 ! force to use domain decomposition to enhance read of input 1155 1156 ! create pseudo mask 1157 il_dim(:)=tl_mpp%t_dim(:)%i_len 1158 ALLOCATE(il_mask(il_dim(jp_I),il_dim(jp_J))) 1159 il_mask(:,:)=1 1160 1161 ! number of proc to get proc size close to im_psize 1162 il_niproc=INT(il_dim(jp_I)/im_psize)+1 1163 il_njproc=INT(il_dim(jp_J)/im_psize)+1 1164 1165 ! compute domain layout 1166 ! output will be written on one file 1167 tf_mpp=mpp_init(tl_mpp%c_name, il_mask, il_niproc, il_njproc,& 1168 & id_perio=tl_file%i_perio, & 1169 & ld_usempp=.FALSE. ) 1170 1171 ! add var 1172 DO ji=1,tl_mpp%t_proc(1)%i_nvar 1173 CALL mpp_add_var(tf_mpp, tl_mpp%t_proc(1)%t_var(ji)) 1174 ENDDO 1175 1067 1176 ENDIF 1068 1177 1069 1178 ! mpp type 1070 mpp__init_file%c_type=TRIM(td_file%c_type)1179 tf_mpp%c_type=TRIM(td_file%c_type) 1071 1180 1072 1181 ! mpp domain type 1073 CALL mpp_get_dom( mpp__init_file)1182 CALL mpp_get_dom(tf_mpp) 1074 1183 1075 1184 ! create some attributes for domain decomposition (use with dimg file) 1076 tl_att=att_init( "DOMAIN_number_total", mpp__init_file%i_nproc )1077 CALL mpp_move_att( mpp__init_file, tl_att)1078 1079 CALL mpp__compute_halo( mpp__init_file)1185 tl_att=att_init( "DOMAIN_number_total", tf_mpp%i_nproc ) 1186 CALL mpp_move_att(tf_mpp, tl_att) 1187 1188 CALL mpp__compute_halo(tf_mpp) 1080 1189 1081 1190 ! clean … … 1093 1202 CALL logger_debug("MPP INIT READ: read mpp structure ") 1094 1203 ! read mpp structure 1095 mpp__init_file=mpp__init_file_rstdimg(tl_file)1204 tf_mpp=mpp__init_file_rstdimg(tl_file) 1096 1205 1097 1206 ! mpp type 1098 mpp__init_file%c_type=TRIM(td_file%c_type)1207 tf_mpp%c_type=TRIM(td_file%c_type) 1099 1208 1100 1209 ! mpp domain type 1101 1210 CALL logger_debug("MPP INIT READ: mpp_get_dom ") 1102 CALL mpp_get_dom( mpp__init_file)1211 CALL mpp_get_dom(tf_mpp) 1103 1212 1104 1213 ! get processor size 1105 1214 CALL logger_debug("MPP INIT READ: get processor size ") 1106 DO ji=1, mpp__init_file%i_nproc1107 1108 il_shape(:)=mpp_get_proc_size( mpp__init_file, ji )1215 DO ji=1,tf_mpp%i_nproc 1216 1217 il_shape(:)=mpp_get_proc_size( tf_mpp, ji ) 1109 1218 1110 1219 tl_dim=dim_init('X',il_shape(1)) 1111 CALL file_add_dim( mpp__init_file%t_proc(ji), tl_dim)1220 CALL file_add_dim(tf_mpp%t_proc(ji), tl_dim) 1112 1221 1113 1222 tl_dim=dim_init('Y',il_shape(2)) 1114 CALL file_add_dim( mpp__init_file%t_proc(ji), tl_dim)1223 CALL file_add_dim(tf_mpp%t_proc(ji), tl_dim) 1115 1224 1116 1225 ! clean … … 1128 1237 1129 1238 ! east west overlap 1130 IF( PRESENT(id_ew) ) mpp__init_file%i_ew=id_ew1239 IF( PRESENT(id_ew) ) tf_mpp%i_ew=id_ew 1131 1240 ! NEMO periodicity 1132 1241 IF( PRESENT(id_perio) )THEN 1133 mpp__init_file%i_perio= id_perio1242 tf_mpp%i_perio= id_perio 1134 1243 SELECT CASE(id_perio) 1135 1244 CASE(3,4) 1136 mpp__init_file%i_pivot=11245 tf_mpp%i_pivot=1 1137 1246 CASE(5,6) 1138 mpp__init_file%i_pivot=01247 tf_mpp%i_pivot=0 1139 1248 CASE DEFAULT 1140 mpp__init_file%i_pivot=11249 tf_mpp%i_pivot=1 1141 1250 END SELECT 1142 1251 ENDIF 1143 1252 1144 IF( PRESENT(id_pivot) ) mpp__init_file%i_pivot= id_pivot1253 IF( PRESENT(id_pivot) ) tf_mpp%i_pivot= id_pivot 1145 1254 1146 1255 ! clean … … 1148 1257 1149 1258 END FUNCTION mpp__init_file 1259 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1260 FUNCTION mpp__init_file_cdf(td_file) & 1261 & RESULT(tf_mpp) 1150 1262 !------------------------------------------------------------------- 1151 1263 !> @brief This function initalise a mpp structure, 1152 1264 !> reading some netcdf files. 1153 ! 1265 !> 1154 1266 !> @details 1155 ! 1267 !> 1156 1268 !> @author J.Paul 1157 1269 !> @date November, 2013 - Initial Version … … 1164 1276 !> @return mpp structure 1165 1277 !------------------------------------------------------------------- 1166 TYPE(TMPP) FUNCTION mpp__init_file_cdf( td_file ) 1278 1167 1279 IMPLICIT NONE 1168 1280 1169 1281 ! Argument 1170 1282 TYPE(TFILE), INTENT(IN) :: td_file 1283 1284 ! function 1285 TYPE(TMPP) :: tf_mpp 1171 1286 1172 1287 ! local variable … … 1196 1311 1197 1312 ! get mpp name 1198 mpp__init_file_cdf%c_name=TRIM( file_rename(td_file%c_name) )1313 tf_mpp%c_name=TRIM( file_rename(td_file%c_name) ) 1199 1314 1200 1315 ! add type 1201 mpp__init_file_cdf%c_type="cdf"1316 tf_mpp%c_type="cdf" 1202 1317 1203 1318 ! global domain size … … 1208 1323 IF( il_attid /= 0 )THEN 1209 1324 tl_dim=dim_init('X',INT(td_file%t_att(il_attid)%d_value(1))) 1210 CALL mpp_add_dim( mpp__init_file_cdf,tl_dim)1325 CALL mpp_add_dim(tf_mpp,tl_dim) 1211 1326 1212 1327 tl_dim=dim_init('Y',INT(td_file%t_att(il_attid)%d_value(2))) 1213 CALL mpp_add_dim( mpp__init_file_cdf,tl_dim)1328 CALL mpp_add_dim(tf_mpp,tl_dim) 1214 1329 ELSE ! assume only one file (not mpp) 1215 1330 tl_dim=dim_init( td_file%t_dim(1)%c_name, td_file%t_dim(1)%i_len) 1216 CALL mpp_add_dim( mpp__init_file_cdf,tl_dim)1331 CALL mpp_add_dim(tf_mpp,tl_dim) 1217 1332 1218 1333 tl_dim=dim_init( td_file%t_dim(2)%c_name, td_file%t_dim(2)%i_len) 1219 CALL mpp_add_dim( mpp__init_file_cdf,tl_dim)1334 CALL mpp_add_dim(tf_mpp,tl_dim) 1220 1335 ENDIF 1221 1336 1222 1337 IF( td_file%t_dim(3)%l_use )THEN 1223 1338 tl_dim=dim_init( td_file%t_dim(3)%c_name, td_file%t_dim(3)%i_len) 1224 CALL mpp_add_dim( mpp__init_file_cdf,tl_dim)1339 CALL mpp_add_dim(tf_mpp,tl_dim) 1225 1340 ENDIF 1226 1341 1227 1342 IF( td_file%t_dim(4)%l_use )THEN 1228 1343 tl_dim=dim_init( td_file%t_dim(4)%c_name, td_file%t_dim(4)%i_len) 1229 CALL mpp_add_dim( mpp__init_file_cdf,tl_dim)1344 CALL mpp_add_dim(tf_mpp,tl_dim) 1230 1345 ENDIF 1231 1346 … … 1247 1362 tl_proc%t_dim(:)=dim_copy(td_file%t_dim(:)) 1248 1363 1249 CALL mpp__read_halo(tl_proc, mpp__init_file_cdf%t_dim(:) )1364 CALL mpp__read_halo(tl_proc, tf_mpp%t_dim(:) ) 1250 1365 1251 1366 ! add attributes 1252 tl_att=att_init( "DOMAIN_size_global", & 1253 & mpp__init_file_cdf%t_dim(:)%i_len) 1367 tl_att=att_init( "DOMAIN_size_global", tf_mpp%t_dim(:)%i_len) 1254 1368 CALL file_move_att(tl_proc, tl_att) 1255 1369 … … 1258 1372 1259 1373 ! add processor to mpp structure 1260 CALL mpp__add_proc( mpp__init_file_cdf, tl_proc)1374 CALL mpp__add_proc(tf_mpp, tl_proc) 1261 1375 1262 1376 ! clean … … 1274 1388 1275 1389 END FUNCTION mpp__init_file_cdf 1390 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1391 FUNCTION mpp__init_file_rstdimg(td_file) & 1392 & RESULT(tf_mpp) 1276 1393 !------------------------------------------------------------------- 1277 1394 !> @brief This function initalise a mpp structure, 1278 1395 !> reading one dimg restart file. 1279 ! 1396 !> 1280 1397 !> @details 1281 ! 1398 !> 1282 1399 !> @author J.Paul 1283 1400 !> @date November, 2013 - Initial Version 1284 1401 !> @date January, 2016 1285 1402 !> - mismatch with "halo" indices, use mpp__compute_halo 1403 !> @date January,2019 1404 !> - clean file structure 1286 1405 !> 1287 1406 !> @param[in] td_file file strcuture 1288 1407 !> @return mpp structure 1289 1408 !------------------------------------------------------------------- 1290 TYPE(TMPP) FUNCTION mpp__init_file_rstdimg( td_file ) 1409 1291 1410 IMPLICIT NONE 1292 1411 1293 1412 ! Argument 1294 1413 TYPE(TFILE), INTENT(IN) :: td_file 1414 1415 ! function 1416 TYPE(TMPP) :: tf_mpp 1295 1417 1296 1418 ! local variable … … 1336 1458 ! read first record 1337 1459 READ( td_file%i_id, IOSTAT=il_status, REC=1 )& 1338 &il_recl, &1339 &il_nx, il_ny, il_nz, &1340 &il_n0d, il_n1d, il_n2d, il_n3d, &1341 &il_rhd, &1342 &il_pni, il_pnj, il_pnij, &1343 &il_area1460 & il_recl, & 1461 & il_nx, il_ny, il_nz, & 1462 & il_n0d, il_n1d, il_n2d, il_n3d, & 1463 & il_rhd, & 1464 & il_pni, il_pnj, il_pnij, & 1465 & il_area 1344 1466 CALL fct_err(il_status) 1345 1467 IF( il_status /= 0 )THEN … … 1349 1471 1350 1472 ! get mpp name 1351 mpp__init_file_rstdimg%c_name=TRIM( file_rename(td_file%c_name) )1473 tf_mpp%c_name=TRIM( file_rename(td_file%c_name) ) 1352 1474 1353 1475 ! add type 1354 mpp__init_file_rstdimg%c_type="dimg"1476 tf_mpp%c_type="dimg" 1355 1477 1356 1478 ! number of processors to be read 1357 mpp__init_file_rstdimg%i_nproc = il_pnij1358 mpp__init_file_rstdimg%i_niproc = il_pni1359 mpp__init_file_rstdimg%i_njproc = il_pnj1360 1361 IF( ASSOCIATED( mpp__init_file_rstdimg%t_proc) )THEN1362 CALL file_clean( mpp__init_file_rstdimg%t_proc(:))1363 DEALLOCATE( mpp__init_file_rstdimg%t_proc)1364 ENDIF 1365 ALLOCATE( mpp__init_file_rstdimg%t_proc(il_pnij) , stat=il_status )1479 tf_mpp%i_nproc = il_pnij 1480 tf_mpp%i_niproc = il_pni 1481 tf_mpp%i_njproc = il_pnj 1482 1483 IF( ASSOCIATED(tf_mpp%t_proc) )THEN 1484 CALL file_clean(tf_mpp%t_proc(:)) 1485 DEALLOCATE(tf_mpp%t_proc) 1486 ENDIF 1487 ALLOCATE( tf_mpp%t_proc(il_pnij) , stat=il_status ) 1366 1488 1367 1489 ALLOCATE(il_lci (il_pnij)) … … 1378 1500 CALL dim_clean(tl_proc%t_dim(:)) 1379 1501 ! initialise file/processors 1380 DO ji=1, mpp__init_file_rstdimg%i_nproc1381 mpp__init_file_rstdimg%t_proc(ji)=file_copy(tl_proc)1502 DO ji=1,tf_mpp%i_nproc 1503 tf_mpp%t_proc(ji)=file_copy(tl_proc) 1382 1504 ENDDO 1383 1505 … … 1389 1511 ! read first record 1390 1512 READ( td_file%i_id, IOSTAT=il_status, REC=1 )& 1391 &il_recl, &1392 &il_nx, il_ny, il_nz, &1393 &il_n0d, il_n1d, il_n2d, il_n3d, &1394 &il_rhd, &1395 &il_pni, il_pnj, il_pnij, &1396 &il_area, &1397 &il_iglo, il_jglo, &1398 & 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)1513 & il_recl, & 1514 & il_nx, il_ny, il_nz, & 1515 & il_n0d, il_n1d, il_n2d, il_n3d, & 1516 & il_rhd, & 1517 & il_pni, il_pnj, il_pnij, & 1518 & il_area, & 1519 & il_iglo, il_jglo, & 1520 & il_lci(1:il_pnij), & 1521 & il_lcj(1:il_pnij), & 1522 & il_ldi(1:il_pnij), & 1523 & il_ldj(1:il_pnij), & 1524 & il_lei(1:il_pnij), & 1525 & il_lej(1:il_pnij), & 1526 & il_impp(1:il_pnij), & 1527 & il_jmpp(1:il_pnij) 1406 1528 CALL fct_err(il_status) 1407 1529 IF( il_status /= 0 )THEN … … 1410 1532 ENDIF 1411 1533 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)1534 tf_mpp%t_proc(1:il_pnij)%i_lci = il_lci (1:il_pnij) 1535 tf_mpp%t_proc(1:il_pnij)%i_lcj = il_lcj (1:il_pnij) 1536 tf_mpp%t_proc(1:il_pnij)%i_ldi = il_ldi (1:il_pnij) 1537 tf_mpp%t_proc(1:il_pnij)%i_ldj = il_ldj (1:il_pnij) 1538 tf_mpp%t_proc(1:il_pnij)%i_lei = il_lei (1:il_pnij) 1539 tf_mpp%t_proc(1:il_pnij)%i_lej = il_lej (1:il_pnij) 1540 tf_mpp%t_proc(1:il_pnij)%i_impp= il_impp(1:il_pnij) 1541 tf_mpp%t_proc(1:il_pnij)%i_jmpp= il_jmpp(1:il_pnij) 1420 1542 1421 1543 DEALLOCATE(il_lci) … … 1430 1552 ! global domain size 1431 1553 tl_dim=dim_init('X',il_iglo) 1432 CALL mpp_add_dim( mpp__init_file_rstdimg,tl_dim)1554 CALL mpp_add_dim(tf_mpp,tl_dim) 1433 1555 tl_dim=dim_init('Y',il_jglo) 1434 CALL mpp_add_dim( mpp__init_file_rstdimg,tl_dim)1556 CALL mpp_add_dim(tf_mpp,tl_dim) 1435 1557 1436 1558 tl_dim=dim_init('Z',il_nz) 1437 CALL mpp_add_dim( mpp__init_file_rstdimg,tl_dim)1438 1439 DO ji=1, mpp__init_file_rstdimg%i_nproc1559 CALL mpp_add_dim(tf_mpp,tl_dim) 1560 1561 DO ji=1,tf_mpp%i_nproc 1440 1562 1441 1563 ! get file name 1442 1564 cl_file = file_rename(td_file%c_name,ji) 1443 mpp__init_file_rstdimg%t_proc(ji)%c_name = TRIM(cl_file)1565 tf_mpp%t_proc(ji)%c_name = TRIM(cl_file) 1444 1566 ! update processor id 1445 mpp__init_file_rstdimg%t_proc(ji)%i_pid=ji1567 tf_mpp%t_proc(ji)%i_pid=ji 1446 1568 1447 1569 ! add attributes 1448 1570 tl_att=att_init( "DOMAIN_number", ji ) 1449 CALL file_move_att( mpp__init_file_rstdimg%t_proc(ji), tl_att)1571 CALL file_move_att(tf_mpp%t_proc(ji), tl_att) 1450 1572 1451 1573 ENDDO 1452 1574 1453 1575 ! add type 1454 mpp__init_file_rstdimg%t_proc(:)%c_type="dimg"1576 tf_mpp%t_proc(:)%c_type="dimg" 1455 1577 1456 1578 ! add attributes 1457 tl_att=att_init( "DOMAIN_size_global", & 1458 & mpp__init_file_rstdimg%t_dim(:)%i_len) 1459 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1460 1461 tl_att=att_init( "DOMAIN_number_total", & 1462 & mpp__init_file_rstdimg%i_nproc ) 1463 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1464 1465 tl_att=att_init( "DOMAIN_I_number_total", & 1466 & mpp__init_file_rstdimg%i_niproc ) 1467 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1468 1469 tl_att=att_init( "DOMAIN_J_number_total", & 1470 & mpp__init_file_rstdimg%i_njproc ) 1471 CALL mpp_move_att(mpp__init_file_rstdimg, tl_att) 1472 1473 CALL mpp_get_dom( mpp__init_file_rstdimg ) 1474 1475 CALL mpp__compute_halo( mpp__init_file_rstdimg ) 1579 tl_att=att_init("DOMAIN_size_global", tf_mpp%t_dim(:)%i_len) 1580 CALL mpp_move_att(tf_mpp, tl_att) 1581 1582 tl_att=att_init("DOMAIN_number_total", tf_mpp%i_nproc) 1583 CALL mpp_move_att(tf_mpp, tl_att) 1584 1585 tl_att=att_init("DOMAIN_I_number_total", tf_mpp%i_niproc) 1586 CALL mpp_move_att(tf_mpp, tl_att) 1587 1588 tl_att=att_init("DOMAIN_J_number_total", tf_mpp%i_njproc) 1589 CALL mpp_move_att(tf_mpp, tl_att) 1590 1591 CALL mpp_get_dom( tf_mpp ) 1592 1593 CALL mpp__compute_halo( tf_mpp ) 1476 1594 1477 1595 ! clean 1478 1596 CALL dim_clean(tl_dim) 1479 1597 CALL att_clean(tl_att) 1598 CALL file_clean(tl_proc) 1480 1599 ENDIF 1481 1600 … … 1488 1607 1489 1608 END FUNCTION mpp__init_file_rstdimg 1609 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1610 FUNCTION mpp__check_proc_dim(td_mpp, td_proc) & 1611 & RESULT(lf_check) 1490 1612 !------------------------------------------------------------------- 1491 1613 !> @brief This function check if variable and mpp structure use same 1492 1614 !> dimension. 1493 ! 1615 !> 1494 1616 !> @author J.Paul 1495 1617 !> @date November, 2013 - Initial Version 1496 ! 1618 !> 1497 1619 !> @param[in] td_mpp mpp structure 1498 1620 !> @param[in] td_proc processor structure 1499 1621 !> @return dimension of processor and mpp structure agree (or not) 1500 1622 !------------------------------------------------------------------- 1501 LOGICAL FUNCTION mpp__check_proc_dim(td_mpp, td_proc) 1623 1502 1624 IMPLICIT NONE 1625 1503 1626 ! Argument 1504 1627 TYPE(TMPP), INTENT(IN) :: td_mpp 1505 1628 TYPE(TFILE), INTENT(IN) :: td_proc 1506 1629 1630 !function 1631 LOGICAL :: lf_check 1632 1507 1633 ! local variable 1508 1634 INTEGER(i4) :: il_isize !< i-direction maximum sub domain size 1509 1635 INTEGER(i4) :: il_jsize !< j-direction maximum sub domain size 1510 1511 1636 !---------------------------------------------------------------- 1512 mpp__check_proc_dim=.TRUE. 1637 1638 lf_check=.TRUE. 1513 1639 ! check used dimension 1514 1640 IF( td_mpp%i_niproc /= 0 .AND. td_mpp%i_njproc /= 0 )THEN 1515 1641 ! check with maximum size of sub domain 1516 1642 il_isize = ( td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + & 1517 &(td_mpp%i_niproc-1) ) / td_mpp%i_niproc + 2*td_mpp%i_preci1643 & (td_mpp%i_niproc-1) ) / td_mpp%i_niproc + 2*td_mpp%i_preci 1518 1644 il_jsize = ( td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + & 1519 &(td_mpp%i_njproc-1) ) / td_mpp%i_njproc + 2*td_mpp%i_precj1645 & (td_mpp%i_njproc-1) ) / td_mpp%i_njproc + 2*td_mpp%i_precj 1520 1646 1521 1647 IF( il_isize < td_proc%i_lci .OR. & 1522 &il_jsize < td_proc%i_lcj )THEN1523 1524 mpp__check_proc_dim=.FALSE.1648 &il_jsize < td_proc%i_lcj )THEN 1649 1650 lf_check=.FALSE. 1525 1651 1526 1652 CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" ) … … 1531 1657 ! check with global domain size 1532 1658 IF( td_mpp%t_dim(1)%i_len < td_proc%i_lci .OR. & 1533 &td_mpp%t_dim(2)%i_len < td_proc%i_lcj )THEN1534 1535 mpp__check_proc_dim=.FALSE.1659 &td_mpp%t_dim(2)%i_len < td_proc%i_lcj )THEN 1660 1661 lf_check=.FALSE. 1536 1662 1537 1663 CALL logger_error( "MPP CHECK DIM: processor and mpp dimension differ" ) … … 1541 1667 1542 1668 END FUNCTION mpp__check_proc_dim 1669 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1670 SUBROUTINE mpp_add_var(td_mpp, td_var) 1543 1671 !------------------------------------------------------------------- 1544 1672 !> @brief … … 1547 1675 !> @author J.Paul 1548 1676 !> @date November, 2013 - Initial version 1549 ! 1677 !> @date January, 2019 1678 !> - do not split variable on domain decomposition, if only one procesor 1679 !> 1550 1680 !> @param[inout] td_mpp mpp strcuture 1551 1681 !> @param[in] td_var variable strcuture 1552 1682 !------------------------------------------------------------------- 1553 SUBROUTINE mpp_add_var( td_mpp, td_var ) 1683 1554 1684 IMPLICIT NONE 1685 1555 1686 ! Argument 1556 1687 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 1564 1695 INTEGER(i4) :: ji 1565 1696 !---------------------------------------------------------------- 1697 1566 1698 ! check if mpp exist 1567 1699 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN … … 1596 1728 1597 1729 ELSE 1598 1730 1599 1731 CALL logger_info( & 1600 1732 & " MPP ADD VAR: add variable "//TRIM(td_var%c_name)//& … … 1603 1735 ! check used dimension 1604 1736 IF( mpp__check_dim(td_mpp, td_var) )THEN 1605 1737 1606 1738 ! check variable dimension expected 1607 1739 CALL var_check_dim(td_var) … … 1616 1748 1617 1749 ! add variable in each processor 1618 DO ji=1,td_mpp%i_nproc 1619 1620 ! split variable on domain decomposition 1621 tl_var=mpp__split_var(td_mpp, td_var, ji) 1622 1623 CALL file_add_var(td_mpp%t_proc(ji), tl_var) 1624 1625 ! clean 1626 CALL var_clean(tl_var) 1627 ENDDO 1750 IF( td_mpp%i_nproc == 1 )THEN 1751 CALL file_add_var(td_mpp%t_proc(1), td_var) 1752 ELSE 1753 DO ji=1,td_mpp%i_nproc 1754 ! split variable on domain decomposition 1755 tl_var=mpp__split_var(td_mpp, td_var, ji) 1756 1757 CALL file_add_var(td_mpp%t_proc(ji), tl_var) 1758 1759 ! clean 1760 CALL var_clean(tl_var) 1761 ENDDO 1762 ENDIF 1628 1763 1629 1764 ENDIF … … 1633 1768 1634 1769 END SUBROUTINE mpp_add_var 1770 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1771 FUNCTION mpp__split_var(td_mpp, td_var, id_procid) & 1772 & RESULT(tf_var) 1635 1773 !------------------------------------------------------------------- 1636 1774 !> @brief This function extract, from variable structure, part that will 1637 1775 !> be written in processor id_procid.<br/> 1638 ! 1776 !> 1639 1777 !> @author J.Paul 1640 1778 !> @date November, 2013 - Initial Version 1641 ! 1779 !> 1642 1780 !> @param[in] td_mpp mpp structure 1643 1781 !> @param[in] td_var variable structure … … 1645 1783 !> @return variable structure 1646 1784 !------------------------------------------------------------------- 1647 TYPE(TVAR) FUNCTION mpp__split_var(td_mpp, td_var, id_procid) 1785 1648 1786 IMPLICIT NONE 1787 1649 1788 ! Argument 1650 1789 TYPE(TMPP), INTENT(IN) :: td_mpp … … 1652 1791 INTEGER(i4), INTENT(IN) :: id_procid 1653 1792 1793 ! function 1794 TYPE(TVAR) :: tf_var 1795 1654 1796 ! local variable 1655 1797 TYPE(TDIM) :: tl_dim … … 1664 1806 1665 1807 ! copy mpp 1666 mpp__split_var=var_copy(td_var) 1808 tf_var=var_copy(td_var, ld_value=.FALSE.) 1809 1810 ! get processor indices 1811 il_ind(:)=mpp_get_proc_index( td_mpp, id_procid ) 1812 il_i1 = il_ind(1) 1813 il_i2 = il_ind(2) 1814 il_j1 = il_ind(3) 1815 il_j2 = il_ind(4) 1816 1817 IF( .NOT. td_var%t_dim(1)%l_use )THEN 1818 il_i1=1 1819 il_i2=1 1820 ENDIF 1821 1822 IF( .NOT. td_var%t_dim(2)%l_use )THEN 1823 il_j1=1 1824 il_j2=1 1825 ENDIF 1667 1826 1668 1827 IF( ASSOCIATED(td_var%d_value) )THEN 1669 1828 ! remove value over global domain from pointer 1670 CALL var_del_value( mpp__split_var )1829 !CALL var_del_value( tf_var ) 1671 1830 1672 1831 ! get processor dimension … … 1676 1835 IF( td_var%t_dim(1)%l_use )THEN 1677 1836 tl_dim=dim_init( TRIM(td_var%t_dim(1)%c_name), il_size(1) ) 1678 CALL var_move_dim( mpp__split_var, tl_dim )1837 CALL var_move_dim( tf_var, tl_dim ) 1679 1838 ENDIF 1680 1839 IF( td_var%t_dim(2)%l_use )THEN 1681 1840 tl_dim=dim_init( TRIM(td_var%t_dim(2)%c_name), il_size(2) ) 1682 CALL var_move_dim( mpp__split_var, tl_dim )1841 CALL var_move_dim( tf_var, tl_dim ) 1683 1842 ENDIF 1684 1843 1685 ! get processor indices1686 il_ind(:)=mpp_get_proc_index( td_mpp, id_procid )1687 il_i1 = il_ind(1)1688 il_i2 = il_ind(2)1689 il_j1 = il_ind(3)1690 il_j2 = il_ind(4)1691 1692 IF( .NOT. td_var%t_dim(1)%l_use )THEN1693 il_i1=11694 il_i2=11695 ENDIF1696 1697 IF( .NOT. td_var%t_dim(2)%l_use )THEN1698 il_j1=11699 il_j2=11700 ENDIF1701 1702 1844 ! add variable value on processor 1703 CALL var_add_value( mpp__split_var, & 1704 & td_var%d_value(il_i1:il_i2, il_j1:il_j2, :, :) ) 1845 CALL var_add_value( tf_var, & 1846 & td_var%d_value(il_i1:il_i2, il_j1:il_j2, :, :) ) 1847 1848 ELSE 1849 1850 tf_var%t_dim(jp_I)%i_len=il_i2-il_i1+1 1851 tf_var%t_dim(jp_J)%i_len=il_j2-il_j1+1 1852 1705 1853 ENDIF 1706 1854 1707 1855 END FUNCTION mpp__split_var 1856 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1857 SUBROUTINE mpp__del_var_mpp(td_mpp) 1708 1858 !------------------------------------------------------------------- 1709 1859 !> @brief … … 1715 1865 !> @param[inout] td_mpp mpp strcuture 1716 1866 !------------------------------------------------------------------- 1717 SUBROUTINE mpp__del_var_mpp( td_mpp )1867 1718 1868 IMPLICIT NONE 1869 1719 1870 ! Argument 1720 1871 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 1736 1887 1737 1888 END SUBROUTINE mpp__del_var_mpp 1889 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1890 SUBROUTINE mpp__del_var_str(td_mpp, td_var) 1738 1891 !------------------------------------------------------------------- 1739 1892 !> @brief … … 1743 1896 !> @author J.Paul 1744 1897 !> @date November, 2013 - Initial version 1745 ! 1898 !> 1746 1899 !> @param[inout] td_mpp mpp strcuture 1747 1900 !> @param[in] td_var variable strcuture 1748 1901 !------------------------------------------------------------------- 1749 SUBROUTINE mpp__del_var_str( td_mpp, td_var )1902 1750 1903 IMPLICIT NONE 1904 1751 1905 ! Argument 1752 1906 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 1760 1914 INTEGER(i4) :: ji 1761 1915 !---------------------------------------------------------------- 1916 1762 1917 ! check if mpp exist 1763 1918 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN … … 1794 1949 1795 1950 ENDIF 1796 1797 ENDIF 1951 ENDIF 1952 1798 1953 END SUBROUTINE mpp__del_var_str 1954 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 1955 SUBROUTINE mpp__del_var_name(td_mpp, cd_name) 1799 1956 !------------------------------------------------------------------- 1800 1957 !> @brief … … 1805 1962 !> @date February, 2015 1806 1963 !> - define local variable structure to avoid mistake with pointer 1807 ! 1964 !> @date January, 2019 1965 !> - clean variable strcuture 1966 !> 1808 1967 !> @param[inout] td_mpp mpp strcuture 1809 1968 !> @param[in] cd_name variable name 1810 1969 !------------------------------------------------------------------- 1811 SUBROUTINE mpp__del_var_name( td_mpp, cd_name )1970 1812 1971 IMPLICIT NONE 1972 1813 1973 ! Argument 1814 1974 TYPE(TMPP) , INTENT(INOUT) :: td_mpp … … 1819 1979 TYPE(TVAR) :: tl_var 1820 1980 !---------------------------------------------------------------- 1981 1821 1982 ! check if mpp exist 1822 1983 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN … … 1850 2011 tl_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid)) 1851 2012 CALL mpp_del_var(td_mpp, tl_var) 1852 2013 ! clean 2014 CALL var_clean(tl_var) 1853 2015 ENDIF 1854 2016 ENDIF 1855 1856 ENDIF 2017 ENDIF 2018 1857 2019 END SUBROUTINE mpp__del_var_name 2020 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2021 SUBROUTINE mpp_move_var(td_mpp, td_var) 1858 2022 !------------------------------------------------------------------- 1859 2023 !> @brief … … 1862 2026 !> @author J.Paul 1863 2027 !> @date November, 2013 - Initial version 1864 ! 2028 !> 1865 2029 !> @param[inout] td_mpp mpp strcuture 1866 2030 !> @param[in] td_var variable structure 1867 2031 !------------------------------------------------------------------- 1868 SUBROUTINE mpp_move_var( td_mpp, td_var ) 2032 1869 2033 IMPLICIT NONE 2034 1870 2035 ! Argument 1871 2036 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 1875 2040 TYPE(TVAR) :: tl_var 1876 2041 !---------------------------------------------------------------- 2042 1877 2043 ! copy variablie 1878 2044 tl_var=var_copy(td_var) … … 1888 2054 1889 2055 END SUBROUTINE mpp_move_var 1890 !> @endcode 2056 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2057 SUBROUTINE mpp__add_proc_unit(td_mpp, td_proc) 1891 2058 !------------------------------------------------------------------- 1892 2059 !> @brief … … 1895 2062 !> @author J.Paul 1896 2063 !> @date November, 2013 - Initial version 2064 !> @date January, 2019 2065 !> - deallocate file structure whatever happens 1897 2066 ! 1898 2067 !> @param[inout] td_mpp mpp strcuture 1899 2068 !> @param[in] td_proc processor strcuture 1900 ! 1901 !> @todo 1902 !> - check proc type 1903 !------------------------------------------------------------------- 1904 SUBROUTINE mpp__add_proc_unit( td_mpp, td_proc ) 2069 !------------------------------------------------------------------- 2070 1905 2071 IMPLICIT NONE 2072 1906 2073 ! Argument 1907 2074 TYPE(TMPP) , INTENT(INOUT) :: td_mpp … … 1917 2084 CHARACTER(LEN=lc) :: cl_name 1918 2085 !---------------------------------------------------------------- 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)1927 2086 1928 2087 ! check file name … … 1988 2147 ! clean 1989 2148 CALL file_clean(tl_proc(:)) 1990 DEALLOCATE(tl_proc)1991 ENDIF2149 ENDIF 2150 DEALLOCATE(tl_proc) 1992 2151 1993 2152 ELSE 2153 1994 2154 ! no processor in mpp structure 1995 2155 IF( ASSOCIATED(td_mpp%t_proc) )THEN … … 2026 2186 2027 2187 END SUBROUTINE mpp__add_proc_unit 2188 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2189 SUBROUTINE mpp__add_proc_arr(td_mpp, td_proc) 2190 !------------------------------------------------------------------- 2191 !> @brief 2192 !> This subroutine add array of processor to mpp structure. 2193 !> @note mpp structure should be empty 2194 !> 2195 !> @author J.Paul 2196 !> @date August, 2017 - Initial version 2197 !> 2198 !> @param[inout] td_mpp mpp strcuture 2199 !> @param[in] td_proc array of processor strcuture 2200 !------------------------------------------------------------------- 2201 2202 IMPLICIT NONE 2203 2204 ! Argument 2205 TYPE(TMPP) , INTENT(INOUT) :: td_mpp 2206 TYPE(TFILE), DIMENSION(:), INTENT(IN ) :: td_proc 2207 2208 ! local variable 2209 INTEGER(i4) :: il_status 2210 INTEGER(i4) :: il_nproc 2211 2212 CHARACTER(LEN=lc) :: cl_name 2213 !---------------------------------------------------------------- 2214 2215 ! check file name 2216 cl_name=TRIM( file_rename(td_proc(1)%c_name) ) 2217 IF( TRIM(cl_name) /= TRIM(td_mpp%c_name) )THEN 2218 CALL logger_warn("MPP ADD PROC: processor name do not match mpp name") 2219 ENDIF 2220 2221 IF( ASSOCIATED(td_mpp%t_proc) )THEN 2222 CALL logger_error( & 2223 & "MPP ADD PROC: some processor(s) already in mpp structure " ) 2224 2225 ELSE 2226 2227 CALL logger_trace("MPP ADD PROC: add array of processor "//& 2228 & " in mpp structure") 2229 2230 il_nproc=SIZE(td_proc) 2231 ALLOCATE( td_mpp%t_proc(il_nproc), stat=il_status ) 2232 IF(il_status /= 0 )THEN 2233 CALL logger_error( "MPP ADD PROC: not enough space to put "//& 2234 & "processor in mpp structure " ) 2235 ENDIF 2236 2237 ! check dimension 2238 IF( ANY(td_mpp%t_dim(1:2)%i_len < td_proc(1)%t_dim(1:2)%i_len) )THEN 2239 CALL logger_error( "MPP ADD PROC: mpp structure and new processor "//& 2240 & " dimension differ. ") 2241 CALL logger_debug("MPP ADD PROC: mpp dimension ("//& 2242 & TRIM(fct_str(td_mpp%t_dim(1)%i_len))//","//& 2243 & TRIM(fct_str(td_mpp%t_dim(2)%i_len))//")" ) 2244 CALL logger_debug("MPP ADD PROC: processor dimension ("//& 2245 & TRIM(fct_str(td_proc(1)%t_dim(1)%i_len))//","//& 2246 & TRIM(fct_str(td_proc(1)%t_dim(2)%i_len))//")" ) 2247 ELSE 2248 td_mpp%i_nproc=il_nproc 2249 2250 ! add new processor 2251 td_mpp%t_proc(:)=file_copy(td_proc(:)) 2252 ENDIF 2253 2254 ENDIF 2255 2256 END SUBROUTINE mpp__add_proc_arr 2257 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2258 SUBROUTINE mpp__del_proc_id(td_mpp, id_procid) 2028 2259 !------------------------------------------------------------------- 2029 2260 !> @brief … … 2032 2263 !> @author J.Paul 2033 2264 !> @date November, 2013 - Initial version 2265 !> @date January, 2019 2266 !> - clean file structure 2034 2267 !> 2035 2268 !> @param[inout] td_mpp mpp strcuture 2036 2269 !> @param[in] id_procid processor id 2037 2270 !------------------------------------------------------------------- 2038 SUBROUTINE mpp__del_proc_id( td_mpp, id_procid ) 2271 2039 2272 IMPLICIT NONE 2273 2040 2274 ! Argument 2041 2275 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 2111 2345 ENDIF 2112 2346 ENDIF 2347 2113 2348 END SUBROUTINE mpp__del_proc_id 2349 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2350 SUBROUTINE mpp__del_proc_str(td_mpp, td_proc) 2114 2351 !------------------------------------------------------------------- 2115 2352 !> @brief … … 2119 2356 !> @author J.Paul 2120 2357 !> @date November, 2013 - Initial version 2121 ! 2358 !> 2122 2359 !> @param[inout] td_mpp : mpp strcuture 2123 2360 !> @param[in] td_proc : file/processor structure 2124 2361 !------------------------------------------------------------------- 2125 SUBROUTINE mpp__del_proc_str( td_mpp, td_proc ) 2362 2126 2363 IMPLICIT NONE 2364 2127 2365 ! Argument 2128 2366 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 2137 2375 2138 2376 END SUBROUTINE mpp__del_proc_str 2377 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2378 SUBROUTINE mpp__move_proc(td_mpp, td_proc) 2139 2379 !------------------------------------------------------------------- 2140 2380 !> @brief … … 2142 2382 !> 2143 2383 !> @detail 2144 ! 2384 !> 2145 2385 !> @author J.Paul 2146 2386 !> @date Nov, 2013 - Initial version 2147 ! 2387 !> 2148 2388 !> @param[inout] td_mpp mpp strcuture 2149 2389 !> @param[in] id_procid processor id 2150 2390 !------------------------------------------------------------------- 2151 SUBROUTINE mpp__move_proc( td_mpp, td_proc ) 2391 2152 2392 IMPLICIT NONE 2393 2153 2394 ! Argument 2154 2395 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 2163 2404 2164 2405 END SUBROUTINE mpp__move_proc 2406 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2407 SUBROUTINE mpp_add_dim(td_mpp, td_dim) 2165 2408 !------------------------------------------------------------------- 2166 2409 !> @brief This subroutine add a dimension structure in a mpp … … 2176 2419 !> @param[in] td_dim dimension structure 2177 2420 !------------------------------------------------------------------- 2178 SUBROUTINE mpp_add_dim(td_mpp, td_dim) 2421 2179 2422 IMPLICIT NONE 2423 2180 2424 ! Argument 2181 2425 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 2187 2431 ! loop indices 2188 2432 !---------------------------------------------------------------- 2433 2189 2434 IF( td_mpp%i_ndim <= ip_maxdim )THEN 2190 2435 … … 2223 2468 2224 2469 END SUBROUTINE mpp_add_dim 2470 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2471 SUBROUTINE mpp_del_dim(td_mpp, td_dim) 2225 2472 !------------------------------------------------------------------- 2226 2473 !> @brief This subroutine delete a dimension structure in a mpp … … 2235 2482 !> @param[in] td_dim dimension structure 2236 2483 !------------------------------------------------------------------- 2237 SUBROUTINE mpp_del_dim(td_mpp, td_dim) 2484 2238 2485 IMPLICIT NONE 2486 2239 2487 ! Argument 2240 2488 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 2247 2495 ! loop indices 2248 2496 !---------------------------------------------------------------- 2249 2250 2497 2251 2498 IF( td_mpp%i_ndim <= ip_maxdim )THEN … … 2275 2522 2276 2523 END SUBROUTINE mpp_del_dim 2524 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2525 SUBROUTINE mpp_move_dim(td_mpp, td_dim) 2277 2526 !------------------------------------------------------------------- 2278 2527 !> @brief This subroutine move a dimension structure … … 2286 2535 !> @param[in] td_dim dimension structure 2287 2536 !------------------------------------------------------------------- 2288 SUBROUTINE mpp_move_dim(td_mpp, td_dim) 2537 2289 2538 IMPLICIT NONE 2539 2290 2540 ! Argument 2291 2541 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 2296 2546 INTEGER(i4) :: il_dimid 2297 2547 !---------------------------------------------------------------- 2548 2298 2549 IF( td_mpp%i_ndim <= ip_maxdim )THEN 2299 2550 … … 2317 2568 & TRIM(td_mpp%c_name)//" ("//TRIM(fct_str(td_mpp%i_ndim))//")") 2318 2569 ENDIF 2570 2319 2571 END SUBROUTINE mpp_move_dim 2572 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2573 SUBROUTINE mpp_add_att(td_mpp, td_att) 2320 2574 !------------------------------------------------------------------- 2321 2575 !> @brief … … 2328 2582 !> @param[in] td_att attribute strcuture 2329 2583 !------------------------------------------------------------------- 2330 SUBROUTINE mpp_add_att( td_mpp, td_att ) 2584 2331 2585 IMPLICIT NONE 2586 2332 2587 ! Argument 2333 2588 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 2340 2595 INTEGER(i4) :: ji 2341 2596 !---------------------------------------------------------------- 2597 2342 2598 ! check if mpp exist 2343 2599 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN … … 2386 2642 2387 2643 END SUBROUTINE mpp_add_att 2644 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2645 SUBROUTINE mpp__del_att_str(td_mpp, td_att) 2388 2646 !------------------------------------------------------------------- 2389 2647 !> @brief … … 2397 2655 !> @param[in] td_att attribute strcuture 2398 2656 !------------------------------------------------------------------- 2399 SUBROUTINE mpp__del_att_str( td_mpp, td_att ) 2657 2400 2658 IMPLICIT NONE 2659 2401 2660 ! Argument 2402 2661 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 2410 2669 INTEGER(i4) :: ji 2411 2670 !---------------------------------------------------------------- 2671 2412 2672 ! check if mpp exist 2413 2673 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN … … 2446 2706 2447 2707 ENDIF 2448 2449 ENDIF 2708 ENDIF 2709 2450 2710 END SUBROUTINE mpp__del_att_str 2711 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2712 SUBROUTINE mpp__del_att_name(td_mpp, cd_name) 2451 2713 !------------------------------------------------------------------- 2452 2714 !> @brief … … 2454 2716 !> 2455 2717 !> @detail 2456 ! 2718 !> 2457 2719 !> @author J.Paul 2458 2720 !> @date November, 2013 - Initial version 2459 2721 !> @date February, 2015 2460 2722 !> - define local attribute structure to avoid mistake with pointer 2461 ! 2723 !> @date January, 2019 2724 !> - clean attributes structure 2725 !> 2462 2726 !> @param[inout] td_mpp mpp strcuture 2463 2727 !> @param[in] cd_name attribute name 2464 2728 !------------------------------------------------------------------- 2465 SUBROUTINE mpp__del_att_name( td_mpp, cd_name ) 2729 2466 2730 IMPLICIT NONE 2731 2467 2732 ! Argument 2468 2733 TYPE(TMPP) , INTENT(INOUT) :: td_mpp … … 2473 2738 TYPE(TATT) :: tl_att 2474 2739 !---------------------------------------------------------------- 2740 2475 2741 ! check if mpp exist 2476 2742 IF( .NOT. ASSOCIATED(td_mpp%t_proc) )THEN … … 2504 2770 tl_att=att_copy(td_mpp%t_proc(1)%t_att(il_attid)) 2505 2771 CALL mpp_del_att(td_mpp, tl_att) 2506 2772 ! clean 2773 CALL att_clean(tl_att) 2507 2774 ENDIF 2508 2775 ENDIF 2509 2510 ENDIF 2776 ENDIF 2777 2511 2778 END SUBROUTINE mpp__del_att_name 2779 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2780 SUBROUTINE mpp_move_att(td_mpp, td_att) 2512 2781 !------------------------------------------------------------------- 2513 2782 !> @brief … … 2516 2785 !> @author J.Paul 2517 2786 !> @date November, 2013 - Initial version 2518 ! 2787 !> 2519 2788 !> @param[inout] td_mpp mpp strcuture 2520 2789 !> @param[in] td_att attribute structure 2521 2790 !------------------------------------------------------------------- 2522 SUBROUTINE mpp_move_att( td_mpp, td_att ) 2791 2523 2792 IMPLICIT NONE 2793 2524 2794 ! Argument 2525 2795 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 2529 2799 TYPE(TATT) :: tl_att 2530 2800 !---------------------------------------------------------------- 2801 2531 2802 ! copy variable 2532 2803 tl_att=att_copy(td_att) … … 2542 2813 2543 2814 END SUBROUTINE mpp_move_att 2815 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 2816 FUNCTION layout__init(td_mpp, id_mask, id_niproc, id_njproc) & 2817 & RESULT(tf_lay) 2544 2818 !------------------------------------------------------------------- 2545 2819 !> @brief … … 2547 2821 !> 2548 2822 !> @detail 2549 !> Domain layout is first compute , with domain dimension, overlap between subdomain,2823 !> Domain layout is first computed, with domain dimension, overlap between subdomain, 2550 2824 !> and the number of processors following I and J. 2551 2825 !> Then the number of sea/land processors is compute with mask … … 2554 2828 !> @date October, 2015 - Initial version 2555 2829 !> @date October, 2016 2556 !> - compare index to t d_lay number of proc instead of td_mpp (bug fix)2830 !> - compare index to tf_lay number of proc instead of td_mpp (bug fix) 2557 2831 !> 2558 2832 !> @param[in] td_mpp mpp strcuture … … 2562 2836 !> @return domain layout structure 2563 2837 !------------------------------------------------------------------- 2564 FUNCTION layout__init( td_mpp, id_mask, id_niproc, id_njproc ) RESULT(td_lay) 2838 2565 2839 IMPLICIT NONE 2840 2566 2841 ! Argument 2567 2842 TYPE(TMPP) , INTENT(IN) :: td_mpp … … 2571 2846 2572 2847 ! function 2573 TYPE(TLAY) :: td_lay2848 TYPE(TLAY) :: tf_lay 2574 2849 2575 2850 ! local variable … … 2593 2868 2594 2869 ! intialise 2595 t d_lay%i_niproc=id_niproc2596 t d_lay%i_njproc=id_njproc2870 tf_lay%i_niproc=id_niproc 2871 tf_lay%i_njproc=id_njproc 2597 2872 2598 2873 CALL logger_info( "MPP COMPUTE LAYOUT: compute domain layout with "//& 2599 & TRIM(fct_str(td_lay%i_niproc))//" x "//&2600 & TRIM(fct_str(td_lay%i_njproc))//" processors")2874 & TRIM(fct_str(tf_lay%i_niproc))//" x "//& 2875 & TRIM(fct_str(tf_lay%i_njproc))//" processors") 2601 2876 2602 2877 ! maximum size of sub domain 2603 il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (t d_lay%i_niproc-1))/ &2604 & td_lay%i_niproc) + 2*td_mpp%i_preci2605 il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (t d_lay%i_njproc-1))/ &2606 & td_lay%i_njproc) + 2*td_mpp%i_precj2607 2608 il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, t d_lay%i_niproc)2609 il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, t d_lay%i_njproc)2610 IF( il_resti == 0 ) il_resti = t d_lay%i_niproc2611 IF( il_restj == 0 ) il_restj = t d_lay%i_njproc2878 il_isize = ((td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci + (tf_lay%i_niproc-1))/ & 2879 & tf_lay%i_niproc) + 2*td_mpp%i_preci 2880 il_jsize = ((td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj + (tf_lay%i_njproc-1))/ & 2881 & tf_lay%i_njproc) + 2*td_mpp%i_precj 2882 2883 il_resti = MOD(td_mpp%t_dim(1)%i_len - 2*td_mpp%i_preci, tf_lay%i_niproc) 2884 il_restj = MOD(td_mpp%t_dim(2)%i_len - 2*td_mpp%i_precj, tf_lay%i_njproc) 2885 IF( il_resti == 0 ) il_resti = tf_lay%i_niproc 2886 IF( il_restj == 0 ) il_restj = tf_lay%i_njproc 2612 2887 2613 2888 ! compute dimension of each sub domain 2614 ALLOCATE( t d_lay%i_lci(td_lay%i_niproc,td_lay%i_njproc) )2615 ALLOCATE( t d_lay%i_lcj(td_lay%i_niproc,td_lay%i_njproc) )2616 2617 t d_lay%i_lci( 1 : il_resti , : ) = il_isize2618 t d_lay%i_lci( il_resti+1 : td_lay%i_niproc, : ) = il_isize-12619 2620 t d_lay%i_lcj( : , 1 : il_restj ) = il_jsize2621 t d_lay%i_lcj( : , il_restj+1 : td_lay%i_njproc) = il_jsize-12889 ALLOCATE( tf_lay%i_lci(tf_lay%i_niproc,tf_lay%i_njproc) ) 2890 ALLOCATE( tf_lay%i_lcj(tf_lay%i_niproc,tf_lay%i_njproc) ) 2891 2892 tf_lay%i_lci( 1 : il_resti , : ) = il_isize 2893 tf_lay%i_lci( il_resti+1 : tf_lay%i_niproc, : ) = il_isize-1 2894 2895 tf_lay%i_lcj( : , 1 : il_restj ) = il_jsize 2896 tf_lay%i_lcj( : , il_restj+1 : tf_lay%i_njproc) = il_jsize-1 2622 2897 2623 2898 ! compute first index of each sub domain 2624 ALLOCATE( t d_lay%i_impp(td_lay%i_niproc,td_lay%i_njproc) )2625 ALLOCATE( t d_lay%i_jmpp(td_lay%i_niproc,td_lay%i_njproc) )2626 2627 t d_lay%i_impp(:,:)=12628 t d_lay%i_jmpp(:,:)=12629 2630 IF( t d_lay%i_niproc > 1 )THEN2631 DO jj=1,t d_lay%i_njproc2632 DO ji=2,t d_lay%i_niproc2633 t d_lay%i_impp(ji,jj) = td_lay%i_impp(ji-1,jj) + &2634 & td_lay%i_lci (ji-1,jj) - 2*td_mpp%i_preci2899 ALLOCATE( tf_lay%i_impp(tf_lay%i_niproc,tf_lay%i_njproc) ) 2900 ALLOCATE( tf_lay%i_jmpp(tf_lay%i_niproc,tf_lay%i_njproc) ) 2901 2902 tf_lay%i_impp(:,:)=1 2903 tf_lay%i_jmpp(:,:)=1 2904 2905 IF( tf_lay%i_niproc > 1 )THEN 2906 DO jj=1,tf_lay%i_njproc 2907 DO ji=2,tf_lay%i_niproc 2908 tf_lay%i_impp(ji,jj) = tf_lay%i_impp(ji-1,jj) + & 2909 & tf_lay%i_lci (ji-1,jj) - 2*td_mpp%i_preci 2635 2910 ENDDO 2636 2911 ENDDO 2637 2912 ENDIF 2638 2913 2639 IF( t d_lay%i_njproc > 1 )THEN2640 DO jj=2,t d_lay%i_njproc2641 DO ji=1,t d_lay%i_niproc2642 t d_lay%i_jmpp(ji,jj) = td_lay%i_jmpp(ji,jj-1) + &2643 & td_lay%i_lcj (ji,jj-1) - 2*td_mpp%i_precj2914 IF( tf_lay%i_njproc > 1 )THEN 2915 DO jj=2,tf_lay%i_njproc 2916 DO ji=1,tf_lay%i_niproc 2917 tf_lay%i_jmpp(ji,jj) = tf_lay%i_jmpp(ji,jj-1) + & 2918 & tf_lay%i_lcj (ji,jj-1) - 2*td_mpp%i_precj 2644 2919 ENDDO 2645 2920 ENDDO 2646 2921 ENDIF 2647 2922 2648 ALLOCATE( td_lay%i_msk(td_lay%i_niproc,td_lay%i_njproc))2649 t d_lay%i_msk(:,:)=02923 ALLOCATE( tf_lay%i_msk(tf_lay%i_niproc,tf_lay%i_njproc) ) 2924 tf_lay%i_msk(:,:)=0 2650 2925 ! init number of sea/land proc 2651 t d_lay%i_nsea=02652 t d_lay%i_nland=td_lay%i_njproc*td_lay%i_niproc2926 tf_lay%i_nsea=0 2927 tf_lay%i_nland=tf_lay%i_njproc*tf_lay%i_niproc 2653 2928 2654 2929 ! check if processor is land or sea 2655 DO jj = 1,t d_lay%i_njproc2656 DO ji = 1,t d_lay%i_niproc2930 DO jj = 1,tf_lay%i_njproc 2931 DO ji = 1,tf_lay%i_niproc 2657 2932 2658 2933 ! compute first and last indoor indices … … 2672 2947 2673 2948 ! east boundary 2674 IF( ji == t d_lay%i_niproc )THEN2675 il_lei = t d_lay%i_lci(ji,jj)2949 IF( ji == tf_lay%i_niproc )THEN 2950 il_lei = tf_lay%i_lci(ji,jj) 2676 2951 ELSE 2677 il_lei = t d_lay%i_lci(ji,jj) - td_mpp%i_preci2952 il_lei = tf_lay%i_lci(ji,jj) - td_mpp%i_preci 2678 2953 ENDIF 2679 2954 2680 2955 ! north boundary 2681 IF( jj == t d_lay%i_njproc )THEN2682 il_lej = t d_lay%i_lcj(ji,jj)2956 IF( jj == tf_lay%i_njproc )THEN 2957 il_lej = tf_lay%i_lcj(ji,jj) 2683 2958 ELSE 2684 il_lej = t d_lay%i_lcj(ji,jj) - td_mpp%i_precj2685 ENDIF 2686 2687 ii1=t d_lay%i_impp(ji,jj) + il_ldi - 12688 ii2=t d_lay%i_impp(ji,jj) + il_lei - 12689 2690 ij1=t d_lay%i_jmpp(ji,jj) + il_ldj - 12691 ij2=t d_lay%i_jmpp(ji,jj) + il_lej - 12692 2693 t d_lay%i_msk(ji,jj)=SUM( id_mask(ii1:ii2,ij1:ij2) )2694 IF( t d_lay%i_msk(ji,jj) > 0 )THEN ! sea2695 t d_lay%i_nsea =td_lay%i_nsea +12696 t d_lay%i_nland=td_lay%i_nland-12959 il_lej = tf_lay%i_lcj(ji,jj) - td_mpp%i_precj 2960 ENDIF 2961 2962 ii1=tf_lay%i_impp(ji,jj) + il_ldi - 1 2963 ii2=tf_lay%i_impp(ji,jj) + il_lei - 1 2964 2965 ij1=tf_lay%i_jmpp(ji,jj) + il_ldj - 1 2966 ij2=tf_lay%i_jmpp(ji,jj) + il_lej - 1 2967 2968 tf_lay%i_msk(ji,jj)=SUM( id_mask(ii1:ii2,ij1:ij2) ) 2969 IF( tf_lay%i_msk(ji,jj) > 0 )THEN ! sea 2970 tf_lay%i_nsea =tf_lay%i_nsea +1 2971 tf_lay%i_nland=tf_lay%i_nland-1 2697 2972 ENDIF 2698 2973 … … 2700 2975 ENDDO 2701 2976 2702 CALL logger_info( "MPP COMPUTE LAYOUT: sea proc "//TRIM(fct_str(t d_lay%i_nsea)))2703 CALL logger_info( "MPP COMPUTE LAYOUT: land proc "//TRIM(fct_str(t d_lay%i_nland)))2704 CALL logger_info( "MPP COMPUTE LAYOUT: sum "//TRIM(fct_str( SUM(t d_lay%i_msk(:,:)))))2705 2706 t d_lay%i_mean= SUM(td_lay%i_msk(:,:)) / td_lay%i_nsea2707 t d_lay%i_min = MINVAL(td_lay%i_msk(:,:),td_lay%i_msk(:,:)/=0)2708 t d_lay%i_max = MAXVAL(td_lay%i_msk(:,:))2977 CALL logger_info( "MPP COMPUTE LAYOUT: sea proc "//TRIM(fct_str(tf_lay%i_nsea))) 2978 CALL logger_info( "MPP COMPUTE LAYOUT: land proc "//TRIM(fct_str(tf_lay%i_nland))) 2979 CALL logger_info( "MPP COMPUTE LAYOUT: sum "//TRIM(fct_str( SUM(tf_lay%i_msk(:,:))))) 2980 2981 tf_lay%i_mean= SUM(tf_lay%i_msk(:,:)) / tf_lay%i_nsea 2982 tf_lay%i_min = MINVAL(tf_lay%i_msk(:,:),tf_lay%i_msk(:,:)/=0) 2983 tf_lay%i_max = MAXVAL(tf_lay%i_msk(:,:)) 2709 2984 2710 2985 IF( lm_layout )THEN 2711 2986 ! print info 2712 2987 WRITE(im_iumout,*) ' ' 2713 WRITE(im_iumout,*) " jpni=",t d_lay%i_niproc ," jpnj=",td_lay%i_njproc2988 WRITE(im_iumout,*) " jpni=",tf_lay%i_niproc ," jpnj=",tf_lay%i_njproc 2714 2989 WRITE(im_iumout,*) " jpi= ",il_isize," jpj= ",il_jsize 2715 2990 WRITE(im_iumout,*) " iresti=",td_mpp%i_preci," irestj=",td_mpp%i_precj 2716 2991 2717 2992 2718 WRITE(im_iumout,*) ' nombre de processeurs ',t d_lay%i_niproc*td_lay%i_njproc2719 WRITE(im_iumout,*) ' nombre de processeurs mer ',t d_lay%i_nsea2720 WRITE(im_iumout,*) ' nombre de processeurs terre ',t d_lay%i_nland2721 WRITE(im_iumout,*) ' moyenne de recouvrement ',t d_lay%i_mean2722 WRITE(im_iumout,*) ' minimum de recouvrement ',t d_lay%i_min2723 WRITE(im_iumout,*) ' maximum de recouvrement ',t d_lay%i_max2993 WRITE(im_iumout,*) ' nombre de processeurs ',tf_lay%i_niproc*tf_lay%i_njproc 2994 WRITE(im_iumout,*) ' nombre de processeurs mer ',tf_lay%i_nsea 2995 WRITE(im_iumout,*) ' nombre de processeurs terre ',tf_lay%i_nland 2996 WRITE(im_iumout,*) ' moyenne de recouvrement ',tf_lay%i_mean 2997 WRITE(im_iumout,*) ' minimum de recouvrement ',tf_lay%i_min 2998 WRITE(im_iumout,*) ' maximum de recouvrement ',tf_lay%i_max 2724 2999 ENDIF 2725 3000 2726 3001 END FUNCTION layout__init 3002 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3003 SUBROUTINE layout__clean(td_lay) 2727 3004 !------------------------------------------------------------------- 2728 3005 !> @brief … … 2731 3008 !> @author J.Paul 2732 3009 !> @date October, 2015 - Initial version 3010 !> @date January, 2019 3011 !> - nullify array in layout structure 2733 3012 !> 2734 3013 !> @param[inout] td_lay domain layout strcuture 2735 3014 !------------------------------------------------------------------- 2736 SUBROUTINE layout__clean( td_lay ) 3015 2737 3016 IMPLICIT NONE 3017 2738 3018 ! Argument 2739 3019 TYPE(TLAY), INTENT(INOUT) :: td_lay … … 2742 3022 IF( ASSOCIATED(td_lay%i_msk) )THEN 2743 3023 DEALLOCATE(td_lay%i_msk) 3024 NULLIFY(td_lay%i_msk) 2744 3025 ENDIF 2745 3026 IF( ASSOCIATED(td_lay%i_impp) )THEN 2746 3027 DEALLOCATE(td_lay%i_impp) 3028 NULLIFY(td_lay%i_impp) 2747 3029 ENDIF 2748 3030 IF( ASSOCIATED(td_lay%i_jmpp) )THEN 2749 3031 DEALLOCATE(td_lay%i_jmpp) 3032 NULLIFY(td_lay%i_jmpp) 2750 3033 ENDIF 2751 3034 IF( ASSOCIATED(td_lay%i_lci) )THEN 2752 3035 DEALLOCATE(td_lay%i_lci) 3036 NULLIFY(td_lay%i_lci) 2753 3037 ENDIF 2754 3038 IF( ASSOCIATED(td_lay%i_lcj) )THEN 2755 3039 DEALLOCATE(td_lay%i_lcj) 3040 NULLIFY(td_lay%i_lcj) 2756 3041 ENDIF 2757 3042 … … 2766 3051 2767 3052 END SUBROUTINE layout__clean 3053 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3054 FUNCTION layout__copy(td_lay) & 3055 & RESULT(tf_lay) 2768 3056 !------------------------------------------------------------------- 2769 3057 !> @brief … … 2778 3066 !> @author J.Paul 2779 3067 !> @date October, 2015 - Initial Version 2780 ! 3068 !> 2781 3069 !> @param[in] td_lay domain layout structure 2782 3070 !> @return copy of input domain layout structure 2783 3071 !------------------------------------------------------------------- 2784 FUNCTION layout__copy( td_lay ) 3072 2785 3073 IMPLICIT NONE 3074 2786 3075 ! Argument 2787 3076 TYPE(TLAY), INTENT(IN) :: td_lay 2788 3077 ! function 2789 TYPE(TLAY) :: layout__copy3078 TYPE(TLAY) :: tf_lay 2790 3079 2791 3080 ! local variable … … 2796 3085 2797 3086 ! copy scalar 2798 layout__copy%i_niproc = td_lay%i_niproc2799 layout__copy%i_njproc = td_lay%i_njproc2800 layout__copy%i_nland = td_lay%i_nland2801 layout__copy%i_nsea = td_lay%i_nsea2802 layout__copy%i_mean = td_lay%i_mean2803 layout__copy%i_min = td_lay%i_min2804 layout__copy%i_max = td_lay%i_max3087 tf_lay%i_niproc = td_lay%i_niproc 3088 tf_lay%i_njproc = td_lay%i_njproc 3089 tf_lay%i_nland = td_lay%i_nland 3090 tf_lay%i_nsea = td_lay%i_nsea 3091 tf_lay%i_mean = td_lay%i_mean 3092 tf_lay%i_min = td_lay%i_min 3093 tf_lay%i_max = td_lay%i_max 2805 3094 2806 3095 ! copy pointers 2807 IF( ASSOCIATED( layout__copy%i_msk) )THEN2808 DEALLOCATE( layout__copy%i_msk)3096 IF( ASSOCIATED(tf_lay%i_msk) )THEN 3097 DEALLOCATE(tf_lay%i_msk) 2809 3098 ENDIF 2810 3099 IF( ASSOCIATED(td_lay%i_msk) )THEN 2811 3100 il_shape(:)=SHAPE(td_lay%i_msk(:,:)) 2812 ALLOCATE( layout__copy%i_msk(il_shape(jp_I),il_shape(jp_J)) )2813 layout__copy%i_msk(:,:)=td_lay%i_msk(:,:)2814 ENDIF 2815 2816 IF( ASSOCIATED( layout__copy%i_msk) ) DEALLOCATE(layout__copy%i_msk)3101 ALLOCATE( tf_lay%i_msk(il_shape(jp_I),il_shape(jp_J)) ) 3102 tf_lay%i_msk(:,:)=td_lay%i_msk(:,:) 3103 ENDIF 3104 3105 IF( ASSOCIATED(tf_lay%i_msk) ) DEALLOCATE(tf_lay%i_msk) 2817 3106 IF( ASSOCIATED(td_lay%i_msk) )THEN 2818 3107 il_shape(:)=SHAPE(td_lay%i_msk(:,:)) … … 2820 3109 il_tmp(:,:)=td_lay%i_msk(:,:) 2821 3110 2822 ALLOCATE( layout__copy%i_msk(il_shape(jp_I),il_shape(jp_J)) )2823 layout__copy%i_msk(:,:)=il_tmp(:,:)3111 ALLOCATE( tf_lay%i_msk(il_shape(jp_I),il_shape(jp_J)) ) 3112 tf_lay%i_msk(:,:)=il_tmp(:,:) 2824 3113 2825 3114 DEALLOCATE(il_tmp) 2826 3115 ENDIF 2827 3116 2828 IF( ASSOCIATED( layout__copy%i_impp) ) DEALLOCATE(layout__copy%i_impp)3117 IF( ASSOCIATED(tf_lay%i_impp) ) DEALLOCATE(tf_lay%i_impp) 2829 3118 IF( ASSOCIATED(td_lay%i_impp) )THEN 2830 3119 il_shape(:)=SHAPE(td_lay%i_impp(:,:)) … … 2832 3121 il_tmp(:,:)=td_lay%i_impp(:,:) 2833 3122 2834 ALLOCATE( layout__copy%i_impp(il_shape(jp_I),il_shape(jp_J)) )2835 layout__copy%i_impp(:,:)=il_tmp(:,:)3123 ALLOCATE( tf_lay%i_impp(il_shape(jp_I),il_shape(jp_J)) ) 3124 tf_lay%i_impp(:,:)=il_tmp(:,:) 2836 3125 2837 3126 DEALLOCATE(il_tmp) 2838 3127 ENDIF 2839 3128 2840 IF( ASSOCIATED( layout__copy%i_jmpp) ) DEALLOCATE(layout__copy%i_jmpp)3129 IF( ASSOCIATED(tf_lay%i_jmpp) ) DEALLOCATE(tf_lay%i_jmpp) 2841 3130 IF( ASSOCIATED(td_lay%i_jmpp) )THEN 2842 3131 il_shape(:)=SHAPE(td_lay%i_jmpp(:,:)) … … 2844 3133 il_tmp(:,:)=td_lay%i_jmpp(:,:) 2845 3134 2846 ALLOCATE( layout__copy%i_jmpp(il_shape(jp_I),il_shape(jp_J)) )2847 layout__copy%i_jmpp(:,:)=il_tmp(:,:)3135 ALLOCATE( tf_lay%i_jmpp(il_shape(jp_I),il_shape(jp_J)) ) 3136 tf_lay%i_jmpp(:,:)=il_tmp(:,:) 2848 3137 2849 3138 DEALLOCATE(il_tmp) 2850 3139 ENDIF 2851 3140 2852 IF( ASSOCIATED( layout__copy%i_lci) ) DEALLOCATE(layout__copy%i_lci)3141 IF( ASSOCIATED(tf_lay%i_lci) ) DEALLOCATE(tf_lay%i_lci) 2853 3142 IF( ASSOCIATED(td_lay%i_lci) )THEN 2854 3143 il_shape(:)=SHAPE(td_lay%i_lci(:,:)) … … 2856 3145 il_tmp(:,:)=td_lay%i_lci(:,:) 2857 3146 2858 ALLOCATE( layout__copy%i_lci(il_shape(jp_I),il_shape(jp_J)) )2859 layout__copy%i_lci(:,:)=il_tmp(:,:)3147 ALLOCATE( tf_lay%i_lci(il_shape(jp_I),il_shape(jp_J)) ) 3148 tf_lay%i_lci(:,:)=il_tmp(:,:) 2860 3149 2861 3150 DEALLOCATE(il_tmp) 2862 3151 ENDIF 2863 3152 2864 IF( ASSOCIATED( layout__copy%i_lcj) ) DEALLOCATE(layout__copy%i_lcj)3153 IF( ASSOCIATED(tf_lay%i_lcj) ) DEALLOCATE(tf_lay%i_lcj) 2865 3154 IF( ASSOCIATED(td_lay%i_lcj) )THEN 2866 3155 il_shape(:)=SHAPE(td_lay%i_lcj(:,:)) … … 2868 3157 il_tmp(:,:)=td_lay%i_lcj(:,:) 2869 3158 2870 ALLOCATE( layout__copy%i_lcj(il_shape(jp_I),il_shape(jp_J)) )2871 layout__copy%i_lcj(:,:)=il_tmp(:,:)3159 ALLOCATE( tf_lay%i_lcj(il_shape(jp_I),il_shape(jp_J)) ) 3160 tf_lay%i_lcj(:,:)=il_tmp(:,:) 2872 3161 2873 3162 DEALLOCATE(il_tmp) … … 2875 3164 2876 3165 END FUNCTION layout__copy 3166 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3167 SUBROUTINE mpp__create_layout(td_mpp, td_lay) 2877 3168 !------------------------------------------------------------------- 2878 3169 !> @brief … … 2880 3171 !> 2881 3172 !> @detail 2882 ! 3173 !> 2883 3174 !> @author J.Paul 2884 3175 !> @date October, 2015 - Initial version 2885 ! 3176 !> @date August, 2017 3177 !> - handle use of domain decomposition for monoproc file 3178 !> 2886 3179 !> @param[inout] td_mpp mpp strcuture 2887 3180 !> @param[in] td_lay domain layout structure 2888 3181 !------------------------------------------------------------------- 2889 SUBROUTINE mpp__create_layout( td_mpp, td_lay ) 3182 2890 3183 IMPLICIT NONE 3184 2891 3185 ! Argument 2892 3186 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 2895 3189 ! local variable 2896 3190 CHARACTER(LEN=lc) :: cl_file 2897 TYPE(TFILE) :: tl_proc2898 3191 TYPE(TATT) :: tl_att 3192 3193 TYPE(TFILE), DIMENSION(:), ALLOCATABLE :: tl_proc 2899 3194 2900 3195 ! loop indices … … 2944 3239 ENDIF 2945 3240 2946 jk=0 3241 ALLOCATE(tl_proc(td_lay%i_nsea)) 3242 jk=1 2947 3243 DO jj=1,td_lay%i_njproc 2948 3244 DO ji=1,td_lay%i_niproc … … 2951 3247 2952 3248 ! get processor file name 2953 cl_file=file_rename(td_mpp%c_name,jk) 3249 IF( td_mpp%l_usempp )THEN 3250 cl_file=file_rename(td_mpp%c_name,jk) 3251 ELSE 3252 cl_file=TRIM(td_mpp%c_name) 3253 ENDIF 2954 3254 ! initialise file structure 2955 tl_proc =file_init(cl_file,td_mpp%c_type)3255 tl_proc(jk)=file_init(cl_file,td_mpp%c_type) 2956 3256 2957 3257 ! procesor id 2958 tl_proc %i_pid=jk2959 2960 tl_att=att_init("DOMAIN_number",tl_proc %i_pid)2961 CALL file_add_att(tl_proc , tl_att)3258 tl_proc(jk)%i_pid=jk-1 3259 3260 tl_att=att_init("DOMAIN_number",tl_proc(jk)%i_pid) 3261 CALL file_add_att(tl_proc(jk), tl_att) 2962 3262 2963 3263 ! processor indices 2964 tl_proc %i_iind=ji2965 tl_proc %i_jind=jj3264 tl_proc(jk)%i_iind=ji 3265 tl_proc(jk)%i_jind=jj 2966 3266 2967 3267 ! fill processor dimension and first indices 2968 tl_proc %i_impp = td_lay%i_impp(ji,jj)2969 tl_proc %i_jmpp = td_lay%i_jmpp(ji,jj)2970 2971 tl_proc %i_lci = td_lay%i_lci(ji,jj)2972 tl_proc %i_lcj = td_lay%i_lcj(ji,jj)3268 tl_proc(jk)%i_impp = td_lay%i_impp(ji,jj) 3269 tl_proc(jk)%i_jmpp = td_lay%i_jmpp(ji,jj) 3270 3271 tl_proc(jk)%i_lci = td_lay%i_lci(ji,jj) 3272 tl_proc(jk)%i_lcj = td_lay%i_lcj(ji,jj) 2973 3273 2974 3274 ! compute first and last indoor indices 2975 3275 2976 3276 ! west boundary 2977 3277 IF( ji == 1 )THEN 2978 tl_proc %i_ldi = 12979 tl_proc %l_ctr = .TRUE.3278 tl_proc(jk)%i_ldi = 1 3279 tl_proc(jk)%l_ctr = .TRUE. 2980 3280 ELSE 2981 tl_proc %i_ldi = 1 + td_mpp%i_preci3281 tl_proc(jk)%i_ldi = 1 + td_mpp%i_preci 2982 3282 ENDIF 2983 3283 2984 3284 ! south boundary 2985 3285 IF( jj == 1 )THEN 2986 tl_proc %i_ldj = 12987 tl_proc %l_ctr = .TRUE.3286 tl_proc(jk)%i_ldj = 1 3287 tl_proc(jk)%l_ctr = .TRUE. 2988 3288 ELSE 2989 tl_proc %i_ldj = 1 + td_mpp%i_precj3289 tl_proc(jk)%i_ldj = 1 + td_mpp%i_precj 2990 3290 ENDIF 2991 3291 2992 3292 ! east boundary 2993 3293 IF( ji == td_mpp%i_niproc )THEN 2994 tl_proc %i_lei = td_lay%i_lci(ji,jj)2995 tl_proc %l_ctr = .TRUE.3294 tl_proc(jk)%i_lei = td_lay%i_lci(ji,jj) 3295 tl_proc(jk)%l_ctr = .TRUE. 2996 3296 ELSE 2997 tl_proc %i_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci3297 tl_proc(jk)%i_lei = td_lay%i_lci(ji,jj) - td_mpp%i_preci 2998 3298 ENDIF 2999 3299 3000 3300 ! north boundary 3001 3301 IF( jj == td_mpp%i_njproc )THEN 3002 tl_proc %i_lej = td_lay%i_lcj(ji,jj)3003 tl_proc %l_ctr = .TRUE.3302 tl_proc(jk)%i_lej = td_lay%i_lcj(ji,jj) 3303 tl_proc(jk)%l_ctr = .TRUE. 3004 3304 ELSE 3005 tl_proc %i_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj3305 tl_proc(jk)%i_lej = td_lay%i_lcj(ji,jj) - td_mpp%i_precj 3006 3306 ENDIF 3007 3008 ! add processor to mpp structure3009 CALL mpp__add_proc(td_mpp, tl_proc)3010 3307 3011 3308 ! clean 3012 3309 CALL att_clean(tl_att) 3013 CALL file_clean(tl_proc)3014 3310 3015 3311 ! update proc number 3016 jk=jk+1 !ji+(jj-1)*td_lay%i_niproc3312 jk=jk+1 3017 3313 3018 3314 ENDIF 3019 3315 ENDDO 3020 3316 ENDDO 3317 ! 3318 CALL mpp__add_proc(td_mpp, tl_proc(:)) 3319 DEALLOCATE(tl_proc) 3021 3320 3022 3321 END SUBROUTINE mpp__create_layout 3322 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3323 SUBROUTINE mpp__optimiz(td_mpp, id_mask, id_nproc) 3023 3324 !------------------------------------------------------------------- 3024 3325 !> @brief … … 3029 3330 !> If no land processor could be removed, it get the decomposition with the 3030 3331 !> most sea processors. 3031 ! 3332 !> 3032 3333 !> @author J.Paul 3033 3334 !> @date November, 2013 - Initial version … … 3036 3337 !> @date February, 2016 3037 3338 !> - new criteria for domain layout in case no land proc 3038 ! 3339 !> 3039 3340 !> @param[inout] td_mpp mpp strcuture 3040 3341 !> @param[in] id_mask sub domain mask (sea=1, land=0) 3041 3342 !> @pram[in] id_nproc maximum number of processor to be used 3042 3343 !------------------------------------------------------------------- 3043 SUBROUTINE mpp__optimiz( td_mpp, id_mask, id_nproc )3344 3044 3345 IMPLICIT NONE 3346 3045 3347 ! Argument 3046 3348 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 3127 3429 3128 3430 END SUBROUTINE mpp__optimiz 3431 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3432 SUBROUTINE mpp__clean_unit(td_mpp) 3129 3433 !------------------------------------------------------------------- 3130 3434 !> @brief … … 3133 3437 !> @author J.Paul 3134 3438 !> @date November, 2013 - Initial version 3439 !> @date January, 2019 3440 !> - nullify file structure inside mpp structure 3135 3441 !> 3136 3442 !> @param[inout] td_mpp mpp strcuture 3137 3443 !------------------------------------------------------------------- 3138 SUBROUTINE mpp__clean_unit( td_mpp ) 3444 3139 3445 IMPLICIT NONE 3446 3140 3447 ! Argument 3141 3448 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 3159 3466 CALL file_clean( td_mpp%t_proc(:) ) 3160 3467 DEALLOCATE(td_mpp%t_proc) 3468 NULLIFY(td_mpp%t_proc) 3161 3469 ENDIF 3162 3470 … … 3165 3473 3166 3474 END SUBROUTINE mpp__clean_unit 3475 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3167 3476 !------------------------------------------------------------------- 3168 3477 !> @brief … … 3174 3483 !> @param[inout] td_mpp mpp strcuture 3175 3484 !------------------------------------------------------------------- 3176 SUBROUTINE mpp__clean_arr( td_mpp ) 3485 SUBROUTINE mpp__clean_arr(td_mpp) 3486 3177 3487 IMPLICIT NONE 3178 3488 ! Argument … … 3189 3499 3190 3500 END SUBROUTINE mpp__clean_arr 3501 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3502 SUBROUTINE mpp__get_use_unit(td_mpp, id_imin, id_imax, id_jmin, id_jmax) 3191 3503 !------------------------------------------------------------------- 3192 3504 !> @brief 3193 3505 !> This subroutine get sub domains which cover "zoom domain". 3506 !> proc use in "zoom domain" 3194 3507 !> 3195 3508 !> @author J.Paul … … 3202 3515 !> @param[in] id_jmax j-direction upper indice 3203 3516 !------------------------------------------------------------------- 3204 SUBROUTINE mpp__get_use_unit( td_mpp, id_imin, id_imax, & 3205 & id_jmin, id_jmax ) 3517 3206 3518 IMPLICIT NONE 3519 3207 3520 ! Argument 3208 3521 TYPE(TMPP) , INTENT(INOUT) :: td_mpp … … 3224 3537 INTEGER(i4) :: jk 3225 3538 !---------------------------------------------------------------- 3539 3226 3540 IF( ASSOCIATED(td_mpp%t_proc) )THEN 3227 3541 … … 3310 3624 3311 3625 END SUBROUTINE mpp__get_use_unit 3626 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3627 SUBROUTINE mpp_get_contour(td_mpp) 3312 3628 !------------------------------------------------------------------- 3313 3629 !> @brief … … 3319 3635 !> @param[inout] td_mpp mpp strcuture 3320 3636 !------------------------------------------------------------------- 3321 SUBROUTINE mpp_get_contour( td_mpp )3637 3322 3638 IMPLICIT NONE 3639 3323 3640 ! Argument 3324 3641 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 3347 3664 3348 3665 END SUBROUTINE mpp_get_contour 3666 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3667 FUNCTION mpp_get_proc_index(td_mpp, id_procid) & 3668 & RESULT(if_idx) 3349 3669 !------------------------------------------------------------------- 3350 3670 !> @brief … … 3359 3679 !> @return array of index (/ i1, i2, j1, j2 /) 3360 3680 !------------------------------------------------------------------- 3361 FUNCTION mpp_get_proc_index( td_mpp, id_procid ) 3681 3362 3682 IMPLICIT NONE 3363 3683 … … 3367 3687 3368 3688 ! function 3369 INTEGER(i4), DIMENSION(4) :: mpp_get_proc_index3689 INTEGER(i4), DIMENSION(4) :: if_idx 3370 3690 3371 3691 ! local variable … … 3409 3729 END SELECT 3410 3730 3411 mpp_get_proc_index(:)=(/il_i1, il_i2, il_j1, il_j2/)3731 if_idx(:)=(/il_i1, il_i2, il_j1, il_j2/) 3412 3732 3413 3733 ELSE … … 3416 3736 3417 3737 END FUNCTION mpp_get_proc_index 3738 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3739 FUNCTION mpp_get_proc_size(td_mpp, id_procid) & 3740 & RESULT(if_size) 3418 3741 !------------------------------------------------------------------- 3419 3742 !> @brief 3420 3743 !> This function return processor domain size, depending of domain 3421 3744 !> decompisition type, given sub domain id. 3422 ! 3745 !> 3423 3746 !> @author J.Paul 3424 3747 !> @date November, 2013 - Initial version 3425 ! 3748 !> 3426 3749 !> @param[in] td_mpp mpp strcuture 3427 3750 !> @param[in] id_procid sub domain id 3428 3751 !> @return array of index (/ isize, jsize /) 3429 3752 !------------------------------------------------------------------- 3430 FUNCTION mpp_get_proc_size( td_mpp, id_procid ) 3753 3431 3754 IMPLICIT NONE 3432 3755 … … 3436 3759 3437 3760 ! function 3438 INTEGER(i4), DIMENSION(2) :: mpp_get_proc_size3761 INTEGER(i4), DIMENSION(2) :: if_size 3439 3762 3440 3763 ! local variable … … 3471 3794 END SELECT 3472 3795 3473 mpp_get_proc_size(:)=(/il_isize, il_jsize/)3796 if_size(:)=(/il_isize, il_jsize/) 3474 3797 3475 3798 ELSE … … 3478 3801 3479 3802 END FUNCTION mpp_get_proc_size 3803 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3804 SUBROUTINE mpp_get_dom(td_mpp) 3480 3805 !------------------------------------------------------------------- 3481 3806 !> @brief … … 3488 3813 !> @param[inout] td_mpp mpp strcuture 3489 3814 !------------------------------------------------------------------- 3490 SUBROUTINE mpp_get_dom( td_mpp )3815 3491 3816 IMPLICIT NONE 3817 3492 3818 ! Argument 3493 3819 TYPE(TMPP), INTENT(INOUT) :: td_mpp … … 3570 3896 3571 3897 END SUBROUTINE mpp_get_dom 3898 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 3899 FUNCTION mpp__check_var_dim(td_mpp, td_var) & 3900 & RESULT(lf_check) 3572 3901 !------------------------------------------------------------------- 3573 3902 !> @brief This function check if variable and mpp structure use same … … 3585 3914 !> @return dimension of variable and mpp structure agree (or not) 3586 3915 !------------------------------------------------------------------- 3587 LOGICAL FUNCTION mpp__check_var_dim(td_mpp, td_var) 3916 3588 3917 IMPLICIT NONE 3918 3589 3919 ! Argument 3590 3920 TYPE(TMPP), INTENT(IN) :: td_mpp 3591 3921 TYPE(TVAR), INTENT(IN) :: td_var 3922 3923 ! function 3924 LOGICAL :: lf_check 3592 3925 3593 3926 ! local variable … … 3601 3934 INTEGER(i4) :: ji 3602 3935 !---------------------------------------------------------------- 3603 mpp__check_var_dim=.TRUE. 3936 3937 lf_check=.TRUE. 3604 3938 3605 3939 ! check used dimension … … 3608 3942 DO ji=1,ip_maxdim 3609 3943 il_ind=dim_get_index( td_mpp%t_dim(:), & 3610 &TRIM(td_var%t_dim(ji)%c_name), &3611 &TRIM(td_var%t_dim(ji)%c_sname))3944 & TRIM(td_var%t_dim(ji)%c_name), & 3945 & TRIM(td_var%t_dim(ji)%c_sname)) 3612 3946 IF( il_ind /= 0 )THEN 3613 3947 IF( td_var%t_dim(ji)%l_use .AND. & 3614 &td_mpp%t_dim(il_ind)%l_use .AND. &3615 &td_var%t_dim(ji)%i_len /= td_mpp%t_dim(il_ind)%i_len )THEN3948 &td_mpp%t_dim(il_ind)%l_use .AND. & 3949 &td_var%t_dim(ji)%i_len /= td_mpp%t_dim(il_ind)%i_len )THEN 3616 3950 IF( INDEX( TRIM(td_var%c_axis), & 3617 &TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN3951 & TRIM(fct_upper(td_var%t_dim(ji)%c_name))) == 0 )THEN 3618 3952 ll_warn=.TRUE. 3619 3953 ELSE … … 3630 3964 IF( td_mpp%t_dim(ji)%l_use )THEN 3631 3965 cl_dim=TRIM(cl_dim)//& 3632 &TRIM(fct_upper(td_mpp%t_dim(ji)%c_sname))//':'//&3633 &TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//','3966 & TRIM(fct_upper(td_mpp%t_dim(ji)%c_sname))//':'//& 3967 & TRIM(fct_str(td_mpp%t_dim(ji)%i_len))//',' 3634 3968 ENDIF 3635 3969 ENDDO … … 3641 3975 IF( td_var%t_dim(ji)%l_use )THEN 3642 3976 cl_dim=TRIM(cl_dim)//& 3643 &TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//&3644 &TRIM(fct_str(td_var%t_dim(ji)%i_len))//','3977 & TRIM(fct_upper(td_var%t_dim(ji)%c_sname))//':'//& 3978 & TRIM(fct_str(td_var%t_dim(ji)%i_len))//',' 3645 3979 ENDIF 3646 3980 ENDDO … … 3648 3982 CALL logger_debug( " variable dimension: "//TRIM(cl_dim) ) 3649 3983 3650 mpp__check_var_dim=.FALSE.3984 lf_check=.FALSE. 3651 3985 3652 3986 CALL logger_error( & 3653 &" MPP CHECK VAR DIM: variable and file dimension differ"//&3654 &" for variable "//TRIM(td_var%c_name)//&3655 &" and file "//TRIM(td_mpp%c_name))3987 & " MPP CHECK VAR DIM: variable and file dimension differ"//& 3988 & " for variable "//TRIM(td_var%c_name)//& 3989 & " and file "//TRIM(td_mpp%c_name)) 3656 3990 3657 3991 ELSEIF( ll_warn )THEN 3658 3992 CALL logger_warn( & 3659 &" MPP CHECK VAR DIM: variable and file dimension differ"//&3660 &" for variable "//TRIM(td_var%c_name)//&3661 &" and file "//TRIM(td_mpp%c_name)//". you should use"//&3662 &" var_check_dim to remove useless dimension.")3993 & " MPP CHECK VAR DIM: variable and file dimension differ"//& 3994 & " for variable "//TRIM(td_var%c_name)//& 3995 & " and file "//TRIM(td_mpp%c_name)//". you should use"//& 3996 & " var_check_dim to remove useless dimension.") 3663 3997 ELSE 3664 3998 3665 3999 IF( td_var%i_ndim > td_mpp%i_ndim )THEN 3666 4000 CALL logger_info("MPP CHECK VAR DIM: variable "//& 3667 &TRIM(td_var%c_name)//" use more dimension than file "//&3668 &TRIM(td_mpp%c_name)//" do until now.")4001 & TRIM(td_var%c_name)//" use more dimension than file "//& 4002 & TRIM(td_mpp%c_name)//" do until now.") 3669 4003 ENDIF 3670 4004 … … 3672 4006 3673 4007 END FUNCTION mpp__check_var_dim 4008 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 4009 FUNCTION mpp_get_index(td_mpp, cd_name) & 4010 & RESULT(if_idx) 3674 4011 !------------------------------------------------------------------- 3675 4012 !> @brief This function return the mpp id, in a array of mpp 3676 4013 !> structure, given mpp base name. 3677 ! 4014 !> 3678 4015 !> @author J.Paul 3679 4016 !> @date November, 2013 - Initial Version 3680 ! 4017 !> 3681 4018 !> @param[in] td_file array of file structure 3682 4019 !> @param[in] cd_name file name 3683 4020 !> @return file id in array of file structure (0 if not found) 3684 4021 !------------------------------------------------------------------- 3685 INTEGER(i4) FUNCTION mpp_get_index(td_mpp, cd_name) 4022 3686 4023 IMPLICIT NONE 4024 3687 4025 ! Argument 3688 4026 TYPE(TMPP) , DIMENSION(:), INTENT(IN) :: td_mpp 3689 4027 CHARACTER(LEN=*), INTENT(IN) :: cd_name 3690 4028 4029 ! function 4030 INTEGER(i4) :: if_idx 4031 3691 4032 ! local variable 3692 4033 CHARACTER(LEN=lc) :: cl_name … … 3696 4037 INTEGER(i4) :: ji 3697 4038 !---------------------------------------------------------------- 3698 mpp_get_index=04039 if_idx=0 3699 4040 il_size=SIZE(td_mpp(:)) 3700 4041 … … 3706 4047 IF( TRIM(fct_lower(td_mpp(ji)%c_name)) == TRIM(fct_lower(cd_name)) )THEN 3707 4048 3708 mpp_get_index=ji4049 if_idx=ji 3709 4050 EXIT 3710 4051 … … 3713 4054 3714 4055 END FUNCTION mpp_get_index 3715 !------------------------------------------------------------------- 3716 !> @brief This function recombine variable splitted mpp structure. 3717 ! 4056 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 4057 FUNCTION mpp_recombine_var(td_mpp, cd_name) & 4058 & RESULT(tf_var) 4059 !------------------------------------------------------------------- 4060 !> @brief This function recombine variable splitted in mpp structure. 4061 !> 3718 4062 !> @author J.Paul 3719 !> @date Oc otber, 2014 - Initial Version3720 ! 4063 !> @date October, 2014 - Initial Version 4064 !> 3721 4065 !> @param[in] td_mpp mpp file structure 3722 4066 !> @param[in] cd_name variable name 3723 4067 !> @return variable strucutre 3724 4068 !------------------------------------------------------------------- 3725 TYPE(TVAR) FUNCTION mpp_recombine_var(td_mpp, cd_name) 3726 IMPLICIT NONE 4069 4070 IMPLICIT NONE 4071 3727 4072 ! Argument 3728 4073 TYPE(TMPP) , INTENT(IN) :: td_mpp 3729 4074 CHARACTER(LEN=*), INTENT(IN) :: cd_name 4075 ! function 4076 TYPE(TVAR) :: tf_var 3730 4077 3731 4078 ! local variable … … 3742 4089 3743 4090 TYPE(TVAR) :: tl_tmp 3744 TYPE(TVAR) :: tl_var3745 4091 3746 4092 ! loop indices … … 3752 4098 IF( il_varid /= 0 )THEN 3753 4099 3754 t l_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid))4100 tf_var=var_copy(td_mpp%t_proc(1)%t_var(il_varid)) 3755 4101 ! Allocate space to hold variable value in structure 3756 IF( ASSOCIATED(t l_var%d_value) )THEN3757 DEALLOCATE(t l_var%d_value)4102 IF( ASSOCIATED(tf_var%d_value) )THEN 4103 DEALLOCATE(tf_var%d_value) 3758 4104 ENDIF 3759 4105 ! 3760 4106 DO ji=1,ip_maxdim 3761 IF( t l_var%t_dim(ji)%l_use )THEN3762 t l_var%t_dim(ji)%i_len=td_mpp%t_dim(ji)%i_len4107 IF( tf_var%t_dim(ji)%l_use )THEN 4108 tf_var%t_dim(ji)%i_len=td_mpp%t_dim(ji)%i_len 3763 4109 ENDIF 3764 4110 ENDDO 3765 4111 3766 ALLOCATE(t l_var%d_value( tl_var%t_dim(1)%i_len, &3767 & tl_var%t_dim(2)%i_len, &3768 & tl_var%t_dim(3)%i_len, &3769 & tl_var%t_dim(4)%i_len),&3770 &stat=il_status)4112 ALLOCATE(tf_var%d_value( tf_var%t_dim(1)%i_len, & 4113 & tf_var%t_dim(2)%i_len, & 4114 & tf_var%t_dim(3)%i_len, & 4115 & tf_var%t_dim(4)%i_len),& 4116 & stat=il_status) 3771 4117 IF(il_status /= 0 )THEN 3772 4118 3773 4119 CALL logger_error( & 3774 & " MPP RECOMBINE VAR: not enough space to put variable "//&3775 & TRIM(tl_var%c_name)//" in variable structure")4120 & " MPP RECOMBINE VAR: not enough space to put variable "//& 4121 & TRIM(tf_var%c_name)//" in variable structure") 3776 4122 3777 4123 ENDIF 3778 4124 3779 4125 ! FillValue by default 3780 t l_var%d_value(:,:,:,:)=tl_var%d_fill4126 tf_var%d_value(:,:,:,:)=tf_var%d_fill 3781 4127 3782 4128 ! read processor … … 3793 4139 3794 4140 il_cnt(:)=(/ il_i2p-il_i1p+1, & 3795 &il_j2p-il_j1p+1, &3796 & tl_var%t_dim(3)%i_len, &3797 & tl_var%t_dim(4)%i_len /)3798 3799 tl_tmp=iom_read_var( td_mpp%t_proc(jk), t l_var%c_name,&3800 &il_strt(:), il_cnt(:) )4141 & il_j2p-il_j1p+1, & 4142 & tf_var%t_dim(3)%i_len, & 4143 & tf_var%t_dim(4)%i_len /) 4144 4145 tl_tmp=iom_read_var( td_mpp%t_proc(jk), tf_var%c_name,& 4146 & il_strt(:), il_cnt(:) ) 3801 4147 3802 4148 ! replace value in output variable structure 3803 t l_var%d_value( il_i1p : il_i2p, &3804 &il_j1p : il_j2p, &3805 &:,:) = tl_tmp%d_value(:,:,:,:)4149 tf_var%d_value( il_i1p : il_i2p, & 4150 & il_j1p : il_j2p, & 4151 & :,:) = tl_tmp%d_value(:,:,:,:) 3806 4152 3807 4153 ! clean … … 3811 4157 ENDDO 3812 4158 3813 mpp_recombine_var=var_copy(tl_var)3814 3815 ! clean3816 CALL var_clean(tl_var)3817 3818 4159 ELSE 3819 4160 3820 4161 CALL logger_error( & 3821 & " MPP RECOMBINE VAR: there is no variable with "//& 3822 & "name or standard name"//TRIM(cd_name)//& 3823 & " in mpp file "//TRIM(td_mpp%c_name)) 3824 ENDIF 4162 & " MPP RECOMBINE VAR: there is no variable with "//& 4163 & "name or standard name"//TRIM(cd_name)//& 4164 & " in mpp file "//TRIM(td_mpp%c_name)) 4165 ENDIF 4166 3825 4167 END FUNCTION mpp_recombine_var 4168 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 4169 SUBROUTINE mpp__read_halo(td_file, td_dimglo) 3826 4170 !------------------------------------------------------------------- 3827 4171 !> @brief This subroutine read subdomain indices defined with halo … … 3833 4177 !> @param[inout] td_file mpp structure 3834 4178 !------------------------------------------------------------------- 3835 SUBROUTINE mpp__read_halo(td_file, td_dimglo) 3836 IMPLICIT NONE 4179 4180 IMPLICIT NONE 4181 3837 4182 ! Argument 3838 4183 TYPE(TFILE) , INTENT(INOUT) :: td_file … … 3946 4291 3947 4292 END SUBROUTINE mpp__read_halo 4293 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 4294 SUBROUTINE mpp__compute_halo(td_mpp) 3948 4295 !------------------------------------------------------------------- 3949 4296 !> @brief This subroutine compute subdomain indices defined with halo … … 3955 4302 !> @param[inout] td_mpp mpp structure 3956 4303 !------------------------------------------------------------------- 3957 SUBROUTINE mpp__compute_halo(td_mpp) 3958 IMPLICIT NONE 4304 4305 IMPLICIT NONE 4306 3959 4307 ! Argument 3960 4308 TYPE(TMPP) , INTENT(INOUT) :: td_mpp … … 4098 4446 4099 4447 END SUBROUTINE mpp__compute_halo 4448 !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ 4100 4449 END MODULE mpp 4101 4450
Note: See TracChangeset
for help on using the changeset viewer.
