- Timestamp:
- 2016-11-18T08:18:45+01:00 (7 years ago)
- Location:
- branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC
- Files:
-
- 4 edited
-
lbclnk.F90 (modified) (7 diffs)
-
lib_mpp.F90 (modified) (9 diffs)
-
mppini.F90 (modified) (5 diffs)
-
mppini_2.h90 (modified) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r5602 r7256 11 11 !! the BDY/OBC communications 12 12 !! 3.4 ! 2012-12 (R. Bourdalle-Badie and G. Reffray) add a C1D case 13 !! 3.6 ! 2015-06 (O. Tintó and M. Castrillo) add lbc_lnk_multi 13 14 !!---------------------------------------------------------------------- 14 15 #if defined key_mpp_mpi … … 24 25 25 26 INTERFACE lbc_lnk_multi 26 MODULE PROCEDURE mpp_lnk_2d_9 27 MODULE PROCEDURE mpp_lnk_2d_9, mpp_lnk_2d_multiple 27 28 END INTERFACE 28 29 … … 80 81 END INTERFACE 81 82 83 INTERFACE lbc_lnk_multi 84 MODULE PROCEDURE lbc_lnk_2d_9, lbc_lnk_2d_multiple 85 END INTERFACE 86 82 87 INTERFACE lbc_bdy_lnk 83 88 MODULE PROCEDURE lbc_bdy_lnk_2d, lbc_bdy_lnk_3d … … 87 92 MODULE PROCEDURE lbc_lnk_2d_e 88 93 END INTERFACE 94 95 TYPE arrayptr 96 REAL , DIMENSION (:,:), POINTER :: pt2d 97 END TYPE arrayptr 98 PUBLIC arrayptr 89 99 90 100 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 91 101 PUBLIC lbc_lnk_e 102 PUBLIC lbc_lnk_multi ! modified ocean lateral boundary conditions 92 103 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 93 104 PUBLIC lbc_lnk_icb … … 171 182 ! 172 183 END SUBROUTINE lbc_lnk_2d 184 185 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 186 !! 187 INTEGER :: num_fields 188 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 189 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 190 ! ! = T , U , V , F , W and I points 191 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 192 ! ! = 1. , the sign is kept 193 ! 194 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 195 ! 196 DO ii = 1, num_fields 197 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 198 END DO 199 ! 200 END SUBROUTINE lbc_lnk_2d_multiple 201 202 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 203 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 204 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 205 !!--------------------------------------------------------------------- 206 ! Second 2D array on which the boundary condition is applied 207 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 208 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 209 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 210 ! define the nature of ptab array grid-points 211 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 212 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 213 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 214 ! =-1 the sign change across the north fold boundary 215 REAL(wp) , INTENT(in ) :: psgnA 216 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 217 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 218 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 219 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 220 !! 221 !!--------------------------------------------------------------------- 222 223 !!The first array 224 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 225 226 !! Look if more arrays to process 227 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 228 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 229 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 230 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 231 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 232 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 233 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 234 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 235 236 END SUBROUTINE lbc_lnk_2d_9 237 238 239 240 173 241 174 242 #else … … 372 440 ! 373 441 END SUBROUTINE lbc_lnk_2d 442 443 SUBROUTINE lbc_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields ) 444 !! 445 INTEGER :: num_fields 446 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 447 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 448 ! ! = T , U , V , F , W and I points 449 REAL(wp) , DIMENSION(:), INTENT(in ) :: psgn_array ! =-1 the sign change across the north fold boundary 450 ! ! = 1. , the sign is kept 451 ! 452 INTEGER :: ii !!MULTI SEND DUMMY LOOP INDICES 453 ! 454 DO ii = 1, num_fields 455 CALL lbc_lnk_2d( pt2d_array(ii)%pt2d, type_array(ii), psgn_array(ii) ) 456 END DO 457 ! 458 END SUBROUTINE lbc_lnk_2d_multiple 459 460 SUBROUTINE lbc_lnk_2d_9( pt2dA, cd_typeA, psgnA, pt2dB, cd_typeB, psgnB, pt2dC, cd_typeC, psgnC & 461 & , pt2dD, cd_typeD, psgnD, pt2dE, cd_typeE, psgnE, pt2dF, cd_typeF, psgnF & 462 & , pt2dG, cd_typeG, psgnG, pt2dH, cd_typeH, psgnH, pt2dI, cd_typeI, psgnI, cd_mpp, pval) 463 !!--------------------------------------------------------------------- 464 ! Second 2D array on which the boundary condition is applied 465 REAL(wp), DIMENSION(jpi,jpj), TARGET , INTENT(inout) :: pt2dA 466 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dB , pt2dC , pt2dD , pt2dE 467 REAL(wp), DIMENSION(jpi,jpj), TARGET, OPTIONAL, INTENT(inout) :: pt2dF , pt2dG , pt2dH , pt2dI 468 ! define the nature of ptab array grid-points 469 CHARACTER(len=1) , INTENT(in ) :: cd_typeA 470 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeB , cd_typeC , cd_typeD , cd_typeE 471 CHARACTER(len=1) , OPTIONAL, INTENT(in ) :: cd_typeF , cd_typeG , cd_typeH , cd_typeI 472 ! =-1 the sign change across the north fold boundary 473 REAL(wp) , INTENT(in ) :: psgnA 474 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnB , psgnC , psgnD , psgnE 475 REAL(wp) , OPTIONAL, INTENT(in ) :: psgnF , psgnG , psgnH , psgnI 476 CHARACTER(len=3) , OPTIONAL, INTENT(in ) :: cd_mpp ! fill the overlap area only 477 REAL(wp) , OPTIONAL, INTENT(in ) :: pval ! background value (used at closed boundaries) 478 !! 479 !!--------------------------------------------------------------------- 480 481 !!The first array 482 CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 483 484 !! Look if more arrays to process 485 IF(PRESENT (psgnB) )CALL lbc_lnk( pt2dA, cd_typeA, psgnA ) 486 IF(PRESENT (psgnC) )CALL lbc_lnk( pt2dC, cd_typeC, psgnC ) 487 IF(PRESENT (psgnD) )CALL lbc_lnk( pt2dD, cd_typeD, psgnD ) 488 IF(PRESENT (psgnE) )CALL lbc_lnk( pt2dE, cd_typeE, psgnE ) 489 IF(PRESENT (psgnF) )CALL lbc_lnk( pt2dF, cd_typeF, psgnF ) 490 IF(PRESENT (psgnG) )CALL lbc_lnk( pt2dG, cd_typeG, psgnG ) 491 IF(PRESENT (psgnH) )CALL lbc_lnk( pt2dH, cd_typeH, psgnH ) 492 IF(PRESENT (psgnI) )CALL lbc_lnk( pt2dI, cd_typeI, psgnI ) 493 494 END SUBROUTINE lbc_lnk_2d_9 495 374 496 375 497 #endif … … 441 563 !!====================================================================== 442 564 END MODULE lbclnk 565 -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r6772 r7256 24 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 26 !! 3.6 ! 2015 (O. Tintó and M. Castrillo - BSC) Added 'mpp_lnk_2d_multiple', 'mpp_lbc_north_2d_multiple', 'mpp_max_multiple' 26 27 !!---------------------------------------------------------------------- 27 28 … … 62 63 USE lbcnfd ! north fold treatment 63 64 USE in_out_manager ! I/O manager 65 USE wrk_nemo ! work arrays 64 66 65 67 IMPLICIT NONE … … 70 72 PUBLIC mpp_ini_north, mpp_lbc_north, mpp_lbc_north_e 71 73 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 74 PUBLIC mpp_max_multiple 72 75 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 PUBLIC mpp_lnk_2d_9 76 PUBLIC mpp_lnk_2d_9 , mpp_lnk_2d_multiple 74 77 PUBLIC mppscatter, mppgather, mppgatheri 75 78 PUBLIC mpp_ini_ice, mpp_ini_znl … … 78 81 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 79 82 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 83 PUBLIC mpprank 80 84 81 85 TYPE arrayptr 82 86 REAL , DIMENSION (:,:), POINTER :: pt2d 83 87 END TYPE arrayptr 88 PUBLIC arrayptr 84 89 85 90 !! * Interfaces … … 105 110 INTERFACE mpp_maxloc 106 111 MODULE PROCEDURE mpp_maxloc2d ,mpp_maxloc3d 112 END INTERFACE 113 114 INTERFACE mpp_max_multiple 115 MODULE PROCEDURE mppmax_real_multiple 107 116 END INTERFACE 108 117 … … 298 307 ENDIF 299 308 309 #if defined key_agrif 310 IF (Agrif_Root()) THEN 311 CALL Agrif_MPI_Init(mpi_comm_opa) 312 ELSE 313 CALL Agrif_MPI_set_grid_comm(mpi_comm_opa) 314 ENDIF 315 #endif 316 300 317 CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 301 318 CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) … … 724 741 ! ----------------------- 725 742 ! 726 DO ii = 1 , num_fields727 743 !First Array 728 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 729 ! 730 SELECT CASE ( jpni ) 731 CASE ( 1 ) ; CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 732 CASE DEFAULT ; CALL mpp_lbc_north( pt2d_array(ii)%pt2d( : , : ), type_array(ii), psgn_array(ii) ) ! for all northern procs. 733 END SELECT 734 ! 735 ENDIF 736 ! 737 END DO 744 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 745 ! 746 SELECT CASE ( jpni ) 747 CASE ( 1 ) ; 748 DO ii = 1 , num_fields 749 CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 750 END DO 751 CASE DEFAULT ; CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields ) ! for all northern procs. 752 END SELECT 753 ! 754 ENDIF 755 ! 738 756 739 757 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) … … 1703 1721 END SUBROUTINE mppmax_real 1704 1722 1723 SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom ) 1724 !!---------------------------------------------------------------------- 1725 !! *** routine mppmax_real *** 1726 !! 1727 !! ** Purpose : Maximum 1728 !! 1729 !!---------------------------------------------------------------------- 1730 REAL(wp), DIMENSION(:) , INTENT(inout) :: ptab ! ??? 1731 INTEGER , INTENT(in ) :: NUM 1732 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 1733 !! 1734 INTEGER :: ierror, localcomm 1735 REAL(wp) , POINTER , DIMENSION(:) :: zwork 1736 !!---------------------------------------------------------------------- 1737 ! 1738 CALL wrk_alloc(NUM , zwork) 1739 localcomm = mpi_comm_opa 1740 IF( PRESENT(kcom) ) localcomm = kcom 1741 ! 1742 CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 1743 ptab = zwork 1744 CALL wrk_dealloc(NUM , zwork) 1745 ! 1746 END SUBROUTINE mppmax_real_multiple 1747 1705 1748 1706 1749 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) … … 2597 2640 END SUBROUTINE mpp_lbc_north_2d 2598 2641 2642 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 2643 !!--------------------------------------------------------------------- 2644 !! *** routine mpp_lbc_north_2d *** 2645 !! 2646 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2647 !! in mpp configuration in case of jpn1 > 1 2648 !! (for multiple 2d arrays ) 2649 !! 2650 !! ** Method : North fold condition and mpp with more than one proc 2651 !! in i-direction require a specific treatment. We gather 2652 !! the 4 northern lines of the global domain on 1 processor 2653 !! and apply lbc north-fold on this sub array. Then we 2654 !! scatter the north fold array back to the processors. 2655 !! 2656 !!---------------------------------------------------------------------- 2657 INTEGER , INTENT (in ) :: num_fields ! number of variables contained in pt2d 2658 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 2659 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points 2660 ! ! = T , U , V , F or W gridpoints 2661 REAL(wp), DIMENSION(:), INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2662 !! ! = 1. , the sign is kept 2663 INTEGER :: ji, jj, jr, jk 2664 INTEGER :: ierr, itaille, ildi, ilei, iilb 2665 INTEGER :: ijpj, ijpjm1, ij, iproc 2666 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2667 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2668 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2669 ! ! Workspace for message transfers avoiding mpi_allgather 2670 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab 2671 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 2672 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio 2673 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr 2674 INTEGER :: istatus(mpi_status_size) 2675 INTEGER :: iflag 2676 !!---------------------------------------------------------------------- 2677 ! 2678 ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), & 2679 & znorthgloio(jpi,4,num_fields,jpni) ) ! expanded to 3 dimensions 2680 ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 2681 ! 2682 ijpj = 4 2683 ijpjm1 = 3 2684 ! 2685 2686 DO jk = 1, num_fields 2687 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable) 2688 ij = jj - nlcj + ijpj 2689 znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 2690 END DO 2691 END DO 2692 ! ! Build in procs of ncomm_north the znorthgloio 2693 itaille = jpi * ijpj 2694 2695 IF ( l_north_nogather ) THEN 2696 ! 2697 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 2698 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 2699 ! 2700 ztabr(:,:,:) = 0 2701 ztabl(:,:,:) = 0 2702 2703 DO jk = 1, num_fields 2704 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 2705 ij = jj - nlcj + ijpj 2706 DO ji = nfsloop, nfeloop 2707 ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 2708 END DO 2709 END DO 2710 END DO 2711 2712 DO jr = 1,nsndto 2713 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2714 CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 2715 ENDIF 2716 END DO 2717 DO jr = 1,nsndto 2718 iproc = nfipproc(isendto(jr),jpnj) 2719 IF(iproc .ne. -1) THEN 2720 ilei = nleit (iproc+1) 2721 ildi = nldit (iproc+1) 2722 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 2723 ENDIF 2724 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 2725 CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 2726 DO jk = 1 , num_fields 2727 DO jj = 1, ijpj 2728 DO ji = ildi, ilei 2729 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D 2730 END DO 2731 END DO 2732 END DO 2733 ELSE IF (iproc .eq. (narea-1)) THEN 2734 DO jk = 1, num_fields 2735 DO jj = 1, ijpj 2736 DO ji = ildi, ilei 2737 ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D 2738 END DO 2739 END DO 2740 END DO 2741 ENDIF 2742 END DO 2743 IF (l_isend) THEN 2744 DO jr = 1,nsndto 2745 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2746 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2747 ENDIF 2748 END DO 2749 ENDIF 2750 ! 2751 DO ji = 1, num_fields ! Loop to manage 3D variables 2752 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 2753 END DO 2754 ! 2755 DO jk = 1, num_fields 2756 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2757 ij = jj - nlcj + ijpj 2758 DO ji = 1, nlci 2759 pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D 2760 END DO 2761 END DO 2762 END DO 2763 2764 ! 2765 ELSE 2766 ! 2767 CALL MPI_ALLGATHER( znorthloc , itaille*num_fields, MPI_DOUBLE_PRECISION, & 2768 & znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2769 ! 2770 ztab(:,:,:) = 0.e0 2771 DO jk = 1, num_fields 2772 DO jr = 1, ndim_rank_north ! recover the global north array 2773 iproc = nrank_north(jr) + 1 2774 ildi = nldit (iproc) 2775 ilei = nleit (iproc) 2776 iilb = nimppt(iproc) 2777 DO jj = 1, ijpj 2778 DO ji = ildi, ilei 2779 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 2780 END DO 2781 END DO 2782 END DO 2783 END DO 2784 2785 DO ji = 1, num_fields 2786 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 2787 END DO 2788 ! 2789 DO jk = 1, num_fields 2790 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 2791 ij = jj - nlcj + ijpj 2792 DO ji = 1, nlci 2793 pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 2794 END DO 2795 END DO 2796 END DO 2797 ! 2798 ! 2799 ENDIF 2800 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 2801 DEALLOCATE( ztabl, ztabr ) 2802 ! 2803 END SUBROUTINE mpp_lbc_north_2d_multiple 2599 2804 2600 2805 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/mppini.F90
r5601 r7256 201 201 202 202 #endif 203 IF(lwp) THEN204 WRITE(numout,*)205 WRITE(numout,*) ' defines mpp subdomains'206 WRITE(numout,*) ' ----------------------'207 WRITE(numout,*) ' iresti=',iresti,' irestj=',irestj208 WRITE(numout,*) ' jpni =',jpni ,' jpnj =',jpnj209 ifreq = 4210 il1 = 1211 DO jn = 1, (jpni-1)/ifreq+1212 il2 = MIN( jpni, il1+ifreq-1 )213 WRITE(numout,*)214 WRITE(numout,9200) ('***',ji = il1,il2-1)215 DO jj = jpnj, 1, -1216 WRITE(numout,9203) (' ',ji = il1,il2-1)217 WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 )218 WRITE(numout,9203) (' ',ji = il1,il2-1)219 WRITE(numout,9200) ('***',ji = il1,il2-1)220 END DO221 WRITE(numout,9201) (ji,ji = il1,il2)222 il1 = il1+ifreq223 END DO224 9200 FORMAT(' ***',20('*************',a3))225 9203 FORMAT(' * ',20(' * ',a3))226 9201 FORMAT(' ',20(' ',i3,' '))227 9202 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * '))228 ENDIF229 230 zidom = nreci231 DO ji = 1, jpni232 zidom = zidom + ilcit(ji,1) - nreci233 END DO234 IF(lwp) WRITE(numout,*)235 IF(lwp) WRITE(numout,*)' sum ilcit(i,1) = ', zidom, ' jpiglo = ', jpiglo236 237 zjdom = nrecj238 DO jj = 1, jpnj239 zjdom = zjdom + ilcjt(1,jj) - nrecj240 END DO241 IF(lwp) WRITE(numout,*)' sum ilcit(1,j) = ', zjdom, ' jpjglo = ', jpjglo242 IF(lwp) WRITE(numout,*)243 244 203 245 204 ! 2. Index arrays for subdomains … … 313 272 nlejt(jn) = nlej 314 273 END DO 315 316 317 ! 4. From global to local 274 275 ! 4. Subdomain print 276 ! ------------------ 277 278 IF(lwp) WRITE(numout,*) 279 IF(lwp) WRITE(numout,*) ' mpp_init: defines mpp subdomains' 280 IF(lwp) WRITE(numout,*) ' ~~~~~~ ----------------------' 281 IF(lwp) WRITE(numout,*) 282 IF(lwp) WRITE(numout,*) 'iresti=',iresti,' irestj=',irestj 283 IF(lwp) WRITE(numout,*) 284 IF(lwp) WRITE(numout,*) 'jpni=',jpni,' jpnj=',jpnj 285 zidom = nreci 286 DO ji = 1, jpni 287 zidom = zidom + ilcit(ji,1) - nreci 288 END DO 289 IF(lwp) WRITE(numout,*) 290 IF(lwp) WRITE(numout,*)' sum ilcit(i,1)=', zidom, ' jpiglo=', jpiglo 291 292 zjdom = nrecj 293 DO jj = 1, jpnj 294 zjdom = zjdom + ilcjt(1,jj) - nrecj 295 END DO 296 IF(lwp) WRITE(numout,*)' sum ilcit(1,j)=', zjdom, ' jpjglo=', jpjglo 297 IF(lwp) WRITE(numout,*) 298 299 IF(lwp) THEN 300 ifreq = 4 301 il1 = 1 302 DO jn = 1, (jpni-1)/ifreq+1 303 il2 = MIN( jpni, il1+ifreq-1 ) 304 WRITE(numout,*) 305 WRITE(numout,9200) ('***',ji = il1,il2-1) 306 DO jj = jpnj, 1, -1 307 WRITE(numout,9203) (' ',ji = il1,il2-1) 308 WRITE(numout,9202) jj, ( ilcit(ji,jj),ilcjt(ji,jj),ji = il1,il2 ) 309 WRITE(numout,9204) (nfipproc(ji,jj),ji=il1,il2) 310 WRITE(numout,9203) (' ',ji = il1,il2-1) 311 WRITE(numout,9200) ('***',ji = il1,il2-1) 312 END DO 313 WRITE(numout,9201) (ji,ji = il1,il2) 314 il1 = il1+ifreq 315 END DO 316 9200 FORMAT(' ***',20('*************',a3)) 317 9203 FORMAT(' * ',20(' * ',a3)) 318 9201 FORMAT(' ',20(' ',i3,' ')) 319 9202 FORMAT(' ',i3,' * ',20(i3,' x',i3,' * ')) 320 9204 FORMAT(' * ',20(' ',i3,' * ')) 321 ENDIF 322 323 ! 5. From global to local 318 324 ! ----------------------- 319 325 … … 322 328 323 329 324 ! 5. Subdomain neighbours330 ! 6. Subdomain neighbours 325 331 ! ---------------------- 326 332 … … 445 451 WRITE(numout,*) ' nimpp = ', nimpp 446 452 WRITE(numout,*) ' njmpp = ', njmpp 447 WRITE(numout,*) ' nbse = ', nbse , ' npse = ', npse 448 WRITE(numout,*) ' nbsw = ', nbsw , ' npsw = ', npsw 449 WRITE(numout,*) ' nbne = ', nbne , ' npne = ', npne 450 WRITE(numout,*) ' nbnw = ', nbnw , ' npnw = ', npnw 453 WRITE(numout,*) ' nreci = ', nreci , ' npse = ', npse 454 WRITE(numout,*) ' nrecj = ', nrecj , ' npsw = ', npsw 455 WRITE(numout,*) ' jpreci = ', jpreci , ' npne = ', npne 456 WRITE(numout,*) ' jprecj = ', jprecj , ' npnw = ', npnw 457 WRITE(numout,*) 451 458 ENDIF 452 459 … … 455 462 ! Prepare mpp north fold 456 463 457 IF (jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN464 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 458 465 CALL mpp_ini_north 459 END IF 466 IF(lwp) WRITE(numout,*) ' mpp_init : North fold boundary prepared for jpni >1' 467 ENDIF 460 468 461 469 ! Prepare NetCDF output file (if necessary) -
branches/2015/dev_r5003_MERCATOR6_CRS/NEMOGCM/NEMO/OPA_SRC/LBC/mppini_2.h90
r6772 r7256 309 309 ENDIF 310 310 311 ! Check wet points over the entire domain to preserve the MPI communication stencil 311 312 isurf = 0 312 313 DO jj = 1, ilj … … 315 316 END DO 316 317 END DO 318 317 319 IF(isurf /= 0) THEN 318 320 icont = icont + 1 … … 326 328 327 329 nfipproc(:,:) = ipproc(:,:) 328 329 330 330 331 ! Control … … 434 435 ii = iin(narea) 435 436 ij = ijn(narea) 437 438 ! set default neighbours 439 noso = ioso(ii,ij) 440 nowe = iowe(ii,ij) 441 noea = ioea(ii,ij) 442 nono = iono(ii,ij) 443 npse = iose(ii,ij) 444 npsw = iosw(ii,ij) 445 npne = ione(ii,ij) 446 npnw = ionw(ii,ij) 447 448 ! check neighbours location 436 449 IF( ioso(ii,ij) >= 0 .AND. ioso(ii,ij) <= (jpni*jpnj-1) ) THEN 437 450 iiso = 1 + MOD(ioso(ii,ij),jpni) … … 517 530 IF (lwp) THEN 518 531 CALL ctl_opn( inum, 'layout.dat', 'REPLACE', 'FORMATTED', 'SEQUENTIAL', -1, numout, .FALSE., narea ) 532 WRITE(inum,'(a)') ' jpnij jpi jpj jpk jpiglo jpjglo' 519 533 WRITE(inum,'(6i8)') jpnij,jpi,jpj,jpk,jpiglo,jpjglo 520 534 WRITE(inum,'(a)') 'NAREA nlci nlcj nldi nldj nlei nlej nimpp njmpp' … … 529 543 END IF 530 544 531 IF( nperio == 1 .AND.jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' )532 533 ! Prepare mpp north fold534 535 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN536 CALL mpp_ini_north537 IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1'538 ENDIF539 540 545 ! Defined npolj, either 0, 3 , 4 , 5 , 6 541 546 ! In this case the important thing is that npolj /= 0 … … 554 559 ENDIF 555 560 561 ! Periodicity : no corner if nbondi = 2 and nperio != 1 562 563 IF(lwp) THEN 564 WRITE(numout,*) ' nproc = ', nproc 565 WRITE(numout,*) ' nowe = ', nowe , ' noea = ', noea 566 WRITE(numout,*) ' nono = ', nono , ' noso = ', noso 567 WRITE(numout,*) ' nbondi = ', nbondi 568 WRITE(numout,*) ' nbondj = ', nbondj 569 WRITE(numout,*) ' npolj = ', npolj 570 WRITE(numout,*) ' nperio = ', nperio 571 WRITE(numout,*) ' nlci = ', nlci 572 WRITE(numout,*) ' nlcj = ', nlcj 573 WRITE(numout,*) ' nimpp = ', nimpp 574 WRITE(numout,*) ' njmpp = ', njmpp 575 WRITE(numout,*) ' nreci = ', nreci , ' npse = ', npse 576 WRITE(numout,*) ' nrecj = ', nrecj , ' npsw = ', npsw 577 WRITE(numout,*) ' jpreci = ', jpreci , ' npne = ', npne 578 WRITE(numout,*) ' jprecj = ', jprecj , ' npnw = ', npnw 579 WRITE(numout,*) 580 ENDIF 581 582 IF( nperio == 1 .AND. jpni /= 1 ) CALL ctl_stop( ' mpp_init2: error on cyclicity' ) 583 584 ! Prepare mpp north fold 585 586 IF( jperio >= 3 .AND. jperio <= 6 .AND. jpni > 1 ) THEN 587 CALL mpp_ini_north 588 IF(lwp) WRITE(numout,*) ' mpp_init2 : North fold boundary prepared for jpni >1' 589 ENDIF 590 556 591 ! Prepare NetCDF output file (if necessary) 557 592 CALL mpp_init_ioipsl 558 593 559 ! Periodicity : no corner if nbondi = 2 and nperio != 1560 561 IF(lwp) THEN562 WRITE(numout,*) ' nproc= ',nproc563 WRITE(numout,*) ' nowe= ',nowe564 WRITE(numout,*) ' noea= ',noea565 WRITE(numout,*) ' nono= ',nono566 WRITE(numout,*) ' noso= ',noso567 WRITE(numout,*) ' nbondi= ',nbondi568 WRITE(numout,*) ' nbondj= ',nbondj569 WRITE(numout,*) ' npolj= ',npolj570 WRITE(numout,*) ' nperio= ',nperio571 WRITE(numout,*) ' nlci= ',nlci572 WRITE(numout,*) ' nlcj= ',nlcj573 WRITE(numout,*) ' nimpp= ',nimpp574 WRITE(numout,*) ' njmpp= ',njmpp575 WRITE(numout,*) ' nbse= ',nbse,' npse= ',npse576 WRITE(numout,*) ' nbsw= ',nbsw,' npsw= ',npsw577 WRITE(numout,*) ' nbne= ',nbne,' npne= ',npne578 WRITE(numout,*) ' nbnw= ',nbnw,' npnw= ',npnw579 ENDIF580 594 581 595 END SUBROUTINE mpp_init2
Note: See TracChangeset
for help on using the changeset viewer.
