SUBROUTINE STASH_GATHER_FIELD ( 7,6STGFLD1A.24
& LOCAL_FIELD , GLOBAL_FIELD , STGFLD1A.25
& LOCAL_SIZE, GLOBAL_SIZE, LEVELS, STGFLD1A.26
& GLOBAL_NORTH , GLOBAL_EAST_IN , GLOBAL_SOUTH , GLOBAL_WEST, GPB0F403.3252
& GRIDTYPE_CODE , GPB0F403.3253
& GATHER_PE, STGFLD1A.29
& DATA_EXTRACTED , GPB0F403.3254
& ICODE, CMESSAGE) STGFLD1A.31
STGFLD1A.32
IMPLICIT NONE STGFLD1A.33
STGFLD1A.34
! Description: STGFLD1A.35
! Takes a decomposed, STASH processed field and gathers STGFLD1A.36
! it to a single processor, ready for I/O, STGFLD1A.37
! STGFLD1A.38
! Method: STGFLD1A.39
! See in-line documentation STGFLD1A.40
! STGFLD1A.41
! Current code owner : P.Burton STGFLD1A.42
! STGFLD1A.43
! History: STGFLD1A.44
! Model Date Modification history from model version 4.2 STGFLD1A.45
! version STGFLD1A.46
! 4.2 17/09/96 New DECK created for MPP version of STASH STGFLD1A.47
! P.Burton STGFLD1A.48
! 4.3 13/03/97 Recoded version P.Burton GPB0F403.3255
! 4.3 13/06/97 More robust handling of zonal fields P.Burton GPB0F404.310
! Fix for global_start_row P.Burton GPB0F404.311
! STGFLD1A.49
! Subroutine arguments: STGFLD1A.50
STGFLD1A.51
INTEGER STGFLD1A.52
& LOCAL_SIZE ! IN: size of level of LOCAL_FIELD STGFLD1A.53
&, GLOBAL_SIZE ! IN: size of level of GLOBAL_FIELD STGFLD1A.54
&, LEVELS ! IN: number of levels STGFLD1A.55
&, GLOBAL_NORTH ! IN: specification of subdomain boundaries STGFLD1A.56
&, GLOBAL_EAST_IN ! IN: "" GPB0F403.3256
&, GLOBAL_SOUTH ! IN: "" STGFLD1A.58
&, GLOBAL_WEST ! IN: "" STGFLD1A.59
&, GRIDTYPE_CODE ! IN: indicates the type of grid output STGFLD1A.60
&, GATHER_PE ! IN: the PE to gather the global field to STGFLD1A.63
&, ICODE ! OUT: return code, 0=OK STGFLD1A.64
STGFLD1A.65
LOGICAL STGFLD1A.66
& DATA_EXTRACTED ! IN: TRUE if the data in LOCAL_FIELD has GPB0F403.3257
! ! already been extracted, or FASLE if GPB0F403.3258
! ! the extraction must be done here. GPB0F403.3259
STGFLD1A.72
REAL STGFLD1A.73
& LOCAL_FIELD(LOCAL_SIZE,LEVELS) STGFLD1A.74
! ! IN : local data STGFLD1A.75
&, GLOBAL_FIELD(GLOBAL_SIZE,LEVELS) STGFLD1A.76
! ! OUT : (PE GATHER_PE only) - full gathered field STGFLD1A.77
STGFLD1A.78
CHARACTER*80 STGFLD1A.79
& CMESSAGE ! OUT: Error message if ICODE .NE. 0 STGFLD1A.80
STGFLD1A.81
! Parameters and common blocks STGFLD1A.82
*CALL STPARAM 
STGFLD1A.83
*CALL CPPXREF GPB0F404.312
*CALL PARVARS STGFLD1A.84
*CALL GCCOM STGFLD1A.85
*CALL AMAXSIZE GPB0F403.3260
STGFLD1A.86
! Local variables STGFLD1A.87
STGFLD1A.88
INTEGER STGFLD1A.89
& GLOBAL_EAST ! copy of GLOBAL_EAST_IN with wrap around s.t. GPB0F403.3261
! ! GLOBAL_EAST > GLOBAL_ROW_LEN GPB0F403.3262
&, global_x ! size of global data EW GPB0F404.313
&, global_y ! size of global data NS GPB0F404.314
&, fld_type ! indicates if field is on P or U grid GPB0F403.3263
&, level ! loop index for loop over levels GPB0F403.3264
&, proc_topleft_x,proc_topleft_y ! processors at corners of GPB0F403.3265
&, proc_botright_x,proc_botright_y ! the subarea GPB0F403.3266
&, dummy1,dummy2 ! ignored return arguments GPB0F403.3267
&, procx,procy ! loop indexes for loops over processors GPB0F403.3268
&, eff_procx ! real x co-ord of processor column procx GPB0F403.3269
&, procid ! processor id of (procx,procy) GPB0F403.3270
&, local_xstart,local_xend ! boundaries of subdomain for GPB0F403.3271
&, local_ystart,local_yend ! processor procid GPB0F403.3272
&, local_start_row ! first row to send from procid GPB0F403.3273
&, local_start_col ! first column to send from procid GPB0F403.3274
&, sendsize_x ! number of points on each row to send GPB0F403.3275
&, nrows_to_send ! number of rows to send from procid GPB0F403.3276
&, local_row_length ! size of sending array EW GPB0F403.3277
&, global_start_row ! first row to receive at on GATHER_PE GPB0F403.3278
&, global_start_col ! first col. to recieve on GATHER_PE GPB0F403.3279
&, global_row_length ! size of receiving array EW GPB0F403.3280
&, flag,info ! GCOM arguments GPB0F403.3281
GPB0F403.3282
! Copies of arguments / variables used to decide if we can use the GPB0F403.3283
! send/receive maps used in the last call GPB0F403.3284
GPB0F403.3285
INTEGER GPB0F403.3286
& old_LOCAL_SIZE , old_GLOBAL_SIZE GPB0F403.3287
&, old_GLOBAL_NORTH , old_GLOBAL_EAST_IN GPB0F403.3288
&, old_GLOBAL_SOUTH , old_GLOBAL_WEST GPB0F403.3289
&, old_GRIDTYPE_CODE , old_GATHER_PE GPB0F403.3290
&, old_current_decomp_type GPB0F403.3291
STGFLD1A.128
INTEGER STGFLD1A.129
! variables defining send and receive maps to be passed to STGFLD1A.130
! GC_RALL_TO_ALL, defining the data transposition STGFLD1A.131
& send_map(7,2) GPB0F403.3292
&, receive_map(7,2*MAXPROC) GPB0F403.3293
&, n_sends,n_recvs ! number of sends and receives GPB0F403.3294
GPB0F403.3295
STGFLD1A.138
LOGICAL STGFLD1A.139
& wrap ! if the subdomain wraps over 0 degree meridion STGFLD1A.140
&, wrap_special ! if there is a wrap around, which starts and GPB0F403.3296
! ends on the same processor GPB0F403.3297
&, zonal_data ! if this is a zonal data grid GPB0F404.315
&, fullfield ! if this is a full field - NOT a subarea GPB0F403.3298
STGFLD1A.143
! Save all the variables that may be used in the next call GPB0F403.3299
SAVE GPB0F403.3300
& old_LOCAL_SIZE , old_GLOBAL_SIZE GPB0F403.3301
&, old_GLOBAL_NORTH , old_GLOBAL_EAST_IN GPB0F403.3302
&, old_GLOBAL_SOUTH , old_GLOBAL_WEST GPB0F403.3303
&, old_GRIDTYPE_CODE , old_GATHER_PE GPB0F403.3304
&, old_current_decomp_type GPB0F403.3305
&, send_map,receive_map,n_sends,n_recvs GPB0F403.3306
STGFLD1A.144
! Set all the old_* variables to a number indicating they've GPB0F403.3307
! not been used yet GPB0F403.3308
GPB0F403.3309
DATA GPB0F403.3310
& old_LOCAL_SIZE , old_GLOBAL_SIZE GPB0F403.3311
&, old_GLOBAL_NORTH , old_GLOBAL_EAST_IN GPB0F403.3312
&, old_GLOBAL_SOUTH , old_GLOBAL_WEST GPB0F403.3313
&, old_GRIDTYPE_CODE , old_GATHER_PE GPB0F403.3314
&, old_current_decomp_type GPB0F403.3315
& / -1,-1,-1,-1,-1,-1,-1,-1,-1 / GPB0F403.3316
GPB0F403.3317
! Functions GPB0F403.3318
GPB0F403.3319
INTEGER GET_FLD_TYPE GPB0F403.3320
! ------------------------------------------------------------------ STGFLD1A.145
STGFLD1A.146
ICODE=0 GPB0F403.3321
STGFLD1A.149
! See if there is wrap around over meridion, and if so make GPB0F403.3322
! sure that GLOBAL_EAST is > glsize(1) GPB0F403.3323
STGFLD1A.152
GLOBAL_EAST=GLOBAL_EAST_IN GPB0F403.3324
IF (GLOBAL_EAST .GT. glsize(1)) THEN GPB0F403.3325
wrap=.TRUE. GPB0F403.3326
ELSEIF (GLOBAL_EAST .LT. GLOBAL_WEST) THEN GPB0F403.3327
wrap=.TRUE. GPB0F403.3328
GLOBAL_EAST=GLOBAL_EAST_IN+glsize(1) GPB0F403.3329
ELSE GPB0F403.3330
wrap=.FALSE. GPB0F403.3331
ENDIF GPB0F403.3332
STGFLD1A.158
IF ((GRIDTYPE_CODE .EQ. ppx_atm_tzonal) .OR. ! Atmos T zonal GPB0F404.316
& ( GRIDTYPE_CODE .EQ. ppx_atm_uzonal) .OR. ! Atmos U zonal GPB0F404.317
& ( GRIDTYPE_CODE .EQ. ppx_ocn_tzonal) .OR. ! Ocean T zonal GPB0F404.318
& ( GRIDTYPE_CODE .EQ. ppx_ocn_uzonal)) ! Atmos U zonal GPB0F404.319
& THEN GPB0F404.320
GPB0F404.321
! This is a zonal field GPB0F404.322
GPB0F404.323
zonal_data=.TRUE. GPB0F404.324
global_x=1 GPB0F404.325
GPB0F404.326
IF ((GRIDTYPE_CODE .EQ. ppx_atm_tzonal) .OR. ! Atmos T zonal GPB0F404.327
& ( GRIDTYPE_CODE .EQ. ppx_ocn_tzonal)) ! Ocean T zonal GPB0F404.328
& THEN GPB0F404.329
fld_type=fld_type_p GPB0F404.330
ELSE GPB0F404.331
fld_type=fld_type_u GPB0F404.332
ENDIF GPB0F404.333
ELSE GPB0F404.334
GPB0F404.335
! This is a normal field GPB0F404.336
GPB0F404.337
zonal_data=.FALSE. GPB0F404.338
global_x=glsize(1) GPB0F404.339
GPB0F404.340
fld_type=GET_FLD_TYPE(GRIDTYPE_CODE) GPB0F404.341
GPB0F404.342
IF (fld_type .EQ. fld_type_unknown) THEN GPB0F404.343
WRITE(6,*) 'STASH_GATHER_FIELD encountered ', GPB0F404.344
& 'field with gridtype code ',GRIDTYPE_CODE GPB0F404.345
WRITE(6,*) 'Unable to process this field.' GPB0F404.346
CMESSAGE='MPP : STASH_GATHER_FIELD could not process field' GPB0F404.347
ICODE=1 GPB0F404.348
GOTO 9999 GPB0F404.349
ENDIF GPB0F404.350
GPB0F404.351
ENDIF GPB0F404.352
GPB0F404.353
IF (fld_type .EQ. fld_type_p) THEN GPB0F404.354
global_y=glsize(2) GPB0F404.355
ELSE GPB0F404.356
global_y=glsize(2)-1 GPB0F404.357
ENDIF GPB0F404.358
STGFLD1A.180
! Set up logical indicating if this is a full field, or just GPB0F403.3343
! a subdomain GPB0F403.3344
STGFLD1A.187
IF (zonal_data) THEN GPB0F404.359
GPB0F404.360
fullfield= ( ( GLOBAL_NORTH .EQ. 1) .AND. GPB0F404.361
& ( GLOBAL_SOUTH .EQ. global_y)) GPB0F404.362
GPB0F404.363
ELSE GPB0F404.364
GPB0F404.365
fullfield = (( GLOBAL_WEST .EQ. 1) .AND. GPB0F404.366
& ( GLOBAL_EAST .EQ. global_x) .AND. GPB0F404.367
& ( GLOBAL_NORTH .EQ. 1) .AND. GPB0F404.368
& ( GLOBAL_SOUTH .EQ. global_y)) GPB0F404.369
GPB0F404.370
ENDIF GPB0F404.371
GPB0F404.372
! If this a fullfield, we can simply use the standard GPB0F404.373
! GATHER_FIELD routine GPB0F404.374
GPB0F404.375
IF (fullfield) THEN GPB0F404.376
GPB0F404.377
IF (zonal_data) THEN GPB0F404.378
GPB0F404.379
CALL GATHER_ZONAL_FIELD( LOCAL_FIELD,GLOBAL_FIELD, GPB0F404.380
& lasize(2),global_y, GPB0F404.381
& LEVELS,GRIDTYPE_CODE, GPB0F404.382
& GATHER_PE) GPB0F404.383
GPB0F404.384
ELSE GPB0F404.385
GPB0F404.386
DO level=1,LEVELS GPB0F404.387
GPB0F404.388
CALL GATHER_FIELD( LOCAL_FIELD(1,level) , GPB0F404.389
& GLOBAL_FIELD(1,level), GPB0F404.390
& lasize(1),lasize(2), GPB0F404.391
& global_x,global_y, GPB0F404.392
& GATHER_PE,GC_ALL_PROC_GROUP, GPB0F404.393
& info) GPB0F404.394
GPB0F404.395
ENDDO GPB0F404.396
GPB0F404.397
ENDIF GPB0F404.398
ELSE GPB0F403.3373
! for subdomains, life is not so easy - we must explicitly GPB0F403.3374
! calculate our own send and receive maps, and use GCG_RALLTOALLE GPB0F403.3375
! to shift the data around. GPB0F403.3376
GPB0F403.3377
! If the same arguments are used as were used in the last call GPB0F403.3378
! to this routine, we can just use the previously calculated GPB0F403.3379
! send and receive maps, otherwise we need to calculate new maps GPB0F403.3380
GPB0F403.3381
IF (.NOT. ( GPB0F403.3382
& (LOCAL_SIZE .EQ. old_LOCAL_SIZE) .AND. GPB0F403.3383
& (GLOBAL_SIZE .EQ. old_GLOBAL_SIZE) .AND. GPB0F403.3384
& (GLOBAL_NORTH .EQ. old_GLOBAL_NORTH) .AND. GPB0F403.3385
& (GLOBAL_EAST_IN .EQ. old_GLOBAL_EAST_IN) .AND. GPB0F403.3386
& (GLOBAL_SOUTH .EQ. old_GLOBAL_SOUTH) .AND. GPB0F403.3387
& (GLOBAL_WEST .EQ. old_GLOBAL_WEST) .AND. GPB0F403.3388
& (GRIDTYPE_CODE .EQ. old_GRIDTYPE_CODE) .AND. GPB0F403.3389
& (GATHER_PE .EQ. old_GATHER_PE) .AND. GPB0F403.3390
& (current_decomp_type .EQ. old_current_decomp_type ))) THEN GPB0F403.3391
GPB0F403.3392
old_LOCAL_SIZE=LOCAL_SIZE GPB0F403.3393
old_GLOBAL_SIZE=GLOBAL_SIZE GPB0F403.3394
old_GLOBAL_NORTH=GLOBAL_NORTH GPB0F403.3395
old_GLOBAL_EAST_IN=GLOBAL_EAST_IN GPB0F403.3396
old_GLOBAL_SOUTH=GLOBAL_SOUTH GPB0F403.3397
old_GLOBAL_WEST=GLOBAL_WEST GPB0F403.3398
old_GRIDTYPE_CODE=GRIDTYPE_CODE GPB0F403.3399
old_GATHER_PE=GATHER_PE GPB0F403.3400
old_current_decomp_type=current_decomp_type GPB0F403.3401
GPB0F403.3402
! Find out what the boundaries of the subdomain area GPB0F403.3403
GPB0F403.3404
CALL GLOBAL_TO_LOCAL_RC(GRIDTYPE_CODE, GPB0F403.3405
& GLOBAL_WEST,GLOBAL_NORTH, GPB0F403.3406
& proc_topleft_x,proc_topleft_y, GPB0F403.3407
& dummy1,dummy2) GPB0F403.3408
CALL GLOBAL_TO_LOCAL_RC(GRIDTYPE_CODE, GPB0F403.3409
& GLOBAL_EAST,GLOBAL_SOUTH, GPB0F403.3410
& proc_botright_x,proc_botright_y, GPB0F403.3411
& dummy1,dummy2) GPB0F403.3412
STGFLD1A.220
! Ensure that the processor x co-ords are such that the botright_x is STGFLD1A.221
! always greater than (or equal to) top_left_x. STGFLD1A.222
IF (wrap) proc_botright_x=gridsize(1)+proc_botright_x STGFLD1A.223
STGFLD1A.224
! wrap_special is set to true if there is a wrap around which starts GPB0F403.3413
! and ends on the same processor. This case requires extra work as GPB0F403.3414
! the processor in question GPB0F403.3415
IF (wrap .AND. (proc_topleft_x+gridsize(1) .EQ. GPB0F403.3416
& proc_botright_x)) THEN GPB0F403.3417
wrap_special=.TRUE. GPB0F403.3418
ELSE GPB0F403.3419
wrap_special=.FALSE. GPB0F403.3420
ENDIF GPB0F403.3421
GPB0F403.3422
n_sends=0 GPB0F403.3423
n_recvs=0 GPB0F403.3424
STGFLD1A.226
DO procy=proc_topleft_y,proc_botright_y STGFLD1A.227
DO procx=proc_topleft_x,proc_botright_x STGFLD1A.228
STGFLD1A.229
eff_procx=MOD(procx,gridsize(1)) STGFLD1A.230
procid=eff_procx+procy*gridsize(1) STGFLD1A.231
STGFLD1A.232
CALL GLOBAL_TO_LOCAL_SUBDOMAIN( GPB0F403.3425
& .TRUE.,.TRUE., GPB0F403.3426
& GRIDTYPE_CODE,procid, GPB0F403.3427
& GLOBAL_NORTH,GLOBAL_EAST, GPB0F403.3428
& GLOBAL_SOUTH,GLOBAL_WEST, GPB0F403.3429
& local_ystart,local_xend, GPB0F403.3430
& local_yend ,local_xstart) GPB0F403.3431
STGFLD1A.242
! Calculate the shape of the arrays, and where to start sending/ GPB0F403.3432
! receiving data, and how many rows to send GPB0F403.3433
GPB0F403.3434
IF (DATA_EXTRACTED) THEN GPB0F403.3435
local_start_row=1 GPB0F403.3436
ELSE GPB0F403.3437
local_start_row=local_ystart GPB0F403.3438
ENDIF GPB0F403.3439
nrows_to_send=local_yend-local_ystart+1 GPB0F403.3440
GPB0F403.3441
global_start_row=g_datastart(2,procid)+local_ystart- GPB0F403.3442
& Offy-GLOBAL_NORTH GPB0F404.399
global_row_length=GLOBAL_EAST-GLOBAL_WEST+1 GPB0F403.3444
GPB0F403.3445
! Calculate the following variables: GPB0F403.3446
! local_row_length : the X dimension size of the local array GPB0F403.3447
! local_send_offx : the offset into each row to start sending from GPB0F403.3448
! sendsize_x : the number of points on each row to send GPB0F403.3449
! The calculation of these numbers is different for processors GPB0F403.3450
! at the start and end of a wrap_special case GPB0F403.3451
GPB0F403.3452
IF (wrap_special .AND. procx .EQ. proc_topleft_x) THEN GPB0F403.3453
IF (DATA_EXTRACTED) THEN GPB0F403.3454
local_row_length=g_lasize(1,procid)+local_xend- GPB0F403.3455
& local_xstart-2*Offx+1 GPB0F403.3456
local_start_col=1 GPB0F403.3457
ELSE GPB0F403.3458
local_row_length=g_lasize(1,procid) GPB0F403.3459
local_start_col=local_xstart GPB0F403.3460
GPB0F403.3461
ENDIF GPB0F403.3462
sendsize_x=g_lasize(1,procid)-local_xstart GPB0F403.3463
global_start_col=1 GPB0F403.3464
GPB0F403.3465
ELSEIF (wrap_special .AND. procx .EQ. proc_botright_x) GPB0F403.3466
& THEN STGFLD1A.245
IF (DATA_EXTRACTED) THEN GPB0F403.3467
local_row_length=g_lasize(1,procid)+local_xend- GPB0F403.3468
& local_xstart-2*Offx+1 GPB0F403.3469
local_start_col=local_row_length-local_xend+Offx+1 GPB0F403.3470
ELSE GPB0F403.3471
local_row_length=g_lasize(1,procid) GPB0F403.3472
local_start_col=Offx+1 GPB0F403.3473
ENDIF GPB0F403.3474
sendsize_x=local_xend-Offx GPB0F403.3475
global_start_col=global_row_length-sendsize_x+1 GPB0F403.3476
GPB0F403.3477
ELSE STGFLD1A.253
IF (DATA_EXTRACTED) THEN GPB0F403.3478
local_row_length=local_xend-local_xstart+1 GPB0F403.3479
local_start_col=1 GPB0F403.3480
ELSE GPB0F403.3481
local_row_length=g_lasize(1,procid) GPB0F403.3482
local_start_col=local_xstart GPB0F403.3483
ENDIF GPB0F403.3484
sendsize_x=local_xend-local_xstart+1 GPB0F403.3485
global_start_col=local_xstart-(Offx+1)+ GPB0F403.3486
& g_datastart(1,procid)-GLOBAL_WEST+1 GPB0F403.3487
ENDIF STGFLD1A.255
STGFLD1A.256
IF (global_start_col .LT. 0) THEN GPB0F403.3488
! Wrapped around field, but this processor is not start or end GPB0F403.3489
! processor GPB0F403.3490
global_start_col=global_start_col+glsize(1) GPB0F403.3491
ENDIF GPB0F403.3492
STGFLD1A.267
! Now we can set up the send and receive map entries for the data on GPB0F403.3493
! this processor GPB0F403.3494
STGFLD1A.269
IF (mype .EQ. procid) THEN ! I need to send some data GPB0F403.3495
STGFLD1A.294
STGFLD1A.295
n_sends=n_sends+1 GPB0F403.3496
STGFLD1A.308
send_map(S_DESTINATION_PE,n_sends) = GATHER_PE GPB0F403.3497
send_map(S_BASE_ADDRESS_IN_SEND_ARRAY,n_sends) = GPB0F403.3498
& (local_start_row-1)*local_row_length + GPB0F403.3499
& local_start_col GPB0F403.3500
send_map(S_NUMBER_OF_ELEMENTS_IN_ITEM,n_sends) = GPB0F403.3501
& nrows_to_send GPB0F403.3502
send_map(S_STRIDE_IN_SEND_ARRAY,n_sends) = GPB0F403.3503
& local_row_length GPB0F403.3504
send_map(S_ELEMENT_LENGTH,n_sends) = sendsize_x GPB0F403.3505
send_map(S_BASE_ADDRESS_IN_RECV_ARRAY,n_sends) = GPB0F403.3506
& (global_start_row-1)*global_row_length + GPB0F403.3507
& global_start_col GPB0F403.3508
send_map(S_STRIDE_IN_RECV_ARRAY,n_sends) = GPB0F403.3509
& global_row_length GPB0F403.3510
STGFLD1A.311
ENDIF ! if I'm sending data GPB0F403.3511
STGFLD1A.319
IF (mype .EQ. GATHER_PE) THEN ! I need to receive data GPB0F403.3512
STGFLD1A.322
n_recvs=n_recvs+1 GPB0F403.3513
STGFLD1A.325
receive_map(R_SOURCE_PE,n_recvs) = procid GPB0F403.3514
receive_map(R_BASE_ADDRESS_IN_RECV_ARRAY,n_recvs) = GPB0F403.3515
& (global_start_row-1)*global_row_length + GPB0F403.3516
& global_start_col GPB0F403.3517
receive_map(R_NUMBER_OF_ELEMENTS_IN_ITEM,n_recvs) = GPB0F403.3518
& nrows_to_send GPB0F403.3519
receive_map(R_STRIDE_IN_RECV_ARRAY,n_recvs) = GPB0F403.3520
& global_row_length GPB0F403.3521
receive_map(R_ELEMENT_LENGTH,n_recvs) = sendsize_x GPB0F403.3522
receive_map(R_BASE_ADDRESS_IN_SEND_ARRAY,n_recvs) = GPB0F403.3523
& (local_start_row-1)*local_row_length + GPB0F403.3524
& local_start_col GPB0F403.3525
receive_map(R_STRIDE_IN_SEND_ARRAY,n_recvs) = GPB0F403.3526
& local_row_length GPB0F403.3527
STGFLD1A.327
ENDIF ! if I'm receiving data GPB0F403.3528
STGFLD1A.335
ENDDO ! procx : loop along processor row GPB0F403.3529
STGFLD1A.338
ENDDO ! procy : loop down processor column GPB0F403.3530
STGFLD1A.341
ENDIF ! if I need to recalculate my send/receive maps GPB0F403.3531
STGFLD1A.343
! Send / receive the data using GCG_RALLTOALLE GPB0F403.3532
STGFLD1A.383
STGFLD1A.384
DO level=1,LEVELS GPB0F403.3533
STGFLD1A.386
flag=0 ! This is currently ignored at GCG v1.1 GPB0F403.3534
STGFLD1A.388
CALL GC_SETOPT(GC_SHM_DIR,GC_SHM_PUT,info) ! set as gather GPB0F403.3535
STGFLD1A.390
info=GC_NONE GPB0F403.3536
STGFLD1A.406
CALL GCG_RALLTOALLE( GPB0F403.3537
& LOCAL_FIELD(1,level) , GPB0F403.3538
& send_map , n_sends ,LOCAL_SIZE , GPB0F403.3539
& GLOBAL_FIELD(1,level) , GPB0F403.3540
& receive_map , n_recvs , GLOBAL_SIZE , GPB0F403.3541
& GC_ALL_PROC_GROUP , flag, info) GPB0F403.3542
STGFLD1A.408
ENDDO GPB0F403.3543
STGFLD1A.410
ENDIF ! if this is a full or extracted field GPB0F403.3544
STGFLD1A.470
9999 CONTINUE STGFLD1A.471
STGFLD1A.472
RETURN STGFLD1A.473
END STGFLD1A.474
STGFLD1A.475
*ENDIF GPB0F403.3545
*ENDIF STGFLD1A.476