Changeset 4891
- Timestamp:
- 2014-11-27T11:52:54+01:00 (9 years ago)
- Location:
- branches/2014/dev_r4743_NOC2_ZTS/NEMOGCM
- Files:
-
- 1 added
- 9 edited
-
NEMO/OPA_SRC/ICB/icb_oce.F90 (modified) (5 diffs)
-
NEMO/OPA_SRC/ICB/icbdyn.F90 (modified) (2 diffs)
-
NEMO/OPA_SRC/ICB/icbini.F90 (modified) (3 diffs)
-
NEMO/OPA_SRC/ICB/icblbc.F90 (modified) (10 diffs)
-
NEMO/OPA_SRC/ICB/icbrst.F90 (modified) (3 diffs)
-
NEMO/OPA_SRC/ICB/icbstp.F90 (modified) (1 diff)
-
NEMO/OPA_SRC/ICB/icbutl.F90 (modified) (3 diffs)
-
NEMO/OPA_SRC/LBC/lbclnk.F90 (modified) (2 diffs)
-
NEMO/OPA_SRC/LBC/lib_mpp.F90 (modified) (5 diffs)
-
TOOLS/MISCELLANEOUS/icb_pp.py (added)
Legend:
- Unmodified
- Added
- Removed
-
branches/2014/dev_r4743_NOC2_ZTS/NEMOGCM/NEMO/OPA_SRC/ICB/icb_oce.F90
r4153 r4891 96 96 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ua_e, va_e 97 97 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ssh_e 98 #if defined key_lim2 || defined key_lim3 98 #if defined key_lim2 || defined key_lim3 || defined key_cice 99 99 REAL(wp), PUBLIC, DIMENSION(:,:), ALLOCATABLE :: ui_e, vi_e 100 100 #endif … … 144 144 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbflddest !: nfold destination proc 145 145 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldproc !: nfold destination proc 146 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldnsend !: nfold number of bergs to send to nfold neighbour 147 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldexpect !: nfold expected number of bergs 148 INTEGER , PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: nicbfldreq !: nfold message handle (immediate send) 146 149 147 150 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: griddata !: work array for icbrst … … 162 165 ! 163 166 icb_alloc = 0 167 ALLOCATE( berg_grid, STAT=ill ) 168 icb_alloc = icb_alloc + ill 164 169 ALLOCATE( berg_grid%calving (jpi,jpj) , berg_grid%calving_hflx (jpi,jpj) , & 165 170 & berg_grid%stored_heat(jpi,jpj) , berg_grid%floating_melt(jpi,jpj) , & … … 171 176 ALLOCATE( uo_e(0:jpi+1,0:jpj+1) , ua_e(0:jpi+1,0:jpj+1) , & 172 177 & vo_e(0:jpi+1,0:jpj+1) , va_e(0:jpi+1,0:jpj+1) , & 173 #if defined key_lim2 || defined key_lim3 178 #if defined key_lim2 || defined key_lim3 || defined key_cice 174 179 & ui_e(0:jpi+1,0:jpj+1) , & 175 180 & vi_e(0:jpi+1,0:jpj+1) , & … … 181 186 icb_alloc = icb_alloc + ill 182 187 183 ALLOCATE( nicbfldpts(jpi) , nicbflddest(jpi) , nicbfldproc(jpni) , STAT=ill) 188 ALLOCATE( nicbfldpts(jpi) , nicbflddest(jpi) , nicbfldproc(jpni) , & 189 & nicbfldnsend(jpni), nicbfldexpect(jpni) , nicbfldreq(jpni), STAT=ill) 184 190 icb_alloc = icb_alloc + ill 185 191 -
branches/2014/dev_r4743_NOC2_ZTS/NEMOGCM/NEMO/OPA_SRC/ICB/icbdyn.F90
r3614 r4891 33 33 CONTAINS 34 34 35 SUBROUTINE icb_dyn( )35 SUBROUTINE icb_dyn( kt ) 36 36 !!---------------------------------------------------------------------- 37 37 !! *** ROUTINE icb_dyn *** … … 50 50 TYPE(iceberg), POINTER :: berg 51 51 TYPE(point) , POINTER :: pt 52 INTEGER :: kt 52 53 !!---------------------------------------------------------------------- 53 54 -
branches/2014/dev_r4743_NOC2_ZTS/NEMOGCM/NEMO/OPA_SRC/ICB/icbini.F90
r4624 r4891 172 172 DO ji = nicbdi, nicbei 173 173 ii = nicbflddest(ji) 174 DO jn = 1, jpni 175 ! work along array until we find an empty slot 176 IF( nicbfldproc(jn) == -1 ) THEN 177 nicbfldproc(jn) = ii 178 EXIT !!gm EXIT should be avoided: use DO WHILE expression instead 179 ENDIF 180 ! before we find an empty slot, we may find processor number is already here so we exit 181 IF( nicbfldproc(jn) == ii ) EXIT 182 END DO 174 IF( ii .GT. 0 ) THEN ! Needed because land suppression can mean 175 ! that unused points are not set in edge haloes 176 DO jn = 1, jpni 177 ! work along array until we find an empty slot 178 IF( nicbfldproc(jn) == -1 ) THEN 179 nicbfldproc(jn) = ii 180 EXIT !!gm EXIT should be avoided: use DO WHILE expression instead 181 ENDIF 182 ! before we find an empty slot, we may find processor number is already here so we exit 183 IF( nicbfldproc(jn) == ii ) EXIT 184 END DO 185 ENDIF 183 186 END DO 184 187 ENDIF … … 210 213 WRITE(numicb,*) 'north fold destination procs ' 211 214 WRITE(numicb,*) nicbflddest 215 WRITE(numicb,*) 'north fold destination proclist ' 216 WRITE(numicb,*) nicbfldproc 212 217 ENDIF 213 218 CALL flush(numicb) … … 397 402 ENDIF 398 403 399 400 401 404 ! IF( lk_lim3 .AND. ln_icebergs ) THEN 405 ! CALL ctl_stop( 'icb_nam: the use of ICB with LIM3 not allowed. ice thickness missing in ICB' ) 406 ! ENDIF 402 407 403 408 IF(lwp) THEN ! control print -
branches/2014/dev_r4743_NOC2_ZTS/NEMOGCM/NEMO/OPA_SRC/ICB/icblbc.F90
r3614 r4891 280 280 zwebergs(1) = ibergs_to_send_e 281 281 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) 282 CALL mpprecv( 11, zewbergs(2), 1 )282 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 283 283 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 284 284 ibergs_rcvd_from_e = INT( zewbergs(2) ) … … 288 288 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) 289 289 CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) 290 CALL mpprecv( 11, zewbergs(2), 1 )291 CALL mpprecv( 12, zwebergs(2), 1 )290 CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) 291 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 292 292 IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 293 293 IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) … … 297 297 zewbergs(1) = ibergs_to_send_w 298 298 CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) 299 CALL mpprecv( 12, zwebergs(2), 1 )299 CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) 300 300 IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 301 301 ibergs_rcvd_from_w = INT( zwebergs(2) ) … … 411 411 zsnbergs(1) = ibergs_to_send_n 412 412 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) 413 CALL mpprecv( 15, znsbergs(2), 1 )413 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 414 414 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) 415 415 ibergs_rcvd_from_n = INT( znsbergs(2) ) … … 419 419 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) 420 420 CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) 421 CALL mpprecv( 15, znsbergs(2), 1 )422 CALL mpprecv( 16, zsnbergs(2), 1 )421 CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) 422 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 423 423 IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) 424 424 IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) … … 428 428 znsbergs(1) = ibergs_to_send_s 429 429 CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) 430 CALL mpprecv( 16, zsnbergs(2), 1 )430 CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) 431 431 IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) 432 432 ibergs_rcvd_from_s = INT( zsnbergs(2) ) … … 581 581 INTEGER :: ifldproc, iproc, ipts 582 582 INTEGER :: iine, ijne 583 REAL(wp), DIMENSION(2) :: zsbergs, znbergs 583 INTEGER :: jjn 584 REAL(wp), DIMENSION(0:3) :: zsbergs, znbergs 584 585 INTEGER :: iml_req1, iml_req2, iml_err 585 586 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat … … 591 592 ! its of fixed size, the first -1 marks end of list of processors 592 593 ! 594 nicbfldnsend(:) = 0 595 nicbfldexpect(:) = 0 596 nicbfldreq(:) = 0 597 ! 598 ! Since each processor may be communicating with more than one northern 599 ! neighbour, cycle through the sends so that the receive order can be 600 ! controlled. 601 ! 602 ! First compute how many icebergs each active neighbour should expect 603 DO jn = 1, jpni 604 IF( nicbfldproc(jn) /= -1 ) THEN 605 ifldproc = nicbfldproc(jn) 606 nicbfldnsend(jn) = 0 607 608 ! Find number of bergs that need to be exchanged 609 ! Pick out exchanges with processor ifldproc 610 ! if ifldproc is this processor then don't send 611 ! 612 IF( ASSOCIATED(first_berg) ) THEN 613 this => first_berg 614 DO WHILE (ASSOCIATED(this)) 615 pt => this%current_point 616 iine = INT( pt%xi + 0.5 ) 617 ijne = INT( pt%yj + 0.5 ) 618 iproc = nicbflddest(mi1(iine)) 619 IF( ijne .GT. mjg(nicbej) ) THEN 620 IF( iproc == ifldproc ) THEN 621 ! 622 IF( iproc /= narea ) THEN 623 tmpberg => this 624 nicbfldnsend(jn) = nicbfldnsend(jn) + 1 625 ENDIF 626 ! 627 ENDIF 628 ENDIF 629 this => this%next 630 END DO 631 ENDIF 632 ! 633 ENDIF 634 ! 635 END DO 636 ! 637 ! Now tell each active neighbour how many icebergs to expect 638 DO jn = 1, jpni 639 IF( nicbfldproc(jn) /= -1 ) THEN 640 ifldproc = nicbfldproc(jn) 641 IF( ifldproc == narea ) CYCLE 642 643 zsbergs(0) = narea 644 zsbergs(1) = nicbfldnsend(jn) 645 !IF ( nicbfldnsend(jn) .GT. 0) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc 646 CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn)) 647 ENDIF 648 ! 649 END DO 650 ! 651 ! and receive the heads-up from active neighbours preparing to send 652 DO jn = 1, jpni 653 IF( nicbfldproc(jn) /= -1 ) THEN 654 ifldproc = nicbfldproc(jn) 655 IF( ifldproc == narea ) CYCLE 656 657 CALL mpprecv( 21, znbergs(1:2), 2 ) 658 DO jjn = 1,jpni 659 IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT 660 END DO 661 IF( jjn .GT. jpni ) write(numicb,*) 'ICB ERROR' 662 nicbfldexpect(jjn) = INT( znbergs(2) ) 663 !IF ( nicbfldexpect(jjn) .GT. 0) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn) 664 !CALL FLUSH(numicb) 665 ENDIF 666 ! 667 END DO 668 ! 669 ! post the mpi waits if using immediate send protocol 670 DO jn = 1, jpni 671 IF( nicbfldproc(jn) /= -1 ) THEN 672 ifldproc = nicbfldproc(jn) 673 IF( ifldproc == narea ) CYCLE 674 675 IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 676 ENDIF 677 ! 678 END DO 679 680 ! 681 ! Cycle through the icebergs again, this time packing and sending any 682 ! going through the north fold. They will be expected. 593 683 DO jn = 1, jpni 594 684 IF( nicbfldproc(jn) /= -1 ) THEN … … 646 736 IF( ifldproc == narea ) CYCLE 647 737 648 zsbergs(1) = ibergs_to_send649 CALL mppsend( 21, zsbergs(1), 1, ifldproc-1, iml_req1)650 CALL mpprecv( 21, znbergs(2), 1 )651 IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err )652 ibergs_to_rcv = INT( znbergs(2) )653 654 738 ! send bergs 655 739 656 740 IF( ibergs_to_send > 0 ) & 657 CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, iml_req2 ) 741 CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) ) 742 ! 743 ENDIF 744 ! 745 END DO 746 ! 747 ! Now receive the expected number of bergs from the active neighbours 748 DO jn = 1, jpni 749 IF( nicbfldproc(jn) /= -1 ) THEN 750 ifldproc = nicbfldproc(jn) 751 IF( ifldproc == narea ) CYCLE 752 ibergs_to_rcv = nicbfldexpect(jn) 753 658 754 IF( ibergs_to_rcv > 0 ) THEN 659 755 CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv) 660 CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width )661 ENDIF 662 IF( ibergs_to_send > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err )756 CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 ) 757 ENDIF 758 ! 663 759 DO jk = 1, ibergs_to_rcv 664 760 IF( nn_verbose_level >= 4 ) THEN … … 668 764 CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk ) 669 765 END DO 670 ! 766 ENDIF 767 ! 768 END DO 769 ! 770 ! Finally post the mpi waits if using immediate send protocol 771 DO jn = 1, jpni 772 IF( nicbfldproc(jn) /= -1 ) THEN 773 ifldproc = nicbfldproc(jn) 774 IF( ifldproc == narea ) CYCLE 775 776 IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) 671 777 ENDIF 672 778 ! -
branches/2014/dev_r4743_NOC2_ZTS/NEMOGCM/NEMO/OPA_SRC/ICB/icbrst.F90
r3614 r4891 64 64 ! start and count arrays 65 65 LOGICAL :: ll_found_restart 66 CHARACTER(len= 80):: cl_filename66 CHARACTER(len=256) :: cl_filename 67 67 CHARACTER(len=NF90_MAX_NAME) :: cl_dname 68 68 TYPE(iceberg) :: localberg ! NOT a pointer but an actual local variable … … 228 228 INTEGER :: jn ! dummy loop index 229 229 INTEGER :: ix_dim, iy_dim, ik_dim, in_dim 230 CHARACTER(len= 80):: cl_filename230 CHARACTER(len=256) :: cl_filename 231 231 TYPE(iceberg), POINTER :: this 232 232 TYPE(point) , POINTER :: pt … … 256 256 IF (nret .ne. NF90_NOERR) CALL ctl_stop('icebergs, write_restart: nf_def_dim k failed') 257 257 258 ! global attributes 259 IF( lk_mpp ) THEN 260 ! Set domain parameters (assume jpdom_local_full) 261 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number_total' , jpnij ) 262 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_number' , narea-1 ) 263 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_dimensions_ids' , (/1 , 2 /) ) 264 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_global' , (/jpiglo, jpjglo/) ) 265 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_size_local' , (/jpi , jpj /) ) 266 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_first' , (/nimpp , njmpp /) ) 267 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_position_last' , (/nimpp + jpi - 1 , njmpp + jpj - 1 /) ) 268 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_start', (/nldi - 1 , nldj - 1 /) ) 269 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_halo_size_end' , (/jpi - nlei , jpj - nlej /) ) 270 nret = NF90_PUT_ATT( ncid, NF90_GLOBAL, 'DOMAIN_type' , 'BOX' ) 271 ENDIF 272 258 273 IF (associated(first_berg)) then 259 274 nret = NF90_DEF_DIM(ncid, 'n', NF90_UNLIMITED, in_dim) -
branches/2014/dev_r4743_NOC2_ZTS/NEMOGCM/NEMO/OPA_SRC/ICB/icbstp.F90
r4153 r4891 105 105 ! !== For each berg, evolve ==! 106 106 ! 107 IF( ASSOCIATED(first_berg) ) CALL icb_dyn( )! ice berg dynamics107 IF( ASSOCIATED(first_berg) ) CALL icb_dyn( kt ) ! ice berg dynamics 108 108 109 109 IF( lk_mpp ) THEN ; CALL icb_lbc_mpp() ! Send bergs to other PEs -
branches/2014/dev_r4743_NOC2_ZTS/NEMOGCM/NEMO/OPA_SRC/ICB/icbutl.F90
r3821 r4891 76 76 va_e(:,:) = 0._wp ; va_e(1:jpi, 1:jpj) = vtau (:,:) 77 77 78 CALL lbc_lnk_ e( uo_e, 'U', -1._wp, 1, 1 )79 CALL lbc_lnk_ e( vo_e, 'V', -1._wp, 1, 1 )80 CALL lbc_lnk_ e( ff_e, 'F', +1._wp, 1, 1 )81 CALL lbc_lnk_ e( ua_e, 'U', -1._wp, 1, 1 )82 CALL lbc_lnk_ e( va_e, 'V', -1._wp, 1, 1 )78 CALL lbc_lnk_icb( uo_e, 'U', -1._wp, 1, 1 ) 79 CALL lbc_lnk_icb( vo_e, 'V', -1._wp, 1, 1 ) 80 CALL lbc_lnk_icb( ff_e, 'F', +1._wp, 1, 1 ) 81 CALL lbc_lnk_icb( ua_e, 'U', -1._wp, 1, 1 ) 82 CALL lbc_lnk_icb( va_e, 'V', -1._wp, 1, 1 ) 83 83 84 84 #if defined key_lim2 || defined key_lim3 … … 86 86 vi_e(:,:) = 0._wp ; vi_e(1:jpi, 1:jpj) = v_ice(:,:) 87 87 88 CALL lbc_lnk_ e( ui_e, 'U', -1._wp, 1, 1 )89 CALL lbc_lnk_ e( vi_e, 'V', -1._wp, 1, 1 )88 CALL lbc_lnk_icb( ui_e, 'U', -1._wp, 1, 1 ) 89 CALL lbc_lnk_icb( vi_e, 'V', -1._wp, 1, 1 ) 90 90 #endif 91 91 … … 102 102 ssh_e(0,jpj+1) = ssh_e(1,jpj) 103 103 ssh_e(jpi+1,jpj+1) = ssh_e(jpi,jpj) 104 CALL lbc_lnk_ e( ssh_e, 'T', +1._wp, 1, 1 )104 CALL lbc_lnk_icb( ssh_e, 'T', +1._wp, 1, 1 ) 105 105 ! 106 106 END SUBROUTINE icb_utl_copy -
branches/2014/dev_r4743_NOC2_ZTS/NEMOGCM/NEMO/OPA_SRC/LBC/lbclnk.F90
r4328 r4891 34 34 END INTERFACE 35 35 36 INTERFACE lbc_lnk_icb 37 MODULE PROCEDURE mpp_lnk_2d_icb 38 END INTERFACE 39 36 40 PUBLIC lbc_lnk ! ocean lateral boundary conditions 37 41 PUBLIC lbc_lnk_e 38 42 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 43 PUBLIC lbc_lnk_icb 39 44 40 45 !!---------------------------------------------------------------------- … … 73 78 END INTERFACE 74 79 80 INTERFACE lbc_lnk_icb 81 MODULE PROCEDURE lbc_lnk_2d_e 82 END INTERFACE 83 75 84 PUBLIC lbc_lnk ! ocean/ice lateral boundary conditions 76 85 PUBLIC lbc_lnk_e 77 86 PUBLIC lbc_bdy_lnk ! ocean lateral BDY boundary conditions 87 PUBLIC lbc_lnk_icb 78 88 79 89 !!---------------------------------------------------------------------- -
branches/2014/dev_r4743_NOC2_ZTS/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r4671 r4891 42 42 !! mpp_lnk_3d_gather : Message passing manadgement for two 3D arrays 43 43 !! mpp_lnk_e : interface (defined in lbclnk) for message passing of 2d array with extra halo (mpp_lnk_2d_e) 44 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 44 45 !! mpprecv : 45 46 !! mppsend : SUBROUTINE mpp_ini_znl … … 56 57 !! mpp_lbc_north : north fold processors gathering 57 58 !! mpp_lbc_north_e : variant of mpp_lbc_north for extra outer halo 59 !! mpp_lbc_north_icb : variant of mpp_lbc_north for extra outer halo with icebergs 58 60 !!---------------------------------------------------------------------- 59 61 USE dom_oce ! ocean space and time domain … … 74 76 PUBLIC mppsend, mpprecv ! needed by TAM and ICB routines 75 77 PUBLIC mpp_lnk_bdy_2d, mpp_lnk_bdy_3d 78 PUBLIC mpp_lbc_north_icb, mpp_lnk_2d_icb 76 79 77 80 !! * Interfaces … … 2084 2087 IF (l_isend) THEN 2085 2088 DO jr = 1,nsndto 2086 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2089 IF ((nfipproc(isendto(jr),jpnj) .ne. (narea-1)) .and. (nfipproc(isendto(jr),jpnj) .ne. -1)) THEN 2090 CALL mpi_wait(ml_req_nf(jr), ml_stat, ml_err) 2091 ENDIF 2087 2092 END DO 2088 2093 ENDIF … … 2891 2896 END SUBROUTINE DDPDD_MPI 2892 2897 2898 SUBROUTINE mpp_lbc_north_icb( pt2d, cd_type, psgn, pr2dj) 2899 !!--------------------------------------------------------------------- 2900 !! *** routine mpp_lbc_north_icb *** 2901 !! 2902 !! ** Purpose : Ensure proper north fold horizontal bondary condition 2903 !! in mpp configuration in case of jpn1 > 1 and for 2d 2904 !! array with outer extra halo 2905 !! 2906 !! ** Method : North fold condition and mpp with more than one proc 2907 !! in i-direction require a specific treatment. We gather 2908 !! the 4+2*jpr2dj northern lines of the global domain on 1 2909 !! processor and apply lbc north-fold on this sub array. 2910 !! Then we scatter the north fold array back to the processors. 2911 !! This version accounts for an extra halo with icebergs. 2912 !! 2913 !!---------------------------------------------------------------------- 2914 REAL(wp), DIMENSION(:,:), INTENT(inout) :: pt2d ! 2D array with extra halo 2915 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of pt3d grid-points 2916 ! ! = T , U , V , F or W -points 2917 REAL(wp) , INTENT(in ) :: psgn ! = -1. the sign change across the 2918 !! ! north fold, = 1. otherwise 2919 INTEGER, OPTIONAL , INTENT(in ) :: pr2dj 2920 INTEGER :: ji, jj, jr 2921 INTEGER :: ierr, itaille, ildi, ilei, iilb 2922 INTEGER :: ijpj, ij, iproc, ipr2dj 2923 ! 2924 REAL(wp), DIMENSION(:,:) , ALLOCATABLE :: ztab_e, znorthloc_e 2925 REAL(wp), DIMENSION(:,:,:), ALLOCATABLE :: znorthgloio_e 2926 2927 !!---------------------------------------------------------------------- 2928 ! 2929 ijpj=4 2930 IF( PRESENT(pr2dj) ) THEN ! use of additional halos 2931 ipr2dj = pr2dj 2932 ELSE 2933 ipr2dj = 0 2934 ENDIF 2935 ALLOCATE( ztab_e(jpiglo,4+2*ipr2dj), znorthloc_e(jpi,4+2*ipr2dj), znorthgloio_e(jpi,4+2*ipr2dj,jpni) ) 2936 2937 ! 2938 ztab_e(:,:) = 0.e0 2939 2940 ij=0 2941 ! put in znorthloc_e the last 4 jlines of pt2d 2942 DO jj = nlcj - ijpj + 1 - ipr2dj, nlcj +ipr2dj 2943 ij = ij + 1 2944 DO ji = 1, jpi 2945 znorthloc_e(ji,ij)=pt2d(ji,jj) 2946 END DO 2947 END DO 2948 ! 2949 itaille = jpi * ( ijpj + 2 * ipr2dj ) 2950 CALL MPI_ALLGATHER( znorthloc_e(1,1) , itaille, MPI_DOUBLE_PRECISION, & 2951 & znorthgloio_e(1,1,1), itaille, MPI_DOUBLE_PRECISION, ncomm_north, ierr ) 2952 ! 2953 DO jr = 1, ndim_rank_north ! recover the global north array 2954 iproc = nrank_north(jr) + 1 2955 ildi = nldit (iproc) 2956 ilei = nleit (iproc) 2957 iilb = nimppt(iproc) 2958 DO jj = 1, ijpj+2*ipr2dj 2959 DO ji = ildi, ilei 2960 ztab_e(ji+iilb-1,jj) = znorthgloio_e(ji,jj,jr) 2961 END DO 2962 END DO 2963 END DO 2964 2965 2966 ! 2. North-Fold boundary conditions 2967 ! ---------------------------------- 2968 CALL lbc_nfd( ztab_e(:,:), cd_type, psgn, pr2dj = ipr2dj ) 2969 2970 ij = ipr2dj 2971 !! Scatter back to pt2d 2972 DO jj = nlcj - ijpj + 1 , nlcj +ipr2dj 2973 ij = ij +1 2974 DO ji= 1, nlci 2975 pt2d(ji,jj) = ztab_e(ji+nimpp-1,ij) 2976 END DO 2977 END DO 2978 ! 2979 DEALLOCATE( ztab_e, znorthloc_e, znorthgloio_e ) 2980 ! 2981 END SUBROUTINE mpp_lbc_north_icb 2982 2983 SUBROUTINE mpp_lnk_2d_icb( pt2d, cd_type, psgn, jpri, jprj ) 2984 !!---------------------------------------------------------------------- 2985 !! *** routine mpp_lnk_2d_icb *** 2986 !! 2987 !! ** Purpose : Message passing manadgement for 2d array (with extra halo and icebergs) 2988 !! 2989 !! ** Method : Use mppsend and mpprecv function for passing mask 2990 !! between processors following neighboring subdomains. 2991 !! domain parameters 2992 !! nlci : first dimension of the local subdomain 2993 !! nlcj : second dimension of the local subdomain 2994 !! jpri : number of rows for extra outer halo 2995 !! jprj : number of columns for extra outer halo 2996 !! nbondi : mark for "east-west local boundary" 2997 !! nbondj : mark for "north-south local boundary" 2998 !! noea : number for local neighboring processors 2999 !! nowe : number for local neighboring processors 3000 !! noso : number for local neighboring processors 3001 !! nono : number for local neighboring processors 3002 !! 3003 !!---------------------------------------------------------------------- 3004 INTEGER , INTENT(in ) :: jpri 3005 INTEGER , INTENT(in ) :: jprj 3006 REAL(wp), DIMENSION(1-jpri:jpi+jpri,1-jprj:jpj+jprj), INTENT(inout) :: pt2d ! 2D array with extra halo 3007 CHARACTER(len=1) , INTENT(in ) :: cd_type ! nature of ptab array grid-points 3008 ! ! = T , U , V , F , W and I points 3009 REAL(wp) , INTENT(in ) :: psgn ! =-1 the sign change across the 3010 !! ! north boundary, = 1. otherwise 3011 INTEGER :: jl ! dummy loop indices 3012 INTEGER :: imigr, iihom, ijhom ! temporary integers 3013 INTEGER :: ipreci, iprecj ! temporary integers 3014 INTEGER :: ml_req1, ml_req2, ml_err ! for key_mpi_isend 3015 INTEGER, DIMENSION(MPI_STATUS_SIZE) :: ml_stat ! for key_mpi_isend 3016 !! 3017 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dns 3018 REAL(wp), DIMENSION(1-jpri:jpi+jpri,jprecj+jprj,2) :: r2dsn 3019 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dwe 3020 REAL(wp), DIMENSION(1-jprj:jpj+jprj,jpreci+jpri,2) :: r2dew 3021 !!---------------------------------------------------------------------- 3022 3023 ipreci = jpreci + jpri ! take into account outer extra 2D overlap area 3024 iprecj = jprecj + jprj 3025 3026 3027 ! 1. standard boundary treatment 3028 ! ------------------------------ 3029 ! Order matters Here !!!! 3030 ! 3031 ! ! East-West boundaries 3032 ! !* Cyclic east-west 3033 IF( nbondi == 2 .AND. (nperio == 1 .OR. nperio == 4 .OR. nperio == 6) ) THEN 3034 pt2d(1-jpri: 1 ,:) = pt2d(jpim1-jpri: jpim1 ,:) ! east 3035 pt2d( jpi :jpi+jpri,:) = pt2d( 2 :2+jpri,:) ! west 3036 ! 3037 ELSE !* closed 3038 IF( .NOT. cd_type == 'F' ) pt2d( 1-jpri :jpreci ,:) = 0.e0 ! south except at F-point 3039 pt2d(nlci-jpreci+1:jpi+jpri,:) = 0.e0 ! north 3040 ENDIF 3041 ! 3042 3043 ! north fold treatment 3044 ! ----------------------- 3045 IF( npolj /= 0 ) THEN 3046 ! 3047 SELECT CASE ( jpni ) 3048 CASE ( 1 ) ; CALL lbc_nfd ( pt2d(1:jpi,1:jpj+jprj), cd_type, psgn, pr2dj=jprj ) 3049 CASE DEFAULT ; CALL mpp_lbc_north_icb( pt2d(1:jpi,1:jpj+jprj) , cd_type, psgn , pr2dj=jprj ) 3050 END SELECT 3051 ! 3052 ENDIF 3053 3054 ! 2. East and west directions exchange 3055 ! ------------------------------------ 3056 ! we play with the neigbours AND the row number because of the periodicity 3057 ! 3058 SELECT CASE ( nbondi ) ! Read Dirichlet lateral conditions 3059 CASE ( -1, 0, 1 ) ! all exept 2 (i.e. close case) 3060 iihom = nlci-nreci-jpri 3061 DO jl = 1, ipreci 3062 r2dew(:,jl,1) = pt2d(jpreci+jl,:) 3063 r2dwe(:,jl,1) = pt2d(iihom +jl,:) 3064 END DO 3065 END SELECT 3066 ! 3067 ! ! Migrations 3068 imigr = ipreci * ( jpj + 2*jprj) 3069 ! 3070 SELECT CASE ( nbondi ) 3071 CASE ( -1 ) 3072 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req1 ) 3073 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 3074 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3075 CASE ( 0 ) 3076 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 3077 CALL mppsend( 2, r2dwe(1-jprj,1,1), imigr, noea, ml_req2 ) 3078 CALL mpprecv( 1, r2dew(1-jprj,1,2), imigr, noea ) 3079 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 3080 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3081 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 3082 CASE ( 1 ) 3083 CALL mppsend( 1, r2dew(1-jprj,1,1), imigr, nowe, ml_req1 ) 3084 CALL mpprecv( 2, r2dwe(1-jprj,1,2), imigr, nowe ) 3085 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3086 END SELECT 3087 ! 3088 ! ! Write Dirichlet lateral conditions 3089 iihom = nlci - jpreci 3090 ! 3091 SELECT CASE ( nbondi ) 3092 CASE ( -1 ) 3093 DO jl = 1, ipreci 3094 pt2d(iihom+jl,:) = r2dew(:,jl,2) 3095 END DO 3096 CASE ( 0 ) 3097 DO jl = 1, ipreci 3098 pt2d(jl-jpri,:) = r2dwe(:,jl,2) 3099 pt2d( iihom+jl,:) = r2dew(:,jl,2) 3100 END DO 3101 CASE ( 1 ) 3102 DO jl = 1, ipreci 3103 pt2d(jl-jpri,:) = r2dwe(:,jl,2) 3104 END DO 3105 END SELECT 3106 3107 3108 ! 3. North and south directions 3109 ! ----------------------------- 3110 ! always closed : we play only with the neigbours 3111 ! 3112 IF( nbondj /= 2 ) THEN ! Read Dirichlet lateral conditions 3113 ijhom = nlcj-nrecj-jprj 3114 DO jl = 1, iprecj 3115 r2dsn(:,jl,1) = pt2d(:,ijhom +jl) 3116 r2dns(:,jl,1) = pt2d(:,jprecj+jl) 3117 END DO 3118 ENDIF 3119 ! 3120 ! ! Migrations 3121 imigr = iprecj * ( jpi + 2*jpri ) 3122 ! 3123 SELECT CASE ( nbondj ) 3124 CASE ( -1 ) 3125 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req1 ) 3126 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 3127 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3128 CASE ( 0 ) 3129 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 3130 CALL mppsend( 4, r2dsn(1-jpri,1,1), imigr, nono, ml_req2 ) 3131 CALL mpprecv( 3, r2dns(1-jpri,1,2), imigr, nono ) 3132 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 3133 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3134 IF(l_isend) CALL mpi_wait(ml_req2,ml_stat,ml_err) 3135 CASE ( 1 ) 3136 CALL mppsend( 3, r2dns(1-jpri,1,1), imigr, noso, ml_req1 ) 3137 CALL mpprecv( 4, r2dsn(1-jpri,1,2), imigr, noso ) 3138 IF(l_isend) CALL mpi_wait(ml_req1,ml_stat,ml_err) 3139 END SELECT 3140 ! 3141 ! ! Write Dirichlet lateral conditions 3142 ijhom = nlcj - jprecj 3143 ! 3144 SELECT CASE ( nbondj ) 3145 CASE ( -1 ) 3146 DO jl = 1, iprecj 3147 pt2d(:,ijhom+jl) = r2dns(:,jl,2) 3148 END DO 3149 CASE ( 0 ) 3150 DO jl = 1, iprecj 3151 pt2d(:,jl-jprj) = r2dsn(:,jl,2) 3152 pt2d(:,ijhom+jl ) = r2dns(:,jl,2) 3153 END DO 3154 CASE ( 1 ) 3155 DO jl = 1, iprecj 3156 pt2d(:,jl-jprj) = r2dsn(:,jl,2) 3157 END DO 3158 END SELECT 3159 3160 END SUBROUTINE mpp_lnk_2d_icb 2893 3161 #else 2894 3162 !!----------------------------------------------------------------------
Note: See TracChangeset
for help on using the changeset viewer.
