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