- Timestamp:
- 2015-12-16T10:25:22+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_merge_2015/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r5836 r6060 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 : … … 94 94 END INTERFACE 95 95 INTERFACE mpp_sum 96 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, &96 MODULE PROCEDURE mppsum_a_int, mppsum_int, mppsum_a_real, mppsum_real, & 97 97 mppsum_realdd, mppsum_a_realdd 98 98 END INTERFACE … … 175 175 !! ** Purpose : Find processor unit 176 176 !!---------------------------------------------------------------------- 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 ) :: localComm177 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt ! 178 CHARACTER(len=*) , INTENT(in ) :: ldname ! 179 INTEGER , INTENT(in ) :: kumnam_ref ! logical unit for reference namelist 180 INTEGER , INTENT(in ) :: kumnam_cfg ! logical unit for configuration namelist 181 INTEGER , INTENT(inout) :: kumond ! logical unit for namelist output 182 INTEGER , INTENT(inout) :: kstop ! stop indicator 183 INTEGER , OPTIONAL , INTENT(in ) :: localComm ! 184 184 ! 185 185 INTEGER :: mynode, ierr, code, ji, ii, ios … … 190 190 ! 191 191 ii = 1 192 WRITE(ldtxt(ii),*) 193 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' 194 WRITE(ldtxt(ii),*) '~~~~~~ ' 192 WRITE(ldtxt(ii),*) ; ii = ii + 1 193 WRITE(ldtxt(ii),*) 'mynode : mpi initialisation' ; ii = ii + 1 194 WRITE(ldtxt(ii),*) '~~~~~~ ' ; ii = ii + 1 195 195 ! 196 196 … … 204 204 205 205 ! ! 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 + 1206 WRITE(ldtxt(ii),*) ' Namelist nammpp' ; ii = ii + 1 207 WRITE(ldtxt(ii),*) ' mpi send type cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 208 WRITE(ldtxt(ii),*) ' size exported buffer nn_buffer = ', nn_buffer,' bytes'; ii = ii + 1 209 209 210 210 #if defined key_agrif … … 223 223 224 224 IF( (jpni < 1) .OR. (jpnj < 1) )THEN 225 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ;ii = ii + 1225 WRITE(ldtxt(ii),*) ' jpni, jpnj and jpnij will be calculated automatically' ; ii = ii + 1 226 226 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 +1227 WRITE(ldtxt(ii),*) ' processor grid extent in i jpni = ',jpni ; ii = ii + 1 228 WRITE(ldtxt(ii),*) ' processor grid extent in j jpnj = ',jpnj ; ii = ii + 1 229 WRITE(ldtxt(ii),*) ' number of local domains jpnij = ',jpnij ; ii = ii + 1 230 230 END IF 231 231 … … 246 246 SELECT CASE ( cn_mpi_send ) 247 247 CASE ( 'S' ) ! Standard mpi send (blocking) 248 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' 248 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 249 249 CASE ( 'B' ) ! Buffer mpi send (blocking) 250 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' 250 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 251 251 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 252 252 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 253 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' 253 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 254 254 l_isend = .TRUE. 255 255 CASE DEFAULT 256 WRITE(ldtxt(ii),cform_err) 257 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send 256 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 257 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 258 258 kstop = kstop + 1 259 259 END SELECT 260 260 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 ! ' 261 WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator ' ; ii = ii + 1 262 WRITE(ldtxt(ii),*) ' without calling MPI_Init before ! ' ; ii = ii + 1 263 263 kstop = kstop + 1 264 264 ELSE 265 265 SELECT CASE ( cn_mpi_send ) 266 266 CASE ( 'S' ) ! Standard mpi send (blocking) 267 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' 267 WRITE(ldtxt(ii),*) ' Standard blocking mpi send (send)' ; ii = ii + 1 268 268 CALL mpi_init( ierr ) 269 269 CASE ( 'B' ) ! Buffer mpi send (blocking) 270 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' 270 WRITE(ldtxt(ii),*) ' Buffer blocking mpi send (bsend)' ; ii = ii + 1 271 271 IF( Agrif_Root() ) CALL mpi_init_opa( ldtxt, ii, ierr ) 272 272 CASE ( 'I' ) ! Immediate mpi send (non-blocking send) 273 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' 273 WRITE(ldtxt(ii),*) ' Immediate non-blocking send (isend)' ; ii = ii + 1 274 274 l_isend = .TRUE. 275 275 CALL mpi_init( ierr ) 276 276 CASE DEFAULT 277 WRITE(ldtxt(ii),cform_err) 278 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send 277 WRITE(ldtxt(ii),cform_err) ; ii = ii + 1 278 WRITE(ldtxt(ii),*) ' bad value for cn_mpi_send = ', cn_mpi_send ; ii = ii + 1 279 279 kstop = kstop + 1 280 280 END SELECT … … 319 319 END FUNCTION mynode 320 320 321 321 322 SUBROUTINE mpp_lnk_3d( ptab, cd_type, psgn, cd_mpp, pval ) 322 323 !!---------------------------------------------------------------------- … … 347 348 CHARACTER(len=3), OPTIONAL , INTENT(in ) :: cd_mpp ! fill the overlap area only 348 349 REAL(wp) , OPTIONAL , INTENT(in ) :: pval ! background value (used at closed boundaries) 349 ! !350 ! 350 351 INTEGER :: ji, jj, jk, jl ! dummy loop indices 351 352 INTEGER :: imigr, iihom, ijhom ! temporary integers 352 353 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 353 354 REAL(wp) :: zland 354 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 355 ! 355 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 356 356 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 357 357 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 358 359 358 !!---------------------------------------------------------------------- 360 359 … … 364 363 ! 365 364 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 366 ELSE ; zland = 0. e0! zero by default365 ELSE ; zland = 0._wp ! zero by default 367 366 ENDIF 368 367 … … 455 454 END SELECT 456 455 457 458 456 ! 3. North and south directions 459 457 ! ----------------------------- … … 508 506 END SELECT 509 507 510 511 508 ! 4. north fold treatment 512 509 ! ----------------------- … … 524 521 ! 525 522 END SUBROUTINE mpp_lnk_3d 523 526 524 527 525 SUBROUTINE mpp_lnk_2d_multiple( pt2d_array , type_array , psgn_array , num_fields , cd_mpp, pval ) … … 542 540 !! noso : number for local neighboring processors 543 541 !! nono : number for local neighboring processors 544 !! 545 !!---------------------------------------------------------------------- 546 547 INTEGER :: num_fields 548 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 542 !!---------------------------------------------------------------------- 549 543 CHARACTER(len=1), DIMENSION(:), INTENT(in ) :: type_array ! define the nature of ptab array grid-points 550 544 ! ! = T , U , V , F , W and I points … … 558 552 INTEGER :: imigr, iihom, ijhom ! temporary integers 559 553 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 560 554 INTEGER :: num_fields 555 TYPE( arrayptr ), DIMENSION(:) :: pt2d_array 561 556 REAL(wp) :: zland 562 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 563 ! 557 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 564 558 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 565 559 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 566 560 567 561 !!---------------------------------------------------------------------- 568 562 ! 569 563 ALLOCATE( zt2ns(jpi,jprecj,2*num_fields), zt2sn(jpi,jprecj,2*num_fields), & 570 564 & zt2ew(jpj,jpreci,2*num_fields), zt2we(jpj,jpreci,2*num_fields) ) 571 572 565 ! 573 566 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 574 ELSE ; zland = 0. e0! zero by default567 ELSE ; zland = 0._wp ! zero by default 575 568 ENDIF 576 569 … … 744 737 ! 745 738 END DO 746 739 ! 747 740 DEALLOCATE( zt2ns, zt2sn, zt2ew, zt2we ) 748 741 ! … … 750 743 751 744 752 SUBROUTINE load_array( pt2d,cd_type,psgn,pt2d_array, type_array, psgn_array,num_fields)745 SUBROUTINE load_array( pt2d, cd_type, psgn, pt2d_array, type_array, psgn_array, num_fields ) 753 746 !!--------------------------------------------------------------------- 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 boundary747 REAL(wp), DIMENSION(jpi,jpj), TARGET, INTENT(inout) :: pt2d ! Second 2D array on which the boundary condition is applied 748 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 749 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 757 750 TYPE(arrayptr) , DIMENSION(9) :: pt2d_array 758 751 CHARACTER(len=1) , DIMENSION(9) :: type_array ! define the nature of ptab array grid-points 759 752 REAL(wp) , DIMENSION(9) :: psgn_array ! =-1 the sign change across the north fold boundary 760 INTEGER , INTENT (inout):: num_fields753 INTEGER , INTENT (inout) :: num_fields 761 754 !!--------------------------------------------------------------------- 762 num_fields =num_fields+1763 pt2d_array(num_fields)%pt2d =>pt2d764 type_array(num_fields) =cd_type765 psgn_array(num_fields) =psgn755 num_fields = num_fields + 1 756 pt2d_array(num_fields)%pt2d => pt2d 757 type_array(num_fields) = cd_type 758 psgn_array(num_fields) = psgn 766 759 END SUBROUTINE load_array 767 760 … … 792 785 INTEGER :: num_fields 793 786 !!--------------------------------------------------------------------- 794 787 ! 795 788 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) 789 ! 790 ! Load the first array 791 CALL load_array( pt2dA, cd_typeA, psgnA, pt2d_array, type_array, psgn_array, num_fields ) 792 ! 793 ! Look if more arrays are added 794 IF( PRESENT(psgnB) ) CALL load_array(pt2dB,cd_typeB,psgnB,pt2d_array, type_array, psgn_array,num_fields) 795 IF( PRESENT(psgnC) ) CALL load_array(pt2dC,cd_typeC,psgnC,pt2d_array, type_array, psgn_array,num_fields) 796 IF( PRESENT(psgnD) ) CALL load_array(pt2dD,cd_typeD,psgnD,pt2d_array, type_array, psgn_array,num_fields) 797 IF( PRESENT(psgnE) ) CALL load_array(pt2dE,cd_typeE,psgnE,pt2d_array, type_array, psgn_array,num_fields) 798 IF( PRESENT(psgnF) ) CALL load_array(pt2dF,cd_typeF,psgnF,pt2d_array, type_array, psgn_array,num_fields) 799 IF( PRESENT(psgnG) ) CALL load_array(pt2dG,cd_typeG,psgnG,pt2d_array, type_array, psgn_array,num_fields) 800 IF( PRESENT(psgnH) ) CALL load_array(pt2dH,cd_typeH,psgnH,pt2d_array, type_array, psgn_array,num_fields) 801 IF( PRESENT(psgnI) ) CALL load_array(pt2dI,cd_typeI,psgnI,pt2d_array, type_array, psgn_array,num_fields) 802 ! 803 CALL mpp_lnk_2d_multiple( pt2d_array, type_array, psgn_array, num_fields, cd_mpp,pval ) 804 ! 811 805 END SUBROUTINE mpp_lnk_2d_9 812 806 … … 843 837 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 844 838 REAL(wp) :: zland 845 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 846 ! 839 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 847 840 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 848 841 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 849 850 !!---------------------------------------------------------------------- 851 842 !!---------------------------------------------------------------------- 843 ! 852 844 ALLOCATE( zt2ns(jpi,jprecj,2), zt2sn(jpi,jprecj,2), & 853 845 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 854 855 846 ! 856 847 IF( PRESENT( pval ) ) THEN ; zland = pval ! set land value 857 ELSE ; zland = 0. e0! zero by default848 ELSE ; zland = 0._wp ! zero by default 858 849 ENDIF 859 850 … … 1046 1037 INTEGER :: imigr, iihom, ijhom ! temporary integers 1047 1038 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 1048 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1049 ! 1039 INTEGER , DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 1050 1040 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ns, zt4sn ! 2 x 3d for north-south & south-north 1051 1041 REAL(wp), DIMENSION(:,:,:,:,:), ALLOCATABLE :: zt4ew, zt4we ! 2 x 3d for east-west & west-east 1052 1053 ! !----------------------------------------------------------------------1042 !!---------------------------------------------------------------------- 1043 ! 1054 1044 ALLOCATE( zt4ns(jpi,jprecj,jpk,2,2), zt4sn(jpi,jprecj,jpk,2,2) , & 1055 1045 & zt4ew(jpj,jpreci,jpk,2,2), zt4we(jpj,jpreci,jpk,2,2) ) 1056 1057 1046 ! 1058 1047 ! 1. standard boundary treatment 1059 1048 ! ------------------------------ … … 1399 1388 END DO 1400 1389 END SELECT 1401 1390 ! 1402 1391 END SUBROUTINE mpp_lnk_2d_e 1403 1392 … … 1449 1438 !!---------------------------------------------------------------------- 1450 1439 ! 1451 1452 1440 ! If a specific process number has been passed to the receive call, 1453 1441 ! 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 1442 use_source = mpi_any_source 1443 IF( PRESENT(ksource) ) use_source = ksource 1444 ! 1459 1445 CALL mpi_recv( pmess, kbytes, mpi_double_precision, use_source, ktyp, mpi_comm_opa, istatus, iflag ) 1460 1446 ! … … 1470 1456 !! 1471 1457 !!---------------------------------------------------------------------- 1472 REAL(wp), DIMENSION(jpi,jpj) ,INTENT(in ) :: ptab ! subdomain input array1473 INTEGER ,INTENT(in ) :: kp ! record length1458 REAL(wp), DIMENSION(jpi,jpj) , INTENT(in ) :: ptab ! subdomain input array 1459 INTEGER , INTENT(in ) :: kp ! record length 1474 1460 REAL(wp), DIMENSION(jpi,jpj,jpnij), INTENT( out) :: pio ! subdomain input array 1475 1461 !! … … 1492 1478 !! 1493 1479 !!---------------------------------------------------------------------- 1494 REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio! output array1495 INTEGER :: kp 1496 REAL(wp), DIMENSION(jpi,jpj) :: ptab! subdomain array input1480 REAL(wp), DIMENSION(jpi,jpj,jpnij) :: pio ! output array 1481 INTEGER :: kp ! Tag (not used with MPI 1482 REAL(wp), DIMENSION(jpi,jpj) :: ptab ! subdomain array input 1497 1483 !! 1498 1484 INTEGER :: itaille, ierror ! temporary integer 1499 1485 !!--------------------------------------------------------------------- 1500 1486 ! 1501 itaille =jpi*jpj1487 itaille = jpi * jpj 1502 1488 ! 1503 1489 CALL mpi_scatter( pio, itaille, mpi_double_precision, ptab, itaille , & … … 1517 1503 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1518 1504 INTEGER , INTENT(in ), OPTIONAL :: kcom ! 1519 ! !1505 ! 1520 1506 INTEGER :: ierror, localcomm ! temporary integer 1521 1507 INTEGER, DIMENSION(kdim) :: iwork … … 1539 1525 !! 1540 1526 !!---------------------------------------------------------------------- 1541 INTEGER, INTENT(inout) :: ktab 1542 INTEGER, INTENT(in ), OPTIONAL :: kcom 1543 ! !1527 INTEGER, INTENT(inout) :: ktab ! ??? 1528 INTEGER, INTENT(in ), OPTIONAL :: kcom ! ??? 1529 ! 1544 1530 INTEGER :: ierror, iwork, localcomm ! temporary integer 1545 1531 !!---------------------------------------------------------------------- … … 1548 1534 IF( PRESENT(kcom) ) localcomm = kcom 1549 1535 ! 1550 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror )1536 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_max, localcomm, ierror ) 1551 1537 ! 1552 1538 ktab = iwork … … 1562 1548 !! 1563 1549 !!---------------------------------------------------------------------- 1564 INTEGER , INTENT( in ) :: kdim 1565 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab 1566 INTEGER , INTENT( in ), OPTIONAL :: kcom 1550 INTEGER , INTENT( in ) :: kdim ! size of array 1551 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 1552 INTEGER , INTENT( in ), OPTIONAL :: kcom ! input array 1567 1553 !! 1568 1554 INTEGER :: ierror, localcomm ! temporary integer … … 1596 1582 IF( PRESENT(kcom) ) localcomm = kcom 1597 1583 ! 1598 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror )1584 CALL mpi_allreduce( ktab, iwork, 1, mpi_integer, mpi_min, localcomm, ierror ) 1599 1585 ! 1600 1586 ktab = iwork … … 1610 1596 !! 1611 1597 !!---------------------------------------------------------------------- 1612 INTEGER, INTENT(in ) :: kdim 1613 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab 1614 ! !1598 INTEGER, INTENT(in ) :: kdim ! ??? 1599 INTEGER, INTENT(inout), DIMENSION (kdim) :: ktab ! ??? 1600 ! 1615 1601 INTEGER :: ierror 1616 1602 INTEGER, DIMENSION (kdim) :: iwork … … 1653 1639 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 1654 1640 INTEGER , INTENT(in ), OPTIONAL :: kcom 1655 ! !1641 ! 1656 1642 INTEGER :: ierror, localcomm 1657 1643 REAL(wp), DIMENSION(kdim) :: zwork … … 1785 1771 END SUBROUTINE mppsum_real 1786 1772 1773 1787 1774 SUBROUTINE mppsum_realdd( ytab, kcom ) 1788 1775 !!---------------------------------------------------------------------- … … 1793 1780 !! 1794 1781 !!----------------------------------------------------------------------- 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 1782 COMPLEX(wp), INTENT(inout) :: ytab ! input scalar 1783 INTEGER , INTENT(in ), OPTIONAL :: kcom 1784 ! 1785 INTEGER :: ierror 1786 INTEGER :: localcomm 1787 COMPLEX(wp) :: zwork 1788 !!----------------------------------------------------------------------- 1789 ! 1803 1790 localcomm = mpi_comm_opa 1804 IF( PRESENT(kcom) ) localcomm = kcom1805 1791 IF( PRESENT(kcom) ) localcomm = kcom 1792 ! 1806 1793 ! reduce local sums into global sum 1807 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, & 1808 MPI_SUMDD,localcomm,ierror) 1794 CALL MPI_ALLREDUCE (ytab, zwork, 1, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 1809 1795 ytab = zwork 1810 1796 ! 1811 1797 END SUBROUTINE mppsum_realdd 1812 1798 … … 1820 1806 !! 1821 1807 !!----------------------------------------------------------------------- 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 1808 INTEGER , INTENT(in ) :: kdim ! size of ytab 1809 COMPLEX(wp), DIMENSION(kdim), INTENT(inout) :: ytab ! input array 1810 INTEGER , OPTIONAL , INTENT(in ) :: kcom 1811 ! 1812 INTEGER:: ierror, localcomm ! local integer 1829 1813 COMPLEX(wp), DIMENSION(kdim) :: zwork ! temporary workspace 1830 1814 !!----------------------------------------------------------------------- 1815 ! 1831 1816 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) 1817 IF( PRESENT(kcom) ) localcomm = kcom 1818 ! 1819 CALL MPI_ALLREDUCE( ytab, zwork, kdim, MPI_DOUBLE_COMPLEX, MPI_SUMDD, localcomm, ierror ) 1836 1820 ytab(:) = zwork(:) 1837 1821 ! 1838 1822 END SUBROUTINE mppsum_a_realdd 1823 1839 1824 1840 1825 SUBROUTINE mpp_minloc2d( ptab, pmask, pmin, ki,kj ) … … 1852 1837 REAL(wp) , INTENT( out) :: pmin ! Global minimum of ptab 1853 1838 INTEGER , INTENT( out) :: ki, kj ! index of minimum in global frame 1854 !! 1839 ! 1840 INTEGER :: ierror 1855 1841 INTEGER , DIMENSION(2) :: ilocs 1856 INTEGER :: ierror1857 1842 REAL(wp) :: zmin ! local minimum 1858 1843 REAL(wp), DIMENSION(2,1) :: zain, zaout … … 2662 2647 END SUBROUTINE mpp_lbc_north_e 2663 2648 2664 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2649 2650 SUBROUTINE mpp_lnk_bdy_3d( ptab, cd_type, psgn, ib_bdy ) 2665 2651 !!---------------------------------------------------------------------- 2666 2652 !! *** routine mpp_lnk_bdy_3d *** … … 2683 2669 !! 2684 2670 !!---------------------------------------------------------------------- 2685 2686 USE lbcnfd ! north fold2687 2688 INCLUDE 'mpif.h'2689 2690 2671 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2691 2672 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points … … 2694 2675 ! ! = 1. , the sign is kept 2695 2676 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 2677 ! 2696 2678 INTEGER :: ji, jj, jk, jl ! dummy loop indices 2697 INTEGER :: imigr, iihom, ijhom ! temporaryintegers2679 INTEGER :: imigr, iihom, ijhom ! local integers 2698 2680 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2699 REAL(wp) :: zland 2681 REAL(wp) :: zland ! local scalar 2700 2682 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 2701 2683 ! 2702 2684 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ns, zt3sn ! 3d for north-south & south-north 2703 2685 REAL(wp), DIMENSION(:,:,:,:), ALLOCATABLE :: zt3ew, zt3we ! 3d for east-west & west-east 2704 2705 !!---------------------------------------------------------------------- 2706 2686 !!---------------------------------------------------------------------- 2687 ! 2707 2688 ALLOCATE( zt3ns(jpi,jprecj,jpk,2), zt3sn(jpi,jprecj,jpk,2), & 2708 2689 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 2709 2690 2710 zland = 0. e02691 zland = 0._wp 2711 2692 2712 2693 ! 1. standard boundary treatment 2713 2694 ! ------------------------------ 2714 2715 2695 ! ! East-West boundaries 2716 2696 ! !* Cyclic east-west 2717 2718 2697 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 ENDIF2698 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) THEN 2699 ptab( 1 ,:,:) = ptab(jpim1,:,:) 2700 ptab(jpi,:,:) = ptab( 2 ,:,:) 2701 ELSE 2702 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 2703 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north 2704 ENDIF 2726 2705 ELSEIF(nbondi == -1) THEN 2727 IF( .NOT. cd_type == 'F' ) ptab( 1:jpreci,:,:) = zland ! south except F-point2706 IF( .NOT. cd_type == 'F' ) ptab(1:jpreci,:,:) = zland ! south except F-point 2728 2707 ELSEIF(nbondi == 1) THEN 2729 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north2708 ptab(nlci-jpreci+1:jpi,:,:) = zland ! north 2730 2709 ENDIF !* closed 2731 2710 2732 2711 IF (nbondj == 2 .OR. nbondj == -1) THEN 2733 IF( .NOT. cd_type == 'F' ) ptab(:, 1:jprecj,:) = zland ! south except F-point2712 IF( .NOT. cd_type == 'F' ) ptab(:,1:jprecj,:) = zland ! south except F-point 2734 2713 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2735 ptab(:,nlcj-jprecj+1:jpj ,:) = zland ! north 2736 ENDIF 2737 2738 ! 2739 2714 ptab(:,nlcj-jprecj+1:jpj,:) = zland ! north 2715 ENDIF 2716 ! 2740 2717 ! 2. East and west directions exchange 2741 2718 ! ------------------------------------ … … 2794 2771 CASE ( 0 ) 2795 2772 DO jl = 1, jpreci 2796 ptab( jl,:,:) = zt3we(:,jl,:,2)2773 ptab( jl,:,:) = zt3we(:,jl,:,2) 2797 2774 ptab(iihom+jl,:,:) = zt3ew(:,jl,:,2) 2798 2775 END DO 2799 2776 CASE ( 1 ) 2800 2777 DO jl = 1, jpreci 2801 ptab( jl,:,:) = zt3we(:,jl,:,2)2778 ptab( jl,:,:) = zt3we(:,jl,:,2) 2802 2779 END DO 2803 2780 END SELECT … … 2885 2862 END SUBROUTINE mpp_lnk_bdy_3d 2886 2863 2887 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 2864 2865 SUBROUTINE mpp_lnk_bdy_2d( ptab, cd_type, psgn, ib_bdy ) 2888 2866 !!---------------------------------------------------------------------- 2889 2867 !! *** routine mpp_lnk_bdy_2d *** … … 2906 2884 !! 2907 2885 !!---------------------------------------------------------------------- 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 2886 REAL(wp), DIMENSION(jpi,jpj), INTENT(inout) :: ptab ! 3D array on which the boundary condition is applied 2887 CHARACTER(len=1) , INTENT(in ) :: cd_type ! define the nature of ptab array grid-points 2888 ! ! = T , U , V , F , W points 2889 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the north fold boundary 2890 ! ! = 1. , the sign is kept 2891 INTEGER , INTENT(in ) :: ib_bdy ! BDY boundary set 2892 ! 2919 2893 INTEGER :: ji, jj, jl ! dummy loop indices 2920 INTEGER :: imigr, iihom, ijhom ! temporaryintegers2894 INTEGER :: imigr, iihom, ijhom ! local integers 2921 2895 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 2922 2896 REAL(wp) :: zland … … 2925 2899 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ns, zt2sn ! 2d for north-south & south-north 2926 2900 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: zt2ew, zt2we ! 2d for east-west & west-east 2927 2928 2901 !!---------------------------------------------------------------------- 2929 2902 … … 2931 2904 & zt2ew(jpj,jpreci,2), zt2we(jpj,jpreci,2) ) 2932 2905 2933 zland = 0. e02906 zland = 0._wp 2934 2907 2935 2908 ! 1. standard boundary treatment 2936 2909 ! ------------------------------ 2937 2938 2910 ! ! 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 2911 ! !* Cyclic east-west 2912 IF( nbondi == 2 ) THEN 2913 IF (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) THEN 2914 ptab( 1 ,:) = ptab(jpim1,:) 2915 ptab(jpi,:) = ptab( 2 ,:) 2916 ELSE 2917 IF(.NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 2918 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 2919 ENDIF 2949 2920 ELSEIF(nbondi == -1) THEN 2950 IF( .NOT. cd_type == 'F' )ptab( 1 :jpreci,:) = zland ! south except F-point2921 IF( .NOT.cd_type == 'F' ) ptab( 1 :jpreci,:) = zland ! south except F-point 2951 2922 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-point2923 ptab(nlci-jpreci+1:jpi ,:) = zland ! north 2924 ENDIF 2925 ! !* closed 2926 IF( nbondj == 2 .OR. nbondj == -1 ) THEN 2927 IF( .NOT.cd_type == 'F' ) ptab(:, 1 :jprecj) = zland ! south except F-point 2957 2928 ELSEIF (nbondj == 2 .OR. nbondj == 1) THEN 2958 ptab(:,nlcj-jprecj+1:jpj) = zland ! north 2959 ENDIF 2960 2961 ! 2962 2929 ptab(:,nlcj-jprecj+1:jpj ) = zland ! north 2930 ENDIF 2931 ! 2963 2932 ! 2. East and west directions exchange 2964 2933 ! ------------------------------------ … … 3107 3076 ! 3108 3077 END SUBROUTINE mpp_lnk_bdy_2d 3078 3109 3079 3110 3080 SUBROUTINE mpi_init_opa( ldtxt, ksft, code ) … … 3196 3166 END SUBROUTINE DDPDD_MPI 3197 3167 3168 3198 3169 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 3199 3170 !!--------------------------------------------------------------------- … … 3218 3189 !! ! north fold, = 1. otherwise 3219 3190 INTEGER, OPTIONAL , INTENT(in ) :: pr2dj 3191 ! 3220 3192 INTEGER :: ji, jj, jr 3221 3193 INTEGER :: ierr, itaille, ildi, ilei, iilb … … 3224 3196 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 3225 3197 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 3226 3227 3198 !!---------------------------------------------------------------------- 3228 3199 ! … … 3234 3205 ENDIF 3235 3206 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 3207 ! 3208 ztab_e(:,:) = 0._wp 3209 ! 3210 ij = 0 3241 3211 ! put in znorthloc_e the last 4 jlines of pt2d 3242 3212 DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj … … 3280 3250 ! 3281 3251 END SUBROUTINE mpp_lbc_north_icb 3252 3282 3253 3283 3254 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) … … 3300 3271 !! noso : number for local neighboring processors 3301 3272 !! nono : number for local neighboring processors 3302 !!3303 3273 !!---------------------------------------------------------------------- 3304 3274 INTEGER , INTENT(in ) :: jpri … … 3459 3429 3460 3430 END SUBROUTINE mpp_lnk_2d_icb 3431 3461 3432 #else 3462 3433 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.
