- Timestamp:
- 2016-07-19T10:38:35+02:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/NERC/dev_r5549_BDY_ZEROGRAD/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r5429 r6808 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 optimizations25 !! 3.5 ! 2013 (S.Mocavero, I.Epicoco - CMCC) north fold optimizations 26 26 !!---------------------------------------------------------------------- 27 27 28 28 !!---------------------------------------------------------------------- 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 unit29 !! ctl_stop : update momentum and tracer Kz from a tke scheme 30 !! ctl_warn : initialization, namelist read, and parameters control 31 !! ctl_opn : Open file and check if required file is available. 32 !! ctl_nam : Prints informations when an error occurs while reading a namelist 33 !! get_unit : give the index of an unused logical unit 34 34 !!---------------------------------------------------------------------- 35 35 #if defined key_mpp_mpi … … 43 43 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 44 44 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 45 !! mpprecv 45 !! mpprecv : 46 46 !! mppsend : SUBROUTINE mpp_ini_znl 47 47 !! mppscatter : … … 72 72 PUBLIC mpp_lnk_3d, mpp_lnk_3d_gather, mpp_lnk_2d, mpp_lnk_2d_e 73 73 PUBLIC mpp_lnk_2d_9 74 PUBLIC mpp_lnk_sum_3d, mpp_lnk_sum_2d 74 75 PUBLIC mppscatter, mppgather 75 76 PUBLIC mpp_ini_ice, mpp_ini_znl … … 94 95 END INTERFACE 95 96 INTERFACE mpp_sum 96 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &97 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 97 98 mppsum_realdd, mppsum_a_realdd 98 99 END INTERFACE … … 175 176 !! ** Purpose : Find processor unit 176 177 !!---------------------------------------------------------------------- 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 ) :: localComm178 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt ! 179 CHARACTER(len=*) , INTENT(in ) :: ldname ! 180 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 181 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist 182 INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output 183 INTEGER , INTENT(inout) :: kstop ! stop indicator 184 INTEGER , OPTIONAL , INTENT(in ) :: localComm ! 184 185 ! 185 186 INTEGER :: mynode, ierr, code, ji, ii, ios … … 190 191 ! 191 192 ii = 1 192 WRITE(ldtxt(ii),*) 193 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' 194 WRITE(ldtxt(ii),*) '~~~~~~ ' 193 WRITE(ldtxt(ii),*) ; ii = ii + 1 194 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 195 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 195 196 ! 196 197 … … 204 205 205 206 ! ! 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 + 1207 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 208 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 209 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 209 210 210 211 #if defined key_agrif … … 223 224 224 225 IF( (jpni < 1) .OR. (jpnj < 1) )THEN 225 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ;ii = ii + 1226 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ; ii = ii + 1 226 227 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 +1228 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1 229 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 230 WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii + 1 230 231 END IF 231 232 … … 246 247 SELECT CASE ( cn_mpi_send ) 247 248 CASE ( 'S' ) ! Standard mpi send (blocking) 248 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' 249 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 249 250 CASE ( 'B' ) ! Buffer mpi send (blocking) 250 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' 251 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 251 252 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 252 253 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 253 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' 254 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 254 255 l_isend = .TRUE. 255 256 CASE DEFAULT 256 WRITE(ldtxt(ii),cform_err) 257 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send 257 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 258 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 258 259 kstop = kstop + 1 259 260 END SELECT 260 261 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 ! ' 262 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 263 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 263 264 kstop = kstop + 1 264 265 ELSE 265 266 SELECT CASE ( cn_mpi_send ) 266 267 CASE ( 'S' ) ! Standard mpi send (blocking) 267 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' 268 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 268 269 CALL mpi_init( ierr ) 269 270 CASE ( 'B' ) ! Buffer mpi send (blocking) 270 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' 271 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 271 272 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 272 273 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 273 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' 274 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 274 275 l_isend = .TRUE. 275 276 CALL mpi_init( ierr ) 276 277 CASE DEFAULT 277 WRITE(ldtxt(ii),cform_err) 278 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send 278 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 279 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 279 280 kstop = kstop + 1 280 281 END SELECT … … 298 299 ENDIF 299 300 301 #if defined key_agrif 302 IF (Agrif_Root()) THEN 303 CALL Agrif_MPI_Init(mpi_comm_opa) 304 ELSE 305 CALL Agrif_MPI_set_grid_comm(mpi_comm_opa) 306 ENDIF 307 #endif 308 300 309 CALL mpi_comm_rank( mpi_comm_opa, mpprank, ierr ) 301 310 CALL mpi_comm_size( mpi_comm_opa, mppsize, ierr ) … … 310 319 ! 311 320 END FUNCTION mynode 321 312 322 313 323 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) … … 339 349 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 340 350 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 341 ! !351 ! 342 352 INTEGER :: ji, jj, jk, jl ! dummy loop indices 343 353 INTEGER :: imigr, iihom, ijhom ! temporary integers 344 354 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 345 355 REAL(wp) :: zland 346 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 347 ! 356 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 348 357 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 349 358 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 350 351 359 !!---------------------------------------------------------------------- 352 360 … … 356 364 ! 357 365 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 358 ELSE ; zland = 0. e0! zero by default366 ELSE ; zland = 0._wp ! zero by default 359 367 ENDIF 360 368 … … 447 455 END SELECT 448 456 449 450 457 ! 3. North and south directions 451 458 ! ----------------------------- … … 500 507 END SELECT 501 508 502 503 509 ! 4. north fold treatment 504 510 ! ----------------------- … … 516 522 ! 517 523 END SUBROUTINE mpp_lnk_3d 524 518 525 519 526 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) … … 534 541 !! noso : number for local neighboring processors 535 542 !! nono : number for local neighboring processors 536 !! 537 !!---------------------------------------------------------------------- 538 539 INTEGER :: num_fields 540 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 543 !!---------------------------------------------------------------------- 541 544 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 542 545 ! ! = T , U , V , F , W and I points … … 550 553 INTEGER :: imigr, iihom, ijhom ! temporary integers 551 554 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 552 555 INTEGER :: num_fields 556 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 553 557 REAL(wp) :: zland 554 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 555 ! 558 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 556 559 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 557 560 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 558 561 559 562 !!---------------------------------------------------------------------- 560 563 ! 561 564 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 562 565 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 563 564 566 ! 565 567 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 566 ELSE ; zland = 0. e0! zero by default568 ELSE ; zland = 0._wp ! zero by default 567 569 ENDIF 568 570 … … 736 738 ! 737 739 END DO 738 740 ! 739 741 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 740 742 ! … … 742 744 743 745 744 SUBROUTINE load_array( pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields)746 SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields ) 745 747 !!--------------------------------------------------------------------- 746 REAL(wp), DIMENSION(jpi,jpj), TARGET ,INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied747 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points748 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary748 REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 749 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 750 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 749 751 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 750 752 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 751 753 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 752 INTEGER , INTENT (inout):: num_fields754 INTEGER , INTENT (inout) :: num_fields 753 755 !!--------------------------------------------------------------------- 754 num_fields =num_fields+1755 pt2d_array(num_fields)%pt2d =>pt2d756 type_array(num_fields) =cd_type757 psgn_array(num_fields) =psgn756 num_fields = num_fields + 1 757 pt2d_array(num_fields)%pt2d => pt2d 758 type_array(num_fields) = cd_type 759 psgn_array(num_fields) = psgn 758 760 END SUBROUTINE load_array 759 761 … … 784 786 INTEGER :: num_fields 785 787 !!--------------------------------------------------------------------- 786 788 ! 787 789 num_fields = 0 788 789 !! Load the first array 790 CALL load_array(pt2dA,cd_typeA,psgnA,pt2d_array, type_array, psgn_array,num_fields) 791 792 !! Look if more arrays are added 793 IF(PRESENT (psgnB) )CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 794 IF(PRESENT (psgnC) )CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 795 IF(PRESENT (psgnD) )CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 796 IF(PRESENT (psgnE) )CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 797 IF(PRESENT (psgnF) )CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 798 IF(PRESENT (psgnG) )CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 799 IF(PRESENT (psgnH) )CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 800 IF(PRESENT (psgnI) )CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 801 802 CALL mpp_lnk_2d_multiple(pt2d_array,type_array,psgn_array,num_fields,cd_mpp,pval) 790 ! 791 ! Load the first array 792 CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) 793 ! 794 ! Look if more arrays are added 795 IF( PRESENT(psgnB) ) CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 796 IF( PRESENT(psgnC) ) CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 797 IF( PRESENT(psgnD) ) CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 798 IF( PRESENT(psgnE) ) CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 799 IF( PRESENT(psgnF) ) CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 800 IF( PRESENT(psgnG) ) CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 801 IF( PRESENT(psgnH) ) CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 802 IF( PRESENT(psgnI) ) CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 803 ! 804 CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) 805 ! 803 806 END SUBROUTINE mpp_lnk_2d_9 804 807 … … 835 838 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 836 839 REAL(wp) :: zland 837 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 838 ! 840 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 839 841 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 840 842 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 841 842 !!---------------------------------------------------------------------- 843 843 !!---------------------------------------------------------------------- 844 ! 844 845 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 845 846 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 846 847 847 ! 848 848 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 849 ELSE ; zland = 0. e0! zero by default849 ELSE ; zland = 0._wp ! zero by default 850 850 ENDIF 851 851 … … 1038 1038 INTEGER :: imigr, iihom, ijhom ! temporary integers 1039 1039 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1040 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1041 ! 1040 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1042 1041 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ns, zt4sn ! 2 x 3d for north-south & south-north 1043 1042 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ew, zt4we ! 2 x 3d for east-west & west-east 1044 1045 ! !----------------------------------------------------------------------1043 !!---------------------------------------------------------------------- 1044 ! 1046 1045 ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) , & 1047 1046 & zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) 1048 1049 1047 ! 1050 1048 ! 1. standard boundary treatment 1051 1049 ! ------------------------------ … … 1391 1389 END DO 1392 1390 END SELECT 1393 1391 ! 1394 1392 END SUBROUTINE mpp_lnk_2d_e 1395 1393 1394 SUBROUTINE mpp_lnk_sum_3d( ptab, cd_type, psgn, cd_mpp, pval ) 1395 !!---------------------------------------------------------------------- 1396 !! *** routine mpp_lnk_sum_3d *** 1397 !! 1398 !! ** Purpose : Message passing manadgement (sum the overlap region) 1399 !! 1400 !! ** Method : Use mppsend and mpprecv function for passing mask 1401 !! between processors following neighboring subdomains. 1402 !! domain parameters 1403 !! nlci : first dimension of the local subdomain 1404 !! nlcj : second dimension of the local subdomain 1405 !! nbondi : mark for "east-west local boundary" 1406 !! nbondj : mark for "north-south local boundary" 1407 !! noea : number for local neighboring processors 1408 !! nowe : number for local neighboring processors 1409 !! noso : number for local neighboring processors 1410 !! nono : number for local neighboring processors 1411 !! 1412 !! ** Action : ptab with update value at its periphery 1413 !! 1414 !!---------------------------------------------------------------------- 1415 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 1416 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1417 ! ! = T , U , V , F , W points 1418 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1419 ! ! = 1. , the sign is kept 1420 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1421 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 1422 !! 1423 INTEGER :: ji, jj, jk, jl ! dummy loop indices 1424 INTEGER :: imigr, iihom, ijhom ! temporary integers 1425 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1426 REAL(wp) :: zland 1427 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1428 ! 1429 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 1430 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 1431 1432 !!---------------------------------------------------------------------- 1433 1434 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 1435 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 1436 1437 ! 1438 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1439 ELSE ; zland = 0.e0 ! zero by default 1440 ENDIF 1441 1442 ! 1. standard boundary treatment 1443 ! ------------------------------ 1444 ! 2. East and west directions exchange 1445 ! ------------------------------------ 1446 ! we play with the neigbours AND the row number because of the periodicity 1447 ! 1448 SELECT CASE ( nbondi ) ! Read lateral conditions 1449 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1450 iihom = nlci-jpreci 1451 DO jl = 1, jpreci 1452 zt3ew(:,jl,:,1) = ptab(jl ,:,:) ; ptab(jl ,:,:) = 0.0_wp 1453 zt3we(:,jl,:,1) = ptab(iihom+jl,:,:) ; ptab(iihom+jl,:,:) = 0.0_wp 1454 END DO 1455 END SELECT 1456 ! 1457 ! ! Migrations 1458 imigr = jpreci * jpj * jpk 1459 ! 1460 SELECT CASE ( nbondi ) 1461 CASE ( -1 ) 1462 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req1 ) 1463 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 1464 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1465 CASE ( 0 ) 1466 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 1467 CALL mppsend( 2, zt3we(1,1,1,1), imigr, noea, ml_req2 ) 1468 CALL mpprecv( 1, zt3ew(1,1,1,2), imigr, noea ) 1469 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 1470 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1471 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1472 CASE ( 1 ) 1473 CALL mppsend( 1, zt3ew(1,1,1,1), imigr, nowe, ml_req1 ) 1474 CALL mpprecv( 2, zt3we(1,1,1,2), imigr, nowe ) 1475 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1476 END SELECT 1477 ! 1478 ! ! Write lateral conditions 1479 iihom = nlci-nreci 1480 ! 1481 SELECT CASE ( nbondi ) 1482 CASE ( -1 ) 1483 DO jl = 1, jpreci 1484 ptab(iihom+jl,:,:) = ptab(iihom+jl,:,:) + zt3ew(:,jl,:,2) 1485 END DO 1486 CASE ( 0 ) 1487 DO jl = 1, jpreci 1488 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 1489 ptab(iihom +jl,:,:) = ptab(iihom +jl,:,:) + zt3ew(:,jl,:,2) 1490 END DO 1491 CASE ( 1 ) 1492 DO jl = 1, jpreci 1493 ptab(jpreci+jl,:,:) = ptab(jpreci+jl,:,:) + zt3we(:,jl,:,2) 1494 END DO 1495 END SELECT 1496 1497 1498 ! 3. North and south directions 1499 ! ----------------------------- 1500 ! always closed : we play only with the neigbours 1501 ! 1502 IF( nbondj /= 2 ) THEN ! Read lateral conditions 1503 ijhom = nlcj-jprecj 1504 DO jl = 1, jprecj 1505 zt3sn(:,jl,:,1) = ptab(:,ijhom+jl,:) ; ptab(:,ijhom+jl,:) = 0.0_wp 1506 zt3ns(:,jl,:,1) = ptab(:,jl ,:) ; ptab(:,jl ,:) = 0.0_wp 1507 END DO 1508 ENDIF 1509 ! 1510 ! ! Migrations 1511 imigr = jprecj * jpi * jpk 1512 ! 1513 SELECT CASE ( nbondj ) 1514 CASE ( -1 ) 1515 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req1 ) 1516 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 1517 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1518 CASE ( 0 ) 1519 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 1520 CALL mppsend( 4, zt3sn(1,1,1,1), imigr, nono, ml_req2 ) 1521 CALL mpprecv( 3, zt3ns(1,1,1,2), imigr, nono ) 1522 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 1523 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1524 IF(l_isend) CALL mpi_wait(ml_req2, ml_stat, ml_err) 1525 CASE ( 1 ) 1526 CALL mppsend( 3, zt3ns(1,1,1,1), imigr, noso, ml_req1 ) 1527 CALL mpprecv( 4, zt3sn(1,1,1,2), imigr, noso ) 1528 IF(l_isend) CALL mpi_wait(ml_req1, ml_stat, ml_err) 1529 END SELECT 1530 ! 1531 ! ! Write lateral conditions 1532 ijhom = nlcj-nrecj 1533 ! 1534 SELECT CASE ( nbondj ) 1535 CASE ( -1 ) 1536 DO jl = 1, jprecj 1537 ptab(:,ijhom+jl,:) = ptab(:,ijhom+jl,:) + zt3ns(:,jl,:,2) 1538 END DO 1539 CASE ( 0 ) 1540 DO jl = 1, jprecj 1541 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl,:,2) 1542 ptab(:,ijhom +jl,:) = ptab(:,ijhom +jl,:) + zt3ns(:,jl,:,2) 1543 END DO 1544 CASE ( 1 ) 1545 DO jl = 1, jprecj 1546 ptab(:,jprecj+jl,:) = ptab(:,jprecj+jl,:) + zt3sn(:,jl ,:,2) 1547 END DO 1548 END SELECT 1549 1550 1551 ! 4. north fold treatment 1552 ! ----------------------- 1553 ! 1554 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 1555 ! 1556 SELECT CASE ( jpni ) 1557 CASE ( 1 ) ; CALL lbc_nfd ( ptab, cd_type, psgn ) ! only 1 northern proc, no mpp 1558 CASE DEFAULT ; CALL mpp_lbc_north( ptab, cd_type, psgn ) ! for all northern procs. 1559 END SELECT 1560 ! 1561 ENDIF 1562 ! 1563 DEALLOCATE( zt3ns, zt3sn, zt3ew, zt3we ) 1564 ! 1565 END SUBROUTINE mpp_lnk_sum_3d 1566 1567 SUBROUTINE mpp_lnk_sum_2d( pt2d, cd_type, psgn, cd_mpp, pval ) 1568 !!---------------------------------------------------------------------- 1569 !! *** routine mpp_lnk_sum_2d *** 1570 !! 1571 !! ** Purpose : Message passing manadgement for 2d array (sum the overlap region) 1572 !! 1573 !! ** Method : Use mppsend and mpprecv function for passing mask 1574 !! between processors following neighboring subdomains. 1575 !! domain parameters 1576 !! nlci : first dimension of the local subdomain 1577 !! nlcj : second dimension of the local subdomain 1578 !! nbondi : mark for "east-west local boundary" 1579 !! nbondj : mark for "north-south local boundary" 1580 !! noea : number for local neighboring processors 1581 !! nowe : number for local neighboring processors 1582 !! noso : number for local neighboring processors 1583 !! nono : number for local neighboring processors 1584 !! 1585 !!---------------------------------------------------------------------- 1586 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: pt2d ! 2D array on which the boundary condition is applied 1587 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 1588 ! ! = T , U , V , F , W and I points 1589 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 1590 ! ! = 1. , the sign is kept 1591 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 1592 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 1593 !! 1594 INTEGER :: ji, jj, jl ! dummy loop indices 1595 INTEGER :: imigr, iihom, ijhom ! temporary integers 1596 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1597 REAL(wp) :: zland 1598 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1599 ! 1600 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 1601 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 1602 1603 !!---------------------------------------------------------------------- 1604 1605 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 1606 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 1607 1608 ! 1609 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 1610 ELSE ; zland = 0.e0 ! zero by default 1611 ENDIF 1612 1613 ! 1. standard boundary treatment 1614 ! ------------------------------ 1615 ! 2. East and west directions exchange 1616 ! ------------------------------------ 1617 ! we play with the neigbours AND the row number because of the periodicity 1618 ! 1619 SELECT CASE ( nbondi ) ! Read lateral conditions 1620 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 1621 iihom = nlci - jpreci 1622 DO jl = 1, jpreci 1623 zt2ew(:,jl,1) = pt2d(jl ,:) ; pt2d(jl ,:) = 0.0_wp 1624 zt2we(:,jl,1) = pt2d(iihom +jl,:) ; pt2d(iihom +jl,:) = 0.0_wp 1625 END DO 1626 END SELECT 1627 ! 1628 ! ! Migrations 1629 imigr = jpreci * jpj 1630 ! 1631 SELECT CASE ( nbondi ) 1632 CASE ( -1 ) 1633 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req1 ) 1634 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 1635 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1636 CASE ( 0 ) 1637 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 1638 CALL mppsend( 2, zt2we(1,1,1), imigr, noea, ml_req2 ) 1639 CALL mpprecv( 1, zt2ew(1,1,2), imigr, noea ) 1640 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 1641 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1642 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1643 CASE ( 1 ) 1644 CALL mppsend( 1, zt2ew(1,1,1), imigr, nowe, ml_req1 ) 1645 CALL mpprecv( 2, zt2we(1,1,2), imigr, nowe ) 1646 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1647 END SELECT 1648 ! 1649 ! ! Write lateral conditions 1650 iihom = nlci-nreci 1651 ! 1652 SELECT CASE ( nbondi ) 1653 CASE ( -1 ) 1654 DO jl = 1, jpreci 1655 pt2d(iihom+jl,:) = pt2d(iihom+jl,:) + zt2ew(:,jl,2) 1656 END DO 1657 CASE ( 0 ) 1658 DO jl = 1, jpreci 1659 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 1660 pt2d(iihom +jl,:) = pt2d(iihom +jl,:) + zt2ew(:,jl,2) 1661 END DO 1662 CASE ( 1 ) 1663 DO jl = 1, jpreci 1664 pt2d(jpreci+jl,:) = pt2d(jpreci+jl,:) + zt2we(:,jl,2) 1665 END DO 1666 END SELECT 1667 1668 1669 ! 3. North and south directions 1670 ! ----------------------------- 1671 ! always closed : we play only with the neigbours 1672 ! 1673 IF( nbondj /= 2 ) THEN ! Read lateral conditions 1674 ijhom = nlcj - jprecj 1675 DO jl = 1, jprecj 1676 zt2sn(:,jl,1) = pt2d(:,ijhom +jl) ; pt2d(:,ijhom +jl) = 0.0_wp 1677 zt2ns(:,jl,1) = pt2d(:,jl ) ; pt2d(:,jl ) = 0.0_wp 1678 END DO 1679 ENDIF 1680 ! 1681 ! ! Migrations 1682 imigr = jprecj * jpi 1683 ! 1684 SELECT CASE ( nbondj ) 1685 CASE ( -1 ) 1686 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req1 ) 1687 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 1688 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1689 CASE ( 0 ) 1690 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 1691 CALL mppsend( 4, zt2sn(1,1,1), imigr, nono, ml_req2 ) 1692 CALL mpprecv( 3, zt2ns(1,1,2), imigr, nono ) 1693 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 1694 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1695 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 1696 CASE ( 1 ) 1697 CALL mppsend( 3, zt2ns(1,1,1), imigr, noso, ml_req1 ) 1698 CALL mpprecv( 4, zt2sn(1,1,2), imigr, noso ) 1699 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 1700 END SELECT 1701 ! 1702 ! ! Write lateral conditions 1703 ijhom = nlcj-nrecj 1704 ! 1705 SELECT CASE ( nbondj ) 1706 CASE ( -1 ) 1707 DO jl = 1, jprecj 1708 pt2d(:,ijhom+jl) = pt2d(:,ijhom+jl) + zt2ns(:,jl,2) 1709 END DO 1710 CASE ( 0 ) 1711 DO jl = 1, jprecj 1712 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 1713 pt2d(:,ijhom +jl) = pt2d(:,ijhom +jl) + zt2ns(:,jl,2) 1714 END DO 1715 CASE ( 1 ) 1716 DO jl = 1, jprecj 1717 pt2d(:,jprecj+jl) = pt2d(:,jprecj+jl) + zt2sn(:,jl,2) 1718 END DO 1719 END SELECT 1720 1721 1722 ! 4. north fold treatment 1723 ! ----------------------- 1724 ! 1725 IF( npolj /= 0 .AND. .NOT. PRESENT(cd_mpp) ) THEN 1726 ! 1727 SELECT CASE ( jpni ) 1728 CASE ( 1 ) ; CALL lbc_nfd ( pt2d, cd_type, psgn ) ! only 1 northern proc, no mpp 1729 CASE DEFAULT ; CALL mpp_lbc_north( pt2d, cd_type, psgn ) ! for all northern procs. 1730 END SELECT 1731 ! 1732 ENDIF 1733 ! 1734 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 1735 ! 1736 END SUBROUTINE mpp_lnk_sum_2d 1396 1737 1397 1738 SUBROUTINE mppsend( ktyp, pmess, kbytes, kdest, md_req ) … … 1441 1782 !!---------------------------------------------------------------------- 1442 1783 ! 1443 1444 1784 ! If a specific process number has been passed to the receive call, 1445 1785 ! use that one. Default is to use mpi_any_source 1446 use_source=mpi_any_source 1447 if(present(ksource)) then 1448 use_source=ksource 1449 end if 1450 1786 use_source = mpi_any_source 1787 IF( PRESENT(ksource) ) use_source = ksource 1788 ! 1451 1789 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag ) 1452 1790 ! … … 1462 1800 !! 1463 1801 !!---------------------------------------------------------------------- 1464 REAL(wp), DIMENSION(jpi,jpj) ,INTENT(in ) :: ptab ! subdomain input array1465 INTEGER ,INTENT(in ) :: kp ! record length1802 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: ptab ! subdomain input array 1803 INTEGER , INTENT(in ) :: kp ! record length 1466 1804 REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array 1467 1805 !! … … 1484 1822 !! 1485 1823 !!---------------------------------------------------------------------- 1486 REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio! output array1487 INTEGER :: kp 1488 REAL(wp), DIMENSION(jpi,jpj) :: ptab! subdomain array input1824 REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array 1825 INTEGER :: kp ! Tag (not used with MPI 1826 REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input 1489 1827 !! 1490 1828 INTEGER :: itaille, ierror ! temporary integer 1491 1829 !!--------------------------------------------------------------------- 1492 1830 ! 1493 itaille =jpi*jpj1831 itaille = jpi * jpj 1494 1832 ! 1495 1833 CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & … … 1509 1847 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1510 1848 INTEGER , INTENT(in ), OPTIONAL :: kcom ! 1511 ! !1849 ! 1512 1850 INTEGER :: ierror, localcomm ! temporary integer 1513 1851 INTEGER, DIMENSION(kdim) :: iwork … … 1531 1869 !! 1532 1870 !!---------------------------------------------------------------------- 1533 INTEGER, INTENT(inout) :: ktab 1534 INTEGER, INTENT(in ), OPTIONAL :: kcom 1535 ! !1871 INTEGER, INTENT(inout) :: ktab ! ??? 1872 INTEGER, INTENT(in ), OPTIONAL :: kcom ! ??? 1873 ! 1536 1874 INTEGER :: ierror, iwork, localcomm ! temporary integer 1537 1875 !!---------------------------------------------------------------------- … … 1540 1878 IF( PRESENT(kcom) ) localcomm = kcom 1541 1879 ! 1542 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror )1880 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) 1543 1881 ! 1544 1882 ktab = iwork … … 1554 1892 !! 1555 1893 !!---------------------------------------------------------------------- 1556 INTEGER , INTENT( in ) :: kdim 1557 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab 1558 INTEGER , INTENT( in ), OPTIONAL :: kcom 1894 INTEGER , INTENT( in ) :: kdim ! size of array 1895 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1896 INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array 1559 1897 !! 1560 1898 INTEGER :: ierror, localcomm ! temporary integer … … 1588 1926 IF( PRESENT(kcom) ) localcomm = kcom 1589 1927 ! 1590 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )1928 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) 1591 1929 ! 1592 1930 ktab = iwork … … 1602 1940 !! 1603 1941 !!---------------------------------------------------------------------- 1604 INTEGER, INTENT(in ) :: kdim 1605 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab 1606 ! !1942 INTEGER, INTENT(in ) :: kdim ! ??? 1943 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ??? 1944 ! 1607 1945 INTEGER :: ierror 1608 1946 INTEGER, DIMENSION (kdim) :: iwork … … 1645 1983 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 1646 1984 INTEGER , INTENT(in ), OPTIONAL :: kcom 1647 ! !1985 ! 1648 1986 INTEGER :: ierror, localcomm 1649 1987 REAL(wp), DIMENSION(kdim) :: zwork … … 1777 2115 END SUBROUTINE mppsum_real 1778 2116 2117 1779 2118 SUBROUTINE mppsum_realdd( ytab, kcom ) 1780 2119 !!---------------------------------------------------------------------- … … 1785 2124 !! 1786 2125 !!----------------------------------------------------------------------- 1787 COMPLEX(wp), INTENT(inout) ::ytab ! input scalar1788 INTEGER , INTENT( in ), OPTIONAL ::kcom1789 1790 !! * Local variables (MPI version)1791 INTEGER :: ierror1792 INTEGER :: localcomm1793 COMPLEX(wp) :: zwork1794 2126 COMPLEX(wp), INTENT(inout) :: ytab ! input scalar 2127 INTEGER , INTENT(in ), OPTIONAL :: kcom 2128 ! 2129 INTEGER :: ierror 2130 INTEGER :: localcomm 2131 COMPLEX(wp) :: zwork 2132 !!----------------------------------------------------------------------- 2133 ! 1795 2134 localcomm = mpi_comm_opa 1796 IF( PRESENT(kcom) ) localcomm = kcom1797 2135 IF( PRESENT(kcom) ) localcomm = kcom 2136 ! 1798 2137 ! reduce local sums into global sum 1799 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, & 1800 MPI_SUMDD,localcomm,ierror) 2138 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 1801 2139 ytab = zwork 1802 2140 ! 1803 2141 END SUBROUTINE mppsum_realdd 1804 2142 … … 1812 2150 !! 1813 2151 !!----------------------------------------------------------------------- 1814 INTEGER , INTENT( in ) :: kdim ! size of ytab 1815 COMPLEX(wp), DIMENSION(kdim), INTENT( inout ) :: ytab ! input array 1816 INTEGER , INTENT( in ), OPTIONAL :: kcom 1817 1818 !! * Local variables (MPI version) 1819 INTEGER :: ierror ! temporary integer 1820 INTEGER :: localcomm 2152 INTEGER , INTENT(in ) :: kdim ! size of ytab 2153 COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array 2154 INTEGER , OPTIONAL , INTENT(in ) :: kcom 2155 ! 2156 INTEGER:: ierror, localcomm ! local integer 1821 2157 COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace 1822 2158 !!----------------------------------------------------------------------- 2159 ! 1823 2160 localcomm = mpi_comm_opa 1824 IF( PRESENT(kcom) ) localcomm = kcom 1825 1826 CALL MPI_ALLREDUCE (ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, & 1827 MPI_SUMDD,localcomm,ierror) 2161 IF( PRESENT(kcom) ) localcomm = kcom 2162 ! 2163 CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 1828 2164 ytab(:) = zwork(:) 1829 2165 ! 1830 2166 END SUBROUTINE mppsum_a_realdd 2167 1831 2168 1832 2169 SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) … … 1844 2181 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 1845 2182 INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame 1846 !! 2183 ! 2184 INTEGER :: ierror 1847 2185 INTEGER , DIMENSION(2) :: ilocs 1848 INTEGER :: ierror1849 2186 REAL(wp) :: zmin ! local minimum 1850 2187 REAL(wp), DIMENSION(2,1) :: zain, zaout … … 2654 2991 END SUBROUTINE mpp_lbc_north_e 2655 2992 2656 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2993 2994 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2657 2995 !!---------------------------------------------------------------------- 2658 2996 !! *** routine mpp_lnk_bdy_3d *** … … 2675 3013 !! 2676 3014 !!---------------------------------------------------------------------- 2677 2678 USE lbcnfd ! north fold2679 2680 INCLUDE 'mpif.h'2681 2682 3015 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2683 3016 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points … … 2686 3019 ! ! = 1. , the sign is kept 2687 3020 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3021 ! 2688 3022 INTEGER :: ji, jj, jk, jl ! dummy loop indices 2689 INTEGER :: imigr, iihom, ijhom ! temporaryintegers3023 INTEGER :: imigr, iihom, ijhom ! local integers 2690 3024 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2691 REAL(wp) :: zland 3025 REAL(wp) :: zland ! local scalar 2692 3026 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 2693 3027 ! 2694 3028 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 2695 3029 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 2696 2697 !!---------------------------------------------------------------------- 2698 3030 !!---------------------------------------------------------------------- 3031 ! 2699 3032 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 2700 3033 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 2701 3034 2702 zland = 0. e03035 zland = 0._wp 2703 3036 2704 3037 ! 1. standard boundary treatment 2705 3038 ! ------------------------------ 2706 2707 3039 ! ! East-West boundaries 2708 3040 ! !* Cyclic east-west 2709 2710 3041 IF( nbondi == 2) THEN 2711 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN2712 ptab( 1 ,:,:) = ptab(jpim1,:,:)2713 ptab(jpi,:,:) = ptab( 2 ,:,:)2714 ELSE2715 IF( .NOT. cd_type == 'F' ) ptab( 1:jpreci,:,:) = zland ! south except F-point2716 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north2717 ENDIF3042 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 3043 ptab( 1 ,:,:) = ptab(jpim1,:,:) 3044 ptab(jpi,:,:) = ptab( 2 ,:,:) 3045 ELSE 3046 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 3047 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north 3048 ENDIF 2718 3049 ELSEIF(nbondi == -1) THEN 2719 IF( .NOT. cd_type == 'F' ) ptab( 1:jpreci,:,:) = zland ! south except F-point3050 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 2720 3051 ELSEIF(nbondi == 1) THEN 2721 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north3052 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north 2722 3053 ENDIF !* closed 2723 3054 2724 3055 IF (nbondj == 2 .OR. nbondj == -1) THEN 2725 IF( .NOT. cd_type == 'F' ) ptab(:, 1:jprecj,:) = zland ! south except F-point3056 IF( .NOT. cd_type == 'F' ) ptab(:,1:jprecj,:) = zland ! south except F-point 2726 3057 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2727 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 2728 ENDIF 2729 2730 ! 2731 3058 ptab(:,nlcj-jprecj+1:jpj,:) = zland ! north 3059 ENDIF 3060 ! 2732 3061 ! 2. East and west directions exchange 2733 3062 ! ------------------------------------ … … 2786 3115 CASE ( 0 ) 2787 3116 DO jl = 1, jpreci 2788 ptab( jl,:,:) = zt3we(:,jl,:,2)3117 ptab( jl,:,:) = zt3we(:,jl,:,2) 2789 3118 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 2790 3119 END DO 2791 3120 CASE ( 1 ) 2792 3121 DO jl = 1, jpreci 2793 ptab( jl,:,:) = zt3we(:,jl,:,2)3122 ptab( jl,:,:) = zt3we(:,jl,:,2) 2794 3123 END DO 2795 3124 END SELECT … … 2877 3206 END SUBROUTINE mpp_lnk_bdy_3d 2878 3207 2879 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 3208 3209 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 2880 3210 !!---------------------------------------------------------------------- 2881 3211 !! *** routine mpp_lnk_bdy_2d *** … … 2898 3228 !! 2899 3229 !!---------------------------------------------------------------------- 2900 2901 USE lbcnfd ! north fold 2902 2903 INCLUDE 'mpif.h' 2904 2905 REAL(wp), DIMENSION(jpi,jpj) , INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2906 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 2907 ! ! = T , U , V , F , W points 2908 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 2909 ! ! = 1. , the sign is kept 2910 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3230 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 3231 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 3232 ! ! = T , U , V , F , W points 3233 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 3234 ! ! = 1. , the sign is kept 3235 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 3236 ! 2911 3237 INTEGER :: ji, jj, jl ! dummy loop indices 2912 INTEGER :: imigr, iihom, ijhom ! temporaryintegers3238 INTEGER :: imigr, iihom, ijhom ! local integers 2913 3239 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2914 3240 REAL(wp) :: zland … … 2917 3243 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 2918 3244 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 2919 2920 3245 !!---------------------------------------------------------------------- 2921 3246 … … 2923 3248 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 2924 3249 2925 zland = 0. e03250 zland = 0._wp 2926 3251 2927 3252 ! 1. standard boundary treatment 2928 3253 ! ------------------------------ 2929 2930 3254 ! ! East-West boundaries 2931 ! !* Cyclic east-west 2932 2933 IF( nbondi == 2) THEN 2934 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 2935 ptab( 1 ,:) = ptab(jpim1,:) 2936 ptab(jpi,:) = ptab( 2 ,:) 2937 ELSE 2938 IF( .NOT. cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 2939 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 2940 ENDIF 3255 ! !* Cyclic east-west 3256 IF( nbondi == 2 ) THEN 3257 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 3258 ptab( 1 ,:) = ptab(jpim1,:) 3259 ptab(jpi,:) = ptab( 2 ,:) 3260 ELSE 3261 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 3262 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3263 ENDIF 2941 3264 ELSEIF(nbondi == -1) THEN 2942 IF( .NOT. cd_type == 'F' )ptab( 1 :jpreci,:) = zland ! south except F-point3265 IF( .NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 2943 3266 ELSEIF(nbondi == 1) THEN 2944 ptab(nlci-jpreci+1:jpi ,:) = zland ! north2945 ENDIF !* closed2946 2947 IF (nbondj == 2 .OR. nbondj == -1) THEN2948 IF( .NOT. cd_type == 'F' ) ptab(:, 1 :jprecj) = zland! south except F-point3267 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 3268 ENDIF 3269 ! !* closed 3270 IF( nbondj == 2 .OR. nbondj == -1 ) THEN 3271 IF( .NOT.cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point 2949 3272 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2950 ptab(:,nlcj-jprecj+1:jpj) = zland ! north 2951 ENDIF 2952 2953 ! 2954 3273 ptab(:,nlcj-jprecj+1:jpj ) = zland ! north 3274 ENDIF 3275 ! 2955 3276 ! 2. East and west directions exchange 2956 3277 ! ------------------------------------ … … 3099 3420 ! 3100 3421 END SUBROUTINE mpp_lnk_bdy_2d 3422 3101 3423 3102 3424 SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) … … 3188 3510 END SUBROUTINE DDPDD_MPI 3189 3511 3512 3190 3513 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 3191 3514 !!--------------------------------------------------------------------- … … 3210 3533 !! ! north fold, = 1. otherwise 3211 3534 INTEGER, OPTIONAL , INTENT(in ) :: pr2dj 3535 ! 3212 3536 INTEGER :: ji, jj, jr 3213 3537 INTEGER :: ierr, itaille, ildi, ilei, iilb … … 3216 3540 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 3217 3541 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 3218 3219 3542 !!---------------------------------------------------------------------- 3220 3543 ! … … 3226 3549 ENDIF 3227 3550 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 3228 3229 ! 3230 ztab_e(:,:) = 0.e0 3231 3232 ij=0 3551 ! 3552 ztab_e(:,:) = 0._wp 3553 ! 3554 ij = 0 3233 3555 ! put in znorthloc_e the last 4 jlines of pt2d 3234 3556 DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj … … 3272 3594 ! 3273 3595 END SUBROUTINE mpp_lbc_north_icb 3596 3274 3597 3275 3598 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) … … 3292 3615 !! noso : number for local neighboring processors 3293 3616 !! nono : number for local neighboring processors 3294 !!3295 3617 !!---------------------------------------------------------------------- 3296 3618 INTEGER , INTENT(in ) :: jpri … … 3451 3773 3452 3774 END SUBROUTINE mpp_lnk_2d_icb 3775 3453 3776 #else 3454 3777 !!---------------------------------------------------------------------- … … 3736 4059 LOGICAL , INTENT(in ) :: ldwp ! boolean term for print 3737 4060 INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number 3738 ! !4061 ! 3739 4062 CHARACTER(len=80) :: clfile 3740 4063 INTEGER :: iost 3741 4064 !!---------------------------------------------------------------------- 3742 4065 ! 3743 4066 ! adapt filename 3744 4067 ! ---------------- … … 3753 4076 knum=get_unit() 3754 4077 #endif 3755 4078 ! 3756 4079 iost=0 3757 4080 IF( cdacce(1:6) == 'DIRECT' ) THEN … … 3786 4109 STOP 'ctl_opn bad opening' 3787 4110 ENDIF 3788 4111 ! 3789 4112 END SUBROUTINE ctl_opn 3790 4113 4114 3791 4115 SUBROUTINE ctl_nam ( kios, cdnam, ldwp ) 3792 4116 !!---------------------------------------------------------------------- … … 3797 4121 !! ** Method : Fortan open 3798 4122 !!---------------------------------------------------------------------- 3799 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 3800 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs 3801 CHARACTER(len=4) :: clios ! string to convert iostat in character for print 3802 LOGICAL , INTENT(in ) :: ldwp ! boolean term for print 3803 !!---------------------------------------------------------------------- 3804 3805 ! 3806 ! ---------------- 3807 WRITE (clios, '(I4.0)') kios 4123 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 4124 CHARACTER(len=*), INTENT(in ) :: cdnam ! group name of namelist for which error occurs 4125 CHARACTER(len=4) :: clios ! string to convert iostat in character for print 4126 LOGICAL , INTENT(in ) :: ldwp ! boolean term for print 4127 !!---------------------------------------------------------------------- 4128 ! 4129 WRITE (clios, '(I4.0)') kios 3808 4130 IF( kios < 0 ) THEN 3809 CALL ctl_warn( ' W A R N I N G: end of record or file while reading namelist '&3810 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )3811 ENDIF 3812 4131 CALL ctl_warn( 'end of record or file while reading namelist ' & 4132 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) ) 4133 ENDIF 4134 ! 3813 4135 IF( kios > 0 ) THEN 3814 CALL ctl_stop( ' E R R O R : misspelled variable in namelist '&3815 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )4136 CALL ctl_stop( 'misspelled variable in namelist ' & 4137 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) ) 3816 4138 ENDIF 3817 4139 kios = 0 3818 4140 RETURN 3819 4141 ! 3820 4142 END SUBROUTINE ctl_nam 4143 3821 4144 3822 4145 INTEGER FUNCTION get_unit()
Note: See TracChangeset
for help on using the changeset viewer.
