SUBROUTINE GATHER_ZONAL_FIELD ( 1GATZON1A.27
& LOCAL_FIELD , GLOBAL_FIELD , GATZON1A.28
& LOCAL_SIZE , GLOBAL_SIZE , GATZON1A.29
& LEVELS, GRID_TYPE , GATZON1A.30
& GATHER_PE) GATZON1A.31
GATZON1A.32
IMPLICIT NONE GATZON1A.33
GATZON1A.34
! Description: GATZON1A.35
! Takes a zonal field on a single processor, and decomposes it over GATZON1A.36
! many processors. GATZON1A.37
! GATZON1A.38
! Current code owner : P.Burton GATZON1A.39
! GATZON1A.40
! History GATZON1A.41
! Model Date Modification history from model version 4.3 GATZON1A.42
! version GATZON1A.43
! 4.4 20/05/97 New DECK created for MPP code. P.Burton GATZON1A.44
! Added special case for gridtype=43+44, GATZON1A.45
! ocean Mead diagnostics - no halos P.Burton GATZON1A.46
! GATZON1A.47
! Subroutine arguments: GATZON1A.48
GATZON1A.49
INTEGER GATZON1A.50
& LOCAL_SIZE ! IN: size of level of LOCAL_FIELD GATZON1A.51
&, GLOBAL_SIZE ! IN: size of level of GLOBAL FIELD GATZON1A.52
&, LEVELS ! IN: number of levels in field GATZON1A.53
&, GRID_TYPE ! IN: grid type of field GATZON1A.54
&, GATHER_PE ! IN: PE to gather GLOBAL_FIELD GATZON1A.55
GATZON1A.56
REAL GATZON1A.57
& LOCAL_FIELD(LOCAL_SIZE,LEVELS) ! IN : field to gather GATZON1A.58
&, GLOBAL_FIELD(GLOBAL_SIZE,LEVELS) ! OUT : gathered field GATZON1A.59
GATZON1A.60
GATZON1A.61
! Parameters and common blocks GATZON1A.62
GATZON1A.63
*CALL CPPXREF 
GATZON1A.64
*CALL GCCOM GATZON1A.65
GATZON1A.66
*CALL PARVARS GATZON1A.67
GATZON1A.68
! Local variables GATZON1A.69
GATZON1A.70
INTEGER GATZON1A.71
& fld_type ! type (P or U) of field GATZON1A.72
&, info ! GCOM return code GATZON1A.73
&, send_map(7,1) ! send map GATZON1A.74
&, receive_map(7,MAXPROC) ! receive map GATZON1A.75
&, flag ! GCOM dummy argument GATZON1A.76
&, n_mess_to_receive ! number of messages to receive GATZON1A.77
&, n_mess_to_send ! number of messages to send GATZON1A.78
&, k,iproc ! loop counter GATZON1A.79
GATZON1A.80
LOGICAL GATZON1A.81
& mead_fld ! indicates an ocean Mead diagnostic field GATZON1A.82
GATZON1A.83
GATZON1A.84
!==================================================================== GATZON1A.85
GATZON1A.86
IF ((grid_type .EQ. ppx_atm_tzonal) .OR. GATZON1A.87
& (grid_type .EQ. ppx_ocn_tzonal)) THEN GATZON1A.88
fld_type=fld_type_p GATZON1A.89
ELSE GATZON1A.90
fld_type=fld_type_u GATZON1A.91
ENDIF GATZON1A.92
GATZON1A.93
IF ((grid_type .EQ. ppx_ocn_uzonal) .OR. GATZON1A.94
& (grid_type .EQ. ppx_ocn_tzonal)) THEN GATZON1A.95
mead_fld=.TRUE. GATZON1A.96
ELSE GATZON1A.97
mead_fld=.FALSE. GATZON1A.98
ENDIF GATZON1A.99
GATZON1A.100
!-------------------------------------------------------------------- GATZON1A.101
GATZON1A.102
n_mess_to_receive=0 GATZON1A.103
GATZON1A.104
IF (mype .EQ. GATHER_PE) THEN GATZON1A.105
DO iproc=0,nproc-1 GATZON1A.106
IF (g_gridpos(1,iproc) .EQ. 0) THEN GATZON1A.107
! Only one processor per LPG row needs to send the data GATZON1A.108
! as it will be the same for each processor along the GATZON1A.109
! row. GATZON1A.110
receive_map(R_SOURCE_PE,n_mess_to_receive+1) = iproc GATZON1A.111
receive_map(R_BASE_ADDRESS_IN_RECV_ARRAY, GATZON1A.112
& n_mess_to_receive+1) = GATZON1A.113
& g_datastart(2,iproc) GATZON1A.114
receive_map(R_NUMBER_OF_ELEMENTS_IN_ITEM, GATZON1A.115
& n_mess_to_receive+1) = 1 GATZON1A.116
receive_map(R_STRIDE_IN_RECV_ARRAY, GATZON1A.117
& n_mess_to_receive+1) = 0 GATZON1A.118
IF (fld_type .EQ. fld_type_p) THEN GATZON1A.119
receive_map(R_ELEMENT_LENGTH,n_mess_to_receive+1) = GATZON1A.120
& g_blsizep(2,iproc) GATZON1A.121
ELSE GATZON1A.122
receive_map(R_ELEMENT_LENGTH,n_mess_to_receive+1) = GATZON1A.123
& g_blsizeu(2,iproc) GATZON1A.124
ENDIF GATZON1A.125
IF (mead_fld) THEN GATZON1A.126
receive_map(R_BASE_ADDRESS_IN_SEND_ARRAY, GATZON1A.127
& n_mess_to_receive+1) = 1 ! no halos for this field GATZON1A.128
ELSE GATZON1A.129
receive_map(R_BASE_ADDRESS_IN_SEND_ARRAY, GATZON1A.130
& n_mess_to_receive+1) = Offy+1 GATZON1A.131
ENDIF GATZON1A.132
receive_map(R_STRIDE_IN_SEND_ARRAY, GATZON1A.133
& n_mess_to_receive+1) = 0 GATZON1A.134
n_mess_to_receive=n_mess_to_receive+1 GATZON1A.135
ENDIF GATZON1A.136
ENDDO GATZON1A.137
ENDIF GATZON1A.138
GATZON1A.139
n_mess_to_send=0 GATZON1A.140
IF (atleft) THEN ! only processors at the left of the LPG will GATZON1A.141
! ! send anything GATZON1A.142
send_map(S_DESTINATION_PE,1) = 0 GATZON1A.143
IF (mead_fld) THEN GATZON1A.144
send_map(S_BASE_ADDRESS_IN_SEND_ARRAY,1) = 1 GATZON1A.145
ELSE GATZON1A.146
send_map(S_BASE_ADDRESS_IN_SEND_ARRAY,1) = Offy+1 GATZON1A.147
ENDIF GATZON1A.148
send_map(S_NUMBER_OF_ELEMENTS_IN_ITEM,1) = 1 GATZON1A.149
send_map(S_STRIDE_IN_SEND_ARRAY,1) = 0 GATZON1A.150
IF (fld_type .EQ. fld_type_p) THEN GATZON1A.151
send_map(S_ELEMENT_LENGTH,1) = blsizep(2) GATZON1A.152
ELSE GATZON1A.153
send_map(S_ELEMENT_LENGTH,1) = blsizeu(2) GATZON1A.154
ENDIF GATZON1A.155
send_map(S_BASE_ADDRESS_IN_RECV_ARRAY,1) = datastart(2) GATZON1A.156
send_map(S_STRIDE_IN_RECV_ARRAY,1) = 0 GATZON1A.157
GATZON1A.158
n_mess_to_send=1 GATZON1A.159
ENDIF GATZON1A.160
GATZON1A.161
info=GC_NONE GATZON1A.162
GATZON1A.163
CALL GC_SETOPT(GC_SHM_DIR,GC_SHM_PUT,info) ! set as gather GATZON1A.164
GATZON1A.165
GATZON1A.166
DO k=1,LEVELS GATZON1A.167
GATZON1A.168
info=GC_NONE GATZON1A.169
flag=GC_NONE GATZON1A.170
GATZON1A.171
IF (fld_type .EQ. fld_type_p) THEN GATZON1A.172
CALL GCG_RALLTOALLE( GATZON1A.173
& LOCAL_FIELD(1,k),send_map,n_mess_to_send,lasize(2), GATZON1A.174
& GLOBAL_FIELD(1,k),receive_map,n_mess_to_receive, GATZON1A.175
& glsize(2),GC_ALL_PROC_GROUP,flag,info) GATZON1A.176
ELSE GATZON1A.177
CALL GCG_RALLTOALLE( GATZON1A.178
& LOCAL_FIELD(1,k),send_map,n_mess_to_send,lasize(2), GATZON1A.179
& GLOBAL_FIELD(1,k),receive_map,n_mess_to_receive, GATZON1A.180
& glsize(2)-1,GC_ALL_PROC_GROUP,flag,info) GATZON1A.181
ENDIF GATZON1A.182
GATZON1A.183
ENDDO GATZON1A.184
GATZON1A.185
RETURN GATZON1A.186
GATZON1A.187
END GATZON1A.188
*ENDIF GATZON1A.189
*ENDIF GATZON1A.190