Changeset 5682 for branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
- Timestamp:
- 2015-08-12T17:46:45+02:00 (9 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5072_UKMO2_OBS_simplification/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4990 r5682 71 71 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 72 72 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 PUBLIC mpp_lnk_2d_9 73 74 PUBLIC mppscatter, mppgather 74 75 PUBLIC mpp_ini_ice, mpp_ini_znl … … 78 79 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 79 80 81 TYPE arrayptr 82 REAL , DIMENSION (:,:), POINTER :: pt2d 83 END TYPE arrayptr 84 80 85 !! * Interfaces 81 86 !! define generic interface for these routine as they are called sometimes … … 164 169 165 170 166 FUNCTION mynode( ldtxt, kumnam_ref , kumnam_cfg , kumond , kstop, localComm )171 FUNCTION mynode( ldtxt, ldname, kumnam_ref , kumnam_cfg , kumond , kstop, localComm ) 167 172 !!---------------------------------------------------------------------- 168 173 !! *** routine mynode *** … … 171 176 !!---------------------------------------------------------------------- 172 177 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 178 CHARACTER(len=*) , INTENT(in ) :: ldname 173 179 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 174 180 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist … … 292 298 ENDIF 293 299 300 #if defined key_agrif 301 IF (Agrif_Root()) THEN 302 CALL Agrif_MPI_Init(mpi_comm_opa) 303 ELSE 304 CALL Agrif_MPI_set_grid_comm(mpi_comm_opa) 305 ENDIF 306 #endif 307 294 308 CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 295 309 CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) … … 297 311 298 312 IF( mynode == 0 ) THEN 299 CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )300 WRITE(kumond, nammpp)313 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 314 WRITE(kumond, nammpp) 301 315 ENDIF 302 316 ! … … 510 524 ! 511 525 END SUBROUTINE mpp_lnk_3d 526 527 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) 528 !!---------------------------------------------------------------------- 529 !! *** routine mpp_lnk_2d_multiple *** 530 !! 531 !! ** Purpose : Message passing management for multiple 2d arrays 532 !! 533 !! ** Method : Use mppsend and mpprecv function for passing mask 534 !! between processors following neighboring subdomains. 535 !! domain parameters 536 !! nlci : first dimension of the local subdomain 537 !! nlcj : second dimension of the local subdomain 538 !! nbondi : mark for "east-west local boundary" 539 !! nbondj : mark for "north-south local boundary" 540 !! noea : number for local neighboring processors 541 !! nowe : number for local neighboring processors 542 !! noso : number for local neighboring processors 543 !! nono : number for local neighboring processors 544 !! 545 !!---------------------------------------------------------------------- 546 547 INTEGER :: num_fields 548 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 549 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 550 ! ! = T , U , V , F , W and I points 551 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 552 ! ! = 1. , the sign is kept 553 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 554 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 555 !! 556 INTEGER :: ji, jj, jl ! dummy loop indices 557 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 558 INTEGER :: imigr, iihom, ijhom ! temporary integers 559 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 560 561 REAL(wp) :: zland 562 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 563 ! 564 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 565 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 566 567 !!---------------------------------------------------------------------- 568 569 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 570 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 571 572 ! 573 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 574 ELSE ; zland = 0.e0 ! zero by default 575 ENDIF 576 577 ! 1. standard boundary treatment 578 ! ------------------------------ 579 ! 580 !First Array 581 DO ii = 1 , num_fields 582 IF( PRESENT( cd_mpp ) ) THEN ! only fill added line/raw with existing values 583 ! 584 ! WARNING pt2d is defined only between nld and nle 585 DO jj = nlcj+1, jpj ! added line(s) (inner only) 586 pt2d_array(ii)%pt2d(nldi :nlei , jj) = pt2d_array(ii)%pt2d(nldi:nlei, nlej) 587 pt2d_array(ii)%pt2d(1 :nldi-1, jj) = pt2d_array(ii)%pt2d(nldi , nlej) 588 pt2d_array(ii)%pt2d(nlei+1:nlci , jj) = pt2d_array(ii)%pt2d( nlei, nlej) 589 END DO 590 DO ji = nlci+1, jpi ! added column(s) (full) 591 pt2d_array(ii)%pt2d(ji, nldj :nlej ) = pt2d_array(ii)%pt2d(nlei, nldj:nlej) 592 pt2d_array(ii)%pt2d(ji, 1 :nldj-1) = pt2d_array(ii)%pt2d(nlei, nldj ) 593 pt2d_array(ii)%pt2d(ji, nlej+1:jpj ) = pt2d_array(ii)%pt2d(nlei, nlej) 594 END DO 595 ! 596 ELSE ! standard close or cyclic treatment 597 ! 598 ! ! East-West boundaries 599 IF( nbondi == 2 .AND. & ! Cyclic east-west 600 & (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 601 pt2d_array(ii)%pt2d( 1 , : ) = pt2d_array(ii)%pt2d( jpim1, : ) ! west 602 pt2d_array(ii)%pt2d( jpi , : ) = pt2d_array(ii)%pt2d( 2 , : ) ! east 603 ELSE ! closed 604 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d( 1 : jpreci,:) = zland ! south except F-point 605 pt2d_array(ii)%pt2d(nlci-jpreci+1 : jpi ,:) = zland ! north 606 ENDIF 607 ! ! North-South boundaries (always closed) 608 IF( .NOT. type_array(ii) == 'F' ) pt2d_array(ii)%pt2d(:, 1:jprecj ) = zland ! south except F-point 609 pt2d_array(ii)%pt2d(:, nlcj-jprecj+1:jpj ) = zland ! north 610 ! 611 ENDIF 612 END DO 613 614 ! 2. East and west directions exchange 615 ! ------------------------------------ 616 ! we play with the neigbours AND the row number because of the periodicity 617 ! 618 DO ii = 1 , num_fields 619 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 620 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 621 iihom = nlci-nreci 622 DO jl = 1, jpreci 623 zt2ew( : , jl , ii ) = pt2d_array(ii)%pt2d( jpreci+jl , : ) 624 zt2we( : , jl , ii ) = pt2d_array(ii)%pt2d( iihom +jl , : ) 625 END DO 626 END SELECT 627 END DO 628 ! 629 ! ! Migrations 630 imigr = jpreci * jpj 631 ! 632 SELECT CASE ( nbondi ) 633 CASE ( -1 ) 634 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req1 ) 635 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 636 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 637 CASE ( 0 ) 638 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 639 CALL mppsend( 2, zt2we(1,1,1), num_fields*imigr, noea, ml_req2 ) 640 CALL mpprecv( 1, zt2ew(1,1,num_fields+1), num_fields*imigr, noea ) 641 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 642 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 643 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 644 CASE ( 1 ) 645 CALL mppsend( 1, zt2ew(1,1,1), num_fields*imigr, nowe, ml_req1 ) 646 CALL mpprecv( 2, zt2we(1,1,num_fields+1), num_fields*imigr, nowe ) 647 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 648 END SELECT 649 ! 650 ! ! Write Dirichlet lateral conditions 651 iihom = nlci - jpreci 652 ! 653 654 DO ii = 1 , num_fields 655 SELECT CASE ( nbondi ) 656 CASE ( -1 ) 657 DO jl = 1, jpreci 658 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 659 END DO 660 CASE ( 0 ) 661 DO jl = 1, jpreci 662 pt2d_array(ii)%pt2d( jl , : ) = zt2we(:,jl,num_fields+ii) 663 pt2d_array(ii)%pt2d( iihom+jl , : ) = zt2ew(:,jl,num_fields+ii) 664 END DO 665 CASE ( 1 ) 666 DO jl = 1, jpreci 667 pt2d_array(ii)%pt2d( jl , : )= zt2we(:,jl,num_fields+ii) 668 END DO 669 END SELECT 670 END DO 671 672 ! 3. North and south directions 673 ! ----------------------------- 674 ! always closed : we play only with the neigbours 675 ! 676 !First Array 677 DO ii = 1 , num_fields 678 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 679 ijhom = nlcj-nrecj 680 DO jl = 1, jprecj 681 zt2sn(:,jl , ii) = pt2d_array(ii)%pt2d( : , ijhom +jl ) 682 zt2ns(:,jl , ii) = pt2d_array(ii)%pt2d( : , jprecj+jl ) 683 END DO 684 ENDIF 685 END DO 686 ! 687 ! ! Migrations 688 imigr = jprecj * jpi 689 ! 690 SELECT CASE ( nbondj ) 691 CASE ( -1 ) 692 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req1 ) 693 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 694 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 695 CASE ( 0 ) 696 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 697 CALL mppsend( 4, zt2sn(1,1,1), num_fields*imigr, nono, ml_req2 ) 698 CALL mpprecv( 3, zt2ns(1,1,num_fields+1), num_fields*imigr, nono ) 699 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 700 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 701 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 702 CASE ( 1 ) 703 CALL mppsend( 3, zt2ns(1,1,1), num_fields*imigr, noso, ml_req1 ) 704 CALL mpprecv( 4, zt2sn(1,1,num_fields+1), num_fields*imigr, noso ) 705 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 706 END SELECT 707 ! 708 ! ! Write Dirichlet lateral conditions 709 ijhom = nlcj - jprecj 710 ! 711 712 DO ii = 1 , num_fields 713 !First Array 714 SELECT CASE ( nbondj ) 715 CASE ( -1 ) 716 DO jl = 1, jprecj 717 pt2d_array(ii)%pt2d( : , ijhom+jl ) = zt2ns( : , jl , num_fields+ii ) 718 END DO 719 CASE ( 0 ) 720 DO jl = 1, jprecj 721 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii) 722 pt2d_array(ii)%pt2d( : , ijhom + jl ) = zt2ns( : , jl , num_fields + ii ) 723 END DO 724 CASE ( 1 ) 725 DO jl = 1, jprecj 726 pt2d_array(ii)%pt2d( : , jl ) = zt2sn( : , jl , num_fields + ii ) 727 END DO 728 END SELECT 729 END DO 730 731 ! 4. north fold treatment 732 ! ----------------------- 733 ! 734 DO ii = 1 , num_fields 735 !First Array 736 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 737 ! 738 SELECT CASE ( jpni ) 739 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 740 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 741 END SELECT 742 ! 743 ENDIF 744 ! 745 END DO 746 747 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 748 ! 749 END SUBROUTINE mpp_lnk_2d_multiple 750 751 752 SUBROUTINE load_array(pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields) 753 !!--------------------------------------------------------------------- 754 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 755 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 756 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 757 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 758 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 759 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 760 INTEGER , INTENT (inout):: num_fields 761 !!--------------------------------------------------------------------- 762 num_fields=num_fields+1 763 pt2d_array(num_fields)%pt2d=>pt2d 764 type_array(num_fields)=cd_type 765 psgn_array(num_fields)=psgn 766 END SUBROUTINE load_array 767 768 769 SUBROUTINE mpp_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 770 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 771 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 772 !!--------------------------------------------------------------------- 773 ! Second 2D array on which the boundary condition is applied 774 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 775 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 776 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 777 ! define the nature of ptab array grid-points 778 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 779 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 780 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 781 ! =-1 the sign change across the north fold boundary 782 REAL(wp) , INTENT(in ) :: psgnA 783 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 784 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 785 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 786 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 787 !! 788 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 789 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 790 ! ! = T , U , V , F , W and I points 791 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 792 INTEGER :: num_fields 793 !!--------------------------------------------------------------------- 794 795 num_fields = 0 796 797 !! Load the first array 798 CALL load_array(pt2dA,cd_typeA,psgnA,pt2d_array, type_array, psgn_array,num_fields) 799 800 !! Look if more arrays are added 801 IF(PRESENT (psgnB) )CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 802 IF(PRESENT (psgnC) )CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 803 IF(PRESENT (psgnD) )CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 804 IF(PRESENT (psgnE) )CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 805 IF(PRESENT (psgnF) )CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 806 IF(PRESENT (psgnG) )CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 807 IF(PRESENT (psgnH) )CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 808 IF(PRESENT (psgnI) )CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 809 810 CALL mpp_lnk_2d_multiple(pt2d_array,type_array,psgn_array,num_fields,cd_mpp,pval) 811 END SUBROUTINE mpp_lnk_2d_9 512 812 513 813 … … 3184 3484 LOGICAL, PUBLIC :: ln_nnogather !: namelist control of northfold comms (needed here in case "key_mpp_mpi" is not used) 3185 3485 INTEGER :: ncomm_ice 3486 INTEGER, PUBLIC :: mpi_comm_opa ! opa local communicator 3186 3487 !!---------------------------------------------------------------------- 3187 3488 CONTAINS … … 3192 3493 END FUNCTION lib_mpp_alloc 3193 3494 3194 FUNCTION mynode( ldtxt, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value)3495 FUNCTION mynode( ldtxt, ldname, kumnam_ref, knumnam_cfg, kumond , kstop, localComm ) RESULT (function_value) 3195 3496 INTEGER, OPTIONAL , INTENT(in ) :: localComm 3196 3497 CHARACTER(len=*),DIMENSION(:) :: ldtxt 3498 CHARACTER(len=*) :: ldname 3197 3499 INTEGER :: kumnam_ref, knumnam_cfg , kumond , kstop 3198 IF( PRESENT( localComm ) .OR. .NOT.PRESENT( localComm ) ) function_value = 0 3500 IF( PRESENT( localComm ) ) mpi_comm_opa = localComm 3501 function_value = 0 3199 3502 IF( .FALSE. ) ldtxt(:) = 'never done' 3200 CALL ctl_opn( kumond, 'output.namelist.dyn', 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )3503 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 3201 3504 END FUNCTION mynode 3202 3505
Note: See TracChangeset
for help on using the changeset viewer.
