SUBROUTINE SCATTER_FIELD(LOCAL_FIELD,GLOBAL_FIELD, 62SCTFLD1A.23
& LOCAL_ROW_LEN,LOCAL_ROWS, SCTFLD1A.24
& GLOBAL_ROW_LEN,GLOBAL_ROWS, SCTFLD1A.25
& SCATTER_PE,PROC_GROUP, SCTFLD1A.26
& INFO) SCTFLD1A.27
SCTFLD1A.28
IMPLICIT NONE SCTFLD1A.29
SCTFLD1A.30
! SCTFLD1A.31
! Description: SCTFLD1A.32
! Takes a model field which is stored entirely on one processor SCTFLD1A.33
! and distributes it over a group of processors using the SCTFLD1A.34
! standard UM decomposition. SCTFLD1A.35
! SCTFLD1A.36
! Method: SCTFLD1A.37
! A send and receive map is constructed which instructs the GCOM SCTFLD1A.38
! permute operation to do a scatter to all processors in the SCTFLD1A.39
! group from the SCATTER_PE SCTFLD1A.40
! SCTFLD1A.41
! Current Code Owner: Paul Burton SCTFLD1A.42
! SCTFLD1A.43
! History: SCTFLD1A.44
! Model Date Modification history from model version 4.1 SCTFLD1A.45
! version SCTFLD1A.46
! 4.1 24/1/96 New DECK created for the Parallel Unified SCTFLD1A.47
! Model. P.Burton SCTFLD1A.48
! 4.2 17/10/96 Modify send/receive maps and change args to GPB2F402.216
! alltoall for GCOM/GCG v1.1 P.Burton GPB2F402.217
! 4.3 07/02/97 Correct INTENT of data arrays GPB3F403.99
! 4.4 06/08/97 Recalculate maps if decomposition has changed GPB1F404.106
! Paul Burton GPB1F404.107
! SCTFLD1A.49
! Subroutine Arguments: SCTFLD1A.50
SCTFLD1A.51
INTEGER SCTFLD1A.52
& LOCAL_ROW_LEN ! IN length of rows in local part of field SCTFLD1A.53
&, LOCAL_ROWS ! IN number of rows in local part of field SCTFLD1A.54
&, GLOBAL_ROW_LEN ! IN length of rows in global field SCTFLD1A.55
&, GLOBAL_ROWS ! IN number of rows in global field SCTFLD1A.56
&, SCATTER_PE ! IN processor to scatter global field from SCTFLD1A.57
&, PROC_GROUP ! IN group ID of processors involved here SCTFLD1A.58
&, INFO ! OUT return code from comms SCTFLD1A.59
SCTFLD1A.60
REAL SCTFLD1A.61
& LOCAL_FIELD(LOCAL_ROW_LEN*LOCAL_ROWS) SCTFLD1A.62
! ! OUT local part of field GPB3F403.100
&, GLOBAL_FIELD(GLOBAL_ROW_LEN*GLOBAL_ROWS) SCTFLD1A.64
! ! IN (on PE GATHER_PE) global field GPB3F403.101
SCTFLD1A.66
! Parameters and Common blocks SCTFLD1A.67
SCTFLD1A.68
*CALL PARVARS 
SCTFLD1A.69
*CALL GCCOM GPB2F402.218
SCTFLD1A.70
! Local variables SCTFLD1A.71
SCTFLD1A.72
INTEGER SCTFLD1A.73
& send_map(7,MAXPROC) GPB2F402.219
&, receive_map(7,1) GPB2F402.220
&, n_mess_to_send SCTFLD1A.76
SCTFLD1A.77
INTEGER SCTFLD1A.78
& old_GLOBAL_ROW_LEN ! value on last call SCTFLD1A.79
&, old_GLOBAL_ROWS ! value on last call SCTFLD1A.80
&, old_PROC_GROUP ! value on last call SCTFLD1A.81
&, old_SCATTER_PE ! value on last call SCTFLD1A.82
&, old_DECOMP ! value on last call GPB1F404.108
SCTFLD1A.83
SAVE send_map,receive_map,n_mess_to_send, SCTFLD1A.84
& old_GLOBAL_ROW_LEN,old_GLOBAL_ROWS,old_PROC_GROUP, SCTFLD1A.85
& old_SCATTER_PE,old_DECOMP GPB1F404.109
DATA old_GLOBAL_ROW_LEN,old_GLOBAL_ROWS,old_PROC_GROUP, SCTFLD1A.87
& old_SCATTER_PE,old_DECOMP GPB1F404.110
& / -1234, -1234, -1234, -1234, -1234/ GPB1F404.111
SCTFLD1A.90
INTEGER SCTFLD1A.91
& fld_type SCTFLD1A.92
&, iproc SCTFLD1A.93
&, flag SCTFLD1A.94
SCTFLD1A.95
!------------------------------------------------------- SCTFLD1A.96
SCTFLD1A.97
! 0.0 Can we use the same send/receive map that we calculated SCTFLD1A.98
! last time round? SCTFLD1A.99
SCTFLD1A.100
IF ((GLOBAL_ROW_LEN .NE. old_GLOBAL_ROW_LEN) .OR. SCTFLD1A.101
& (GLOBAL_ROWS .NE. old_GLOBAL_ROWS ) .OR. SCTFLD1A.102
& (PROC_GROUP .NE. old_PROC_GROUP ) .OR. SCTFLD1A.103
& (SCATTER_PE .NE. old_SCATTER_PE ) .OR. GPB1F404.112
& (current_decomp_type .NE. old_DECOMP )) THEN GPB1F404.113
! Different arguments from the last call so we need SCTFLD1A.105
! to calculate a new send/receive map SCTFLD1A.106
SCTFLD1A.107
! 1.0 Find the type of field (P or U) being done SCTFLD1A.108
SCTFLD1A.109
IF (GLOBAL_ROWS .EQ. glsize(2)) THEN SCTFLD1A.110
fld_type=fld_type_p SCTFLD1A.111
ELSEIF (GLOBAL_ROWS .EQ. glsize(2)-1) THEN SCTFLD1A.112
fld_type=fld_type_u SCTFLD1A.113
ELSE SCTFLD1A.114
WRITE(6,*) 'Bad field type in SCATTER_FIELD' SCTFLD1A.115
info=-1 SCTFLD1A.116
GOTO 9999 SCTFLD1A.117
ENDIF SCTFLD1A.118
SCTFLD1A.119
! 2.0 Set up the send map (for PE SCATTER_PE only) SCTFLD1A.120
SCTFLD1A.121
! Assume here that this group consists of all processors SCTFLD1A.122
! We'll get some new GCG functionality soon to improve this SCTFLD1A.123
SCTFLD1A.124
n_mess_to_send=0 SCTFLD1A.125
SCTFLD1A.126
IF (mype .EQ. SCATTER_PE) THEN SCTFLD1A.127
DO iproc=0,nproc-1 SCTFLD1A.128
send_map(S_DESTINATION_PE,iproc+1) = iproc GPB2F402.221
send_map(S_BASE_ADDRESS_IN_SEND_ARRAY,iproc+1) = GPB2F402.222
& g_datastart(1,iproc)+ GPB2F402.223
& (g_datastart(2,iproc)-1)*GLOBAL_ROW_LEN GPB2F402.224
IF (fld_type .EQ. fld_type_p) THEN SCTFLD1A.132
send_map(S_NUMBER_OF_ELEMENTS_IN_ITEM,iproc+1) = GPB2F402.225
& g_blsizep(2,iproc) GPB2F402.226
ELSE SCTFLD1A.134
send_map(S_NUMBER_OF_ELEMENTS_IN_ITEM,iproc+1) = GPB2F402.227
& g_blsizeu(2,iproc) GPB2F402.228
ENDIF SCTFLD1A.136
send_map(S_STRIDE_IN_SEND_ARRAY,iproc+1) = GLOBAL_ROW_LEN GPB2F402.229
send_map(S_ELEMENT_LENGTH,iproc+1) = g_blsizep(1,iproc) GPB2F402.230
send_map(S_BASE_ADDRESS_IN_RECV_ARRAY,iproc+1) = GPB2F402.231
& Offy*g_lasize(1,iproc)+Offx+1 GPB2F402.232
send_map(S_STRIDE_IN_RECV_ARRAY,iproc+1) = GPB2F402.233
& g_lasize(1,iproc) GPB2F402.234
ENDDO SCTFLD1A.141
n_mess_to_send=nproc SCTFLD1A.142
ENDIF SCTFLD1A.143
SCTFLD1A.144
! 3.0 Set up the receive map SCTFLD1A.145
SCTFLD1A.146
receive_map(R_SOURCE_PE,1) = SCATTER_PE GPB2F402.235
receive_map(R_BASE_ADDRESS_IN_RECV_ARRAY,1) = GPB2F402.236
& Offy*LOCAL_ROW_LEN+1+Offx GPB2F402.237
IF (atbase) THEN SCTFLD1A.149
IF (fld_type .EQ. fld_type_p) THEN SCTFLD1A.150
receive_map(R_NUMBER_OF_ELEMENTS_IN_ITEM,1) = GPB2F402.238
& LOCAL_ROWS-2*Offy GPB2F402.239
ELSE SCTFLD1A.152
receive_map(R_NUMBER_OF_ELEMENTS_IN_ITEM,1) = GPB2F402.240
& LOCAL_ROWS-2*Offy-1 GPB2F402.241
! One less row at the bottom of a U field SCTFLD1A.154
ENDIF SCTFLD1A.155
ELSE SCTFLD1A.156
receive_map(R_NUMBER_OF_ELEMENTS_IN_ITEM,1) = GPB2F402.242
& LOCAL_ROWS-2*Offy GPB2F402.243
ENDIF SCTFLD1A.158
receive_map(R_STRIDE_IN_RECV_ARRAY,1) = LOCAL_ROW_LEN GPB2F402.244
receive_map(R_ELEMENT_LENGTH,1) = LOCAL_ROW_LEN-2*Offx GPB2F402.245
receive_map(R_BASE_ADDRESS_IN_SEND_ARRAY,1) = GPB2F402.246
& datastart(1)+(datastart(2)-1)*GLOBAL_ROW_LEN GPB2F402.247
receive_map(R_STRIDE_IN_SEND_ARRAY,1) = GLOBAL_ROW_LEN GPB2F402.248
GPB2F402.249
SCTFLD1A.163
old_GLOBAL_ROW_LEN=GLOBAL_ROW_LEN SCTFLD1A.164
old_GLOBAL_ROWS=GLOBAL_ROWS SCTFLD1A.165
old_PROC_GROUP=PROC_GROUP SCTFLD1A.166
old_SCATTER_PE=SCATTER_PE SCTFLD1A.167
old_DECOMP=current_decomp_type GPB1F404.114
SCTFLD1A.168
ENDIF ! we need to recalculate send/receive maps. SCTFLD1A.169
SCTFLD1A.170
! 4.0 Do the exchange of data SCTFLD1A.171
SCTFLD1A.172
flag=GC_NONE ! This is currently ignored at GCG v1.1 GPB2F402.250
GPB2F402.251
CALL GC_SETOPT(GC_SHM_DIR,GC_SHM_GET,info) ! set as scatter GPB2F402.252
info=GC_NONE GPB2F402.253
SCTFLD1A.174
CALL GCG_RALLTOALLE(GLOBAL_FIELD,send_map,n_mess_to_send, SCTFLD1A.175
& GLOBAL_ROW_LEN*GLOBAL_ROWS, GPB2F402.254
& LOCAL_FIELD,receive_map,1, SCTFLD1A.177
& LOCAL_ROW_LEN*LOCAL_ROWS, GPB2F402.255
& PROC_GROUP,flag,info) SCTFLD1A.179
SCTFLD1A.180
9999 CONTINUE SCTFLD1A.181
SCTFLD1A.182
RETURN SCTFLD1A.183
END SCTFLD1A.184
*ENDIF SCTFLD1A.185
*ENDIF GPB3F403.280