- Timestamp:
- 2015-12-04T17:05:58+01:00 (8 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5836_NOC3_vvl_by_default/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r5883 r6004 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 … … 2704 2689 & zt3ew(jpj,jpreci,jpk,2), zt3we(jpj,jpreci,jpk,2) ) 2705 2690 2706 zland = 0. -WP2691 zland = 0._wp 2707 2692 2708 2693 ! 1. standard boundary treatment
Note: See TracChangeset
for help on using the changeset viewer.
