[3614] | 1 | MODULE icblbc |
---|
| 2 | !!====================================================================== |
---|
| 3 | !! *** MODULE icblbc *** |
---|
| 4 | !! Ocean physics: routines to handle boundary exchanges for icebergs |
---|
| 5 | !!====================================================================== |
---|
[9190] | 6 | !! History : 3.3 ! 2010-01 (Martin&Adcroft) Original code |
---|
| 7 | !! - ! 2011-03 (Madec) Part conversion to NEMO form |
---|
| 8 | !! - ! Removal of mapping from another grid |
---|
| 9 | !! - ! 2011-04 (Alderson) Split into separate modules |
---|
| 10 | !! - ! 2011-05 (Alderson) MPP exchanges written based on lib_mpp |
---|
| 11 | !! - ! 2011-05 (Alderson) MPP and single processor boundary conditions added |
---|
[3614] | 12 | !!---------------------------------------------------------------------- |
---|
[9190] | 13 | |
---|
[3614] | 14 | !!---------------------------------------------------------------------- |
---|
| 15 | !! icb_lbc : - Pass icebergs across cyclic boundaries |
---|
| 16 | !! icb_lbc_mpp : - In MPP pass icebergs from linked list between processors |
---|
| 17 | !! as they advect around |
---|
| 18 | !! - Lagrangian processes cannot be handled by existing NEMO MPP |
---|
| 19 | !! routines because they do not lie on regular jpi,jpj grids |
---|
| 20 | !! - Processor exchanges are handled as in lib_mpp whenever icebergs step |
---|
| 21 | !! across boundary of interior domain (nicbdi-nicbei, nicbdj-nicbej) |
---|
| 22 | !! so that iceberg does not exist in more than one processor |
---|
| 23 | !! - North fold exchanges controlled by three arrays: |
---|
| 24 | !! nicbflddest - unique processor numbers that current one exchanges with |
---|
| 25 | !! nicbfldproc - processor number that current grid point exchanges with |
---|
| 26 | !! nicbfldpts - packed i,j point in exchanging processor |
---|
| 27 | !!---------------------------------------------------------------------- |
---|
| 28 | USE par_oce ! ocean parameters |
---|
| 29 | USE dom_oce ! ocean domain |
---|
| 30 | USE in_out_manager ! IO parameters |
---|
| 31 | USE lib_mpp ! MPI code and lk_mpp in particular |
---|
| 32 | USE icb_oce ! define iceberg arrays |
---|
| 33 | USE icbutl ! iceberg utility routines |
---|
| 34 | |
---|
| 35 | IMPLICIT NONE |
---|
| 36 | PRIVATE |
---|
| 37 | |
---|
| 38 | #if defined key_mpp_mpi |
---|
| 39 | |
---|
| 40 | !$AGRIF_DO_NOT_TREAT |
---|
| 41 | INCLUDE 'mpif.h' |
---|
| 42 | !$AGRIF_END_DO_NOT_TREAT |
---|
| 43 | |
---|
| 44 | TYPE, PUBLIC :: buffer |
---|
[9190] | 45 | INTEGER :: size = 0 |
---|
| 46 | REAL(wp), DIMENSION(:,:), POINTER :: data |
---|
[3614] | 47 | END TYPE buffer |
---|
| 48 | |
---|
[9190] | 49 | TYPE(buffer), POINTER :: obuffer_n=>NULL() , ibuffer_n=>NULL() |
---|
| 50 | TYPE(buffer), POINTER :: obuffer_s=>NULL() , ibuffer_s=>NULL() |
---|
| 51 | TYPE(buffer), POINTER :: obuffer_e=>NULL() , ibuffer_e=>NULL() |
---|
| 52 | TYPE(buffer), POINTER :: obuffer_w=>NULL() , ibuffer_w=>NULL() |
---|
[3614] | 53 | |
---|
| 54 | ! north fold exchange buffers |
---|
[9190] | 55 | TYPE(buffer), POINTER :: obuffer_f=>NULL() , ibuffer_f=>NULL() |
---|
[3614] | 56 | |
---|
[9190] | 57 | INTEGER, PARAMETER, PRIVATE :: jp_delta_buf = 25 ! Size by which to increment buffers |
---|
| 58 | INTEGER, PARAMETER, PRIVATE :: jp_buffer_width = 15+nkounts ! items to store for each berg |
---|
[3614] | 59 | |
---|
| 60 | #endif |
---|
| 61 | |
---|
| 62 | PUBLIC icb_lbc |
---|
| 63 | PUBLIC icb_lbc_mpp |
---|
| 64 | |
---|
| 65 | !!---------------------------------------------------------------------- |
---|
[9598] | 66 | !! NEMO/OCE 4.0 , NEMO Consortium (2018) |
---|
[5215] | 67 | !! $Id$ |
---|
[10068] | 68 | !! Software governed by the CeCILL license (see ./LICENSE) |
---|
[3614] | 69 | !!---------------------------------------------------------------------- |
---|
| 70 | CONTAINS |
---|
| 71 | |
---|
| 72 | SUBROUTINE icb_lbc() |
---|
| 73 | !!---------------------------------------------------------------------- |
---|
| 74 | !! *** SUBROUTINE icb_lbc *** |
---|
| 75 | !! |
---|
| 76 | !! ** Purpose : in non-mpp case need to deal with cyclic conditions |
---|
| 77 | !! including north-fold |
---|
| 78 | !!---------------------------------------------------------------------- |
---|
| 79 | TYPE(iceberg), POINTER :: this |
---|
| 80 | TYPE(point) , POINTER :: pt |
---|
| 81 | INTEGER :: iine |
---|
| 82 | !!---------------------------------------------------------------------- |
---|
| 83 | |
---|
| 84 | !! periodic east/west boundaries |
---|
| 85 | !! ============================= |
---|
| 86 | |
---|
[9667] | 87 | IF( l_Iperio ) THEN |
---|
[3614] | 88 | |
---|
| 89 | this => first_berg |
---|
| 90 | DO WHILE( ASSOCIATED(this) ) |
---|
| 91 | pt => this%current_point |
---|
| 92 | iine = INT( pt%xi + 0.5 ) |
---|
| 93 | IF( iine > mig(nicbei) ) THEN |
---|
| 94 | pt%xi = ricb_right + MOD(pt%xi, 1._wp ) - 1._wp |
---|
| 95 | ELSE IF( iine < mig(nicbdi) ) THEN |
---|
| 96 | pt%xi = ricb_left + MOD(pt%xi, 1._wp ) |
---|
| 97 | ENDIF |
---|
| 98 | this => this%next |
---|
| 99 | END DO |
---|
| 100 | ! |
---|
| 101 | ENDIF |
---|
| 102 | |
---|
| 103 | !! north/south boundaries |
---|
| 104 | !! ====================== |
---|
[9667] | 105 | IF( l_Jperio) CALL ctl_stop(' north-south periodicity not implemented for icebergs') |
---|
[3614] | 106 | ! north fold |
---|
[9667] | 107 | IF( npolj /= 0 ) CALL icb_lbc_nfld() |
---|
[3614] | 108 | ! |
---|
| 109 | END SUBROUTINE icb_lbc |
---|
| 110 | |
---|
| 111 | |
---|
| 112 | SUBROUTINE icb_lbc_nfld() |
---|
| 113 | !!---------------------------------------------------------------------- |
---|
| 114 | !! *** SUBROUTINE icb_lbc_nfld *** |
---|
| 115 | !! |
---|
| 116 | !! ** Purpose : single processor north fold exchange |
---|
| 117 | !!---------------------------------------------------------------------- |
---|
| 118 | TYPE(iceberg), POINTER :: this |
---|
| 119 | TYPE(point) , POINTER :: pt |
---|
| 120 | INTEGER :: iine, ijne, ipts |
---|
| 121 | INTEGER :: iiglo, ijglo |
---|
| 122 | !!---------------------------------------------------------------------- |
---|
| 123 | ! |
---|
| 124 | this => first_berg |
---|
| 125 | DO WHILE( ASSOCIATED(this) ) |
---|
| 126 | pt => this%current_point |
---|
| 127 | ijne = INT( pt%yj + 0.5 ) |
---|
| 128 | IF( ijne .GT. mjg(nicbej) ) THEN |
---|
| 129 | ! |
---|
| 130 | iine = INT( pt%xi + 0.5 ) |
---|
| 131 | ipts = nicbfldpts (mi1(iine)) |
---|
| 132 | ! |
---|
| 133 | ! moving across the cut line means both position and |
---|
| 134 | ! velocity must change |
---|
| 135 | ijglo = INT( ipts/nicbpack ) |
---|
| 136 | iiglo = ipts - nicbpack*ijglo |
---|
| 137 | pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) |
---|
| 138 | pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) |
---|
| 139 | pt%uvel = -1._wp * pt%uvel |
---|
| 140 | pt%vvel = -1._wp * pt%vvel |
---|
| 141 | ENDIF |
---|
| 142 | this => this%next |
---|
| 143 | END DO |
---|
| 144 | ! |
---|
| 145 | END SUBROUTINE icb_lbc_nfld |
---|
| 146 | |
---|
| 147 | #if defined key_mpp_mpi |
---|
| 148 | !!---------------------------------------------------------------------- |
---|
| 149 | !! 'key_mpp_mpi' MPI massively parallel processing library |
---|
| 150 | !!---------------------------------------------------------------------- |
---|
| 151 | |
---|
| 152 | SUBROUTINE icb_lbc_mpp() |
---|
| 153 | !!---------------------------------------------------------------------- |
---|
| 154 | !! *** SUBROUTINE icb_lbc_mpp *** |
---|
| 155 | !! |
---|
| 156 | !! ** Purpose : multi processor exchange |
---|
| 157 | !! |
---|
| 158 | !! ** Method : identify direction for exchange, pack into a buffer |
---|
| 159 | !! which is basically a real array and delete from linked list |
---|
| 160 | !! length of buffer is exchanged first with receiving processor |
---|
| 161 | !! then buffer is sent if necessary |
---|
| 162 | !!---------------------------------------------------------------------- |
---|
| 163 | TYPE(iceberg) , POINTER :: tmpberg, this |
---|
| 164 | TYPE(point) , POINTER :: pt |
---|
| 165 | INTEGER :: ibergs_to_send_e, ibergs_to_send_w |
---|
| 166 | INTEGER :: ibergs_to_send_n, ibergs_to_send_s |
---|
| 167 | INTEGER :: ibergs_rcvd_from_e, ibergs_rcvd_from_w |
---|
| 168 | INTEGER :: ibergs_rcvd_from_n, ibergs_rcvd_from_s |
---|
| 169 | INTEGER :: i, ibergs_start, ibergs_end |
---|
| 170 | INTEGER :: iine, ijne |
---|
| 171 | INTEGER :: ipe_N, ipe_S, ipe_W, ipe_E |
---|
| 172 | REAL(wp), DIMENSION(2) :: zewbergs, zwebergs, znsbergs, zsnbergs |
---|
| 173 | INTEGER :: iml_req1, iml_req2, iml_req3, iml_req4 |
---|
| 174 | INTEGER :: iml_req5, iml_req6, iml_req7, iml_req8, iml_err |
---|
| 175 | INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat |
---|
| 176 | |
---|
| 177 | ! set up indices of neighbouring processors |
---|
| 178 | ipe_N = -1 |
---|
| 179 | ipe_S = -1 |
---|
| 180 | ipe_W = -1 |
---|
| 181 | ipe_E = -1 |
---|
| 182 | IF( nbondi .EQ. 0 .OR. nbondi .EQ. 1) ipe_W = nowe |
---|
| 183 | IF( nbondi .EQ. -1 .OR. nbondi .EQ. 0) ipe_E = noea |
---|
| 184 | IF( nbondj .EQ. 0 .OR. nbondj .EQ. 1) ipe_S = noso |
---|
| 185 | IF( nbondj .EQ. -1 .OR. nbondj .EQ. 0) ipe_N = nono |
---|
| 186 | ! |
---|
| 187 | ! at northern line of processors with north fold handle bergs differently |
---|
| 188 | IF( npolj > 0 ) ipe_N = -1 |
---|
| 189 | |
---|
| 190 | ! if there's only one processor in x direction then don't let mpp try to handle periodicity |
---|
| 191 | IF( jpni == 1 ) THEN |
---|
| 192 | ipe_E = -1 |
---|
| 193 | ipe_W = -1 |
---|
| 194 | ENDIF |
---|
| 195 | |
---|
| 196 | IF( nn_verbose_level >= 2 ) THEN |
---|
| 197 | WRITE(numicb,*) 'processor west : ', ipe_W |
---|
| 198 | WRITE(numicb,*) 'processor east : ', ipe_E |
---|
| 199 | WRITE(numicb,*) 'processor north : ', ipe_N |
---|
| 200 | WRITE(numicb,*) 'processor south : ', ipe_S |
---|
| 201 | WRITE(numicb,*) 'processor nimpp : ', nimpp |
---|
| 202 | WRITE(numicb,*) 'processor njmpp : ', njmpp |
---|
| 203 | WRITE(numicb,*) 'processor nbondi: ', nbondi |
---|
| 204 | WRITE(numicb,*) 'processor nbondj: ', nbondj |
---|
| 205 | CALL flush( numicb ) |
---|
| 206 | ENDIF |
---|
| 207 | |
---|
| 208 | ! periodicity is handled here when using mpp when there is more than one processor in |
---|
| 209 | ! the i direction, but it also has to happen when jpni=1 case so this is dealt with |
---|
| 210 | ! in icb_lbc and called here |
---|
| 211 | |
---|
| 212 | IF( jpni == 1 ) CALL icb_lbc() |
---|
| 213 | |
---|
| 214 | ! Note that xi is adjusted when swapping because of periodic condition |
---|
| 215 | |
---|
| 216 | IF( nn_verbose_level > 0 ) THEN |
---|
| 217 | ! store the number of icebergs on this processor at start |
---|
| 218 | ibergs_start = icb_utl_count() |
---|
| 219 | ENDIF |
---|
| 220 | |
---|
| 221 | ibergs_to_send_e = 0 |
---|
| 222 | ibergs_to_send_w = 0 |
---|
| 223 | ibergs_to_send_n = 0 |
---|
| 224 | ibergs_to_send_s = 0 |
---|
| 225 | ibergs_rcvd_from_e = 0 |
---|
| 226 | ibergs_rcvd_from_w = 0 |
---|
| 227 | ibergs_rcvd_from_n = 0 |
---|
| 228 | ibergs_rcvd_from_s = 0 |
---|
| 229 | |
---|
| 230 | IF( ASSOCIATED(first_berg) ) THEN ! Find number of bergs that headed east/west |
---|
| 231 | this => first_berg |
---|
| 232 | DO WHILE (ASSOCIATED(this)) |
---|
| 233 | pt => this%current_point |
---|
| 234 | iine = INT( pt%xi + 0.5 ) |
---|
| 235 | IF( ipe_E >= 0 .AND. iine > mig(nicbei) ) THEN |
---|
| 236 | tmpberg => this |
---|
| 237 | this => this%next |
---|
| 238 | ibergs_to_send_e = ibergs_to_send_e + 1 |
---|
| 239 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 240 | WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to east' |
---|
| 241 | CALL flush( numicb ) |
---|
| 242 | ENDIF |
---|
| 243 | ! deal with periodic case |
---|
| 244 | tmpberg%current_point%xi = ricb_right + MOD(tmpberg%current_point%xi, 1._wp ) - 1._wp |
---|
| 245 | ! now pack it into buffer and delete from list |
---|
| 246 | CALL icb_pack_into_buffer( tmpberg, obuffer_e, ibergs_to_send_e) |
---|
| 247 | CALL icb_utl_delete(first_berg, tmpberg) |
---|
| 248 | ELSE IF( ipe_W >= 0 .AND. iine < mig(nicbdi) ) THEN |
---|
| 249 | tmpberg => this |
---|
| 250 | this => this%next |
---|
| 251 | ibergs_to_send_w = ibergs_to_send_w + 1 |
---|
| 252 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 253 | WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to west' |
---|
| 254 | CALL flush( numicb ) |
---|
| 255 | ENDIF |
---|
| 256 | ! deal with periodic case |
---|
| 257 | tmpberg%current_point%xi = ricb_left + MOD(tmpberg%current_point%xi, 1._wp ) |
---|
| 258 | ! now pack it into buffer and delete from list |
---|
| 259 | CALL icb_pack_into_buffer( tmpberg, obuffer_w, ibergs_to_send_w) |
---|
| 260 | CALL icb_utl_delete(first_berg, tmpberg) |
---|
| 261 | ELSE |
---|
| 262 | this => this%next |
---|
| 263 | ENDIF |
---|
| 264 | END DO |
---|
| 265 | ENDIF |
---|
| 266 | IF( nn_verbose_level >= 3) THEN |
---|
| 267 | WRITE(numicb,*) 'bergstep ',nktberg,' send ew: ', ibergs_to_send_e, ibergs_to_send_w |
---|
| 268 | CALL flush(numicb) |
---|
| 269 | ENDIF |
---|
| 270 | |
---|
| 271 | ! send bergs east and receive bergs from west (ie ones that were sent east) and vice versa |
---|
| 272 | |
---|
| 273 | ! pattern here is copied from lib_mpp code |
---|
| 274 | |
---|
| 275 | SELECT CASE ( nbondi ) |
---|
| 276 | CASE( -1 ) |
---|
| 277 | zwebergs(1) = ibergs_to_send_e |
---|
| 278 | CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req1) |
---|
[4990] | 279 | CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) |
---|
[3614] | 280 | IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) |
---|
| 281 | ibergs_rcvd_from_e = INT( zewbergs(2) ) |
---|
| 282 | CASE( 0 ) |
---|
| 283 | zewbergs(1) = ibergs_to_send_w |
---|
| 284 | zwebergs(1) = ibergs_to_send_e |
---|
| 285 | CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req2) |
---|
| 286 | CALL mppsend( 12, zwebergs(1), 1, ipe_E, iml_req3) |
---|
[4990] | 287 | CALL mpprecv( 11, zewbergs(2), 1, ipe_E ) |
---|
| 288 | CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) |
---|
[3614] | 289 | IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) |
---|
| 290 | IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) |
---|
| 291 | ibergs_rcvd_from_e = INT( zewbergs(2) ) |
---|
| 292 | ibergs_rcvd_from_w = INT( zwebergs(2) ) |
---|
| 293 | CASE( 1 ) |
---|
| 294 | zewbergs(1) = ibergs_to_send_w |
---|
| 295 | CALL mppsend( 11, zewbergs(1), 1, ipe_W, iml_req4) |
---|
[4990] | 296 | CALL mpprecv( 12, zwebergs(2), 1, ipe_W ) |
---|
[3614] | 297 | IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) |
---|
| 298 | ibergs_rcvd_from_w = INT( zwebergs(2) ) |
---|
| 299 | END SELECT |
---|
| 300 | IF( nn_verbose_level >= 3) THEN |
---|
| 301 | WRITE(numicb,*) 'bergstep ',nktberg,' recv ew: ', ibergs_rcvd_from_w, ibergs_rcvd_from_e |
---|
| 302 | CALL flush(numicb) |
---|
| 303 | ENDIF |
---|
| 304 | |
---|
| 305 | SELECT CASE ( nbondi ) |
---|
| 306 | CASE( -1 ) |
---|
| 307 | IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req1 ) |
---|
| 308 | IF( ibergs_rcvd_from_e > 0 ) THEN |
---|
| 309 | CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) |
---|
| 310 | CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) |
---|
| 311 | ENDIF |
---|
| 312 | IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) |
---|
| 313 | DO i = 1, ibergs_rcvd_from_e |
---|
| 314 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 315 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' |
---|
| 316 | CALL flush( numicb ) |
---|
| 317 | ENDIF |
---|
| 318 | CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) |
---|
| 319 | ENDDO |
---|
| 320 | CASE( 0 ) |
---|
| 321 | IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req2 ) |
---|
| 322 | IF( ibergs_to_send_e > 0 ) CALL mppsend( 14, obuffer_e%data, ibergs_to_send_e*jp_buffer_width, ipe_E, iml_req3 ) |
---|
| 323 | IF( ibergs_rcvd_from_e > 0 ) THEN |
---|
| 324 | CALL icb_increase_ibuffer(ibuffer_e, ibergs_rcvd_from_e) |
---|
| 325 | CALL mpprecv( 13, ibuffer_e%data, ibergs_rcvd_from_e*jp_buffer_width ) |
---|
| 326 | ENDIF |
---|
| 327 | IF( ibergs_rcvd_from_w > 0 ) THEN |
---|
| 328 | CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) |
---|
| 329 | CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) |
---|
| 330 | ENDIF |
---|
| 331 | IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) |
---|
| 332 | IF( ibergs_to_send_e > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) |
---|
| 333 | DO i = 1, ibergs_rcvd_from_e |
---|
| 334 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 335 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_e%data(16,i)),' from east' |
---|
| 336 | CALL flush( numicb ) |
---|
| 337 | ENDIF |
---|
| 338 | CALL icb_unpack_from_buffer(first_berg, ibuffer_e, i) |
---|
| 339 | END DO |
---|
| 340 | DO i = 1, ibergs_rcvd_from_w |
---|
| 341 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 342 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' |
---|
| 343 | CALL flush( numicb ) |
---|
| 344 | ENDIF |
---|
| 345 | CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) |
---|
| 346 | ENDDO |
---|
| 347 | CASE( 1 ) |
---|
| 348 | IF( ibergs_to_send_w > 0 ) CALL mppsend( 13, obuffer_w%data, ibergs_to_send_w*jp_buffer_width, ipe_W, iml_req4 ) |
---|
| 349 | IF( ibergs_rcvd_from_w > 0 ) THEN |
---|
| 350 | CALL icb_increase_ibuffer(ibuffer_w, ibergs_rcvd_from_w) |
---|
| 351 | CALL mpprecv( 14, ibuffer_w%data, ibergs_rcvd_from_w*jp_buffer_width ) |
---|
| 352 | ENDIF |
---|
| 353 | IF( ibergs_to_send_w > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) |
---|
| 354 | DO i = 1, ibergs_rcvd_from_w |
---|
| 355 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 356 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_w%data(16,i)),' from west' |
---|
| 357 | CALL flush( numicb ) |
---|
| 358 | ENDIF |
---|
| 359 | CALL icb_unpack_from_buffer(first_berg, ibuffer_w, i) |
---|
| 360 | END DO |
---|
| 361 | END SELECT |
---|
| 362 | |
---|
| 363 | ! Find number of bergs that headed north/south |
---|
| 364 | ! (note: this block should technically go ahead of the E/W recv block above |
---|
| 365 | ! to handle arbitrary orientation of PEs. But for simplicity, it is |
---|
| 366 | ! here to accomodate diagonal transfer of bergs between PEs -AJA) |
---|
| 367 | |
---|
| 368 | IF( ASSOCIATED(first_berg) ) THEN |
---|
| 369 | this => first_berg |
---|
| 370 | DO WHILE (ASSOCIATED(this)) |
---|
| 371 | pt => this%current_point |
---|
| 372 | ijne = INT( pt%yj + 0.5 ) |
---|
| 373 | IF( ipe_N >= 0 .AND. ijne .GT. mjg(nicbej) ) THEN |
---|
| 374 | tmpberg => this |
---|
| 375 | this => this%next |
---|
| 376 | ibergs_to_send_n = ibergs_to_send_n + 1 |
---|
| 377 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 378 | WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to north' |
---|
| 379 | CALL flush( numicb ) |
---|
| 380 | ENDIF |
---|
| 381 | CALL icb_pack_into_buffer( tmpberg, obuffer_n, ibergs_to_send_n) |
---|
| 382 | CALL icb_utl_delete(first_berg, tmpberg) |
---|
| 383 | ELSE IF( ipe_S >= 0 .AND. ijne .LT. mjg(nicbdj) ) THEN |
---|
| 384 | tmpberg => this |
---|
| 385 | this => this%next |
---|
| 386 | ibergs_to_send_s = ibergs_to_send_s + 1 |
---|
| 387 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 388 | WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for transfer to south' |
---|
| 389 | CALL flush( numicb ) |
---|
| 390 | ENDIF |
---|
| 391 | CALL icb_pack_into_buffer( tmpberg, obuffer_s, ibergs_to_send_s) |
---|
| 392 | CALL icb_utl_delete(first_berg, tmpberg) |
---|
| 393 | ELSE |
---|
| 394 | this => this%next |
---|
| 395 | ENDIF |
---|
| 396 | END DO |
---|
| 397 | ENDIF |
---|
| 398 | if( nn_verbose_level >= 3) then |
---|
| 399 | write(numicb,*) 'bergstep ',nktberg,' send ns: ', ibergs_to_send_n, ibergs_to_send_s |
---|
| 400 | call flush(numicb) |
---|
| 401 | endif |
---|
| 402 | |
---|
| 403 | ! send bergs north |
---|
| 404 | ! and receive bergs from south (ie ones sent north) |
---|
| 405 | |
---|
| 406 | SELECT CASE ( nbondj ) |
---|
| 407 | CASE( -1 ) |
---|
| 408 | zsnbergs(1) = ibergs_to_send_n |
---|
| 409 | CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req1) |
---|
[4990] | 410 | CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) |
---|
[3614] | 411 | IF( l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) |
---|
| 412 | ibergs_rcvd_from_n = INT( znsbergs(2) ) |
---|
| 413 | CASE( 0 ) |
---|
| 414 | znsbergs(1) = ibergs_to_send_s |
---|
| 415 | zsnbergs(1) = ibergs_to_send_n |
---|
| 416 | CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req2) |
---|
| 417 | CALL mppsend( 16, zsnbergs(1), 1, ipe_N, iml_req3) |
---|
[4990] | 418 | CALL mpprecv( 15, znsbergs(2), 1, ipe_N ) |
---|
| 419 | CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) |
---|
[3614] | 420 | IF( l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) |
---|
| 421 | IF( l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) |
---|
| 422 | ibergs_rcvd_from_n = INT( znsbergs(2) ) |
---|
| 423 | ibergs_rcvd_from_s = INT( zsnbergs(2) ) |
---|
| 424 | CASE( 1 ) |
---|
| 425 | znsbergs(1) = ibergs_to_send_s |
---|
| 426 | CALL mppsend( 15, znsbergs(1), 1, ipe_S, iml_req4) |
---|
[4990] | 427 | CALL mpprecv( 16, zsnbergs(2), 1, ipe_S ) |
---|
[3614] | 428 | IF( l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) |
---|
| 429 | ibergs_rcvd_from_s = INT( zsnbergs(2) ) |
---|
| 430 | END SELECT |
---|
| 431 | if( nn_verbose_level >= 3) then |
---|
| 432 | write(numicb,*) 'bergstep ',nktberg,' recv ns: ', ibergs_rcvd_from_s, ibergs_rcvd_from_n |
---|
| 433 | call flush(numicb) |
---|
| 434 | endif |
---|
| 435 | |
---|
| 436 | SELECT CASE ( nbondj ) |
---|
| 437 | CASE( -1 ) |
---|
| 438 | IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req1 ) |
---|
| 439 | IF( ibergs_rcvd_from_n > 0 ) THEN |
---|
| 440 | CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) |
---|
| 441 | CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) |
---|
| 442 | ENDIF |
---|
| 443 | IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req1, iml_stat, iml_err ) |
---|
| 444 | DO i = 1, ibergs_rcvd_from_n |
---|
| 445 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 446 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' |
---|
| 447 | CALL flush( numicb ) |
---|
| 448 | ENDIF |
---|
| 449 | CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) |
---|
| 450 | END DO |
---|
| 451 | CASE( 0 ) |
---|
| 452 | IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req2 ) |
---|
| 453 | IF( ibergs_to_send_n > 0 ) CALL mppsend( 18, obuffer_n%data, ibergs_to_send_n*jp_buffer_width, ipe_N, iml_req3 ) |
---|
| 454 | IF( ibergs_rcvd_from_n > 0 ) THEN |
---|
| 455 | CALL icb_increase_ibuffer(ibuffer_n, ibergs_rcvd_from_n) |
---|
| 456 | CALL mpprecv( 17, ibuffer_n%data, ibergs_rcvd_from_n*jp_buffer_width ) |
---|
| 457 | ENDIF |
---|
| 458 | IF( ibergs_rcvd_from_s > 0 ) THEN |
---|
| 459 | CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) |
---|
| 460 | CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) |
---|
| 461 | ENDIF |
---|
| 462 | IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req2, iml_stat, iml_err ) |
---|
| 463 | IF( ibergs_to_send_n > 0 .AND. l_isend ) CALL mpi_wait( iml_req3, iml_stat, iml_err ) |
---|
| 464 | DO i = 1, ibergs_rcvd_from_n |
---|
| 465 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 466 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_n%data(16,i)),' from north' |
---|
| 467 | CALL flush( numicb ) |
---|
| 468 | ENDIF |
---|
| 469 | CALL icb_unpack_from_buffer(first_berg, ibuffer_n, i) |
---|
| 470 | END DO |
---|
| 471 | DO i = 1, ibergs_rcvd_from_s |
---|
| 472 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 473 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' |
---|
| 474 | CALL flush( numicb ) |
---|
| 475 | ENDIF |
---|
| 476 | CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) |
---|
| 477 | ENDDO |
---|
| 478 | CASE( 1 ) |
---|
| 479 | IF( ibergs_to_send_s > 0 ) CALL mppsend( 17, obuffer_s%data, ibergs_to_send_s*jp_buffer_width, ipe_S, iml_req4 ) |
---|
| 480 | IF( ibergs_rcvd_from_s > 0 ) THEN |
---|
| 481 | CALL icb_increase_ibuffer(ibuffer_s, ibergs_rcvd_from_s) |
---|
| 482 | CALL mpprecv( 18, ibuffer_s%data, ibergs_rcvd_from_s*jp_buffer_width ) |
---|
| 483 | ENDIF |
---|
| 484 | IF( ibergs_to_send_s > 0 .AND. l_isend ) CALL mpi_wait( iml_req4, iml_stat, iml_err ) |
---|
| 485 | DO i = 1, ibergs_rcvd_from_s |
---|
| 486 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 487 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_s%data(16,i)),' from south' |
---|
| 488 | CALL flush( numicb ) |
---|
| 489 | ENDIF |
---|
| 490 | CALL icb_unpack_from_buffer(first_berg, ibuffer_s, i) |
---|
| 491 | END DO |
---|
| 492 | END SELECT |
---|
| 493 | |
---|
| 494 | IF( nn_verbose_level > 0 ) THEN |
---|
| 495 | ! compare the number of icebergs on this processor from the start to the end |
---|
| 496 | ibergs_end = icb_utl_count() |
---|
| 497 | i = ( ibergs_rcvd_from_n + ibergs_rcvd_from_s + ibergs_rcvd_from_e + ibergs_rcvd_from_w ) - & |
---|
| 498 | ( ibergs_to_send_n + ibergs_to_send_s + ibergs_to_send_e + ibergs_to_send_w ) |
---|
| 499 | IF( ibergs_end-(ibergs_start+i) .NE. 0 ) THEN |
---|
| 500 | WRITE( numicb,* ) 'send_bergs_to_other_pes: net change in number of icebergs' |
---|
| 501 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_end=', & |
---|
| 502 | ibergs_end,' on PE',narea |
---|
| 503 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_start=', & |
---|
| 504 | ibergs_start,' on PE',narea |
---|
| 505 | WRITE( numicb,1000) 'send_bergs_to_other_pes: delta=', & |
---|
| 506 | i,' on PE',narea |
---|
| 507 | WRITE( numicb,1000) 'send_bergs_to_other_pes: error=', & |
---|
| 508 | ibergs_end-(ibergs_start+i),' on PE',narea |
---|
| 509 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_n=', & |
---|
| 510 | ibergs_to_send_n,' on PE',narea |
---|
| 511 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_s=', & |
---|
| 512 | ibergs_to_send_s,' on PE',narea |
---|
| 513 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_e=', & |
---|
| 514 | ibergs_to_send_e,' on PE',narea |
---|
| 515 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_to_send_w=', & |
---|
| 516 | ibergs_to_send_w,' on PE',narea |
---|
| 517 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_n=', & |
---|
| 518 | ibergs_rcvd_from_n,' on PE',narea |
---|
| 519 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_s=', & |
---|
| 520 | ibergs_rcvd_from_s,' on PE',narea |
---|
| 521 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_e=', & |
---|
| 522 | ibergs_rcvd_from_e,' on PE',narea |
---|
| 523 | WRITE( numicb,1000) 'send_bergs_to_other_pes: ibergs_rcvd_from_w=', & |
---|
| 524 | ibergs_rcvd_from_w,' on PE',narea |
---|
| 525 | 1000 FORMAT(a,i5,a,i4) |
---|
| 526 | CALL ctl_stop('send_bergs_to_other_pes: lost or gained an iceberg or two') |
---|
| 527 | ENDIF |
---|
| 528 | ENDIF |
---|
| 529 | |
---|
| 530 | ! deal with north fold if we necessary when there is more than one top row processor |
---|
| 531 | ! note that for jpni=1 north fold has been dealt with above in call to icb_lbc |
---|
| 532 | IF( npolj /= 0 .AND. jpni > 1 ) CALL icb_lbc_mpp_nfld( ) |
---|
| 533 | |
---|
| 534 | IF( nn_verbose_level > 0 ) THEN |
---|
| 535 | i = 0 |
---|
| 536 | this => first_berg |
---|
| 537 | DO WHILE (ASSOCIATED(this)) |
---|
| 538 | pt => this%current_point |
---|
| 539 | iine = INT( pt%xi + 0.5 ) |
---|
| 540 | ijne = INT( pt%yj + 0.5 ) |
---|
| 541 | IF( iine .LT. mig(nicbdi) .OR. & |
---|
| 542 | iine .GT. mig(nicbei) .OR. & |
---|
| 543 | ijne .LT. mjg(nicbdj) .OR. & |
---|
| 544 | ijne .GT. mjg(nicbej)) THEN |
---|
| 545 | i = i + 1 |
---|
| 546 | WRITE(numicb,*) 'berg lost in halo: ', this%number(:),iine,ijne |
---|
| 547 | WRITE(numicb,*) ' ', nimpp, njmpp |
---|
| 548 | WRITE(numicb,*) ' ', nicbdi, nicbei, nicbdj, nicbej |
---|
| 549 | CALL flush( numicb ) |
---|
| 550 | ENDIF |
---|
| 551 | this => this%next |
---|
| 552 | ENDDO ! WHILE |
---|
[10425] | 553 | CALL mpp_sum('icblbc', i) |
---|
[3614] | 554 | IF( i .GT. 0 ) THEN |
---|
| 555 | WRITE( numicb,'(a,i4)') 'send_bergs_to_other_pes: # of bergs outside computational domain = ',i |
---|
| 556 | CALL ctl_stop('send_bergs_to_other_pes: there are bergs still in halos!') |
---|
| 557 | ENDIF ! root_pe |
---|
| 558 | ENDIF ! debug |
---|
| 559 | ! |
---|
| 560 | CALL mppsync() |
---|
| 561 | ! |
---|
| 562 | END SUBROUTINE icb_lbc_mpp |
---|
| 563 | |
---|
| 564 | |
---|
| 565 | SUBROUTINE icb_lbc_mpp_nfld() |
---|
| 566 | !!---------------------------------------------------------------------- |
---|
| 567 | !! *** SUBROUTINE icb_lbc_mpp_nfld *** |
---|
| 568 | !! |
---|
| 569 | !! ** Purpose : north fold treatment in multi processor exchange |
---|
| 570 | !! |
---|
| 571 | !! ** Method : |
---|
| 572 | !!---------------------------------------------------------------------- |
---|
| 573 | TYPE(iceberg) , POINTER :: tmpberg, this |
---|
| 574 | TYPE(point) , POINTER :: pt |
---|
| 575 | INTEGER :: ibergs_to_send |
---|
| 576 | INTEGER :: ibergs_to_rcv |
---|
| 577 | INTEGER :: iiglo, ijglo, jk, jn |
---|
| 578 | INTEGER :: ifldproc, iproc, ipts |
---|
| 579 | INTEGER :: iine, ijne |
---|
[4990] | 580 | INTEGER :: jjn |
---|
| 581 | REAL(wp), DIMENSION(0:3) :: zsbergs, znbergs |
---|
[3614] | 582 | INTEGER :: iml_req1, iml_req2, iml_err |
---|
| 583 | INTEGER, DIMENSION(MPI_STATUS_SIZE) :: iml_stat |
---|
| 584 | |
---|
| 585 | ! set up indices of neighbouring processors |
---|
| 586 | |
---|
| 587 | ! nicbfldproc is a list of unique processor numbers that this processor |
---|
| 588 | ! exchanges with (including itself), so we loop over this array; since |
---|
| 589 | ! its of fixed size, the first -1 marks end of list of processors |
---|
| 590 | ! |
---|
[4990] | 591 | nicbfldnsend(:) = 0 |
---|
| 592 | nicbfldexpect(:) = 0 |
---|
| 593 | nicbfldreq(:) = 0 |
---|
| 594 | ! |
---|
| 595 | ! Since each processor may be communicating with more than one northern |
---|
| 596 | ! neighbour, cycle through the sends so that the receive order can be |
---|
| 597 | ! controlled. |
---|
| 598 | ! |
---|
| 599 | ! First compute how many icebergs each active neighbour should expect |
---|
[3614] | 600 | DO jn = 1, jpni |
---|
| 601 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 602 | ifldproc = nicbfldproc(jn) |
---|
[4990] | 603 | nicbfldnsend(jn) = 0 |
---|
| 604 | |
---|
| 605 | ! Find number of bergs that need to be exchanged |
---|
| 606 | ! Pick out exchanges with processor ifldproc |
---|
| 607 | ! if ifldproc is this processor then don't send |
---|
| 608 | ! |
---|
| 609 | IF( ASSOCIATED(first_berg) ) THEN |
---|
| 610 | this => first_berg |
---|
| 611 | DO WHILE (ASSOCIATED(this)) |
---|
| 612 | pt => this%current_point |
---|
| 613 | iine = INT( pt%xi + 0.5 ) |
---|
| 614 | ijne = INT( pt%yj + 0.5 ) |
---|
| 615 | iproc = nicbflddest(mi1(iine)) |
---|
| 616 | IF( ijne .GT. mjg(nicbej) ) THEN |
---|
| 617 | IF( iproc == ifldproc ) THEN |
---|
| 618 | ! |
---|
| 619 | IF( iproc /= narea ) THEN |
---|
| 620 | tmpberg => this |
---|
| 621 | nicbfldnsend(jn) = nicbfldnsend(jn) + 1 |
---|
| 622 | ENDIF |
---|
| 623 | ! |
---|
| 624 | ENDIF |
---|
| 625 | ENDIF |
---|
| 626 | this => this%next |
---|
| 627 | END DO |
---|
| 628 | ENDIF |
---|
| 629 | ! |
---|
| 630 | ENDIF |
---|
| 631 | ! |
---|
| 632 | END DO |
---|
| 633 | ! |
---|
| 634 | ! Now tell each active neighbour how many icebergs to expect |
---|
| 635 | DO jn = 1, jpni |
---|
| 636 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 637 | ifldproc = nicbfldproc(jn) |
---|
| 638 | IF( ifldproc == narea ) CYCLE |
---|
| 639 | |
---|
| 640 | zsbergs(0) = narea |
---|
| 641 | zsbergs(1) = nicbfldnsend(jn) |
---|
[10570] | 642 | !IF ( nicbfldnsend(jn) .GT. 0 .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB sending ',nicbfldnsend(jn),' to ', ifldproc |
---|
[4990] | 643 | CALL mppsend( 21, zsbergs(0:1), 2, ifldproc-1, nicbfldreq(jn)) |
---|
| 644 | ENDIF |
---|
| 645 | ! |
---|
| 646 | END DO |
---|
| 647 | ! |
---|
| 648 | ! and receive the heads-up from active neighbours preparing to send |
---|
| 649 | DO jn = 1, jpni |
---|
| 650 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 651 | ifldproc = nicbfldproc(jn) |
---|
| 652 | IF( ifldproc == narea ) CYCLE |
---|
| 653 | |
---|
| 654 | CALL mpprecv( 21, znbergs(1:2), 2 ) |
---|
| 655 | DO jjn = 1,jpni |
---|
| 656 | IF( nicbfldproc(jjn) .eq. INT(znbergs(1)) ) EXIT |
---|
| 657 | END DO |
---|
[10570] | 658 | IF( jjn .GT. jpni .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB ERROR' |
---|
[4990] | 659 | nicbfldexpect(jjn) = INT( znbergs(2) ) |
---|
[10570] | 660 | !IF ( nicbfldexpect(jjn) .GT. 0 .AND. nn_verbose_level > 0 ) write(numicb,*) 'ICB expecting ',nicbfldexpect(jjn),' from ', nicbfldproc(jjn) |
---|
| 661 | !IF (nn_verbose_level > 0) CALL FLUSH(numicb) |
---|
[4990] | 662 | ENDIF |
---|
| 663 | ! |
---|
| 664 | END DO |
---|
| 665 | ! |
---|
| 666 | ! post the mpi waits if using immediate send protocol |
---|
| 667 | DO jn = 1, jpni |
---|
| 668 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 669 | ifldproc = nicbfldproc(jn) |
---|
| 670 | IF( ifldproc == narea ) CYCLE |
---|
| 671 | |
---|
| 672 | IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) |
---|
| 673 | ENDIF |
---|
| 674 | ! |
---|
| 675 | END DO |
---|
| 676 | |
---|
| 677 | ! |
---|
| 678 | ! Cycle through the icebergs again, this time packing and sending any |
---|
| 679 | ! going through the north fold. They will be expected. |
---|
| 680 | DO jn = 1, jpni |
---|
| 681 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 682 | ifldproc = nicbfldproc(jn) |
---|
[3614] | 683 | ibergs_to_send = 0 |
---|
| 684 | |
---|
| 685 | ! Find number of bergs that need to be exchanged |
---|
| 686 | ! Pick out exchanges with processor ifldproc |
---|
| 687 | ! if ifldproc is this processor then don't send |
---|
| 688 | ! |
---|
| 689 | IF( ASSOCIATED(first_berg) ) THEN |
---|
| 690 | this => first_berg |
---|
| 691 | DO WHILE (ASSOCIATED(this)) |
---|
| 692 | pt => this%current_point |
---|
| 693 | iine = INT( pt%xi + 0.5 ) |
---|
| 694 | ijne = INT( pt%yj + 0.5 ) |
---|
| 695 | ipts = nicbfldpts (mi1(iine)) |
---|
| 696 | iproc = nicbflddest(mi1(iine)) |
---|
| 697 | IF( ijne .GT. mjg(nicbej) ) THEN |
---|
| 698 | IF( iproc == ifldproc ) THEN |
---|
| 699 | ! |
---|
| 700 | ! moving across the cut line means both position and |
---|
| 701 | ! velocity must change |
---|
| 702 | ijglo = INT( ipts/nicbpack ) |
---|
| 703 | iiglo = ipts - nicbpack*ijglo |
---|
| 704 | pt%xi = iiglo - ( pt%xi - REAL(iine,wp) ) |
---|
| 705 | pt%yj = ijglo - ( pt%yj - REAL(ijne,wp) ) |
---|
| 706 | pt%uvel = -1._wp * pt%uvel |
---|
| 707 | pt%vvel = -1._wp * pt%vvel |
---|
| 708 | ! |
---|
| 709 | ! now remove berg from list and pack it into a buffer |
---|
| 710 | IF( iproc /= narea ) THEN |
---|
| 711 | tmpberg => this |
---|
| 712 | ibergs_to_send = ibergs_to_send + 1 |
---|
| 713 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 714 | WRITE(numicb,*) 'bergstep ',nktberg,' packing berg ',tmpberg%number(:),' for north fold' |
---|
| 715 | CALL flush( numicb ) |
---|
| 716 | ENDIF |
---|
| 717 | CALL icb_pack_into_buffer( tmpberg, obuffer_f, ibergs_to_send) |
---|
| 718 | CALL icb_utl_delete(first_berg, tmpberg) |
---|
| 719 | ENDIF |
---|
| 720 | ! |
---|
| 721 | ENDIF |
---|
| 722 | ENDIF |
---|
| 723 | this => this%next |
---|
| 724 | END DO |
---|
| 725 | ENDIF |
---|
| 726 | if( nn_verbose_level >= 3) then |
---|
| 727 | write(numicb,*) 'bergstep ',nktberg,' send nfld: ', ibergs_to_send |
---|
| 728 | call flush(numicb) |
---|
| 729 | endif |
---|
| 730 | ! |
---|
| 731 | ! if we're in this processor, then we've done everything we need to |
---|
| 732 | ! so go on to next element of loop |
---|
| 733 | IF( ifldproc == narea ) CYCLE |
---|
| 734 | |
---|
| 735 | ! send bergs |
---|
| 736 | |
---|
| 737 | IF( ibergs_to_send > 0 ) & |
---|
[4990] | 738 | CALL mppsend( 12, obuffer_f%data, ibergs_to_send*jp_buffer_width, ifldproc-1, nicbfldreq(jn) ) |
---|
| 739 | ! |
---|
| 740 | ENDIF |
---|
| 741 | ! |
---|
| 742 | END DO |
---|
| 743 | ! |
---|
| 744 | ! Now receive the expected number of bergs from the active neighbours |
---|
| 745 | DO jn = 1, jpni |
---|
| 746 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 747 | ifldproc = nicbfldproc(jn) |
---|
| 748 | IF( ifldproc == narea ) CYCLE |
---|
| 749 | ibergs_to_rcv = nicbfldexpect(jn) |
---|
| 750 | |
---|
[3614] | 751 | IF( ibergs_to_rcv > 0 ) THEN |
---|
| 752 | CALL icb_increase_ibuffer(ibuffer_f, ibergs_to_rcv) |
---|
[4990] | 753 | CALL mpprecv( 12, ibuffer_f%data, ibergs_to_rcv*jp_buffer_width, ifldproc-1 ) |
---|
[3614] | 754 | ENDIF |
---|
[4990] | 755 | ! |
---|
[3614] | 756 | DO jk = 1, ibergs_to_rcv |
---|
| 757 | IF( nn_verbose_level >= 4 ) THEN |
---|
| 758 | WRITE(numicb,*) 'bergstep ',nktberg,' unpacking berg ',INT(ibuffer_f%data(16,jk)),' from north fold' |
---|
| 759 | CALL flush( numicb ) |
---|
| 760 | ENDIF |
---|
| 761 | CALL icb_unpack_from_buffer(first_berg, ibuffer_f, jk ) |
---|
| 762 | END DO |
---|
| 763 | ENDIF |
---|
| 764 | ! |
---|
| 765 | END DO |
---|
| 766 | ! |
---|
[4990] | 767 | ! Finally post the mpi waits if using immediate send protocol |
---|
| 768 | DO jn = 1, jpni |
---|
| 769 | IF( nicbfldproc(jn) /= -1 ) THEN |
---|
| 770 | ifldproc = nicbfldproc(jn) |
---|
| 771 | IF( ifldproc == narea ) CYCLE |
---|
| 772 | |
---|
| 773 | IF( l_isend ) CALL mpi_wait( nicbfldreq(jn), iml_stat, iml_err ) |
---|
| 774 | ENDIF |
---|
| 775 | ! |
---|
| 776 | END DO |
---|
| 777 | ! |
---|
[3614] | 778 | END SUBROUTINE icb_lbc_mpp_nfld |
---|
| 779 | |
---|
| 780 | |
---|
| 781 | SUBROUTINE icb_pack_into_buffer( berg, pbuff, kb ) |
---|
| 782 | !!---------------------------------------------------------------------- |
---|
| 783 | !!---------------------------------------------------------------------- |
---|
| 784 | TYPE(iceberg), POINTER :: berg |
---|
| 785 | TYPE(buffer) , POINTER :: pbuff |
---|
| 786 | INTEGER , INTENT(in) :: kb |
---|
| 787 | ! |
---|
| 788 | INTEGER :: k ! local integer |
---|
| 789 | !!---------------------------------------------------------------------- |
---|
| 790 | ! |
---|
| 791 | IF( .NOT. ASSOCIATED(pbuff) ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) |
---|
| 792 | IF( kb .GT. pbuff%size ) CALL icb_increase_buffer( pbuff, jp_delta_buf ) |
---|
| 793 | |
---|
| 794 | !! pack points into buffer |
---|
| 795 | |
---|
| 796 | pbuff%data( 1,kb) = berg%current_point%lon |
---|
| 797 | pbuff%data( 2,kb) = berg%current_point%lat |
---|
| 798 | pbuff%data( 3,kb) = berg%current_point%uvel |
---|
| 799 | pbuff%data( 4,kb) = berg%current_point%vvel |
---|
| 800 | pbuff%data( 5,kb) = berg%current_point%xi |
---|
| 801 | pbuff%data( 6,kb) = berg%current_point%yj |
---|
| 802 | pbuff%data( 7,kb) = float(berg%current_point%year) |
---|
| 803 | pbuff%data( 8,kb) = berg%current_point%day |
---|
| 804 | pbuff%data( 9,kb) = berg%current_point%mass |
---|
| 805 | pbuff%data(10,kb) = berg%current_point%thickness |
---|
| 806 | pbuff%data(11,kb) = berg%current_point%width |
---|
| 807 | pbuff%data(12,kb) = berg%current_point%length |
---|
| 808 | pbuff%data(13,kb) = berg%current_point%mass_of_bits |
---|
| 809 | pbuff%data(14,kb) = berg%current_point%heat_density |
---|
| 810 | |
---|
| 811 | pbuff%data(15,kb) = berg%mass_scaling |
---|
| 812 | DO k=1,nkounts |
---|
| 813 | pbuff%data(15+k,kb) = REAL( berg%number(k), wp ) |
---|
| 814 | END DO |
---|
| 815 | ! |
---|
| 816 | END SUBROUTINE icb_pack_into_buffer |
---|
| 817 | |
---|
| 818 | |
---|
| 819 | SUBROUTINE icb_unpack_from_buffer(first, pbuff, kb) |
---|
| 820 | !!---------------------------------------------------------------------- |
---|
| 821 | !!---------------------------------------------------------------------- |
---|
| 822 | TYPE(iceberg), POINTER :: first |
---|
| 823 | TYPE(buffer) , POINTER :: pbuff |
---|
| 824 | INTEGER , INTENT(in) :: kb |
---|
| 825 | ! |
---|
| 826 | TYPE(iceberg) :: currentberg |
---|
| 827 | TYPE(point) :: pt |
---|
| 828 | INTEGER :: ik |
---|
| 829 | !!---------------------------------------------------------------------- |
---|
| 830 | ! |
---|
| 831 | pt%lon = pbuff%data( 1,kb) |
---|
| 832 | pt%lat = pbuff%data( 2,kb) |
---|
| 833 | pt%uvel = pbuff%data( 3,kb) |
---|
| 834 | pt%vvel = pbuff%data( 4,kb) |
---|
| 835 | pt%xi = pbuff%data( 5,kb) |
---|
| 836 | pt%yj = pbuff%data( 6,kb) |
---|
| 837 | pt%year = INT( pbuff%data( 7,kb) ) |
---|
| 838 | pt%day = pbuff%data( 8,kb) |
---|
| 839 | pt%mass = pbuff%data( 9,kb) |
---|
| 840 | pt%thickness = pbuff%data(10,kb) |
---|
| 841 | pt%width = pbuff%data(11,kb) |
---|
| 842 | pt%length = pbuff%data(12,kb) |
---|
| 843 | pt%mass_of_bits = pbuff%data(13,kb) |
---|
| 844 | pt%heat_density = pbuff%data(14,kb) |
---|
| 845 | |
---|
| 846 | currentberg%mass_scaling = pbuff%data(15,kb) |
---|
| 847 | DO ik = 1, nkounts |
---|
| 848 | currentberg%number(ik) = INT( pbuff%data(15+ik,kb) ) |
---|
| 849 | END DO |
---|
| 850 | ! |
---|
| 851 | CALL icb_utl_add(currentberg, pt ) |
---|
| 852 | ! |
---|
| 853 | END SUBROUTINE icb_unpack_from_buffer |
---|
| 854 | |
---|
| 855 | |
---|
| 856 | SUBROUTINE icb_increase_buffer(old,kdelta) |
---|
| 857 | !!---------------------------------------------------------------------- |
---|
| 858 | TYPE(buffer), POINTER :: old |
---|
| 859 | INTEGER , INTENT(in) :: kdelta |
---|
| 860 | ! |
---|
| 861 | TYPE(buffer), POINTER :: new |
---|
| 862 | INTEGER :: inew_size |
---|
| 863 | !!---------------------------------------------------------------------- |
---|
| 864 | ! |
---|
| 865 | IF( .NOT. ASSOCIATED(old) ) THEN ; inew_size = kdelta |
---|
| 866 | ELSE ; inew_size = old%size + kdelta |
---|
| 867 | ENDIF |
---|
| 868 | ALLOCATE( new ) |
---|
| 869 | ALLOCATE( new%data( jp_buffer_width, inew_size) ) |
---|
| 870 | new%size = inew_size |
---|
| 871 | IF( ASSOCIATED(old) ) THEN |
---|
| 872 | new%data(:,1:old%size) = old%data(:,1:old%size) |
---|
| 873 | DEALLOCATE(old%data) |
---|
| 874 | DEALLOCATE(old) |
---|
| 875 | ENDIF |
---|
| 876 | old => new |
---|
| 877 | ! |
---|
| 878 | END SUBROUTINE icb_increase_buffer |
---|
| 879 | |
---|
| 880 | |
---|
| 881 | SUBROUTINE icb_increase_ibuffer(old,kdelta) |
---|
| 882 | !!---------------------------------------------------------------------- |
---|
| 883 | !!---------------------------------------------------------------------- |
---|
| 884 | TYPE(buffer), POINTER :: old |
---|
| 885 | INTEGER , INTENT(in) :: kdelta |
---|
| 886 | ! |
---|
| 887 | TYPE(buffer), POINTER :: new |
---|
| 888 | INTEGER :: inew_size, iold_size |
---|
| 889 | !!---------------------------------------------------------------------- |
---|
| 890 | |
---|
| 891 | IF( .NOT. ASSOCIATED(old) ) THEN |
---|
| 892 | inew_size = kdelta + jp_delta_buf |
---|
| 893 | iold_size = 0 |
---|
| 894 | ELSE |
---|
| 895 | iold_size = old%size |
---|
| 896 | IF( kdelta .LT. old%size ) THEN |
---|
| 897 | inew_size = old%size + kdelta |
---|
| 898 | ELSE |
---|
| 899 | inew_size = kdelta + jp_delta_buf |
---|
| 900 | ENDIF |
---|
| 901 | ENDIF |
---|
| 902 | |
---|
| 903 | IF( iold_size .NE. inew_size ) THEN |
---|
| 904 | ALLOCATE( new ) |
---|
| 905 | ALLOCATE( new%data( jp_buffer_width, inew_size) ) |
---|
| 906 | new%size = inew_size |
---|
| 907 | IF( ASSOCIATED(old) ) THEN |
---|
| 908 | new%data(:,1:old%size) = old%data(:,1:old%size) |
---|
| 909 | DEALLOCATE(old%data) |
---|
| 910 | DEALLOCATE(old) |
---|
| 911 | ENDIF |
---|
| 912 | old => new |
---|
[10570] | 913 | !IF (nn_verbose_level > 0) WRITE( numicb,*) 'icb_increase_ibuffer',narea,' increased to',inew_size |
---|
[3614] | 914 | ENDIF |
---|
| 915 | ! |
---|
| 916 | END SUBROUTINE icb_increase_ibuffer |
---|
| 917 | |
---|
| 918 | #else |
---|
| 919 | !!---------------------------------------------------------------------- |
---|
| 920 | !! Default case: Dummy module share memory computing |
---|
| 921 | !!---------------------------------------------------------------------- |
---|
| 922 | SUBROUTINE icb_lbc_mpp() |
---|
| 923 | WRITE(numout,*) 'icb_lbc_mpp: You should not have seen this message!!' |
---|
| 924 | END SUBROUTINE icb_lbc_mpp |
---|
| 925 | #endif |
---|
| 926 | |
---|
| 927 | !!====================================================================== |
---|
| 928 | END MODULE icblbc |
---|