- Timestamp:
- 2016-11-28T17:04:10+01:00 (7 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2016/dev_INGV_UKMO_2016/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r5836 r7351 23 23 !! the mppobc routine to optimize the BDY and OBC communications 24 24 !! 3.5 ! 2013 ( C. Ethe, G. Madec ) message passing arrays as local variables 25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 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 28 29 !!---------------------------------------------------------------------- 29 !! ctl_stop : update momentum and tracer Kz from a tke scheme30 !! ctl_warn : initialization, namelist read, and parameters control31 !! ctl_opn : Open file and check if required file is available.32 !! ctl_nam : Prints informations when an error occurs while reading a namelist33 !! get_unit : give the index of an unused logical unit30 !! ctl_stop : update momentum and tracer Kz from a tke scheme 31 !! ctl_warn : initialization, namelist read, and parameters control 32 !! ctl_opn : Open file and check if required file is available. 33 !! ctl_nam : Prints informations when an error occurs while reading a namelist 34 !! get_unit : give the index of an unused logical unit 34 35 !!---------------------------------------------------------------------- 35 36 #if defined key_mpp_mpi … … 43 44 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 44 45 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 45 !! mpprecv 46 !! mpprecv : 46 47 !! mppsend : SUBROUTINE mpp_ini_znl 47 48 !! mppscatter : … … 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 77 PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d 74 78 PUBLIC mppscatter, mppgather 75 79 PUBLIC mpp_ini_ice, mpp_ini_znl … … 78 82 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 79 83 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 84 PUBLIC mpprank 80 85 81 86 TYPE arrayptr 82 87 REAL , DIMENSION (:,:), POINTER :: pt2d 83 88 END TYPE arrayptr 89 PUBLIC arrayptr 84 90 85 91 !! * Interfaces … … 94 100 END INTERFACE 95 101 INTERFACE mpp_sum 96 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &102 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 97 103 mppsum_realdd, mppsum_a_realdd 98 104 END INTERFACE … … 107 113 END INTERFACE 108 114 115 INTERFACE mpp_max_multiple 116 MODULE PROCEDURE mppmax_real_multiple 117 END INTERFACE 118 109 119 !! ========================= !! 110 120 !! MPI variable definition !! … … 175 185 !! ** Purpose : Find processor unit 176 186 !!---------------------------------------------------------------------- 177 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt 178 CHARACTER(len=*) , INTENT(in ) :: ldname 179 INTEGER , INTENT(in ) :: kumnam_ref 180 INTEGER , INTENT(in ) :: kumnam_cfg 181 INTEGER , INTENT(inout) :: kumond 182 INTEGER , INTENT(inout) :: kstop 183 INTEGER , OPTIONAL , INTENT(in ) :: localComm187 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt ! 188 CHARACTER(len=*) , INTENT(in ) :: ldname ! 189 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 190 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist 191 INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output 192 INTEGER , INTENT(inout) :: kstop ! stop indicator 193 INTEGER , OPTIONAL , INTENT(in ) :: localComm ! 184 194 ! 185 195 INTEGER :: mynode, ierr, code, ji, ii, ios … … 190 200 ! 191 201 ii = 1 192 WRITE(ldtxt(ii),*) 193 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' 194 WRITE(ldtxt(ii),*) '~~~~~~ ' 202 WRITE(ldtxt(ii),*) ; ii = ii + 1 203 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 204 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 195 205 ! 196 206 … … 204 214 205 215 ! ! control print 206 WRITE(ldtxt(ii),*) ' Namelist nammpp' 207 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send; ii = ii + 1208 WRITE(ldtxt(ii),*) ' size in bytes of exported buffer nn_buffer = ', nn_buffer; ii = ii + 1216 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 217 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 218 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 209 219 210 220 #if defined key_agrif … … 223 233 224 234 IF( (jpni < 1) .OR. (jpnj < 1) )THEN 225 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ;ii = ii + 1235 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ; ii = ii + 1 226 236 ELSE 227 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ;ii = ii + 1228 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ;ii = ii + 1229 WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii +1237 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1 238 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 239 WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii + 1 230 240 END IF 231 241 … … 246 256 SELECT CASE ( cn_mpi_send ) 247 257 CASE ( 'S' ) ! Standard mpi send (blocking) 248 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' 258 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 249 259 CASE ( 'B' ) ! Buffer mpi send (blocking) 250 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' 260 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 251 261 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 252 262 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 253 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' 263 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 254 264 l_isend = .TRUE. 255 265 CASE DEFAULT 256 WRITE(ldtxt(ii),cform_err) 257 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send 266 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 267 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 258 268 kstop = kstop + 1 259 269 END SELECT 260 270 ELSE IF ( PRESENT(localComm) .and. .not. mpi_was_called ) THEN 261 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' 262 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' 271 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 272 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 263 273 kstop = kstop + 1 264 274 ELSE 265 275 SELECT CASE ( cn_mpi_send ) 266 276 CASE ( 'S' ) ! Standard mpi send (blocking) 267 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' 277 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 268 278 CALL mpi_init( ierr ) 269 279 CASE ( 'B' ) ! Buffer mpi send (blocking) 270 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' 280 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 271 281 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 272 282 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 273 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' 283 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 274 284 l_isend = .TRUE. 275 285 CALL mpi_init( ierr ) 276 286 CASE DEFAULT 277 WRITE(ldtxt(ii),cform_err) 278 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send 287 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 288 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 279 289 kstop = kstop + 1 280 290 END SELECT … … 319 329 END FUNCTION mynode 320 330 331 321 332 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 322 333 !!---------------------------------------------------------------------- … … 347 358 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 348 359 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 349 ! !360 ! 350 361 INTEGER :: ji, jj, jk, jl ! dummy loop indices 351 362 INTEGER :: imigr, iihom, ijhom ! temporary integers 352 363 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 353 364 REAL(wp) :: zland 354 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 355 ! 365 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 356 366 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 357 367 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 358 359 368 !!---------------------------------------------------------------------- 360 369 … … 364 373 ! 365 374 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 366 ELSE ; zland = 0. e0! zero by default375 ELSE ; zland = 0._wp ! zero by default 367 376 ENDIF 368 377 … … 455 464 END SELECT 456 465 457 458 466 ! 3. North and south directions 459 467 ! ----------------------------- … … 508 516 END SELECT 509 517 510 511 518 ! 4. north fold treatment 512 519 ! ----------------------- … … 524 531 ! 525 532 END SUBROUTINE mpp_lnk_3d 533 526 534 527 535 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) … … 542 550 !! noso : number for local neighboring processors 543 551 !! nono : number for local neighboring processors 544 !! 545 !!---------------------------------------------------------------------- 546 547 INTEGER :: num_fields 548 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 552 !!---------------------------------------------------------------------- 549 553 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 550 554 ! ! = T , U , V , F , W and I points … … 558 562 INTEGER :: imigr, iihom, ijhom ! temporary integers 559 563 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 560 564 INTEGER :: num_fields 565 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 561 566 REAL(wp) :: zland 562 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 563 ! 567 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 564 568 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 565 569 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 566 570 567 571 !!---------------------------------------------------------------------- 568 572 ! 569 573 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 570 574 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 571 572 575 ! 573 576 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 574 ELSE ; zland = 0. e0! zero by default577 ELSE ; zland = 0._wp ! zero by default 575 578 ENDIF 576 579 … … 732 735 ! ----------------------- 733 736 ! 734 DO ii = 1 , num_fields735 737 !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 738 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 739 ! 740 SELECT CASE ( jpni ) 741 CASE ( 1 ) ; 742 DO ii = 1 , num_fields 743 CALL lbc_nfd ( pt2d_array(ii)%pt2d( : , : ), type_array(ii) , psgn_array(ii) ) ! only 1 northern proc, no mpp 744 END DO 745 CASE DEFAULT ; CALL mpp_lbc_north_2d_multiple( pt2d_array, type_array, psgn_array, num_fields ) ! for all northern procs. 746 END SELECT 747 ! 748 ENDIF 749 ! 750 ! 747 751 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 748 752 ! … … 750 754 751 755 752 SUBROUTINE load_array( pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields)756 SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields ) 753 757 !!--------------------------------------------------------------------- 754 REAL(wp), DIMENSION(jpi,jpj), TARGET ,INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied755 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points756 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary758 REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 759 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 760 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 757 761 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 758 762 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 759 763 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 760 INTEGER , INTENT (inout):: num_fields764 INTEGER , INTENT (inout) :: num_fields 761 765 !!--------------------------------------------------------------------- 762 num_fields =num_fields+1763 pt2d_array(num_fields)%pt2d =>pt2d764 type_array(num_fields) =cd_type765 psgn_array(num_fields) =psgn766 num_fields = num_fields + 1 767 pt2d_array(num_fields)%pt2d => pt2d 768 type_array(num_fields) = cd_type 769 psgn_array(num_fields) = psgn 766 770 END SUBROUTINE load_array 767 771 … … 792 796 INTEGER :: num_fields 793 797 !!--------------------------------------------------------------------- 794 798 ! 795 799 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) 800 ! 801 ! Load the first array 802 CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) 803 ! 804 ! Look if more arrays are added 805 IF( PRESENT(psgnB) ) CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 806 IF( PRESENT(psgnC) ) CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 807 IF( PRESENT(psgnD) ) CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 808 IF( PRESENT(psgnE) ) CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 809 IF( PRESENT(psgnF) ) CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 810 IF( PRESENT(psgnG) ) CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 811 IF( PRESENT(psgnH) ) CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 812 IF( PRESENT(psgnI) ) CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 813 ! 814 CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) 815 ! 811 816 END SUBROUTINE mpp_lnk_2d_9 812 817 … … 843 848 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 844 849 REAL(wp) :: zland 845 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 846 ! 850 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 847 851 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 848 852 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 849 850 !!---------------------------------------------------------------------- 851 853 !!---------------------------------------------------------------------- 854 ! 852 855 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 853 856 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 854 855 857 ! 856 858 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 857 ELSE ; zland = 0. e0! zero by default859 ELSE ; zland = 0._wp ! zero by default 858 860 ENDIF 859 861 … … 1046 1048 INTEGER :: imigr, iihom, ijhom ! temporary integers 1047 1049 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1048 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1049 ! 1050 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1050 1051 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ns, zt4sn ! 2 x 3d for north-south & south-north 1051 1052 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ew, zt4we ! 2 x 3d for east-west & west-east 1052 1053 ! !----------------------------------------------------------------------1053 !!---------------------------------------------------------------------- 1054 ! 1054 1055 ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) , & 1055 1056 & zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) 1056 1057 1057 ! 1058 1058 ! 1. standard boundary treatment 1059 1059 ! ------------------------------ … … 1399 1399 END DO 1400 1400 END SELECT 1401 1401 ! 1402 1402 END SUBROUTINE mpp_lnk_2d_e 1403 1403 1404 SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) 1405 !!---------------------------------------------------------------------- 1406 !! *** routine mpp_lnk_sum_3d *** 1407 !! 1408 !! ** Purpose : Message passing manadgement (sum the overlap region) 1409 !! 1410 !! ** Method : Use mppsend and mpprecv function for passing mask 1411 !! between processors following neighboring subdomains. 1412 !! domain parameters 1413 !! nlci : first dimension of the local subdomain 1414 !! nlcj : second dimension of the local subdomain 1415 !! nbondi : mark for "east-west local boundary" 1416 !! nbondj : mark for "north-south local boundary" 1417 !! noea : number for local neighboring processors 1418 !! nowe : number for local neighboring processors 1419 !! noso : number for local neighboring processors 1420 !! nono : number for local neighboring processors 1421 !! 1422 !! ** Action : ptab with update value at its periphery 1423 !! 1424 !!---------------------------------------------------------------------- 1425 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 1426 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1427 ! ! = T , U , V , F , W points 1428 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1429 ! ! = 1. , the sign is kept 1430 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1431 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 1432 !! 1433 INTEGER :: ji, jj, jk, jl ! dummy loop indices 1434 INTEGER :: imigr, iihom, ijhom ! temporary integers 1435 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1436 REAL(wp) :: zland 1437 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1438 ! 1439 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 1440 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 1441 1442 !!---------------------------------------------------------------------- 1443 1444 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 1445 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 1446 1447 ! 1448 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1449 ELSE ; zland = 0.e0 ! zero by default 1450 ENDIF 1451 1452 ! 1. standard boundary treatment 1453 ! ------------------------------ 1454 ! 2. East and west directions exchange 1455 ! ------------------------------------ 1456 ! we play with the neigbours AND the row number because of the periodicity 1457 ! 1458 SELECT CASE ( nbondi ) ! Read lateral conditions 1459 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1460 iihom = nlci-jpreci 1461 DO jl = 1, jpreci 1462 zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0.0_wp 1463 zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0.0_wp 1464 END DO 1465 END SELECT 1466 ! 1467 ! ! Migrations 1468 imigr = jpreci * jpj * jpk 1469 ! 1470 SELECT CASE ( nbondi ) 1471 CASE ( -1 ) 1472 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 1473 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 1474 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1475 CASE ( 0 ) 1476 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 1477 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 1478 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 1479 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 1480 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1481 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1482 CASE ( 1 ) 1483 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 1484 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 1485 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1486 END SELECT 1487 ! 1488 ! ! Write lateral conditions 1489 iihom = nlci-nreci 1490 ! 1491 SELECT CASE ( nbondi ) 1492 CASE ( -1 ) 1493 DO jl = 1, jpreci 1494 ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2) 1495 END DO 1496 CASE ( 0 ) 1497 DO jl = 1, jpreci 1498 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 1499 ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 1500 END DO 1501 CASE ( 1 ) 1502 DO jl = 1, jpreci 1503 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 1504 END DO 1505 END SELECT 1506 1507 1508 ! 3. North and south directions 1509 ! ----------------------------- 1510 ! always closed : we play only with the neigbours 1511 ! 1512 IF( nbondj /= 2 ) THEN ! Read lateral conditions 1513 ijhom = nlcj-jprecj 1514 DO jl = 1, jprecj 1515 zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp 1516 zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0.0_wp 1517 END DO 1518 ENDIF 1519 ! 1520 ! ! Migrations 1521 imigr = jprecj * jpi * jpk 1522 ! 1523 SELECT CASE ( nbondj ) 1524 CASE ( -1 ) 1525 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 1526 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 1527 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1528 CASE ( 0 ) 1529 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 1530 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 1531 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 1532 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 1533 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1534 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1535 CASE ( 1 ) 1536 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 1537 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 1538 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1539 END SELECT 1540 ! 1541 ! ! Write lateral conditions 1542 ijhom = nlcj-nrecj 1543 ! 1544 SELECT CASE ( nbondj ) 1545 CASE ( -1 ) 1546 DO jl = 1, jprecj 1547 ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2) 1548 END DO 1549 CASE ( 0 ) 1550 DO jl = 1, jprecj 1551 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2) 1552 ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2) 1553 END DO 1554 CASE ( 1 ) 1555 DO jl = 1, jprecj 1556 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl ,:,2) 1557 END DO 1558 END SELECT 1559 1560 1561 ! 4. north fold treatment 1562 ! ----------------------- 1563 ! 1564 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 1565 ! 1566 SELECT CASE ( jpni ) 1567 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 1568 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 1569 END SELECT 1570 ! 1571 ENDIF 1572 ! 1573 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 1574 ! 1575 END SUBROUTINE mpp_lnk_sum_3d 1576 1577 SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 1578 !!---------------------------------------------------------------------- 1579 !! *** routine mpp_lnk_sum_2d *** 1580 !! 1581 !! ** Purpose : Message passing manadgement for 2d array (sum the overlap region) 1582 !! 1583 !! ** Method : Use mppsend and mpprecv function for passing mask 1584 !! between processors following neighboring subdomains. 1585 !! domain parameters 1586 !! nlci : first dimension of the local subdomain 1587 !! nlcj : second dimension of the local subdomain 1588 !! nbondi : mark for "east-west local boundary" 1589 !! nbondj : mark for "north-south local boundary" 1590 !! noea : number for local neighboring processors 1591 !! nowe : number for local neighboring processors 1592 !! noso : number for local neighboring processors 1593 !! nono : number for local neighboring processors 1594 !! 1595 !!---------------------------------------------------------------------- 1596 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 1597 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1598 ! ! = T , U , V , F , W and I points 1599 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1600 ! ! = 1. , the sign is kept 1601 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1602 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 1603 !! 1604 INTEGER :: ji, jj, jl ! dummy loop indices 1605 INTEGER :: imigr, iihom, ijhom ! temporary integers 1606 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1607 REAL(wp) :: zland 1608 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1609 ! 1610 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 1611 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 1612 1613 !!---------------------------------------------------------------------- 1614 1615 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 1616 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 1617 1618 ! 1619 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1620 ELSE ; zland = 0.e0 ! zero by default 1621 ENDIF 1622 1623 ! 1. standard boundary treatment 1624 ! ------------------------------ 1625 ! 2. East and west directions exchange 1626 ! ------------------------------------ 1627 ! we play with the neigbours AND the row number because of the periodicity 1628 ! 1629 SELECT CASE ( nbondi ) ! Read lateral conditions 1630 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1631 iihom = nlci - jpreci 1632 DO jl = 1, jpreci 1633 zt2ew(:,jl,1) = pt2d(jl ,:) ; pt2d(jl ,:) = 0.0_wp 1634 zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp 1635 END DO 1636 END SELECT 1637 ! 1638 ! ! Migrations 1639 imigr = jpreci * jpj 1640 ! 1641 SELECT CASE ( nbondi ) 1642 CASE ( -1 ) 1643 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 1644 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 1645 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1646 CASE ( 0 ) 1647 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 1648 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 1649 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 1650 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 1651 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1652 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1653 CASE ( 1 ) 1654 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 1655 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 1656 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1657 END SELECT 1658 ! 1659 ! ! Write lateral conditions 1660 iihom = nlci-nreci 1661 ! 1662 SELECT CASE ( nbondi ) 1663 CASE ( -1 ) 1664 DO jl = 1, jpreci 1665 pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2) 1666 END DO 1667 CASE ( 0 ) 1668 DO jl = 1, jpreci 1669 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 1670 pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2) 1671 END DO 1672 CASE ( 1 ) 1673 DO jl = 1, jpreci 1674 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 1675 END DO 1676 END SELECT 1677 1678 1679 ! 3. North and south directions 1680 ! ----------------------------- 1681 ! always closed : we play only with the neigbours 1682 ! 1683 IF( nbondj /= 2 ) THEN ! Read lateral conditions 1684 ijhom = nlcj - jprecj 1685 DO jl = 1, jprecj 1686 zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp 1687 zt2ns(:,jl,1) = pt2d(:,jl ) ; pt2d(:,jl ) = 0.0_wp 1688 END DO 1689 ENDIF 1690 ! 1691 ! ! Migrations 1692 imigr = jprecj * jpi 1693 ! 1694 SELECT CASE ( nbondj ) 1695 CASE ( -1 ) 1696 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 1697 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 1698 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1699 CASE ( 0 ) 1700 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 1701 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 1702 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 1703 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 1704 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1705 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1706 CASE ( 1 ) 1707 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 1708 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 1709 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1710 END SELECT 1711 ! 1712 ! ! Write lateral conditions 1713 ijhom = nlcj-nrecj 1714 ! 1715 SELECT CASE ( nbondj ) 1716 CASE ( -1 ) 1717 DO jl = 1, jprecj 1718 pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2) 1719 END DO 1720 CASE ( 0 ) 1721 DO jl = 1, jprecj 1722 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 1723 pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2) 1724 END DO 1725 CASE ( 1 ) 1726 DO jl = 1, jprecj 1727 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 1728 END DO 1729 END SELECT 1730 1731 1732 ! 4. north fold treatment 1733 ! ----------------------- 1734 ! 1735 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 1736 ! 1737 SELECT CASE ( jpni ) 1738 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp 1739 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. 1740 END SELECT 1741 ! 1742 ENDIF 1743 ! 1744 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 1745 ! 1746 END SUBROUTINE mpp_lnk_sum_2d 1404 1747 1405 1748 SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) … … 1449 1792 !!---------------------------------------------------------------------- 1450 1793 ! 1451 1452 1794 ! If a specific process number has been passed to the receive call, 1453 1795 ! use that one. Default is to use mpi_any_source 1454 use_source=mpi_any_source 1455 if(present(ksource)) then 1456 use_source=ksource 1457 end if 1458 1796 use_source = mpi_any_source 1797 IF( PRESENT(ksource) ) use_source = ksource 1798 ! 1459 1799 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag ) 1460 1800 ! … … 1470 1810 !! 1471 1811 !!---------------------------------------------------------------------- 1472 REAL(wp), DIMENSION(jpi,jpj) ,INTENT(in ) :: ptab ! subdomain input array1473 INTEGER ,INTENT(in ) :: kp ! record length1812 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: ptab ! subdomain input array 1813 INTEGER , INTENT(in ) :: kp ! record length 1474 1814 REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array 1475 1815 !! … … 1492 1832 !! 1493 1833 !!---------------------------------------------------------------------- 1494 REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio! output array1495 INTEGER :: kp 1496 REAL(wp), DIMENSION(jpi,jpj) :: ptab! subdomain array input1834 REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array 1835 INTEGER :: kp ! Tag (not used with MPI 1836 REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input 1497 1837 !! 1498 1838 INTEGER :: itaille, ierror ! temporary integer 1499 1839 !!--------------------------------------------------------------------- 1500 1840 ! 1501 itaille =jpi*jpj1841 itaille = jpi * jpj 1502 1842 ! 1503 1843 CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & … … 1517 1857 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1518 1858 INTEGER , INTENT(in ), OPTIONAL :: kcom ! 1519 ! !1859 ! 1520 1860 INTEGER :: ierror, localcomm ! temporary integer 1521 1861 INTEGER, DIMENSION(kdim) :: iwork … … 1539 1879 !! 1540 1880 !!---------------------------------------------------------------------- 1541 INTEGER, INTENT(inout) :: ktab 1542 INTEGER, INTENT(in ), OPTIONAL :: kcom 1543 ! !1881 INTEGER, INTENT(inout) :: ktab ! ??? 1882 INTEGER, INTENT(in ), OPTIONAL :: kcom ! ??? 1883 ! 1544 1884 INTEGER :: ierror, iwork, localcomm ! temporary integer 1545 1885 !!---------------------------------------------------------------------- … … 1548 1888 IF( PRESENT(kcom) ) localcomm = kcom 1549 1889 ! 1550 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror )1890 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) 1551 1891 ! 1552 1892 ktab = iwork … … 1562 1902 !! 1563 1903 !!---------------------------------------------------------------------- 1564 INTEGER , INTENT( in ) :: kdim 1565 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab 1566 INTEGER , INTENT( in ), OPTIONAL :: kcom 1904 INTEGER , INTENT( in ) :: kdim ! size of array 1905 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1906 INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array 1567 1907 !! 1568 1908 INTEGER :: ierror, localcomm ! temporary integer … … 1596 1936 IF( PRESENT(kcom) ) localcomm = kcom 1597 1937 ! 1598 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )1938 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) 1599 1939 ! 1600 1940 ktab = iwork … … 1610 1950 !! 1611 1951 !!---------------------------------------------------------------------- 1612 INTEGER, INTENT(in ) :: kdim 1613 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab 1614 ! !1952 INTEGER, INTENT(in ) :: kdim ! ??? 1953 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ??? 1954 ! 1615 1955 INTEGER :: ierror 1616 1956 INTEGER, DIMENSION (kdim) :: iwork … … 1653 1993 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 1654 1994 INTEGER , INTENT(in ), OPTIONAL :: kcom 1655 ! !1995 ! 1656 1996 INTEGER :: ierror, localcomm 1657 1997 REAL(wp), DIMENSION(kdim) :: zwork … … 1688 2028 ! 1689 2029 END SUBROUTINE mppmax_real 2030 2031 SUBROUTINE mppmax_real_multiple( ptab, NUM , kcom ) 2032 !!---------------------------------------------------------------------- 2033 !! *** routine mppmax_real *** 2034 !! 2035 !! ** Purpose : Maximum 2036 !! 2037 !!---------------------------------------------------------------------- 2038 REAL(wp), DIMENSION(:) , INTENT(inout) :: ptab ! ??? 2039 INTEGER , INTENT(in ) :: NUM 2040 INTEGER , INTENT(in ), OPTIONAL :: kcom ! ??? 2041 !! 2042 INTEGER :: ierror, localcomm 2043 REAL(wp) , POINTER , DIMENSION(:) :: zwork 2044 !!---------------------------------------------------------------------- 2045 ! 2046 CALL wrk_alloc(NUM , zwork) 2047 localcomm = mpi_comm_opa 2048 IF( PRESENT(kcom) ) localcomm = kcom 2049 ! 2050 CALL mpi_allreduce( ptab, zwork, NUM, mpi_double_precision, mpi_max, localcomm, ierror ) 2051 ptab = zwork 2052 CALL wrk_dealloc(NUM , zwork) 2053 ! 2054 END SUBROUTINE mppmax_real_multiple 1690 2055 1691 2056 … … 1785 2150 END SUBROUTINE mppsum_real 1786 2151 2152 1787 2153 SUBROUTINE mppsum_realdd( ytab, kcom ) 1788 2154 !!---------------------------------------------------------------------- … … 1793 2159 !! 1794 2160 !!----------------------------------------------------------------------- 1795 COMPLEX(wp), INTENT(inout) ::ytab ! input scalar1796 INTEGER , INTENT( in ), OPTIONAL ::kcom1797 1798 !! * Local variables (MPI version)1799 INTEGER :: ierror1800 INTEGER :: localcomm1801 COMPLEX(wp) :: zwork1802 2161 COMPLEX(wp), INTENT(inout) :: ytab ! input scalar 2162 INTEGER , INTENT(in ), OPTIONAL :: kcom 2163 ! 2164 INTEGER :: ierror 2165 INTEGER :: localcomm 2166 COMPLEX(wp) :: zwork 2167 !!----------------------------------------------------------------------- 2168 ! 1803 2169 localcomm = mpi_comm_opa 1804 IF( PRESENT(kcom) ) localcomm = kcom1805 2170 IF( PRESENT(kcom) ) localcomm = kcom 2171 ! 1806 2172 ! reduce local sums into global sum 1807 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, & 1808 MPI_SUMDD,localcomm,ierror) 2173 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 1809 2174 ytab = zwork 1810 2175 ! 1811 2176 END SUBROUTINE mppsum_realdd 1812 2177 … … 1820 2185 !! 1821 2186 !!----------------------------------------------------------------------- 1822 INTEGER , INTENT( in ) :: kdim ! size of ytab 1823 COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array 1824 INTEGER , INTENT( in ), OPTIONAL :: kcom 1825 1826 !! * Local variables (MPI version) 1827 INTEGER :: ierror ! temporary integer 1828 INTEGER :: localcomm 2187 INTEGER , INTENT(in ) :: kdim ! size of ytab 2188 COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array 2189 INTEGER , OPTIONAL , INTENT(in ) :: kcom 2190 ! 2191 INTEGER:: ierror, localcomm ! local integer 1829 2192 COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace 1830 2193 !!----------------------------------------------------------------------- 2194 ! 1831 2195 localcomm = mpi_comm_opa 1832 IF( PRESENT(kcom) ) localcomm = kcom 1833 1834 CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, & 1835 MPI_SUMDD,localcomm,ierror) 2196 IF( PRESENT(kcom) ) localcomm = kcom 2197 ! 2198 CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 1836 2199 ytab(:) = zwork(:) 1837 2200 ! 1838 2201 END SUBROUTINE mppsum_a_realdd 2202 1839 2203 1840 2204 SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) … … 1852 2216 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 1853 2217 INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame 1854 !! 2218 ! 2219 INTEGER :: ierror 1855 2220 INTEGER , DIMENSION(2) :: ilocs 1856 INTEGER :: ierror1857 2221 REAL(wp) :: zmin ! local minimum 1858 2222 REAL(wp), DIMENSION(2,1) :: zain, zaout … … 2583 2947 END SUBROUTINE mpp_lbc_north_2d 2584 2948 2949 SUBROUTINE mpp_lbc_north_2d_multiple( pt2d_array, cd_type, psgn, num_fields) 2950 !!--------------------------------------------------------------------- 2951 !! *** routine mpp_lbc_north_2d *** 2952 !! 2953 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2954 !! in mpp configuration in case of jpn1 > 1 2955 !! (for multiple 2d arrays ) 2956 !! 2957 !! ** Method : North fold condition and mpp with more than one proc 2958 !! in i-direction require a specific treatment. We gather 2959 !! the 4 northern lines of the global domain on 1 processor 2960 !! and apply lbc north-fold on this sub array. Then we 2961 !! scatter the north fold array back to the processors. 2962 !! 2963 !!---------------------------------------------------------------------- 2964 INTEGER , INTENT (in ) :: num_fields ! number of variables contained in pt2d 2965 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 2966 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: cd_type ! nature of pt2d grid-points 2967 ! ! = T , U , V , F or W gridpoints 2968 REAL(wp), DIMENSION(:), INTENT(in ) :: psgn ! = -1. the sign change across the north fold 2969 !! ! = 1. , the sign is kept 2970 INTEGER :: ji, jj, jr, jk 2971 INTEGER :: ierr, itaille, ildi, ilei, iilb 2972 INTEGER :: ijpj, ijpjm1, ij, iproc 2973 INTEGER, DIMENSION (jpmaxngh) :: ml_req_nf !for mpi_isend when avoiding mpi_allgather 2974 INTEGER :: ml_err ! for mpi_isend when avoiding mpi_allgather 2975 INTEGER, DIMENSION(MPI_STATUS_SIZE):: ml_stat ! for mpi_isend when avoiding mpi_allgather 2976 ! ! Workspace for message transfers avoiding mpi_allgather 2977 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztab 2978 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: znorthloc, zfoldwk 2979 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: znorthgloio 2980 REAL(wp), DIMENSION(:,:,:) , ALLOCATABLE :: ztabl, ztabr 2981 INTEGER :: istatus(mpi_status_size) 2982 INTEGER :: iflag 2983 !!---------------------------------------------------------------------- 2984 ! 2985 ALLOCATE( ztab(jpiglo,4,num_fields), znorthloc(jpi,4,num_fields), zfoldwk(jpi,4,num_fields), & 2986 & znorthgloio(jpi,4,num_fields,jpni) ) ! expanded to 3 dimensions 2987 ALLOCATE( ztabl(jpi,4,num_fields), ztabr(jpi*jpmaxngh, 4,num_fields) ) 2988 ! 2989 ijpj = 4 2990 ijpjm1 = 3 2991 ! 2992 2993 DO jk = 1, num_fields 2994 DO jj = nlcj-ijpj+1, nlcj ! put in znorthloc the last 4 jlines of pt2d (for every variable) 2995 ij = jj - nlcj + ijpj 2996 znorthloc(:,ij,jk) = pt2d_array(jk)%pt2d(:,jj) 2997 END DO 2998 END DO 2999 ! ! Build in procs of ncomm_north the znorthgloio 3000 itaille = jpi * ijpj 3001 3002 IF ( l_north_nogather ) THEN 3003 ! 3004 ! Avoid the use of mpi_allgather by exchanging only with the processes already identified 3005 ! (in nemo_northcomms) as being involved in this process' northern boundary exchange 3006 ! 3007 ztabr(:,:,:) = 0 3008 ztabl(:,:,:) = 0 3009 3010 DO jk = 1, num_fields 3011 DO jj = nlcj-ijpj+1, nlcj ! First put local values into the global array 3012 ij = jj - nlcj + ijpj 3013 DO ji = nfsloop, nfeloop 3014 ztabl(ji,ij,jk) = pt2d_array(jk)%pt2d(ji,jj) 3015 END DO 3016 END DO 3017 END DO 3018 3019 DO jr = 1,nsndto 3020 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 3021 CALL mppsend(5, znorthloc, itaille*num_fields, nfipproc(isendto(jr),jpnj), ml_req_nf(jr)) ! Buffer expanded "num_fields" times 3022 ENDIF 3023 END DO 3024 DO jr = 1,nsndto 3025 iproc = nfipproc(isendto(jr),jpnj) 3026 IF(iproc .ne. -1) THEN 3027 ilei = nleit (iproc+1) 3028 ildi = nldit (iproc+1) 3029 iilb = nfiimpp(isendto(jr),jpnj) - nfiimpp(isendto(1),jpnj) 3030 ENDIF 3031 IF((iproc .ne. (narea-1)) .and. (iproc .ne. -1)) THEN 3032 CALL mpprecv(5, zfoldwk, itaille*num_fields, iproc) ! Buffer expanded "num_fields" times 3033 DO jk = 1 , num_fields 3034 DO jj = 1, ijpj 3035 DO ji = ildi, ilei 3036 ztabr(iilb+ji,jj,jk) = zfoldwk(ji,jj,jk) ! Modified to 3D 3037 END DO 3038 END DO 3039 END DO 3040 ELSE IF (iproc .eq. (narea-1)) THEN 3041 DO jk = 1, num_fields 3042 DO jj = 1, ijpj 3043 DO ji = ildi, ilei 3044 ztabr(iilb+ji,jj,jk) = pt2d_array(jk)%pt2d(ji,nlcj-ijpj+jj) ! Modified to 3D 3045 END DO 3046 END DO 3047 END DO 3048 ENDIF 3049 END DO 3050 IF (l_isend) THEN 3051 DO jr = 1,nsndto 3052 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 3053 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 3054 ENDIF 3055 END DO 3056 ENDIF 3057 ! 3058 DO ji = 1, num_fields ! Loop to manage 3D variables 3059 CALL mpp_lbc_nfd( ztabl(:,:,ji), ztabr(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 3060 END DO 3061 ! 3062 DO jk = 1, num_fields 3063 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 3064 ij = jj - nlcj + ijpj 3065 DO ji = 1, nlci 3066 pt2d_array(jk)%pt2d(ji,jj) = ztabl(ji,ij,jk) ! Modified to 3D 3067 END DO 3068 END DO 3069 END DO 3070 3071 ! 3072 ELSE 3073 ! 3074 CALL MPI_ALLGATHER( znorthloc , itaille*num_fields, MPI_DOUBLE_PRECISION, & 3075 & znorthgloio, itaille*num_fields, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 3076 ! 3077 ztab(:,:,:) = 0.e0 3078 DO jk = 1, num_fields 3079 DO jr = 1, ndim_rank_north ! recover the global north array 3080 iproc = nrank_north(jr) + 1 3081 ildi = nldit (iproc) 3082 ilei = nleit (iproc) 3083 iilb = nimppt(iproc) 3084 DO jj = 1, ijpj 3085 DO ji = ildi, ilei 3086 ztab(ji+iilb-1,jj,jk) = znorthgloio(ji,jj,jk,jr) 3087 END DO 3088 END DO 3089 END DO 3090 END DO 3091 3092 DO ji = 1, num_fields 3093 CALL lbc_nfd( ztab(:,:,ji), cd_type(ji), psgn(ji) ) ! North fold boundary condition 3094 END DO 3095 ! 3096 DO jk = 1, num_fields 3097 DO jj = nlcj-ijpj+1, nlcj ! Scatter back to pt2d 3098 ij = jj - nlcj + ijpj 3099 DO ji = 1, nlci 3100 pt2d_array(jk)%pt2d(ji,jj) = ztab(ji+nimpp-1,ij,jk) 3101 END DO 3102 END DO 3103 END DO 3104 ! 3105 ! 3106 ENDIF 3107 DEALLOCATE( ztab, znorthloc, zfoldwk, znorthgloio ) 3108 DEALLOCATE( ztabl, ztabr ) 3109 ! 3110 END SUBROUTINE mpp_lbc_north_2d_multiple 2585 3111 2586 3112 SUBROUTINE mpp_lbc_north_e( pt2d, cd_type, psgn) … … 2662 3188 END SUBROUTINE mpp_lbc_north_e 2663 3189 2664 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 3190 3191 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2665 3192 !!---------------------------------------------------------------------- 2666 3193 !! *** routine mpp_lnk_bdy_3d *** … … 2683 3210 !! 2684 3211 !!---------------------------------------------------------------------- 2685 2686 USE lbcnfd ! north fold2687 2688 INCLUDE 'mpif.h'2689 2690 3212 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2691 3213 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points … … 2694 3216 ! ! = 1. , the sign is kept 2695 3217 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3218 ! 2696 3219 INTEGER :: ji, jj, jk, jl ! dummy loop indices 2697 INTEGER :: imigr, iihom, ijhom ! temporaryintegers3220 INTEGER :: imigr, iihom, ijhom ! local integers 2698 3221 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2699 REAL(wp) :: zland 3222 REAL(wp) :: zland ! local scalar 2700 3223 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 2701 3224 ! 2702 3225 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 2703 3226 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 2704 2705 !!---------------------------------------------------------------------- 2706 3227 !!---------------------------------------------------------------------- 3228 ! 2707 3229 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 2708 3230 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 2709 3231 2710 zland = 0. e03232 zland = 0._wp 2711 3233 2712 3234 ! 1. standard boundary treatment 2713 3235 ! ------------------------------ 2714 2715 3236 ! ! East-West boundaries 2716 3237 ! !* Cyclic east-west 2717 2718 3238 IF( nbondi == 2) THEN 2719 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN2720 ptab( 1 ,:,:) = ptab(jpim1,:,:)2721 ptab(jpi,:,:) = ptab( 2 ,:,:)2722 ELSE2723 IF( .NOT. cd_type == 'F' ) ptab( 1:jpreci,:,:) = zland ! south except F-point2724 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north2725 ENDIF3239 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 3240 ptab( 1 ,:,:) = ptab(jpim1,:,:) 3241 ptab(jpi,:,:) = ptab( 2 ,:,:) 3242 ELSE 3243 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 3244 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north 3245 ENDIF 2726 3246 ELSEIF(nbondi == -1) THEN 2727 IF( .NOT. cd_type == 'F' ) ptab( 1:jpreci,:,:) = zland ! south except F-point3247 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 2728 3248 ELSEIF(nbondi == 1) THEN 2729 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north3249 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north 2730 3250 ENDIF !* closed 2731 3251 2732 3252 IF (nbondj == 2 .OR. nbondj == -1) THEN 2733 IF( .NOT. cd_type == 'F' ) ptab(:, 1:jprecj,:) = zland ! south except F-point3253 IF( .NOT. cd_type == 'F' ) ptab(:,1:jprecj,:) = zland ! south except F-point 2734 3254 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2735 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 2736 ENDIF 2737 2738 ! 2739 3255 ptab(:,nlcj-jprecj+1:jpj,:) = zland ! north 3256 ENDIF 3257 ! 2740 3258 ! 2. East and west directions exchange 2741 3259 ! ------------------------------------ … … 2794 3312 CASE ( 0 ) 2795 3313 DO jl = 1, jpreci 2796 ptab( jl,:,:) = zt3we(:,jl,:,2)3314 ptab( jl,:,:) = zt3we(:,jl,:,2) 2797 3315 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 2798 3316 END DO 2799 3317 CASE ( 1 ) 2800 3318 DO jl = 1, jpreci 2801 ptab( jl,:,:) = zt3we(:,jl,:,2)3319 ptab( jl,:,:) = zt3we(:,jl,:,2) 2802 3320 END DO 2803 3321 END SELECT … … 2885 3403 END SUBROUTINE mpp_lnk_bdy_3d 2886 3404 2887 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 3405 3406 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 2888 3407 !!---------------------------------------------------------------------- 2889 3408 !! *** routine mpp_lnk_bdy_2d *** … … 2906 3425 !! 2907 3426 !!---------------------------------------------------------------------- 2908 2909 USE lbcnfd ! north fold 2910 2911 INCLUDE 'mpif.h' 2912 2913 REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2914 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 2915 ! ! = T , U , V , F , W points 2916 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 2917 ! ! = 1. , the sign is kept 2918 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3427 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3428 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 3429 ! ! = T , U , V , F , W points 3430 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 3431 ! ! = 1. , the sign is kept 3432 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3433 ! 2919 3434 INTEGER :: ji, jj, jl ! dummy loop indices 2920 INTEGER :: imigr, iihom, ijhom ! temporaryintegers3435 INTEGER :: imigr, iihom, ijhom ! local integers 2921 3436 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2922 3437 REAL(wp) :: zland … … 2925 3440 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 2926 3441 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 2927 2928 3442 !!---------------------------------------------------------------------- 2929 3443 … … 2931 3445 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 2932 3446 2933 zland = 0. e03447 zland = 0._wp 2934 3448 2935 3449 ! 1. standard boundary treatment 2936 3450 ! ------------------------------ 2937 2938 3451 ! ! East-West boundaries 2939 ! !* Cyclic east-west 2940 2941 IF( nbondi == 2) THEN 2942 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 2943 ptab( 1 ,:) = ptab(jpim1,:) 2944 ptab(jpi,:) = ptab( 2 ,:) 2945 ELSE 2946 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 2947 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 2948 ENDIF 3452 ! !* Cyclic east-west 3453 IF( nbondi == 2 ) THEN 3454 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 3455 ptab( 1 ,:) = ptab(jpim1,:) 3456 ptab(jpi,:) = ptab( 2 ,:) 3457 ELSE 3458 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3459 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3460 ENDIF 2949 3461 ELSEIF(nbondi == -1) THEN 2950 IF( .NOT. cd_type == 'F' )ptab( 1 :jpreci,:) = zland ! south except F-point3462 IF( .NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 2951 3463 ELSEIF(nbondi == 1) THEN 2952 ptab(nlci-jpreci+1:jpi ,:) = zland ! north2953 ENDIF !* closed2954 2955 IF (nbondj == 2 .OR. nbondj == -1) THEN2956 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj) = zland! south except F-point3464 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3465 ENDIF 3466 ! !* closed 3467 IF( nbondj == 2 .OR. nbondj == -1 ) THEN 3468 IF( .NOT.cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point 2957 3469 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2958 ptab(:,nlcj-jprecj+1:jpj) = zland ! north 2959 ENDIF 2960 2961 ! 2962 3470 ptab(:,nlcj-jprecj+1:jpj ) = zland ! north 3471 ENDIF 3472 ! 2963 3473 ! 2. East and west directions exchange 2964 3474 ! ------------------------------------ … … 3107 3617 ! 3108 3618 END SUBROUTINE mpp_lnk_bdy_2d 3619 3109 3620 3110 3621 SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) … … 3196 3707 END SUBROUTINE DDPDD_MPI 3197 3708 3709 3198 3710 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 3199 3711 !!--------------------------------------------------------------------- … … 3218 3730 !! ! north fold, = 1. otherwise 3219 3731 INTEGER, OPTIONAL , INTENT(in ) :: pr2dj 3732 ! 3220 3733 INTEGER :: ji, jj, jr 3221 3734 INTEGER :: ierr, itaille, ildi, ilei, iilb … … 3224 3737 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 3225 3738 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 3226 3227 3739 !!---------------------------------------------------------------------- 3228 3740 ! … … 3234 3746 ENDIF 3235 3747 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 3236 3237 ! 3238 ztab_e(:,:) = 0.e0 3239 3240 ij=0 3748 ! 3749 ztab_e(:,:) = 0._wp 3750 ! 3751 ij = 0 3241 3752 ! put in znorthloc_e the last 4 jlines of pt2d 3242 3753 DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj … … 3280 3791 ! 3281 3792 END SUBROUTINE mpp_lbc_north_icb 3793 3282 3794 3283 3795 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) … … 3300 3812 !! noso : number for local neighboring processors 3301 3813 !! nono : number for local neighboring processors 3302 !!3303 3814 !!---------------------------------------------------------------------- 3304 3815 INTEGER , INTENT(in ) :: jpri … … 3459 3970 3460 3971 END SUBROUTINE mpp_lnk_2d_icb 3972 3461 3973 #else 3462 3974 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.
