SUBROUTINE STGLOM(fieldin,vx,vy,vz,st_grid,gr,lwrap,lmasswt, 1,4GPB0F403.541
& xstart,ystart,xend,yend, STGLOM1A.31
*IF DEF,MPP GPB0F403.542
& global_xstart,global_ystart, GPB0F403.543
& global_xend,global_yend, GPB0F403.544
*ENDIF GPB0F403.545
& fieldout,index_lev,level_list,zsize, STGLOM1A.32
& pstar_weight,delta_ak,delta_bk, GPB0F403.546
& area_weight,mask, GPB0F403.547
& row_length,p_rows, GPB0F403.548
& level_code,mask_code,weight_code,rmdi, STGLOM1A.36
& icode,cmessage) STGLOM1A.37
C STGLOM1A.38
IMPLICIT NONE STGLOM1A.39
C STGLOM1A.40
INTEGER STGLOM1A.41
& vx,vy,vz, ! IN input field size STGLOM1A.42
& st_grid, ! IN STASH grdtype code STGLOM1A.43
& gr, ! IN input fld grid GPB0F403.549
& xstart,ystart, ! IN lower LH corner STGLOM1A.44
& xend,yend, ! IN upper RH corner STGLOM1A.45
*IF DEF,MPP GPB0F403.550
& global_xstart,global_ystart, ! IN global versions of GPB0F403.551
& global_xend, global_yend, ! IN xstart etc. GPB0F403.552
*ENDIF GPB0F403.553
& zsize, ! IN no of horiz levels to process STGLOM1A.46
& index_lev(zsize), ! IN offset for each horiz lev STGLOM1A.47
& level_list(zsize), ! IN model level at each horiz lev STGLOM1A.48
& row_length,p_rows, ! IN primary dimensions GPB0F403.554
& level_code, ! IN input level code STGLOM1A.50
& mask_code, ! IN masking code STGLOM1A.51
& weight_code, ! IN weighting code STGLOM1A.52
& icode ! OUT error return code STGLOM1A.53
CHARACTER*(*) STGLOM1A.54
& cmessage ! OUT error return msg STGLOM1A.55
LOGICAL STGLOM1A.56
& lwrap, ! IN TRUE if wraparound STGLOM1A.57
& lmasswt, ! IN TRUE if masswts OK TJ170993.223
& mask(row_length,p_rows) ! IN mask array GPB0F403.555
REAL STGLOM1A.59
& fieldin(vx,vy,vz), ! IN input field STGLOM1A.60
& fieldout(1), ! OUT output field STGLOM1A.61
& pstar_weight(row_length,p_rows), ! IN pstar mass weight GPB0F403.556
& delta_ak(*), ! IN hybrid coordinates STGLOM1A.64
& delta_bk(*), ! IN hybrid coordinates STGLOM1A.65
& area_weight(row_length,p_rows), ! IN area weighting GPB0F403.557
! (already interpolated to the correct grid and GPB0F403.558
! set to 1.0 where no area weighting is required) GPB0F403.559
& rmdi ! IN missing data indic STGLOM1A.68
C*---------------------------------------------------------------------- STGLOM1A.69
C STGLOM1A.70
C External subroutines called STGLOM1A.71
C STGLOM1A.72
C STGLOM1A.74
*CALL STPARAM 
STGLOM1A.75
*CALL STERR STGLOM1A.76
C STGLOM1A.77
C Local variables STGLOM1A.78
C STGLOM1A.79
INTEGER i,ii,j,k,kk ! ARRAY INDICES FOR VARIABLE STGLOM1A.80
integer level ! value of level STGLOM1A.81
STGLOM1A.82
*IF DEF,MPP GPB0F403.560
GPB0F403.561
*CALL PARVARS GPB0F403.562
GPB0F403.563
GPB0F403.564
*IF DEF,REPROD GPB0F403.565
GPB0F403.566
GPB0F403.567
INTEGER GPB0F403.568
! Co-ords to PE at top left of subarea GPB0F403.569
& proc_top_left_x , proc_top_left_y GPB0F403.570
GPB0F403.571
! unused return values from GLOBAL_TO_LOCAL_RC GPB0F403.572
&, dummy1 , dummy2 GPB0F403.573
GPB0F403.574
! PE number of PE at top left of subarea GPB0F403.575
&, sum_pe GPB0F403.576
GPB0F403.577
! size of local and global arrays GPB0F403.578
&, local_size,global_size GPB0F403.579
GPB0F403.580
! Weighted version of fieldin GPB0F403.581
REAL local_sum_array_top(xstart:xend,ystart:yend) GPB0F403.582
! Weights applied to fieldin GPB0F403.583
REAL local_sum_array_bot(xstart:xend,ystart:yend) GPB0F403.584
GPB0F403.585
*ELSE GPB0F403.586
GPB0F403.587
INTEGER GPB0F403.588
! limits of local data to be summed GPB0F403.589
& local_sum_xstart,local_sum_xend GPB0F403.590
&, local_sum_ystart,local_sum_yend GPB0F403.591
GPB0F403.592
! return code from GCOM routines GPB0F403.593
&, info GPB0F403.594
GPB0F403.595
*ENDIF GPB0F403.596
GPB0F403.597
GPB0F403.600
*IF DEF,REPROD GPB0F403.601
INTEGER GPB0F403.602
! Sizes of the global_sum_arrays defined below GPB2F405.212
& global_sum_array_sizex,global_sum_array_sizey GPB0F403.606
GPB0F403.607
REAL GPB0F403.616
! Collected versions of fieldin and the weights containing GPB0F403.617
! whole (subarea) columns of meridional data GPB0F403.618
& global_sum_array_top(global_xstart:global_xend, GPB2F405.213
& global_ystart:global_yend) GPB2F405.214
&, global_sum_array_bot(global_xstart:global_xend, GPB2F405.215
& global_ystart:global_yend) GPB2F405.216
GPB0F403.623
*ELSE GPB0F403.633
GPB0F403.634
! sum(1) is equivalenced to SUMGBOT GPB0F403.635
! sum(2) is equivalenced to SUMGTOP GPB0F403.636
REAL sum(2) GPB0F403.638
GPB0F403.639
EQUIVALENCE GPB0F403.640
& (sum(1) , SUMGBOT ) , (sum(2) , SUMGTOP) GPB2F405.217
GPB0F403.643
*ENDIF GPB0F403.644
GPB0F403.645
*ENDIF GPB0F403.646
GPB0F403.647
REAL SUMGTOP STGLOM1A.85
REAL SUMGBOT STGLOM1A.86
STGLOM1A.87
CL---------------------------------------------------------------------- STGLOM1A.88
CL 0. Initialise sums STGLOM1A.89
CL STGLOM1A.90
SUMGTOP=0.0 STGLOM1A.91
SUMGBOT=0.0 STGLOM1A.92
CL---------------------------------------------------------------------- STGLOM1A.93
*IF -DEF,MPP,OR,DEF,REPROD GPB0F403.657
*IF -DEF,MPP GPB0F403.658
! Sum up weighted versions of fieldin array GPB0F403.659
*ELSE GPB0F403.660
! Create arrays of weighted data suitable to be summed GPB0F403.661
*ENDIF GPB0F403.662
GPB0F403.663
*IF DEF,MPP GPB0F403.664
! Only do the calculations if some of the subarea is contained GPB0F403.665
! within this processor GPB0F403.666
IF ((xstart .NE. st_no_data) .AND. (xend .NE. st_no_data) .AND. GPB0F403.667
& (ystart .NE. st_no_data) .AND. (yend .NE. st_no_data)) THEN GPB0F403.668
GPB0F403.669
*ENDIF GPB0F403.670
GPB0F403.671
DO kk=1,zsize GPB0F403.672
k=index_lev(kk) STGLOM1A.153
level=level_list(kk) GPB0F403.673
GPB0F403.674
DO i=xstart,xend STGLOM1A.154
*IF -DEF,MPP GPB0F403.675
IF (lwrap) THEN STGLOM1A.155
ii=1+MOD(i-1,vx) GPB0F403.676
ELSE STGLOM1A.157
ii=i STGLOM1A.158
ENDIF STGLOM1A.159
*ELSE GPB0F403.677
IF ( lwrap .AND. (i .GT. (lasize(1)-Offx))) THEN GPB0F403.678
ii=i-lasize(1)+2*Offx ! miss halos on wrap around GPB0F403.679
ELSE GPB0F403.680
ii=i GPB0F403.681
ENDIF GPB0F403.682
*ENDIF GPB0F403.683
DO j=ystart,yend STGLOM1A.160
*IF DEF,MPP GPB0F403.684
GPB0F403.685
IF (kk .EQ. 1) THEN GPB0F403.686
local_sum_array_bot(i,j)=0.0 GPB0F403.687
local_sum_array_top(i,j)=0.0 GPB0F403.688
ENDIF GPB0F403.689
GPB0F403.690
*ENDIF GPB0F403.691
IF (mask(ii,j)) THEN GPB0F403.692
IF (.NOT. lmasswt) THEN GPB0F403.693
*IF -DEF,MPP GPB0F403.694
SUMGBOT=SUMGBOT+ GPB0F403.695
& pstar_weight(ii,j)*area_weight(ii,j) GPB0F403.696
SUMGTOP=SUMGTOP+ GPB0F403.697
& fieldin(ii,j,k)*pstar_weight(ii,j)* GPB0F403.698
& area_weight(ii,j) GPB0F403.699
*ELSE GPB0F403.700
local_sum_array_bot(i,j)=local_sum_array_bot(i,j)+ GPB0F403.701
& pstar_weight(ii,j)*area_weight(ii,j) GPB0F403.702
local_sum_array_top(i,j)=local_sum_array_top(i,j)+ GPB0F403.703
& fieldin(ii,j,k)*pstar_weight(ii,j)* GPB0F403.704
& area_weight(ii,j) GPB0F403.705
*ENDIF GPB0F403.706
ELSE GPB0F403.707
*IF -DEF,MPP GPB0F403.708
SUMGBOT=SUMGBOT- GPB0F403.709
& (delta_ak(level)+delta_bk(level)* GPB0F403.710
& pstar_weight(ii,j))*area_weight(ii,j) GPB0F403.711
SUMGTOP=SUMGTOP-fieldin(ii,j,k)* GPB0F403.712
& (delta_ak(level)+delta_bk(level)* GPB0F403.713
& pstar_weight(ii,j))*area_weight(ii,j) GPB0F403.714
*ELSE GPB0F403.715
local_sum_array_bot(i,j)=local_sum_array_bot(i,j)- GPB0F403.716
& (delta_ak(level)+delta_bk(level)* GPB0F403.717
& pstar_weight(ii,j))*area_weight(ii,j) GPB0F403.718
local_sum_array_top(i,j)=local_sum_array_top(i,j)- GPB0F403.719
& fieldin(ii,j,k)* GPB0F403.720
& (delta_ak(level)+delta_bk(level)* GPB0F403.721
& pstar_weight(ii,j))*area_weight(ii,j) GPB0F403.722
*ENDIF GPB0F403.723
ENDIF GPB0F403.724
ENDIF GPB0F403.725
ENDDO STGLOM1A.163
ENDDO STGLOM1A.164
ENDDO GPB0F403.726
GPB0F403.727
*IF DEF,MPP GPB0F403.728
ENDIF ! if this processor contains any of the subarea GPB0F403.729
*ENDIF GPB0F403.730
GPB0F403.731
GPB0F403.732
*IF -DEF,MPP GPB0F403.733
IF (SUMGBOT .EQ. 0.0) THEN GPB0F403.734
fieldout(1)=rmdi STGLOM1A.367
ELSE STGLOM1A.368
fieldout(1)=SUMGTOP/SUMGBOT STGLOM1A.369
ENDIF STGLOM1A.370
GPB0F403.735
*ELSE GPB0F403.736
GPB0F404.285
! Initialise fieldout - so all PE's have valid data GPB0F404.286
! (Only PEs on top left of subdomain get the field mean) GPB0F404.287
GPB0F404.288
fieldout(1)=0.0 GPB0F404.289
GPB0F404.290
GPB0F403.737
! The local_sum_arrays must be distributed so that the complete GPB0F403.738
! sub-area exists on a single processor, so that a reproducible sum GPB0F403.739
! can be carried out. GPB0F403.740
GPB0F403.741
! 0.0 : Initialise variables defining the size of the arrays GPB0F403.742
! global_sum_arrays GPB0F403.743
GPB0F403.744
global_sum_array_sizex=global_xend-global_xstart+1 GPB2F405.218
global_sum_array_sizey=global_yend-global_ystart+1 GPB2F405.219
GPB0F403.748
! 1.0 Gather the fields to a single processor GPB0F403.749
GPB0F403.750
CALL GLOBAL_TO_LOCAL_RC(gr, GPB0F403.751
& global_xstart , global_ystart, GPB0F403.752
& proc_top_left_x, proc_top_left_y, GPB0F403.753
& dummy1,dummy2) GPB0F403.754
GPB0F403.755
sum_pe=proc_top_left_x + nproc_x*proc_top_left_y GPB0F405.12
GPB0F403.757
local_size=(xend-xstart+1)*(yend-ystart+1) GPB0F403.758
global_size=global_sum_array_sizex*global_sum_array_sizey GPB0F403.759
GPB0F403.760
CALL STASH_GATHER_FIELD ( GPB0F403.761
& local_sum_array_top , global_sum_array_top , GPB0F403.762
& local_size , global_size, GPB0F403.763
& 1, ! 1 level GPB0F403.764
& global_ystart, global_xend, global_yend, global_xstart, GPB0F403.765
& gr , sum_pe, GPB0F403.766
& .TRUE., ! data has been extracted GPB0F403.767
& ICODE,CMESSAGE) GPB0F403.768
GPB0F403.769
IF (ICODE .NE. 0) THEN GPB0F403.770
WRITE(6,*) 'STFIELDM : MPP Error in STASH_GATHER_FIELD' GPB0F403.771
WRITE(6,*) CMESSAGE GPB0F403.772
GOTO 999 GPB0F403.773
ENDIF GPB0F403.774
GPB0F403.775
CALL STASH_GATHER_FIELD ( GPB0F403.776
& local_sum_array_bot , global_sum_array_bot , GPB0F403.777
& local_size , global_size, GPB0F403.778
& 1, ! 1 level GPB0F403.779
& global_ystart, global_xend, global_yend, global_xstart, GPB0F403.780
& gr , sum_pe, GPB0F403.781
& .TRUE., ! data has been extracted GPB0F403.782
& ICODE,CMESSAGE) GPB0F403.783
GPB0F403.784
IF (ICODE .NE. 0) THEN GPB0F403.785
WRITE(6,*) 'STFIELDM : MPP Error in STASH_GATHER_FIELD' GPB0F403.786
WRITE(6,*) CMESSAGE GPB0F403.787
GOTO 999 GPB0F403.788
ENDIF GPB0F403.789
GPB0F403.790
! 2.0 Calculate the sums GPB0F403.791
GPB0F403.792
IF (mype .EQ. sum_pe) THEN GPB0F403.793
GPB0F403.794
DO i=global_xstart,global_xend GPB2F405.220
DO j=global_ystart,global_yend GPB2F405.221
SUMGTOP=SUMGTOP+global_sum_array_top(i,j) GPB2F405.222
SUMGBOT=SUMGBOT+global_sum_array_bot(i,j) GPB2F405.223
ENDDO GPB0F403.801
ENDDO GPB0F403.802
GPB0F403.803
IF (SUMGBOT .EQ. 0.0) THEN GPB0F403.804
fieldout=rmdi GPB0F403.805
ELSE GPB0F403.806
fieldout=SUMGTOP/SUMGBOT GPB0F403.807
ENDIF GPB0F403.808
GPB0F403.809
ENDIF GPB0F403.810
GPB0F403.811
*ENDIF GPB0F403.812
*ELSE GPB0F403.813
GPB0F403.814
! 1.0 Find the bounds of the actual data required in the summation GPB0F403.815
! (ie. excluding the halos, contained within GPB0F403.816
! xstart,xend,ystart,yend. GPB0F403.817
GPB0F403.818
CALL GLOBAL_TO_LOCAL_SUBDOMAIN(.FALSE.,.FALSE., GPB0F403.819
& gr,mype, GPB0F403.820
& global_ystart,global_xend, GPB0F403.821
& global_yend,global_xstart, GPB0F403.822
& local_sum_ystart,local_sum_xend, GPB0F403.823
& local_sum_yend,local_sum_xstart) GPB0F403.824
GPB0F403.825
IF (local_sum_xstart .GT. local_sum_xend) GPB0F403.826
& local_sum_xend=local_sum_xend+ROW_LENGTH-2*Offx GPB0F403.827
GPB0F403.828
! 2.0 Calculate the partial sums GPB0F403.829
GPB0F403.830
! Only do the calculations if some of the subdomain exists on this GPB0F403.831
! processor GPB0F403.832
GPB0F403.833
IF ( (local_sum_xstart .NE. st_no_data) .AND. GPB0F403.834
& (local_sum_xend .NE. st_no_data) .AND. GPB0F403.835
& (local_sum_ystart .NE. st_no_data) .AND. GPB0F403.836
& (local_sum_yend .NE. st_no_data)) THEN GPB0F403.837
GPB0F403.838
! 2.2 Do the actual sum GPB0F403.839
GPB0F403.840
DO kk=1,zsize GPB0F403.841
GPB0F403.842
k=index_lev(kk) GPB0F403.843
level=level_list(kk) GPB0F403.844
GPB0F403.845
DO i=local_sum_xstart,local_sum_xend GPB0F403.846
GPB0F403.847
IF ( lwrap .AND. (i .GT. (lasize(1)-Offx))) THEN GPB0F403.848
ii=i-lasize(1)+2*Offx ! miss halos on wrap around GPB0F403.849
ELSE GPB0F403.850
ii=i GPB0F403.851
ENDIF GPB0F403.852
GPB0F403.853
DO j=local_sum_ystart,local_sum_yend GPB0F403.854
IF (mask(ii,j)) THEN GPB0F403.855
IF (.NOT. lmasswt) THEN GPB0F403.856
GPB0F403.857
SUMGBOT=SUMGBOT+ GPB0F404.291
& pstar_weight(ii,j)*area_weight(ii,j) GPB0F403.859
SUMGTOP=SUMGTOP+ GPB0F403.860
& fieldin(ii,j,k)*pstar_weight(ii,j)* GPB0F403.861
& area_weight(ii,j) GPB0F403.862
ELSE GPB0F403.863
SUMGBOT=SUMGBOT- GPB0F403.864
& (delta_ak(level)+delta_bk(level)* GPB0F403.865
& pstar_weight(ii,j))*area_weight(ii,j) GPB0F403.866
SUMGTOP= GPB0F403.867
& SUMGTOP-fieldin(ii,j,k)* GPB0F403.868
& (delta_ak(level)+delta_bk(level)* GPB0F403.869
& pstar_weight(ii,j))*area_weight(ii,j) GPB0F403.870
ENDIF ! if (.NOT. lmasswt) GPB0F403.871
ENDIF ! if this point is to be processed GPB0F403.872
ENDDO ! j : loop over rows GPB0F403.873
ENDDO ! i : loop over columns GPB0F403.874
ENDDO ! kk : loop over levels GPB0F403.875
ENDIF ! if subdomain covers this processor GPB0F403.876
GPB0F403.877
! 3.0 add all the partial sums together, and store GPB0F403.878
GPB0F403.879
! sum(1) is equivalenced to SUMGTOP GPB0F403.880
! sum(2) is equivalenced to SUMGBOT GPB0F403.881
GPB0F403.882
CALL GC_RSUM(2,nproc,info,sum) GPB0F403.883
GPB0F403.884
IF ( (local_sum_xstart .NE. st_no_data) .AND. GPB0F403.885
& (local_sum_xend .NE. st_no_data) .AND. GPB0F403.886
& (local_sum_ystart .NE. st_no_data) .AND. GPB0F403.887
& (local_sum_yend .NE. st_no_data)) THEN GPB0F403.888
GPB0F403.889
IF (SUMGBOT .EQ. 0.0) THEN GPB0F403.890
fieldout=rmdi GPB0F403.891
ELSE GPB0F403.892
fieldout=SUMGTOP/SUMGBOT GPB0F403.893
ENDIF GPB0F403.894
ENDIF GPB0F403.895
GPB0F403.896
*ENDIF GPB0F403.897
999 CONTINUE STGLOM1A.372
RETURN STGLOM1A.373
END STGLOM1A.374
*ENDIF STGLOM1A.375