SUBROUTINE STZONM(fieldin,vx,vy,st_grid,gr,lwrap,lmasswt, 1,6GPB0F403.2177
& xstart,ystart,xend,yend, STZONM1A.30
*IF DEF,MPP GPB0F403.2178
& global_xstart,global_ystart, GPB0F403.2179
& global_xend,global_yend, GPB0F403.2180
*ENDIF GPB0F403.2181
& fieldout, STZONM1A.31
& pstar_weight,delta_ak,delta_bk, GPB0F403.2182
& area_weight,mask, GPB0F403.2183
& row_length,p_rows, GPB0F403.2184
& level_code,mask_code,weight_code,rmdi, STZONM1A.35
& icode,cmessage) STZONM1A.36
C STZONM1A.37
IMPLICIT NONE STZONM1A.38
C STZONM1A.39
INTEGER STZONM1A.40
& vx,vy, ! IN input field size STZONM1A.41
& st_grid, ! IN STASH grdtype code STZONM1A.42
& gr, ! IN input fld grid GPB0F403.2185
& xstart,ystart, ! IN lower LH corner STZONM1A.43
& xend,yend, ! IN upper RH corner STZONM1A.44
*IF DEF,MPP GPB0F403.2186
& global_xstart,global_ystart, ! IN global versions of GPB0F403.2187
& global_xend, global_yend, ! IN xstart etc. GPB0F403.2188
*ENDIF GPB0F403.2189
& row_length,p_rows, ! IN primary dimensions GPB0F403.2190
& level_code, ! IN input level code STZONM1A.46
& mask_code, ! IN masking code STZONM1A.47
& weight_code, ! IN weighting code STZONM1A.48
& icode ! OUT error return code STZONM1A.49
CHARACTER*(*) STZONM1A.50
& cmessage ! OUT error return msg STZONM1A.51
LOGICAL STZONM1A.52
& lwrap, ! IN TRUE if wraparound STZONM1A.53
& lmasswt, ! IN TRUE if masswts OK TJ170993.155
& mask(row_length,p_rows) ! IN mask array GPB0F403.2191
REAL STZONM1A.55
& fieldin(vx,vy), ! IN input field STZONM1A.56
& fieldout(ystart:yend), ! OUT output field STZONM1A.57
& pstar_weight(row_length,p_rows), ! IN pstar mass weight GPB0F403.2192
& delta_ak, ! IN hybrid coordinates STZONM1A.60
& delta_bk, ! IN hybrid coordinates STZONM1A.61
& area_weight(row_length,p_rows), ! IN area weighting GPB0F403.2193
! (already interpolated to the correct grid and GPB0F403.2194
! set to 1.0 where no area weighting is required) GPB0F403.2195
& rmdi ! IN missing data indic STZONM1A.64
C*---------------------------------------------------------------------- STZONM1A.65
C STZONM1A.66
C External subroutines called STZONM1A.67
C STZONM1A.68
C STZONM1A.70
*CALL STPARAM 
STZONM1A.71
*CALL STERR STZONM1A.72
C STZONM1A.73
C Local variables STZONM1A.74
C STZONM1A.75
INTEGER i,ii,j ! ARRAY INDICES FOR VARIABLE STZONM1A.76
STZONM1A.77
*IF DEF,MPP GPB0F403.2196
GPB0F403.2197
*CALL PARVARS GPB0F403.2198
GPB0F403.2199
INTEGER GPB0F403.2200
GPB0F403.2201
*IF DEF,REPROD GPB0F403.2202
! Processor co-ordinates of processors at the corners of the GPB0F403.2203
! processed subdomain GPB0F403.2204
& proc_top_left_x,proc_top_left_y GPB0F403.2205
&, proc_bot_right_x,proc_bot_right_y GPB0F403.2206
GPB0F403.2207
! size of the full subarea in GPB0F403.2208
&, zonal_sum_global_len_x GPB0F403.2209
GPB0F403.2210
! loop variables for loops over processors in subdomain GPB0F403.2211
&, proc_x,proc_y GPB0F403.2212
GPB0F403.2213
! real processor x co-ordinate - when proc_x > nproc_x is just GPB0F403.2214
! proc_x-nproc_x GPB0F403.2215
&, eff_proc_x GPB0F403.2216
GPB0F403.2217
! processor id of processor (proc_x,proc_y) GPB0F403.2218
&, proc_id GPB0F403.2219
GPB0F403.2220
! definition of the extracted subarea array on processor proc_id GPB0F403.2221
&, local_array_top_left_x,local_array_top_left_y GPB0F403.2222
&, local_array_bot_right_x,local_array_bot_right_y GPB0F403.2223
GPB0F403.2224
! definition of the real data contained within the extracted GPB0F403.2225
! subarea on processor proc_id (ie. not including halos) GPB0F403.2226
&, local_data_top_left_x,local_data_top_left_y GPB0F403.2227
&, local_data_bot_right_x,local_data_bot_right_y GPB0F403.2228
GPB0F403.2229
! size in the x dimension of the subarea array on proc_id GPB0F403.2230
&, local_array_size_x GPB0F403.2231
GPB0F403.2232
! length of (partial) local zonal data to be sent GPB0F403.2233
&, local_send_size_x GPB0F403.2234
GPB0F403.2235
! offset of data to be sent from start of local row GPB0F403.2236
&, local_send_off_x GPB0F403.2237
GPB0F403.2238
! position in the full zonal row of (partial) data to be sent GPB0F403.2239
&, pos_in_zonal_array GPB0F403.2240
GPB0F403.2241
! number of (partial) zonal mean rows on processor proc_id GPB0F403.2242
&, local_n_rows_to_send GPB0F403.2243
GPB0F403.2244
! the first (partial) zonal mean row to be sent from proc_id GPB0F403.2245
&, local_send_off_y GPB0F403.2246
GPB0F403.2247
! the global zonal mean number of the first local (partial) zonal GPB0F403.2248
! mean row to be sent from proc_id GPB0F403.2249
&, global_zonal_row_number_start GPB0F403.2250
GPB0F403.2251
! loop counter for loop over rows to send GPB0F403.2252
&, row GPB0F403.2253
GPB0F403.2254
! index of row in proc_id's array of local data GPB0F403.2255
&, local_row GPB0F403.2256
GPB0F403.2257
! global zonal row number of a row GPB0F403.2258
&, global_zonal_row_id GPB0F403.2259
GPB0F403.2260
! processor which this zonal mean row will be sent to GPB0F403.2261
&, dest_proc GPB0F403.2262
GPB0F403.2263
! row number on the destination processor GPB0F403.2264
&, work_dest_row_id GPB0F403.2265
GPB0F403.2266
! number of items of zonal data to send and receive GPB0F403.2267
&, n_send_data , n_rec_data GPB0F403.2268
GPB0F403.2269
! number of final zonal means to send and receive GPB0F403.2270
&, n_send_means , n_rec_means GPB0F403.2271
GPB0F403.2272
! number of rows of (full) zonal data on this processor GPB0F403.2273
&, n_rows_full_zonal_data GPB0F403.2274
GPB0F403.2275
! size of local_sum_arrays and global_sum_arrays GPB0F403.2276
&, local_sum_array_len GPB0F403.2277
&, global_sum_array_len GPB0F403.2278
GPB0F403.2279
! field type (P or U) of input field GPB0F403.2280
&, fld_type GPB0F403.2281
GPB0F403.2282
! arguments for GCOM routines GPB0F403.2283
&, flag , info GPB0F403.2284
GPB0F403.2285
! dummy variables (unused return values from subroutine calls) GPB0F403.2286
&, dummy1,dummy2 GPB0F403.2287
*ELSE GPB0F403.2288
! size of subarea on this processor, not including halo areas GPB0F403.2289
& local_sum_xstart,local_sum_xend GPB0F403.2290
&, local_sum_ystart,local_sum_yend GPB0F403.2291
GPB0F403.2292
! number of rows of zonal data to sum on this processor GPB0F403.2293
! (yend-ystart+1) GPB0F403.2294
&, partial_sum_data_sizey GPB0F403.2295
GPB0F403.2296
! return code from GCOM routines GPB0F403.2297
&, info GPB0F403.2298
*ENDIF GPB0F403.2299
GPB0F403.2300
GPB0F403.2302
*IF DEF,REPROD GPB0F403.2303
LOGICAL GPB0F403.2304
GPB0F403.2305
! indicates if the subarea requested for zonal meaning wraps over GPB0F403.2306
! zero longitude GPB0F403.2307
& lwrap_zonal_mean GPB0F403.2308
GPB0F403.2309
! indicates if the subdomain contains processors which hold both GPB0F403.2310
! the start and end of the subdomain, which wraps over zero GPB0F403.2311
! longitude GPB0F403.2312
&, lwrap_proc GPB0F403.2313
GPB0F403.2314
! indicates that a full field is being zonal meaned GPB0F403.2315
&, fullfield GPB0F403.2316
GPB0F403.2317
REAL GPB0F403.2318
! temporary variables used in calculation of zonal means GPB0F403.2319
& zonal_sum_top,zonal_sum_bot GPB0F403.2320
GPB0F403.2321
INTEGER GPB0F403.2322
GPB0F403.2323
! Send/receive maps for zonal data arrays to be summed GPB0F403.2324
& send_data_map(7,2*(yend-ystart+1)) GPB0F403.2325
&, rec_data_map(7,2*(global_yend-global_ystart+1)*nproc) GPB2F405.295
GPB0F403.2327
! send/receive maps for zonal means GPB0F403.2328
&, send_means_map(7,2*(global_yend-global_ystart+1)) GPB0F403.2329
&, rec_means_map(7,2*(yend-ystart+1)) GPB0F403.2330
GPB0F403.2331
! Weighted version of fieldin GPB0F403.2332
REAL local_sum_array_top(xstart:xend,ystart:yend) GPB0F403.2333
! Weights applied to fieldin GPB0F403.2334
REAL local_sum_array_bot(xstart:xend,ystart:yend) GPB0F403.2335
*ENDIF GPB0F403.2336
GPB0F403.2337
GPB0F403.2339
*IF DEF,REPROD GPB0F403.2340
INTEGER GPB0F403.2341
! Sizes of the global_sum_arrays defined below GPB2F405.296
& global_sum_array_sizex,global_sum_array_sizey GPB0F403.2345
GPB0F403.2346
REAL GPB0F403.2355
! Collected versions of fieldin and the weights containing GPB0F403.2356
! whole (subarea) rows of zonal data GPB0F403.2357
& global_sum_array_top(global_xstart:global_xend, GPB2F405.297
& global_yend-global_ystart+1) GPB2F405.298
&, global_sum_array_bot(global_xstart:global_xend, GPB2F405.299
& global_yend-global_ystart+1) GPB2F405.300
GPB0F403.2362
! Calculated zonal means on the calculating processor GPB0F403.2363
&, zonal_mean_array(global_yend-global_ystart+1) GPB2F405.301
GPB0F403.2365
*ELSE GPB0F403.2378
INTEGER GPB0F403.2379
! Size of local partial sum arrays defined below GPB2F405.302
& partial_sum_array_sizey GPB0F403.2383
GPB0F403.2384
REAL GPB0F403.2391
! Partial zonal sums of subarea rows GPB0F403.2392
& partial_SUMZTOP(vy*2) GPB2F405.303
&, partial_SUMZBOT(vy*2) GPB2F405.304
GPB0F403.2395
*ENDIF GPB0F403.2406
GPB0F403.2407
*IF DEF,REPROD GPB0F403.2408
GPB0F403.2409
! Integer function used for obtaining field type GPB0F403.2410
INTEGER GET_FLD_TYPE GPB0F403.2411
GPB0F403.2412
*ENDIF GPB0F403.2413
GPB0F403.2414
*CALL GCCOM GPB0F403.2415
GPB0F403.2416
*ENDIF GPB0F403.2417
REAL SUMZTOP(ystart:yend) STZONM1A.80
REAL SUMZBOT(ystart:yend) STZONM1A.81
STZONM1A.82
CL---------------------------------------------------------------------- STZONM1A.83
CL 0. Initialise sums STZONM1A.84
CL STZONM1A.85
CFPP$ NOINNER R STZONM1A.86
DO j=ystart,yend STZONM1A.87
SUMZTOP(j)=0.0 STZONM1A.88
SUMZBOT(j)=0.0 STZONM1A.89
ENDDO STZONM1A.90
CL---------------------------------------------------------------------- STZONM1A.91
GPB0F403.2418
! pstar_weight and area_weight arrays contain appropriate GPB0F403.2419
! weighting factors, interpolated to the correct grid, for GPB0F403.2420
! mass weighting and area weighting respectively. If either type GPB0F403.2421
! of weighting is not required, the relevant array is set to 1.0 GPB0F403.2422
! The mask array contains appropriate masking GPB0F403.2423
GPB0F403.2424
*IF -DEF,MPP,OR,DEF,REPROD GPB0F403.2425
*IF -DEF,MPP GPB0F403.2426
! Sum up weighted versions of fieldin array GPB0F403.2427
*ELSE GPB0F403.2428
! Create arrays of weighted data suitable to be summed GPB0F403.2429
*ENDIF GPB0F403.2430
GPB0F403.2431
*IF DEF,MPP GPB0F403.2432
! Only do the calculations if some of the subarea is contained GPB0F403.2433
! within this processor GPB0F403.2434
IF ((xstart .NE. st_no_data) .AND. (xend .NE. st_no_data) .AND. GPB0F403.2435
& (ystart .NE. st_no_data) .AND. (yend .NE. st_no_data)) THEN GPB0F403.2436
GPB0F403.2437
*ENDIF GPB0F403.2438
DO i=xstart,xend GPB0F403.2439
*IF -DEF,MPP GPB0F403.2440
IF (lwrap) THEN GPB0F403.2441
ii=1+MOD(i-1,vx) GPB0F403.2442
ELSE GPB0F403.2443
ii=i GPB0F403.2444
ENDIF GPB0F403.2445
*ELSE GPB0F403.2446
IF ( lwrap .AND. (i .GT. (lasize(1)-Offx))) THEN GPB0F403.2447
ii=i-lasize(1)+2*Offx ! miss halos on wrap around GPB0F403.2448
ELSE GPB0F403.2449
ii=i GPB0F403.2450
ENDIF GPB0F403.2451
*ENDIF GPB0F403.2452
DO j=ystart,yend GPB0F403.2453
IF (mask(ii,j)) THEN GPB0F403.2454
IF (.NOT. lmasswt) THEN GPB0F403.2455
*IF -DEF,MPP GPB0F403.2456
SUMZBOT(j)=SUMZBOT(j)+ GPB0F403.2457
& pstar_weight(ii,j) GPB0F403.2458
SUMZTOP(j)=SUMZTOP(j)+ GPB0F403.2459
& fieldin(ii,j)*pstar_weight(ii,j) GPB0F403.2460
*ELSE GPB0F403.2461
local_sum_array_bot(i,j)= GPB0F403.2462
& pstar_weight(ii,j) GPB0F403.2463
local_sum_array_top(i,j)= GPB0F403.2464
& fieldin(ii,j)*pstar_weight(ii,j) GPB0F403.2465
*ENDIF GPB0F403.2466
ELSE GPB0F403.2467
*IF -DEF,MPP GPB0F403.2468
SUMZBOT(j)=SUMZBOT(j)- GPB0F403.2469
& (delta_ak+delta_bk*pstar_weight(ii,j)) GPB0F403.2470
SUMZTOP(j)=SUMZTOP(j)-fieldin(ii,j)* GPB0F403.2471
& (delta_ak+delta_bk*pstar_weight(ii,j)) GPB0F403.2472
*ELSE GPB0F403.2473
local_sum_array_bot(i,j)= GPB0F403.2474
& -1.0*(delta_ak+delta_bk*pstar_weight(ii,j)) GPB0F403.2475
local_sum_array_top(i,j)= GPB0F403.2476
& -1.0*fieldin(ii,j)* GPB0F403.2477
& (delta_ak+delta_bk*pstar_weight(ii,j)) GPB0F403.2478
*ENDIF GPB0F403.2479
ENDIF GPB0F403.2480
*IF -DEF,MPP GPB0F403.2481
ENDIF GPB0F403.2482
*ELSE GPB0F403.2483
ELSE STZONM1A.102
local_sum_array_bot(i,j)=0.0 GPB0F403.2484
local_sum_array_top(i,j)=0.0 GPB0F403.2485
ENDIF STZONM1A.104
*ENDIF GPB0F403.2486
ENDDO GPB0F403.2487
ENDDO GPB0F403.2488
GPB0F403.2489
*IF DEF,MPP GPB0F403.2490
ENDIF ! if this processor contains any of the subarea GPB0F403.2491
*ENDIF GPB0F403.2492
GPB0F403.2493
*IF -DEF,MPP GPB0F403.2494
GPB0F403.2495
DO j=ystart,yend STZONM1A.443
IF (SUMZBOT(j) .EQ. 0.0) THEN GPB0F403.2496
fieldout(j)=rmdi STZONM1A.445
ELSE STZONM1A.446
fieldout(j)=SUMZTOP(j)/SUMZBOT(j) STZONM1A.447
ENDIF STZONM1A.448
ENDDO STZONM1A.449
GPB0F403.2497
*ELSE GPB0F403.2498
GPB0F404.304
! Initialise fieldout array - so all PE's have valid data GPB0F404.305
! (Only PEs on left of subdomain get the zonal means) GPB0F404.306
DO i=ystart,yend GPB0F404.307
fieldout(i)=0.0 GPB0F404.308
ENDDO GPB0F404.309
GPB0F403.2499
! The local_sum_arrays must be distributed so that complete GPB0F403.2500
! sub-area rows exist on processors, so that a reproducible sum GPB0F403.2501
! can be carried out. GPB0F403.2502
! The following code calculates where the local_sum_array data GPB0F403.2503
! must be sent to, and where the final answers must be sent back to GPB0F403.2504
GPB0F403.2505
! 0.0 : Initialise variables defining the size of the arrays GPB0F403.2506
! global_sum_arrays GPB0F403.2507
GPB0F403.2508
global_sum_array_sizex=global_xend-global_xstart+1 GPB2F405.305
global_sum_array_sizey=global_yend-global_ystart+1 GPB2F405.306
GPB0F403.2512
local_sum_array_len=((xend-xstart)+1)*((yend-ystart)+1) GPB0F403.2513
global_sum_array_len=global_sum_array_sizex* GPB0F403.2514
& global_sum_array_sizey GPB0F403.2515
GPB0F403.2516
! Set a logicial indicating if the area being meaned is the GPB0F403.2517
! full field GPB0F403.2518
GPB0F403.2519
fld_type=GET_FLD_TYPE(gr) GPB0F403.2520
GPB0F403.2521
fullfield= ((( global_xstart .EQ. 1) .AND. GPB0F403.2522
& ( global_xend) .EQ. glsize(1)) .AND. GPB0F403.2523
& ( global_ystart .EQ. 1) .AND. GPB0F403.2524
& (((fld_type .EQ. fld_type_p) .AND. GPB0F403.2525
& (global_yend .EQ. glsize(2))) .OR. GPB0F403.2526
& ((fld_type .EQ. fld_type_u) .AND. GPB0F403.2527
& (global_yend .EQ. glsize(2)-1)))) GPB0F403.2528
GPB0F403.2529
! Calculate the length of the full zonal subarea GPB0F403.2530
GPB0F403.2531
zonal_sum_global_len_x=global_xend-global_xstart+1 GPB0F403.2532
GPB0F403.2533
! 1.0 Find the set of processors covering the requested sub-area GPB0F403.2534
GPB0F403.2535
CALL GLOBAL_TO_LOCAL_RC(gr, GPB0F403.2536
& global_xstart , global_ystart, GPB0F403.2537
& proc_top_left_x, proc_top_left_y, GPB0F403.2538
& dummy1,dummy2) GPB0F403.2539
GPB0F403.2540
CALL GLOBAL_TO_LOCAL_RC(gr, GPB0F403.2541
& global_xend,global_yend, GPB0F403.2542
& proc_bot_right_x, proc_bot_right_y, GPB0F403.2543
& dummy1,dummy2) GPB0F403.2544
GPB0F403.2545
! Set a logical to indicate if the zonal mean area required GPB0F403.2546
! wraps over zero longitude GPB0F403.2547
GPB0F403.2548
lwrap_zonal_mean= GPB0F403.2549
& ((global_xend .GT. glsize(1)) .OR. GPB0F403.2550
& (global_xend .LT. global_xstart)) GPB0F403.2551
GPB0F403.2552
! If there is a wrap around over 0 longitude, ensure that GPB0F403.2553
! proc_bot_right_x > proc_top_left_x GPB0F403.2554
GPB0F403.2555
IF (lwrap_zonal_mean) GPB0F403.2556
& proc_bot_right_x=proc_bot_right_x+nproc_x GPB0F403.2557
GPB0F403.2558
! Set up a logical to indicate if a processor in the subdomain GPB0F403.2559
! contains both the start and end of a zonal mean which wraps over GPB0F403.2560
! zero longitude. If TRUE, some extra work is required at this GPB0F403.2561
! processor as it contains data for two non-contiguous parts GPB0F403.2562
! of the zonal mean GPB0F403.2563
GPB0F403.2564
lwrap_proc=(proc_bot_right_x .EQ. proc_top_left_x+nproc_x) GPB0F403.2565
GPB0F403.2566
! 2.0 Loop over all the processors in the subdomain, and set GPB0F403.2567
! up the send/receive maps defining the redistribution GPB0F403.2568
! of data GPB0F403.2569
GPB0F403.2570
n_send_data=0 ! number of items of data to send GPB0F403.2571
n_rec_data=0 ! number of items of data to receive GPB0F403.2572
n_send_means=0 ! number of zonal means I will send GPB0F403.2573
n_rec_means=0 ! number of zonal means I will receive GPB0F403.2574
n_rows_full_zonal_data=0 ! number of rows of data I will mean GPB0F403.2575
GPB0F403.2576
DO proc_y=proc_top_left_y , proc_bot_right_y GPB0F403.2577
GPB0F403.2578
DO proc_x=proc_top_left_x , proc_bot_right_x GPB0F403.2579
GPB0F403.2580
eff_proc_x=MOD(proc_x,nproc_x) GPB0F403.2581
proc_id=eff_proc_x+proc_y*nproc_x GPB0F403.2582
GPB0F403.2583
! 2.1 Find the size of the array containing the zonal arrays on GPB0F403.2584
! processor proc_id GPB0F403.2585
GPB0F403.2586
CALL GLOBAL_TO_LOCAL_SUBDOMAIN(.TRUE.,.TRUE., GPB0F403.2587
& gr,proc_id, GPB0F403.2588
& global_ystart,global_xend, GPB0F403.2589
& global_yend,global_xstart, GPB0F403.2590
& local_array_top_left_y,local_array_bot_right_x, GPB0F403.2591
& local_array_bot_right_y,local_array_top_left_x) GPB0F403.2592
GPB0F403.2593
! 2.2 Using this information, calculate the size of this array in GPB0F403.2594
! the x dimension. If the data is wrapped round, the calculation GPB0F403.2595
! is done differently: GPB0F403.2596
GPB0F403.2597
IF (local_array_top_left_x .LE. local_array_bot_right_x) GPB0F403.2598
& THEN GPB0F403.2599
local_array_size_x= GPB0F403.2600
& local_array_bot_right_x-local_array_top_left_x+1 GPB0F403.2601
ELSE ! wrap around GPB0F403.2602
local_array_size_x= GPB0F403.2603
& local_array_bot_right_x-local_array_top_left_x+1+ GPB0F403.2604
& g_lasize(1,proc_id)-2*Offx GPB0F403.2605
ENDIF GPB0F403.2606
GPB0F403.2607
! 2.3 Find out the size of the actual zonal mean data within the GPB0F403.2608
! subarea array on processor proc_id GPB0F403.2609
GPB0F403.2610
CALL GLOBAL_TO_LOCAL_SUBDOMAIN(.FALSE.,.FALSE., GPB0F403.2611
& gr,proc_id, GPB0F403.2612
& global_ystart,global_xend, GPB0F403.2613
& global_yend,global_xstart, GPB0F403.2614
& local_data_top_left_y,local_data_bot_right_x, GPB0F403.2615
& local_data_bot_right_y,local_data_top_left_x) GPB0F403.2616
GPB0F403.2617
! 2.4 Calculate various quantities, which require different GPB0F403.2618
! calculations depending on if LWRAP_PROC is .TRUE., GPB0F403.2619
! and if so, if this processor contains both start and GPB0F403.2620
! end of the zonal data GPB0F403.2621
! local_send_size_x : the length of data to be sent GPB0F403.2622
! local_send_off_x : the offset of this data from the GPB0F403.2623
! start of row GPB0F403.2624
! pos_in_zonal_array : position of this data in the full GPB0F403.2625
! zonal array GPB0F403.2626
GPB0F403.2627
IF ((LWRAP_PROC) .AND. (proc_x .EQ. proc_top_left_x)) THEN GPB0F403.2628
! Processor containing start and end of zonal mean - but here GPB0F403.2629
! we're interested only in the start segment GPB0F403.2630
GPB0F403.2631
local_send_size_x= GPB0F403.2632
& g_lasize(1,proc_id)-local_data_top_left_x-Offx+1 GPB0F403.2633
local_send_off_x= GPB0F403.2634
& local_data_top_left_x-local_array_top_left_x GPB0F403.2635
pos_in_zonal_array= GPB0F403.2636
& g_datastart(1,proc_id)+local_data_top_left_x-Offx- GPB0F403.2637
& global_xstart GPB0F403.2638
GPB0F403.2639
ELSEIF ((LWRAP_PROC) .AND. GPB0F403.2640
& (proc_x .EQ. proc_bot_right_x)) THEN GPB0F403.2641
! Processor containing start and end of zonal mean - but here GPB0F403.2642
! we're interested only in the end segment GPB0F403.2643
GPB0F403.2644
local_send_size_x=local_data_bot_right_x-Offx GPB0F403.2645
local_send_off_x=local_array_size_x-local_send_size_x GPB0F403.2646
pos_in_zonal_array= GPB0F403.2647
& zonal_sum_global_len_x-local_send_size_x+1 GPB0F403.2648
GPB0F403.2649
ELSE GPB0F403.2650
! all other processors GPB0F403.2651
GPB0F403.2652
local_send_size_x= GPB0F403.2653
& local_data_bot_right_x-local_data_top_left_x+1 GPB0F403.2654
local_send_off_x= GPB0F403.2655
& local_data_top_left_x-local_array_top_left_x GPB0F403.2656
pos_in_zonal_array= GPB0F403.2657
& g_datastart(1,proc_id)+local_data_top_left_x-Offx- GPB0F403.2658
& global_xstart GPB0F403.2659
GPB0F403.2660
ENDIF GPB0F403.2661
GPB0F403.2662
IF (pos_in_zonal_array .LT. 1) THEN GPB0F403.2663
! This means the sub-area wraps over zero longitude - so to get GPB0F403.2664
! the correct position in the array we add the global row length GPB0F403.2665
pos_in_zonal_array=pos_in_zonal_array+glsize(1) GPB0F403.2666
ENDIF GPB0F403.2667
GPB0F403.2668
! 2.5 Find the number of zonal mean rows to be sent from this GPB0F403.2669
! processor GPB0F403.2670
GPB0F403.2671
local_n_rows_to_send= GPB0F403.2672
& local_data_bot_right_y-local_data_top_left_y+1 GPB0F403.2673
GPB0F403.2674
! 2.6 and the first row to be sent from this processor GPB0F403.2675
GPB0F403.2676
local_send_off_y= GPB0F403.2677
& local_data_top_left_y-local_array_top_left_y GPB0F403.2678
GPB0F403.2679
! 2.7 Calculate which global zonal mean is the first one to GPB0F403.2680
! send from this processor GPB0F403.2681
GPB0F403.2682
global_zonal_row_number_start= GPB0F403.2683
& g_datastart(2,proc_id)+local_data_top_left_y-Offy- GPB0F403.2684
& global_ystart GPB0F403.2685
GPB0F403.2686
! 2.8 Loop over rows and construct send/receive maps GPB0F403.2687
GPB0F403.2688
DO row=1,local_n_rows_to_send GPB0F403.2689
GPB0F403.2690
! 2.8.1 Find the local_row index on proc_id, and the global zonal GPB0F403.2691
! row index of this row GPB0F403.2692
GPB0F403.2693
local_row=row+local_send_off_y GPB0F403.2694
global_zonal_row_id=global_zonal_row_number_start+row-1 GPB0F403.2695
GPB0F403.2696
! 2.8.2 and find the destination processor of this row, and GPB0F403.2697
! where on this processor it will be sent to GPB0F403.2698
GPB0F403.2699
dest_proc=MOD(global_zonal_row_id-1,nproc) GPB0F403.2700
work_dest_row_id=((global_zonal_row_id-1)/nproc)+1 GPB0F403.2701
GPB0F403.2702
! 2.8.3 If this processor is proc_id construct a send_data_map GPB0F403.2703
! entry for this row of data GPB0F403.2704
GPB0F403.2705
IF (mype .EQ. proc_id) THEN GPB0F403.2706
GPB0F403.2707
n_send_data = n_send_data+1 GPB0F403.2708
GPB0F403.2709
send_data_map(S_DESTINATION_PE,n_send_data)= GPB0F403.2710
& dest_proc GPB0F403.2711
send_data_map(S_BASE_ADDRESS_IN_SEND_ARRAY, GPB0F403.2712
& n_send_data)= GPB0F403.2713
& (local_row-1)*local_array_size_x + GPB0F403.2714
& local_send_off_x+1 GPB0F403.2715
send_data_map(S_NUMBER_OF_ELEMENTS_IN_ITEM, GPB0F403.2716
& n_send_data)=1 GPB0F403.2717
send_data_map(S_STRIDE_IN_SEND_ARRAY,n_send_data)=1 GPB0F403.2718
send_data_map(S_ELEMENT_LENGTH,n_send_data)= GPB0F403.2719
& local_send_size_x GPB0F403.2720
send_data_map(S_BASE_ADDRESS_IN_RECV_ARRAY, GPB0F403.2721
& n_send_data)= GPB0F403.2722
& (work_dest_row_id-1)*global_sum_array_sizex + GPB0F403.2723
& pos_in_zonal_array GPB0F403.2724
send_data_map(S_STRIDE_IN_RECV_ARRAY,n_send_data)=1 GPB0F403.2725
GPB0F403.2726
! 2.8.3.1 If this processor is on LHS of the subarea, then it is GPB0F403.2727
! responsible for holding the final zonal mean values. GPB0F403.2728
! So we must set up a rec_means_map entry to allow the GPB0F403.2729
! zonal mean value for this row to be returned. GPB0F403.2730
GPB0F403.2731
IF (proc_x .EQ. proc_top_left_x) THEN GPB0F403.2732
GPB0F403.2733
n_rec_means = n_rec_means+1 GPB0F403.2734
GPB0F403.2735
rec_means_map(R_SOURCE_PE,n_rec_means)=dest_proc GPB0F403.2736
IF (fullfield) THEN ! We don't want halos GPB0F403.2737
rec_means_map(R_BASE_ADDRESS_IN_RECV_ARRAY, GPB0F403.2738
& n_rec_means)= GPB0F403.2739
& local_row-Offy GPB0F403.2740
ELSE ! halos are automatically removed GPB0F403.2741
rec_means_map(R_BASE_ADDRESS_IN_RECV_ARRAY, GPB0F403.2742
& n_rec_means)= GPB0F403.2743
& local_row GPB0F403.2744
ENDIF GPB0F403.2745
rec_means_map(R_NUMBER_OF_ELEMENTS_IN_ITEM, GPB0F403.2746
& n_rec_means)= 1 GPB0F403.2747
rec_means_map(R_STRIDE_IN_RECV_ARRAY, GPB0F403.2748
& n_rec_means)= 1 GPB0F403.2749
rec_means_map(R_ELEMENT_LENGTH,n_rec_means)=1 GPB0F403.2750
rec_means_map(R_BASE_ADDRESS_IN_SEND_ARRAY, GPB0F403.2751
& n_rec_means)= GPB0F403.2752
& work_dest_row_id GPB0F403.2753
rec_means_map(R_STRIDE_IN_SEND_ARRAY, GPB0F403.2754
& n_rec_means)=1 GPB0F403.2755
ENDIF GPB0F403.2756
GPB0F403.2757
ENDIF GPB0F403.2758
GPB0F403.2759
! 2.8.4 If this processor is dest_proc construct a rec_data_map GPB0F403.2760
! entry for this row of data GPB0F403.2761
GPB0F403.2762
IF (mype .EQ. dest_proc) THEN GPB0F403.2763
GPB0F403.2764
IF (proc_x .EQ. proc_top_left_x) GPB0F403.2765
! increment counter of full zonal rows on this processor GPB0F403.2766
& n_rows_full_zonal_data=n_rows_full_zonal_data+1 GPB0F403.2767
GPB0F403.2768
n_rec_data = n_rec_data+1 GPB0F403.2769
GPB0F403.2770
rec_data_map(R_SOURCE_PE,n_rec_data)= GPB0F403.2771
& proc_id GPB0F403.2772
rec_data_map(R_BASE_ADDRESS_IN_RECV_ARRAY,n_rec_data)= GPB0F403.2773
& (work_dest_row_id-1)*global_sum_array_sizex + GPB0F403.2774
& pos_in_zonal_array GPB0F403.2775
rec_data_map(R_NUMBER_OF_ELEMENTS_IN_ITEM,n_rec_data)= GPB0F403.2776
& 1 GPB0F403.2777
rec_data_map(R_STRIDE_IN_RECV_ARRAY,n_rec_data)=1 GPB0F403.2778
rec_data_map(R_ELEMENT_LENGTH,n_rec_data)= GPB0F403.2779
& local_send_size_x GPB0F403.2780
rec_data_map(R_BASE_ADDRESS_IN_SEND_ARRAY,n_rec_data)= GPB0F403.2781
& (local_row-1)*local_array_size_x + GPB0F403.2782
& local_send_off_x+1 GPB0F403.2783
rec_data_map(R_STRIDE_IN_SEND_ARRAY,n_rec_data)=1 GPB0F403.2784
GPB0F403.2785
! 2.8.4.1 Set up the send_means_map entry for sending the GPB0F403.2786
! resulting zonal mean of this row back to GPB0F403.2787
! the processor at the LHS of the subarea. GPB0F403.2788
! We only need to do this once per row (not for GPB0F403.2789
! each value of proc_x). GPB0F403.2790
GPB0F403.2791
IF (proc_x .EQ. proc_top_left_x) THEN GPB0F403.2792
GPB0F403.2793
n_send_means = n_send_means+1 GPB0F403.2794
GPB0F403.2795
send_means_map(S_DESTINATION_PE,n_send_means)= GPB0F403.2796
& proc_id GPB0F403.2797
send_means_map(S_BASE_ADDRESS_IN_SEND_ARRAY, GPB0F403.2798
& n_send_means)=work_dest_row_id GPB0F403.2799
send_means_map(S_NUMBER_OF_ELEMENTS_IN_ITEM, GPB0F403.2800
& n_send_means)=1 GPB0F403.2801
send_means_map(S_STRIDE_IN_SEND_ARRAY, GPB0F403.2802
& n_send_means)=1 GPB0F403.2803
send_means_map(S_ELEMENT_LENGTH,n_send_means)=1 GPB0F403.2804
IF (fullfield) THEN ! we don't want halos GPB0F403.2805
send_means_map(S_BASE_ADDRESS_IN_RECV_ARRAY, GPB0F403.2806
& n_send_means)=local_row-Offy GPB0F403.2807
ELSE ! halos are automatically removed GPB0F403.2808
send_means_map(S_BASE_ADDRESS_IN_RECV_ARRAY, GPB0F403.2809
& n_send_means)=local_row GPB0F403.2810
ENDIF GPB0F403.2811
send_means_map(S_STRIDE_IN_RECV_ARRAY, GPB0F403.2812
& n_send_means)=1 GPB0F403.2813
GPB0F403.2814
ENDIF ! if at LHS of subarea GPB0F403.2815
GPB0F403.2816
ENDIF ! if mype .eq. dest_proc GPB0F403.2817
GPB0F403.2818
ENDDO ! row : loop over local rows on proc_id GPB0F403.2819
ENDDO ! proc_x : loop over processors in x dimension GPB0F403.2820
ENDDO ! proc_y : loop over processors in y dimension GPB0F403.2821
GPB0F403.2822
! 3.0 Now the send and receive maps are set up, use GPB0F403.2823
! GCG_RALLTOALLE to redistribute the data GPB0F403.2824
! from the local_sum_arrays to the global_sum_arrays GPB0F403.2825
GPB0F403.2826
flag=GC_NONE ! flag argument is currently ignored by GCOM GPB0F403.2827
GPB0F403.2828
! We do a SHM_PUT operation, because the send arrays are non- GPB0F403.2829
! memory aligned, and the receiving arrays are. GPB0F403.2830
CALL GC_SETOPT(GC_SHM_DIR,GC_SHM_PUT,info) GPB0F403.2831
info=GC_NONE GPB0F403.2832
GPB0F403.2833
CALL GCG_RALLTOALLE( GPB0F403.2834
& local_sum_array_top , send_data_map , n_send_data , GPB0F403.2835
& local_sum_array_len , GPB0F403.2836
& global_sum_array_top , rec_data_map , n_rec_data , GPB0F403.2837
& global_sum_array_len , GPB0F403.2838
& gc_all_proc_group , flag , info) GPB0F403.2839
GPB0F403.2840
CALL GC_SETOPT(GC_SHM_DIR,GC_SHM_PUT,info) GPB0F403.2841
info=GC_NONE GPB0F403.2842
GPB0F403.2843
CALL GCG_RALLTOALLE( GPB0F403.2844
& local_sum_array_bot , send_data_map , n_send_data , GPB0F403.2845
& local_sum_array_len , GPB0F403.2846
& global_sum_array_bot , rec_data_map , n_rec_data , GPB0F403.2847
& global_sum_array_len , GPB0F403.2848
& gc_all_proc_group , flag , info) GPB0F403.2849
GPB0F403.2850
! 4.0 Calculate mean of any zonal data on this processor GPB0F403.2851
GPB0F403.2852
DO j=1,n_rows_full_zonal_data GPB0F403.2853
GPB0F403.2854
zonal_sum_top=0.0 GPB0F403.2855
zonal_sum_bot=0.0 GPB0F403.2856
GPB0F403.2857
DO i=global_xstart,global_xend GPB2F405.307
GPB0F403.2859
zonal_sum_top=zonal_sum_top+ GPB0F403.2860
& global_sum_array_top(i,j) GPB0F403.2861
zonal_sum_bot=zonal_sum_bot+ GPB0F403.2862
& global_sum_array_bot(i,j) GPB0F403.2863
ENDDO GPB0F403.2864
GPB0F403.2865
IF (zonal_sum_bot .EQ. 0.0) THEN GPB0F403.2866
zonal_mean_array(j)=rmdi GPB0F403.2867
ELSE GPB0F403.2868
zonal_mean_array(j)=zonal_sum_top/zonal_sum_bot GPB0F403.2869
ENDIF GPB0F403.2870
GPB0F403.2871
ENDDO GPB0F403.2872
GPB0F403.2873
! 5.0 Send the calculated means back to the processors on the GPB0F403.2874
! LHS of the subarea, into the fieldout array GPB0F403.2875
GPB0F403.2876
flag=GC_NONE ! flag argument is currently ignored by GCOM GPB0F403.2877
GPB0F403.2878
! We do a SHM_GET operation, because the send arrays are memory GPB0F403.2879
! aligned, but the receiving arrays are not. GPB0F403.2880
CALL GC_SETOPT(GC_SHM_DIR,GC_SHM_PUT,info) GPB0F403.2881
info=GC_NONE GPB0F403.2882
GPB0F403.2883
CALL GCG_RALLTOALLE( GPB0F403.2884
& zonal_mean_array , send_means_map , n_send_means , GPB0F403.2885
& global_sum_array_sizey, GPB0F403.2886
& fieldout , rec_means_map , n_rec_means, GPB0F403.2887
& (yend-ystart)+1, GPB0F403.2888
& gc_all_proc_group , flag , info) GPB0F403.2889
GPB0F403.2890
*ENDIF GPB0F403.2891
*ELSE GPB0F403.2892
GPB0F403.2893
! 0.0 : Initialise variables defining the size of the arrays GPB0F403.2894
! partial_sum_arrays GPB0F403.2895
partial_sum_array_sizey=vy*2 GPB2F405.308
GPB0F403.2898
GPB0F403.2899
! 1.0 Find the bounds of the actual data required in the summation GPB0F403.2900
! (ie. excluding the halos, contained within GPB0F403.2901
! xstart,xend,ystart,yend. GPB0F403.2902
GPB0F403.2903
CALL GLOBAL_TO_LOCAL_SUBDOMAIN(.FALSE.,.FALSE., GPB0F403.2904
& gr,mype, GPB0F403.2905
& global_ystart,global_xend, GPB0F403.2906
& global_yend,global_xstart, GPB0F403.2907
& local_sum_ystart,local_sum_xend, GPB0F403.2908
& local_sum_yend,local_sum_xstart) GPB0F403.2909
GPB0F403.2910
! 1.1 And the number of partial sums on this processor GPB0F403.2911
GPB0F403.2912
IF (local_sum_xstart .GT. local_sum_xend) GPB0F403.2913
& local_sum_xend=local_sum_xend+ROW_LENGTH-2*Offx GPB0F403.2914
GPB0F403.2915
partial_sum_data_sizey=local_sum_yend-local_sum_ystart+1 GPB0F403.2916
GPB0F403.2917
GPB0F403.2918
! 1.2 Initialise the sum arrays GPB0F403.2919
GPB0F403.2920
IF ((local_sum_ystart .NE. st_no_data) .AND. GPB0F403.2921
& (local_sum_yend .NE. st_no_data)) THEN GPB0F403.2922
GPB0F403.2923
DO j=ystart,yend GPB0F403.2924
partial_SUMZBOT(j)=0.0 GPB0F403.2925
partial_SUMZTOP(j)=0.0 GPB0F403.2926
ENDDO GPB0F403.2927
GPB0F403.2928
ENDIF GPB0F403.2929
GPB0F403.2930
! 2.0 Calculate the partial sums GPB0F403.2931
GPB0F403.2932
! Only do calculations if some of the subdomain exists on this GPB0F403.2933
! processor GPB0F403.2934
IF ( (local_sum_xstart .NE. st_no_data) .AND. GPB0F403.2935
& (local_sum_xend .NE. st_no_data) .AND. GPB0F403.2936
& (local_sum_ystart .NE. st_no_data) .AND. GPB0F403.2937
& (local_sum_yend .NE. st_no_data)) THEN GPB0F403.2938
GPB0F403.2939
! 2.2 Add do the actual sum GPB0F403.2940
GPB0F403.2941
DO i=local_sum_xstart,local_sum_xend GPB0F403.2942
GPB0F403.2943
IF ( lwrap .AND. (i .GT. (lasize(1)-Offx))) THEN GPB0F403.2944
ii=i-lasize(1)+2*Offx ! miss halos on wrap around GPB0F403.2945
ELSE GPB0F403.2946
ii=i GPB0F403.2947
ENDIF GPB0F403.2948
GPB0F403.2949
! Only do the sum if this is not a halo point GPB0F403.2950
GPB0F403.2951
DO j=local_sum_ystart,local_sum_yend GPB0F403.2952
IF (mask(ii,j)) THEN GPB0F403.2953
IF (.NOT. lmasswt) THEN GPB0F403.2954
GPB0F403.2955
partial_SUMZBOT(j)=partial_SUMZBOT(j)+ GPB0F403.2956
& pstar_weight(ii,j) GPB0F403.2957
partial_SUMZTOP(j)=partial_SUMZTOP(j)+ GPB0F403.2958
& fieldin(ii,j)*pstar_weight(ii,j) GPB0F403.2959
ELSE GPB0F403.2960
partial_SUMZBOT(j)=partial_SUMZBOT(j)- GPB0F403.2961
& (delta_ak+delta_bk*pstar_weight(ii,j)) GPB0F403.2962
partial_SUMZTOP(j)=partial_SUMZTOP(j)-fieldin(ii,j)* GPB0F403.2963
& (delta_ak+delta_bk*pstar_weight(ii,j)) GPB0F403.2964
ENDIF ! if (.NOT. lmasswt) GPB0F403.2965
ENDIF ! if this point is to be processed GPB0F403.2966
ENDDO ! j : loop over rows GPB0F403.2967
ENDDO ! i : loop over columns GPB0F403.2968
ENDIF ! if subdomain covers this processor GPB0F403.2969
GPB0F403.2970
! 3.0 Sums up the partial sums along each row to make a full sum GPB0F403.2971
GPB0F403.2972
! So a sum along the processor row if the subdomain covers any GPB0F403.2973
! processor(s) along the row GPB0F403.2974
GPB0F403.2975
IF ((local_sum_ystart .NE. st_no_data) .AND. GPB0F403.2976
& (local_sum_yend .NE. st_no_data)) THEN GPB0F403.2977
GPB0F403.2978
CALL GCG_RSUM(partial_sum_data_sizey,gc_proc_row_group, GPB0F403.2979
& info,partial_SUMZBOT(local_sum_ystart)) GPB0F403.2980
CALL GCG_RSUM(partial_sum_data_sizey,gc_proc_row_group, GPB0F403.2981
& info,partial_SUMZTOP(local_sum_ystart)) GPB0F403.2982
GPB0F403.2983
! So now the partial_* arrays actually contain the full sums GPB0F403.2984
! along the row GPB0F403.2985
GPB0F403.2986
! 3.1 And put the mean zonal values into the fieldout array GPB0F403.2987
GPB0F403.2988
! Only processors in the subdomain area need to record the GPB0F403.2989
! results GPB0F403.2990
IF ((local_sum_xstart .NE. st_no_data) .AND. GPB0F403.2991
& (local_sum_xend .NE. st_no_data)) THEN GPB0F403.2992
GPB0F403.2993
DO j=local_sum_ystart,local_sum_yend GPB0F403.2994
IF (partial_SUMZBOT(j) .EQ. 0.0) THEN GPB0F403.2995
fieldout(j)=rmdi GPB0F403.2996
ELSE GPB0F403.2997
fieldout(j)=partial_SUMZTOP(j)/partial_SUMZBOT(j) GPB0F403.2998
ENDIF GPB0F403.2999
ENDDO GPB0F403.3000
GPB0F403.3001
ENDIF ! is this processor in the subdomain GPB0F403.3002
GPB0F403.3003
ENDIF ! does the subdomain intersect with this processor row GPB0F403.3004
GPB0F403.3005
*ENDIF GPB0F403.3006
CL STZONM1A.450
999 CONTINUE STZONM1A.451
RETURN STZONM1A.452
END STZONM1A.453
*ENDIF STZONM1A.454