SUBROUTINE GATHER_FIELD(LOCAL_FIELD,GLOBAL_FIELD, 130GATFLD1A.23
& LOCAL_ROW_LEN,LOCAL_ROWS, GATFLD1A.24
& GLOBAL_ROW_LEN,GLOBAL_ROWS, GATFLD1A.25
& GATHER_PE,PROC_GROUP, GATFLD1A.26
& INFO) GATFLD1A.27
GATFLD1A.28
IMPLICIT NONE GATFLD1A.29
GATFLD1A.30
! GATFLD1A.31
! Description: GATFLD1A.32
! Takes a model field that has been decomposed over a group of GATFLD1A.33
! processors, and gathers the data together so that one processor GATFLD1A.34
! contains the entire global field. GATFLD1A.35
! GATFLD1A.36
! Method: GATFLD1A.37
! A send and receive map is constructed which instructs the GCOM GATFLD1A.38
! permute operation to do a gather from all processors in the GATFLD1A.39
! group to the GATHER_PE GATFLD1A.40
! GATFLD1A.41
! Current Code Owner: Paul Burton GATFLD1A.42
! GATFLD1A.43
! History: GATFLD1A.44
! Model Date Modification history from model version 4.1 GATFLD1A.45
! version GATFLD1A.46
! 4.1 22/1/96 New DECK created for the Parallel Unified GATFLD1A.47
! Model. P.Burton GATFLD1A.48
! 4.2 17/10/96 Modify send/receive maps and change args to GPB2F402.27
! alltoall for GCOM/GCG v1.1 P.Burton GPB2F402.28
! 4.4 06/08/97 Recalculate maps if decomposition has changed GPB1F404.115
! Paul Burton GPB1F404.116
! GATFLD1A.49
! Subroutine Arguments: GATFLD1A.50
GATFLD1A.51
INTEGER GATFLD1A.52
& LOCAL_ROW_LEN ! IN length of rows in local part of field GATFLD1A.53
&, LOCAL_ROWS ! IN number of rows in local part of field GATFLD1A.54
&, GLOBAL_ROW_LEN ! IN length of rows in global field GATFLD1A.55
&, GLOBAL_ROWS ! IN number of rows in global field GATFLD1A.56
&, GATHER_PE ! IN processor to gather global field to GATFLD1A.57
&, PROC_GROUP ! IN group ID of processors involved here GATFLD1A.58
&, INFO ! OUT return code from comms GATFLD1A.59
GATFLD1A.60
REAL GATFLD1A.61
& LOCAL_FIELD(LOCAL_ROW_LEN*LOCAL_ROWS) GATFLD1A.62
! ! IN local part of field GATFLD1A.63
&, GLOBAL_FIELD(GLOBAL_ROW_LEN*GLOBAL_ROWS) GATFLD1A.64
! ! OUT (on PE GATHER_PE) global field GATFLD1A.65
GATFLD1A.66
! Parameters and Common blocks GATFLD1A.67
GATFLD1A.68
*CALL PARVARS 
GATFLD1A.69
*CALL GCCOM GPB2F402.29
GATFLD1A.70
! Local variables GATFLD1A.71
GATFLD1A.72
INTEGER GATFLD1A.73
& send_map(7,1) GPB2F402.30
&, receive_map(7,MAXPROC) GPB2F402.31
&, n_mess_to_rec GATFLD1A.76
GATFLD1A.77
INTEGER GATFLD1A.78
& old_GLOBAL_ROW_LEN ! value on last call GATFLD1A.79
&, old_GLOBAL_ROWS ! value on last call GATFLD1A.80
&, old_PROC_GROUP ! value on last call GATFLD1A.81
&, old_GATHER_PE ! value on last call GATFLD1A.82
&, old_DECOMP ! value on last call GPB1F404.117
GATFLD1A.83
SAVE send_map,receive_map,n_mess_to_rec, GATFLD1A.84
& old_GLOBAL_ROW_LEN,old_GLOBAL_ROWS,old_PROC_GROUP, GATFLD1A.85
& old_GATHER_PE,old_DECOMP GPB1F404.118
DATA old_GLOBAL_ROW_LEN,old_GLOBAL_ROWS,old_PROC_GROUP, GATFLD1A.87
& old_GATHER_PE,old_DECOMP GPB1F404.119
& / -1234, -1234, -1234, -1234, -1234/ GPB1F404.120
GATFLD1A.90
INTEGER GATFLD1A.91
& fld_type GATFLD1A.92
&, iproc GATFLD1A.93
&, flag GATFLD1A.94
GATFLD1A.95
!------------------------------------------------------- GATFLD1A.96
GATFLD1A.97
! 0.0 Can we use the same send/receive map that we calculated GATFLD1A.98
! last time round? GATFLD1A.99
GATFLD1A.100
IF ((GLOBAL_ROW_LEN .NE. old_GLOBAL_ROW_LEN) .OR. GATFLD1A.101
& (GLOBAL_ROWS .NE. old_GLOBAL_ROWS ) .OR. GATFLD1A.102
& (PROC_GROUP .NE. old_PROC_GROUP ) .OR. GATFLD1A.103
& (GATHER_PE .NE. old_GATHER_PE ) .OR. GPB1F404.121
& (current_decomp_type .NE. old_DECOMP )) THEN GPB1F404.122
! Different arguments from the last call so we need GATFLD1A.105
! to calculate a new send/receive map GATFLD1A.106
GATFLD1A.107
! 1.0 Find the type of field (P or U) being done GATFLD1A.108
GATFLD1A.109
IF (GLOBAL_ROWS .EQ. glsize(2)) THEN GATFLD1A.110
fld_type=fld_type_p GATFLD1A.111
ELSEIF (GLOBAL_ROWS .EQ. glsize(2)-1) THEN GATFLD1A.112
fld_type=fld_type_u GATFLD1A.113
ELSE GATFLD1A.114
WRITE(6,*) 'Bad field type in GATHER_FIELD' GATFLD1A.115
info=-1 GATFLD1A.116
GOTO 9999 GATFLD1A.117
ENDIF GATFLD1A.118
GATFLD1A.119
GATFLD1A.120
! 2.0 Set up send map GATFLD1A.121
GATFLD1A.122
send_map(S_DESTINATION_PE,1) = GATHER_PE GPB2F402.32
! processor to send to GPB2F402.33
GPB2F402.34
send_map(S_BASE_ADDRESS_IN_SEND_ARRAY,1) = GPB2F402.35
& Offy*LOCAL_ROW_LEN+1+Offx GPB2F402.36
! first data to send GPB2F402.37
GPB2F402.38
IF (atbase) THEN GATFLD1A.125
IF (fld_type .EQ. fld_type_p) THEN GATFLD1A.126
send_map(S_NUMBER_OF_ELEMENTS_IN_ITEM,1)=LOCAL_ROWS-2*Offy GPB2F402.39
! number of rows GPB2F402.40
GPB2F402.41
ELSE GATFLD1A.128
send_map(S_NUMBER_OF_ELEMENTS_IN_ITEM,1)=LOCAL_ROWS-2*Offy-1 GPB2F402.42
GPB2F402.43
! One less row at the bottom of a U field GATFLD1A.130
ENDIF GATFLD1A.131
ELSE GATFLD1A.132
send_map(S_NUMBER_OF_ELEMENTS_IN_ITEM,1) = LOCAL_ROWS-2*Offy GPB2F402.44
! number of rows GPB2F402.45
GPB2F402.46
ENDIF GATFLD1A.134
send_map(S_STRIDE_IN_SEND_ARRAY,1) = LOCAL_ROW_LEN GPB2F402.47
! stride between row starts GPB2F402.48
GPB2F402.49
send_map(S_ELEMENT_LENGTH,1) = LOCAL_ROW_LEN-2*Offx GPB2F402.50
! length of local row minus halos GPB2F402.51
GPB2F402.52
send_map(S_BASE_ADDRESS_IN_RECV_ARRAY,1) = GPB2F402.53
& datastart(1)+(datastart(2)-1)*GLOBAL_ROW_LEN GPB2F402.54
! start position in global data of this local data GPB2F402.55
GPB2F402.56
send_map(S_STRIDE_IN_RECV_ARRAY,1) = GLOBAL_ROW_LEN GPB2F402.57
! stride between rows in global data GPB2F402.58
GPB2F402.59
GATFLD1A.142
! 3.0 Set up the receive map (for PE GATHER_PE only) GATFLD1A.143
GATFLD1A.144
! Assume here that this group consists of all processors GATFLD1A.145
! We'll get some new GCG functionality soon to improve this GATFLD1A.146
GATFLD1A.147
n_mess_to_rec=0 GATFLD1A.148
GATFLD1A.149
IF (mype .EQ. GATHER_PE) THEN GATFLD1A.150
DO iproc=0,nproc-1 GATFLD1A.151
receive_map(R_SOURCE_PE,iproc+1) = iproc GPB2F402.60
GPB2F402.61
receive_map(R_BASE_ADDRESS_IN_RECV_ARRAY,iproc+1) = GPB2F402.62
& g_datastart(1,iproc)+(g_datastart(2,iproc)-1)*glsize(1) GPB2F402.63
GPB2F402.64
IF (fld_type .EQ. fld_type_p) THEN GATFLD1A.155
receive_map(R_NUMBER_OF_ELEMENTS_IN_ITEM,iproc+1) = GPB2F402.65
& g_blsizep(2,iproc) GPB2F402.66
GPB2F402.67
ELSE GATFLD1A.157
receive_map(R_NUMBER_OF_ELEMENTS_IN_ITEM,iproc+1) = GPB2F402.68
& g_blsizeu(2,iproc) GPB2F402.69
ENDIF GATFLD1A.159
receive_map(R_STRIDE_IN_RECV_ARRAY,iproc+1) = GPB2F402.70
& GLOBAL_ROW_LEN GPB2F402.71
GPB2F402.72
receive_map(R_ELEMENT_LENGTH,iproc+1) = g_blsizep(1,iproc) GPB2F402.73
GPB2F402.74
receive_map(R_BASE_ADDRESS_IN_SEND_ARRAY,iproc+1) = GPB2F402.75
& Offy*g_lasize(1,iproc)+Offx+1 GPB2F402.76
GPB2F402.77
receive_map(R_STRIDE_IN_SEND_ARRAY,iproc+1) = GPB2F402.78
& g_lasize(1,iproc) GPB2F402.79
GPB2F402.80
ENDDO GATFLD1A.164
n_mess_to_rec=nproc GATFLD1A.165
ENDIF GATFLD1A.166
GATFLD1A.167
old_GLOBAL_ROW_LEN=GLOBAL_ROW_LEN GATFLD1A.168
old_GLOBAL_ROWS=GLOBAL_ROWS GATFLD1A.169
old_PROC_GROUP=PROC_GROUP GATFLD1A.170
old_GATHER_PE=GATHER_PE GATFLD1A.171
old_DECOMP=current_decomp_type GPB1F404.123
GATFLD1A.172
ENDIF ! we need to recalculate send/receive maps. GATFLD1A.173
GATFLD1A.174
! 4.0 Do the exchange of data GATFLD1A.175
GATFLD1A.176
flag=0 ! This is currently ignored at GCG v1.1 GPB2F402.81
GPB2F402.82
CALL GC_SETOPT(GC_SHM_DIR,GC_SHM_PUT,info) ! gather operation GPB2F402.83
info=GC_NONE GPB2F402.84
GATFLD1A.178
CALL GCG_RALLTOALLE(LOCAL_FIELD,send_map,1, GATFLD1A.179
& LOCAL_ROW_LEN*LOCAL_ROWS, GPB2F402.85
& GLOBAL_FIELD,receive_map,n_mess_to_rec, GATFLD1A.181
& GLOBAL_ROW_LEN*GLOBAL_ROWS, GPB2F402.86
& PROC_GROUP,flag,info) GATFLD1A.183
GATFLD1A.184
9999 CONTINUE GATFLD1A.185
GATFLD1A.186
RETURN GATFLD1A.187
END GATFLD1A.188
*ENDIF GATFLD1A.189
*ENDIF GPB3F403.277