Changeset 869 for trunk/NEMO/OPA_SRC/lib_mpp.F90
- Timestamp:
- 2008-03-26T10:21:54+01:00 (16 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
trunk/NEMO/OPA_SRC/lib_mpp.F90
r719 r869 60 60 PUBLIC mynode, mpparent, mpp_isl, mpp_min, mpp_max, mpp_sum, mpp_lbc_north 61 61 PUBLIC mpp_lbc_north_e, mpp_minloc, mpp_maxloc, mpp_lnk_3d, mpp_lnk_2d, mpp_lnk_3d_gather, mpp_lnk_2d_e, mpplnks 62 PUBLIC mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync 62 PUBLIC mpprecv, mppsend, mppscatter, mppgather, mppobc, mpp_ini_north, mppstop, mppsync, mpp_ini_ice, mpp_comm_free 63 63 #if defined key_oasis3 || defined key_oasis4 64 64 PUBLIC mppsize, mpprank … … 113 113 mpi_comm_opa ! opa local communicator 114 114 115 ! variables used in case of sea-ice 116 INTEGER, PUBLIC :: & ! 117 ngrp_ice, & ! group ID for the ice processors (to compute rheology) 118 ncomm_ice, & ! communicator made by the processors with sea-ice 119 ndim_rank_ice, & ! number of 'ice' processors 120 n_ice_root ! number (in the comm_ice) of proc 0 in the ice comm 121 INTEGER, DIMENSION(:), ALLOCATABLE :: & 122 nrank_ice ! dimension ndim_rank_north, number of the procs belonging to ncomm_north 115 123 ! variables used in case of north fold condition in mpp_mpi with jpni > 1 116 124 INTEGER :: & ! … … 853 861 854 862 CASE ( 1 ) ! only one proc along I, no mpp exchange 855 863 856 864 SELECT CASE ( npolj ) 857 865 … … 872 880 END DO 873 881 END DO 874 882 875 883 CASE ( 'U' ) 876 884 DO jk = 1, jpk … … 3069 3077 3070 3078 3071 SUBROUTINE mppmax_a_int( ktab, kdim )3079 SUBROUTINE mppmax_a_int( ktab, kdim, kcom ) 3072 3080 !!---------------------------------------------------------------------- 3073 3081 !! *** routine mppmax_a_int *** … … 3079 3087 INTEGER , INTENT( in ) :: kdim ! size of array 3080 3088 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 3089 INTEGER , INTENT(in), OPTIONAL :: kcom 3081 3090 3082 3091 #if defined key_mpp_shmem … … 3110 3119 !! * Local variables (MPI version) 3111 3120 INTEGER :: ierror 3121 INTEGER :: localcomm 3112 3122 INTEGER, DIMENSION(kdim) :: iwork 3123 3124 localcomm = mpi_comm_opa 3125 IF( PRESENT(kcom) ) localcomm = kcom 3113 3126 3114 3127 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, & 3115 & mpi_max, mpi_comm_opa, ierror )3128 & mpi_max, localcomm, ierror ) 3116 3129 3117 3130 ktab(:) = iwork(:) … … 3121 3134 3122 3135 3123 SUBROUTINE mppmax_int( ktab )3136 SUBROUTINE mppmax_int( ktab, kcom ) 3124 3137 !!---------------------------------------------------------------------- 3125 3138 !! *** routine mppmax_int *** … … 3132 3145 !! * Arguments 3133 3146 INTEGER, INTENT(inout) :: ktab ! ??? 3147 INTEGER, INTENT(in), OPTIONAL :: kcom ! ??? 3134 3148 3135 3149 !! * Local declarations … … 3159 3173 !! * Local variables (MPI version) 3160 3174 INTEGER :: ierror, iwork 3161 3175 INTEGER :: localcomm 3176 3177 localcomm = mpi_comm_opa 3178 IF( PRESENT(kcom) ) localcomm = kcom 3179 3162 3180 CALL mpi_allreduce(ktab,iwork, 1,mpi_integer & 3163 & ,mpi_max, mpi_comm_opa,ierror)3181 & ,mpi_max,localcomm,ierror) 3164 3182 3165 3183 ktab = iwork … … 3169 3187 3170 3188 3171 SUBROUTINE mppmin_a_int( ktab, kdim )3189 SUBROUTINE mppmin_a_int( ktab, kdim, kcom ) 3172 3190 !!---------------------------------------------------------------------- 3173 3191 !! *** routine mppmin_a_int *** … … 3179 3197 INTEGER , INTENT( in ) :: kdim ! size of array 3180 3198 INTEGER , INTENT(inout), DIMENSION(kdim) :: ktab ! input array 3199 INTEGER , INTENT(in), OPTIONAL :: kcom ! input array 3181 3200 3182 3201 #if defined key_mpp_shmem … … 3210 3229 !! * Local variables (MPI version) 3211 3230 INTEGER :: ierror 3231 INTEGER :: localcomm 3212 3232 INTEGER, DIMENSION(kdim) :: iwork 3213 3233 3234 localcomm = mpi_comm_opa 3235 IF( PRESENT(kcom) ) localcomm = kcom 3236 3214 3237 CALL mpi_allreduce( ktab, iwork, kdim, mpi_integer, & 3215 & mpi_min, mpi_comm_opa, ierror )3238 & mpi_min, localcomm, ierror ) 3216 3239 3217 3240 ktab(:) = iwork(:) … … 3505 3528 3506 3529 3507 SUBROUTINE mppmax_a_real( ptab, kdim )3530 SUBROUTINE mppmax_a_real( ptab, kdim, kcom ) 3508 3531 !!---------------------------------------------------------------------- 3509 3532 !! *** routine mppmax_a_real *** … … 3515 3538 INTEGER , INTENT( in ) :: kdim 3516 3539 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 3540 INTEGER , INTENT( in ), OPTIONAL :: kcom 3517 3541 3518 3542 #if defined key_mpp_shmem … … 3547 3571 !! * Local variables (MPI version) 3548 3572 INTEGER :: ierror 3573 INTEGER :: localcomm 3549 3574 REAL(wp), DIMENSION(kdim) :: zwork 3550 3575 3576 localcomm = mpi_comm_opa 3577 IF( PRESENT(kcom) ) localcomm = kcom 3578 3551 3579 CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision & 3552 ,mpi_max, mpi_comm_opa,ierror)3580 ,mpi_max,localcomm,ierror) 3553 3581 ptab(:) = zwork(:) 3554 3582 … … 3558 3586 3559 3587 3560 SUBROUTINE mppmax_real( ptab )3588 SUBROUTINE mppmax_real( ptab, kcom ) 3561 3589 !!---------------------------------------------------------------------- 3562 3590 !! *** routine mppmax_real *** … … 3567 3595 !! * Arguments 3568 3596 REAL(wp), INTENT(inout) :: ptab ! ??? 3597 INTEGER, INTENT(in), OPTIONAL :: kcom ! ??? 3569 3598 3570 3599 #if defined key_mpp_shmem … … 3591 3620 !! * Local variables (MPI version) 3592 3621 INTEGER :: ierror 3622 INTEGER :: localcomm 3593 3623 REAL(wp) :: zwork 3594 3624 3625 localcomm = mpi_comm_opa 3626 IF( PRESENT(kcom) ) localcomm = kcom 3627 3595 3628 CALL mpi_allreduce( ptab, zwork , 1 , mpi_double_precision, & 3596 & mpi_max, mpi_comm_opa, ierror )3629 & mpi_max, localcomm, ierror ) 3597 3630 ptab = zwork 3598 3631 … … 3602 3635 3603 3636 3604 SUBROUTINE mppmin_a_real( ptab, kdim )3637 SUBROUTINE mppmin_a_real( ptab, kdim, kcom ) 3605 3638 !!---------------------------------------------------------------------- 3606 3639 !! *** routine mppmin_a_real *** … … 3612 3645 INTEGER , INTENT( in ) :: kdim 3613 3646 REAL(wp), INTENT(inout), DIMENSION(kdim) :: ptab 3647 INTEGER , INTENT( in ), OPTIONAL :: kcom 3614 3648 3615 3649 #if defined key_mpp_shmem … … 3644 3678 !! * Local variables (MPI version) 3645 3679 INTEGER :: ierror 3680 INTEGER :: localcomm 3646 3681 REAL(wp), DIMENSION(kdim) :: zwork 3647 3682 3683 localcomm = mpi_comm_opa 3684 IF( PRESENT(kcom) ) localcomm = kcom 3685 3648 3686 CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision & 3649 ,mpi_min, mpi_comm_opa,ierror)3687 ,mpi_min,localcomm,ierror) 3650 3688 ptab(:) = zwork(:) 3651 3689 … … 3655 3693 3656 3694 3657 SUBROUTINE mppmin_real( ptab )3695 SUBROUTINE mppmin_real( ptab, kcom ) 3658 3696 !!---------------------------------------------------------------------- 3659 3697 !! *** routine mppmin_real *** … … 3665 3703 !! * Arguments 3666 3704 REAL(wp), INTENT( inout ) :: ptab ! 3705 INTEGER,INTENT(in), OPTIONAL :: kcom 3667 3706 3668 3707 #if defined key_mpp_shmem … … 3690 3729 INTEGER :: ierror 3691 3730 REAL(wp) :: zwork 3731 INTEGER :: localcomm 3732 3733 localcomm = mpi_comm_opa 3734 IF( PRESENT(kcom) ) localcomm = kcom 3692 3735 3693 3736 CALL mpi_allreduce( ptab, zwork, 1,mpi_double_precision & 3694 & ,mpi_min, mpi_comm_opa,ierror)3737 & ,mpi_min,localcomm,ierror) 3695 3738 ptab = zwork 3696 3739 … … 3700 3743 3701 3744 3702 SUBROUTINE mppsum_a_real( ptab, kdim )3745 SUBROUTINE mppsum_a_real( ptab, kdim, kcom ) 3703 3746 !!---------------------------------------------------------------------- 3704 3747 !! *** routine mppsum_a_real *** … … 3710 3753 INTEGER , INTENT( in ) :: kdim ! size of ptab 3711 3754 REAL(wp), DIMENSION(kdim), INTENT( inout ) :: ptab ! input array 3755 INTEGER, INTENT(in), OPTIONAL :: kcom 3712 3756 3713 3757 #if defined key_mpp_shmem … … 3742 3786 !! * Local variables (MPI version) 3743 3787 INTEGER :: ierror ! temporary integer 3788 INTEGER :: localcomm 3744 3789 REAL(wp), DIMENSION(kdim) :: zwork ! temporary workspace 3790 3791 3792 localcomm = mpi_comm_opa 3793 IF( PRESENT(kcom) ) localcomm = kcom 3745 3794 3746 3795 CALL mpi_allreduce(ptab, zwork,kdim,mpi_double_precision & 3747 & ,mpi_sum, mpi_comm_opa,ierror)3796 & ,mpi_sum,localcomm,ierror) 3748 3797 ptab(:) = zwork(:) 3749 3798 … … 3753 3802 3754 3803 3755 SUBROUTINE mppsum_real( ptab )3804 SUBROUTINE mppsum_real( ptab, kcom ) 3756 3805 !!---------------------------------------------------------------------- 3757 3806 !! *** routine mppsum_real *** … … 3762 3811 !!----------------------------------------------------------------------- 3763 3812 REAL(wp), INTENT(inout) :: ptab ! input scalar 3813 INTEGER, INTENT(in), OPTIONAL :: kcom 3764 3814 3765 3815 #if defined key_mpp_shmem … … 3786 3836 !! * Local variables (MPI version) 3787 3837 INTEGER :: ierror 3838 INTEGER :: localcomm 3788 3839 REAL(wp) :: zwork 3789 3840 3790 CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision & 3791 & ,mpi_sum,mpi_comm_opa,ierror) 3841 localcomm = mpi_comm_opa 3842 IF( PRESENT(kcom) ) localcomm = kcom 3843 3844 CALL mpi_allreduce(ptab, zwork, 1,mpi_double_precision & 3845 & ,mpi_sum,localcomm,ierror) 3792 3846 ptab = zwork 3793 3847 … … 4289 4343 END SUBROUTINE mppobc 4290 4344 4345 SUBROUTINE mpp_comm_free( kcom) 4346 4347 INTEGER, INTENT(in) :: kcom 4348 INTEGER :: ierr 4349 4350 CALL MPI_COMM_FREE(kcom, ierr) 4351 4352 END SUBROUTINE mpp_comm_free 4353 4354 4355 SUBROUTINE mpp_ini_ice(pindic) 4356 !!---------------------------------------------------------------------- 4357 !! *** routine mpp_ini_ice *** 4358 !! 4359 !! ** Purpose : Initialize special communicator for ice areas 4360 !! condition together with global variables needed in the ddmpp folding 4361 !! 4362 !! ** Method : - Look for ice processors in ice routines 4363 !! - Put their number in nrank_ice 4364 !! - Create groups for the world processors and the ice processors 4365 !! - Create a communicator for ice processors 4366 !! 4367 !! ** output 4368 !! njmppmax = njmpp for northern procs 4369 !! ndim_rank_ice = number of processors in the northern line 4370 !! nrank_north (ndim_rank_north) = number of the northern procs. 4371 !! ngrp_world = group ID for the world processors 4372 !! ngrp_ice = group ID for the ice processors 4373 !! ncomm_ice = communicator for the ice procs. 4374 !! n_ice_root = number (in the world) of proc 0 in the ice comm. 4375 !! 4376 !! History : 4377 !! ! 03-09 (J.M. Molines, MPI only ) 4378 !!---------------------------------------------------------------------- 4379 #ifdef key_mpp_shmem 4380 CALL ctl_stop( ' mpp_ini_ice not available in SHMEM' ) 4381 # elif key_mpp_mpi 4382 INTEGER, INTENT(in) :: pindic 4383 INTEGER :: ierr 4384 INTEGER :: jproc 4385 INTEGER :: ii,ji 4386 INTEGER, DIMENSION(jpnij) :: kice 4387 INTEGER, DIMENSION(jpnij) :: zwork 4388 INTEGER :: zrank 4389 !!---------------------------------------------------------------------- 4390 4391 ! Look for how many procs with sea-ice 4392 ! 4393 kice = 0 4394 DO jproc=1,jpnij 4395 IF(jproc == narea .AND. pindic .GT. 0) THEN 4396 kice(jproc) = 1 4397 ENDIF 4398 END DO 4399 4400 zwork = 0 4401 CALL MPI_ALLREDUCE( kice, zwork,jpnij, mpi_integer, & 4402 mpi_sum, mpi_comm_opa, ierr ) 4403 ndim_rank_ice = sum(zwork) 4404 4405 ! Allocate the right size to nrank_north 4406 IF(ALLOCATED(nrank_ice)) DEALLOCATE(nrank_ice) 4407 ALLOCATE(nrank_ice(ndim_rank_ice)) 4408 4409 ii = 0 4410 nrank_ice = 0 4411 DO jproc=1,jpnij 4412 IF(zwork(jproc) == 1) THEN 4413 ii = ii + 1 4414 nrank_ice(ii) = jproc -1 4415 ENDIF 4416 END DO 4417 4418 ! Create the world group 4419 CALL MPI_COMM_GROUP(mpi_comm_opa,ngrp_world,ierr) 4420 4421 ! Create the ice group from the world group 4422 CALL MPI_GROUP_INCL(ngrp_world,ndim_rank_ice,nrank_ice,ngrp_ice,ierr) 4423 4424 ! Create the ice communicator , ie the pool of procs with sea-ice 4425 CALL MPI_COMM_CREATE(mpi_comm_opa,ngrp_ice,ncomm_ice,ierr) 4426 4427 ! Find proc number in the world of proc 0 in the north 4428 CALL MPI_GROUP_TRANSLATE_RANKS(ngrp_ice,1,0,ngrp_world,n_ice_root,ierr) 4429 #endif 4430 4431 END SUBROUTINE mpp_ini_ice 4432 4291 4433 4292 4434 SUBROUTINE mpp_ini_north … … 5237 5379 5238 5380 LOGICAL, PUBLIC, PARAMETER :: lk_mpp = .FALSE. !: mpp flag 5381 INTEGER :: ncomm_ice 5239 5382 5240 5383 CONTAINS … … 5248 5391 END SUBROUTINE mppsync 5249 5392 5250 SUBROUTINE mpp_sum_as( parr, kdim ) ! Dummy routine5393 SUBROUTINE mpp_sum_as( parr, kdim, kcom ) ! Dummy routine 5251 5394 REAL , DIMENSION(:) :: parr 5252 5395 INTEGER :: kdim 5253 WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1) 5396 INTEGER, OPTIONAL :: kcom 5397 WRITE(*,*) 'mpp_sum_as: You should not have seen this print! error?', kdim, parr(1), kcom 5254 5398 END SUBROUTINE mpp_sum_as 5255 5399 5256 SUBROUTINE mpp_sum_a2s( parr, kdim ) ! Dummy routine5400 SUBROUTINE mpp_sum_a2s( parr, kdim, kcom ) ! Dummy routine 5257 5401 REAL , DIMENSION(:,:) :: parr 5258 5402 INTEGER :: kdim 5259 WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1) 5403 INTEGER, OPTIONAL :: kcom 5404 WRITE(*,*) 'mpp_sum_a2s: You should not have seen this print! error?', kdim, parr(1,1), kcom 5260 5405 END SUBROUTINE mpp_sum_a2s 5261 5406 5262 SUBROUTINE mpp_sum_ai( karr, kdim ) ! Dummy routine5407 SUBROUTINE mpp_sum_ai( karr, kdim, kcom ) ! Dummy routine 5263 5408 INTEGER, DIMENSION(:) :: karr 5264 5409 INTEGER :: kdim 5265 WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1) 5410 INTEGER, OPTIONAL :: kcom 5411 WRITE(*,*) 'mpp_sum_ai: You should not have seen this print! error?', kdim, karr(1), kcom 5266 5412 END SUBROUTINE mpp_sum_ai 5267 5413 5268 SUBROUTINE mpp_sum_s( psca ) ! Dummy routine5414 SUBROUTINE mpp_sum_s( psca, kcom ) ! Dummy routine 5269 5415 REAL :: psca 5270 WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca 5416 INTEGER, OPTIONAL :: kcom 5417 WRITE(*,*) 'mpp_sum_s: You should not have seen this print! error?', psca, kcom 5271 5418 END SUBROUTINE mpp_sum_s 5272 5419 5273 SUBROUTINE mpp_sum_i( kint ) ! Dummy routine5420 SUBROUTINE mpp_sum_i( kint, kcom ) ! Dummy routine 5274 5421 integer :: kint 5275 WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint 5422 INTEGER, OPTIONAL :: kcom 5423 WRITE(*,*) 'mpp_sum_i: You should not have seen this print! error?', kint, kcom 5276 5424 END SUBROUTINE mpp_sum_i 5277 5425 5278 SUBROUTINE mppmax_a_real( parr, kdim )5426 SUBROUTINE mppmax_a_real( parr, kdim, kcom ) 5279 5427 REAL , DIMENSION(:) :: parr 5280 5428 INTEGER :: kdim 5281 WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1) 5429 INTEGER, OPTIONAL :: kcom 5430 WRITE(*,*) 'mppmax_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 5282 5431 END SUBROUTINE mppmax_a_real 5283 5432 5284 SUBROUTINE mppmax_real( psca )5433 SUBROUTINE mppmax_real( psca, kcom ) 5285 5434 REAL :: psca 5286 WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca 5435 INTEGER, OPTIONAL :: kcom 5436 WRITE(*,*) 'mppmax_real: You should not have seen this print! error?', psca, kcom 5287 5437 END SUBROUTINE mppmax_real 5288 5438 5289 SUBROUTINE mppmin_a_real( parr, kdim )5439 SUBROUTINE mppmin_a_real( parr, kdim, kcom ) 5290 5440 REAL , DIMENSION(:) :: parr 5291 5441 INTEGER :: kdim 5292 WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1) 5442 INTEGER, OPTIONAL :: kcom 5443 WRITE(*,*) 'mppmin_a_real: You should not have seen this print! error?', kdim, parr(1), kcom 5293 5444 END SUBROUTINE mppmin_a_real 5294 5445 5295 SUBROUTINE mppmin_real( psca )5446 SUBROUTINE mppmin_real( psca, kcom ) 5296 5447 REAL :: psca 5297 WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca 5448 INTEGER, OPTIONAL :: kcom 5449 WRITE(*,*) 'mppmin_real: You should not have seen this print! error?', psca, kcom 5298 5450 END SUBROUTINE mppmin_real 5299 5451 5300 SUBROUTINE mppmax_a_int( karr, kdim )5452 SUBROUTINE mppmax_a_int( karr, kdim ,kcom) 5301 5453 INTEGER, DIMENSION(:) :: karr 5302 5454 INTEGER :: kdim 5455 INTEGER, OPTIONAL :: kcom 5303 5456 WRITE(*,*) 'mppmax_a_int: You should not have seen this print! error?', kdim, karr(1) 5304 5457 END SUBROUTINE mppmax_a_int 5305 5458 5306 SUBROUTINE mppmax_int( kint 5459 SUBROUTINE mppmax_int( kint, kcom) 5307 5460 INTEGER :: kint 5308 WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint 5461 INTEGER, OPTIONAL :: kcom 5462 WRITE(*,*) 'mppmax_int: You should not have seen this print! error?', kint, kcom 5309 5463 END SUBROUTINE mppmax_int 5310 5464 5311 SUBROUTINE mppmin_a_int( karr, kdim )5465 SUBROUTINE mppmin_a_int( karr, kdim, kcom ) 5312 5466 INTEGER, DIMENSION(:) :: karr 5313 5467 INTEGER :: kdim 5314 WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1) 5468 INTEGER, OPTIONAL :: kcom 5469 WRITE(*,*) 'mppmin_a_int: You should not have seen this print! error?', kdim, karr(1), kcom 5315 5470 END SUBROUTINE mppmin_a_int 5316 5471 5317 SUBROUTINE mppmin_int( kint )5472 SUBROUTINE mppmin_int( kint, kcom ) 5318 5473 INTEGER :: kint 5319 WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint 5474 INTEGER, OPTIONAL :: kcom 5475 WRITE(*,*) 'mppmin_int: You should not have seen this print! error?', kint, kcom 5320 5476 END SUBROUTINE mppmin_int 5321 5477 … … 5412 5568 END SUBROUTINE mppstop 5413 5569 5570 SUBROUTINE mpp_ini_lim 5571 WRITE(*,*) 'mpp_ini_north: You should not have seen this print! error?' 5572 END SUBROUTINE mpp_ini_lim 5573 5574 SUBROUTINE mpp_comm_free(kcom) 5575 INTEGER :: kcom 5576 WRITE(*,*) 'mpp_comm_free: You should not have seen this print! error?' 5577 END SUBROUTINE mpp_comm_free 5578 5414 5579 #endif 5415 5580 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.