1 |
C $Header: /u/gcmpack/MITgcm/pkg/obcs/obcs_set_connect.F,v 1.1 2014/11/25 01:07:23 jmc Exp $ |
2 |
C $Name: $ |
3 |
|
4 |
#include "OBCS_OPTIONS.h" |
5 |
|
6 |
C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----| |
7 |
CBOP |
8 |
C !ROUTINE: OBCS_SET_CONNECT |
9 |
|
10 |
C !INTERFACE: |
11 |
SUBROUTINE OBCS_SET_CONNECT( myThid ) |
12 |
|
13 |
C !DESCRIPTION: |
14 |
C *==========================================================* |
15 |
C | SUBROUTINE OBCS_SET_CONNECT |
16 |
C | o Set OB connected piece Id for each level |
17 |
C *==========================================================* |
18 |
|
19 |
C !USES: |
20 |
IMPLICIT NONE |
21 |
|
22 |
C === Global variables === |
23 |
#include "SIZE.h" |
24 |
#include "EEPARAMS.h" |
25 |
#include "PARAMS.h" |
26 |
#include "GRID.h" |
27 |
#include "OBCS_PARAMS.h" |
28 |
#include "OBCS_GRID.h" |
29 |
|
30 |
C !INPUT/OUTPUT PARAMETERS: |
31 |
C myThid :: my Thread Id. number |
32 |
INTEGER myThid |
33 |
CEOP |
34 |
|
35 |
#ifdef ALLOW_OBCS |
36 |
C !LOCAL VARIABLES: |
37 |
C msgBuf :: Informational/error message buffer |
38 |
C bi,bj :: tile indices |
39 |
C i, j, k :: Loop counters |
40 |
CHARACTER*(MAX_LEN_MBUF) msgBuf |
41 |
INTEGER bi, bj |
42 |
INTEGER i, j, k |
43 |
INTEGER idN, idS, idE, idW |
44 |
INTEGER fp, prtMsg |
45 |
INTEGER n, newConnect, maxConnect |
46 |
INTEGER numConnect, listConnect(OBCS_maxConnect) |
47 |
INTEGER numLocal(nSx,nSy), listLocal(OBCS_maxConnect,nSx,nSy) |
48 |
INTEGER tmpConnect(sNx+sNx+sNy+sNy) |
49 |
_RS tmpXZ(1-OLx:sNx+OLx,Nr,nSx,nSy) |
50 |
_RS tmpYZ(1-OLy:sNy+OLy,Nr,nSx,nSy) |
51 |
_RL tmpRL |
52 |
|
53 |
#ifdef ALLOW_DEBUG |
54 |
IF (debugMode) CALL DEBUG_ENTER('OBCS_SET_CONNECT',myThid) |
55 |
#endif |
56 |
|
57 |
C-- Initialise domain connected-piece Id for OB grid points: |
58 |
DO bj = myByLo(myThid), myByHi(myThid) |
59 |
DO bi = myBxLo(myThid), myBxHi(myThid) |
60 |
idN = 0 |
61 |
idS = 0 |
62 |
idE = 0 |
63 |
idW = 0 |
64 |
IF ( tileHasOBN(bi,bj) ) idN = 1 |
65 |
IF ( tileHasOBS(bi,bj) ) idS = 1 |
66 |
IF ( tileHasOBE(bi,bj) ) idE = 1 |
67 |
IF ( tileHasOBW(bi,bj) ) idW = 1 |
68 |
DO k=1,Nr |
69 |
DO i=1,sNx |
70 |
OBN_connect(i,k,bi,bj) = idN |
71 |
OBS_connect(i,k,bi,bj) = idS |
72 |
ENDDO |
73 |
DO j=1,sNy |
74 |
OBE_connect(j,k,bi,bj) = idE |
75 |
OBW_connect(j,k,bi,bj) = idW |
76 |
ENDDO |
77 |
ENDDO |
78 |
ENDDO |
79 |
ENDDO |
80 |
|
81 |
C-- Read from files domain connected-piece Id for OB grid points: |
82 |
C- Note: current Section READ routines (MDS_READ_SEC_XZ,_YZ) are |
83 |
C single (Master) thread (output only available to Master Thread) |
84 |
prtMsg = 0 |
85 |
fp = readBinaryPrec |
86 |
_BARRIER |
87 |
IF ( OBNconnectFile.NE.' ' ) THEN |
88 |
CALL READ_REC_XZ_RS( OBNconnectFile, fp,Nr, tmpXZ, 1,0,myThid ) |
89 |
_BEGIN_MASTER(myThid) |
90 |
DO bj = 1,nSy |
91 |
DO bi = 1,nSx |
92 |
IF ( tileHasOBN(bi,bj) ) THEN |
93 |
DO k=1,Nr |
94 |
DO i=1,sNx |
95 |
OBN_connect(i,k,bi,bj) = NINT( tmpXZ(i,k,bi,bj) ) |
96 |
ENDDO |
97 |
ENDDO |
98 |
ENDIF |
99 |
ENDDO |
100 |
ENDDO |
101 |
_END_MASTER(myThid) |
102 |
prtMsg = 1 |
103 |
ENDIF |
104 |
IF ( OBSconnectFile.NE.' ' ) THEN |
105 |
CALL READ_REC_XZ_RS( OBSconnectFile, fp,Nr, tmpXZ, 1,0,myThid ) |
106 |
_BEGIN_MASTER(myThid) |
107 |
DO bj = 1,nSy |
108 |
DO bi = 1,nSx |
109 |
IF ( tileHasOBS(bi,bj) ) THEN |
110 |
DO k=1,Nr |
111 |
DO i=1,sNx |
112 |
OBS_connect(i,k,bi,bj) = NINT( tmpXZ(i,k,bi,bj) ) |
113 |
ENDDO |
114 |
ENDDO |
115 |
ENDIF |
116 |
ENDDO |
117 |
ENDDO |
118 |
_END_MASTER(myThid) |
119 |
prtMsg = 1 |
120 |
ENDIF |
121 |
IF ( OBEconnectFile.NE.' ' ) THEN |
122 |
CALL READ_REC_YZ_RS( OBEconnectFile, fp,Nr, tmpYZ, 1,0,myThid ) |
123 |
_BEGIN_MASTER(myThid) |
124 |
DO bj = 1,nSy |
125 |
DO bi = 1,nSx |
126 |
IF ( tileHasOBE(bi,bj) ) THEN |
127 |
DO k=1,Nr |
128 |
DO j=1,sNy |
129 |
OBE_connect(j,k,bi,bj) = NINT( tmpYZ(j,k,bi,bj) ) |
130 |
ENDDO |
131 |
ENDDO |
132 |
ENDIF |
133 |
ENDDO |
134 |
ENDDO |
135 |
_END_MASTER(myThid) |
136 |
prtMsg = 1 |
137 |
ENDIF |
138 |
IF ( OBWconnectFile.NE.' ' ) THEN |
139 |
CALL READ_REC_YZ_RS( OBWconnectFile, fp,Nr, tmpYZ, 1,0,myThid ) |
140 |
_BEGIN_MASTER(myThid) |
141 |
DO bj = 1,nSy |
142 |
DO bi = 1,nSx |
143 |
IF ( tileHasOBW(bi,bj) ) THEN |
144 |
DO k=1,Nr |
145 |
DO j=1,sNy |
146 |
OBW_connect(j,k,bi,bj) = NINT( tmpYZ(j,k,bi,bj) ) |
147 |
ENDDO |
148 |
ENDDO |
149 |
ENDIF |
150 |
ENDDO |
151 |
ENDDO |
152 |
_END_MASTER(myThid) |
153 |
prtMsg = 1 |
154 |
ENDIF |
155 |
_BARRIER |
156 |
|
157 |
DO bj = myByLo(myThid), myByHi(myThid) |
158 |
DO bi = myBxLo(myThid), myBxHi(myThid) |
159 |
DO k=1,Nr |
160 |
DO i=1,sNx |
161 |
IF (OB_Jn(i,bi,bj).EQ.OB_indexNone) OBN_connect(i,k,bi,bj)=0 |
162 |
IF (OB_Js(i,bi,bj).EQ.OB_indexNone) OBS_connect(i,k,bi,bj)=0 |
163 |
ENDDO |
164 |
DO j=1,sNy |
165 |
IF (OB_Ie(j,bi,bj).EQ.OB_indexNone) OBE_connect(j,k,bi,bj)=0 |
166 |
IF (OB_Iw(j,bi,bj).EQ.OB_indexNone) OBW_connect(j,k,bi,bj)=0 |
167 |
ENDDO |
168 |
ENDDO |
169 |
ENDDO |
170 |
ENDDO |
171 |
|
172 |
C-- Count how many connected parts there are for each level: |
173 |
prtMsg = prtMsg*debugLevel |
174 |
DO k=1,Nr |
175 |
|
176 |
maxConnect = 0 |
177 |
DO bj = myByLo(myThid), myByHi(myThid) |
178 |
DO bi = myBxLo(myThid), myBxHi(myThid) |
179 |
|
180 |
C- make a local copy |
181 |
DO i=1,sNx |
182 |
tmpConnect(i) = OBN_connect(i,k,bi,bj) |
183 |
tmpConnect(sNx+i) = OBS_connect(i,k,bi,bj) |
184 |
ENDDO |
185 |
DO j=1,sNy |
186 |
tmpConnect(sNx*2+j) = OBW_connect(j,k,bi,bj) |
187 |
tmpConnect(sNx*2+sNy+j) = OBE_connect(j,k,bi,bj) |
188 |
ENDDO |
189 |
|
190 |
C- make a list for each tile |
191 |
numLocal(bi,bj) = 0 |
192 |
DO n=1,OBCS_maxConnect |
193 |
listLocal(n,bi,bj) = 0 |
194 |
ENDDO |
195 |
newConnect = 1 |
196 |
DO WHILE ( newConnect.NE. 0 ) |
197 |
newConnect = 0 |
198 |
DO i=1,(sNx+sNy)*2 |
199 |
IF ( tmpConnect(i).GE.1 ) THEN |
200 |
IF ( newConnect.EQ.0 ) THEN |
201 |
newConnect = tmpConnect(i) |
202 |
numLocal(bi,bj) = numLocal(bi,bj) + 1 |
203 |
IF ( numLocal(bi,bj).LE.OBCS_maxConnect ) |
204 |
& listLocal(numLocal(bi,bj),bi,bj) = newConnect |
205 |
ENDIF |
206 |
IF ( tmpConnect(i).EQ.newConnect ) |
207 |
& tmpConnect(i) = 0 |
208 |
ENDIF |
209 |
ENDDO |
210 |
ENDDO |
211 |
IF ( numLocal(bi,bj).GT.OBCS_maxConnect ) THEN |
212 |
WRITE(msgBuf,'(A,3(A,I4),2(A,I10))') 'OBCS_SET_CONNECT: ', |
213 |
& 'k=', k, ' numLocal(', bi,',',bj,')=', numLocal(bi,bj), |
214 |
& ' exceeds OBCS_maxConnect=', OBCS_maxConnect |
215 |
CALL PRINT_ERROR( msgBuf, myThid ) |
216 |
STOP 'ABNORMAL END: S/R OBCS_SET_CONNECT' |
217 |
ENDIF |
218 |
IF ( prtMsg.GE.debLevC ) THEN |
219 |
IF ( numLocal(bi,bj).EQ.0 ) THEN |
220 |
WRITE(msgBuf,'(A,2I4,A,I8)') 'OBCS_SET_CONNECT: bi,bj=', |
221 |
& bi, bj, ' , numLocal=', numLocal(bi,bj) |
222 |
ELSE |
223 |
WRITE(msgBuf,'(A,2I4,2(A,I8))') 'OBCS_SET_CONNECT: bi,bj=', |
224 |
& bi, bj, ' , numLocal=', numLocal(bi,bj), |
225 |
& ' , listLocal:', listLocal(1,bi,bj) |
226 |
ENDIF |
227 |
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, |
228 |
& SQUEEZE_RIGHT, myThid ) |
229 |
DO j=2,numLocal(bi,bj),15 |
230 |
n = MIN(numLocal(bi,bj),j+14) |
231 |
WRITE(msgBuf,'(A,15I8)') |
232 |
& ' ... ', (listLocal(i,bi,bj),i=j,n) |
233 |
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, |
234 |
& SQUEEZE_RIGHT, myThid ) |
235 |
ENDDO |
236 |
ENDIF |
237 |
DO n=1,numLocal(bi,bj) |
238 |
maxConnect = MAX( maxConnect, listLocal(n,bi,bj) ) |
239 |
ENDDO |
240 |
|
241 |
ENDDO |
242 |
ENDDO |
243 |
|
244 |
tmpRL = maxConnect |
245 |
_GLOBAL_MAX_RL( tmpRL, myThid ) |
246 |
maxConnect = NINT( tmpRL ) |
247 |
|
248 |
C- combine set of list (1 per tile) into 1 global list |
249 |
numConnect = 0 |
250 |
DO j=1,maxConnect |
251 |
tmpRL = zeroRL |
252 |
DO bj = myByLo(myThid), myByHi(myThid) |
253 |
DO bi = myBxLo(myThid), myBxHi(myThid) |
254 |
DO n=1,numLocal(bi,bj) |
255 |
IF ( listLocal(n,bi,bj).EQ.j ) tmpRL = oneRL |
256 |
ENDDO |
257 |
ENDDO |
258 |
ENDDO |
259 |
_GLOBAL_MAX_RL( tmpRL, myThid ) |
260 |
IF ( tmpRL.EQ.oneRL ) THEN |
261 |
numConnect = numConnect + 1 |
262 |
IF ( numConnect.LE.OBCS_maxConnect ) |
263 |
& listConnect(numConnect) = j |
264 |
ENDIF |
265 |
ENDDO |
266 |
IF ( numConnect.GT.OBCS_maxConnect ) THEN |
267 |
WRITE(msgBuf,'(A,I4,2(A,I10))') 'OBCS_SET_CONNECT: @ k=', k, |
268 |
& ' numConnect=', numConnect, |
269 |
& ' exceeds OBCS_maxConnect=', OBCS_maxConnect |
270 |
CALL PRINT_ERROR( msgBuf, myThid ) |
271 |
STOP 'ABNORMAL END: S/R OBCS_SET_CONNECT' |
272 |
ENDIF |
273 |
IF ( prtMsg.GE.debLevA ) THEN |
274 |
_BEGIN_MASTER(myThid) |
275 |
WRITE(msgBuf,'(A,I4,2(A,I10))') 'OBCS_SET_CONNECT: @ k=', k, |
276 |
& ', maxConnect=', maxConnect, ' , numConnect=', numConnect |
277 |
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, |
278 |
& SQUEEZE_RIGHT, myThid ) |
279 |
DO j=1,numConnect,15 |
280 |
n = MIN(numConnect,j+14) |
281 |
WRITE(msgBuf,'(A,15I8)') |
282 |
& ' listConnect:', (listConnect(i),i=j,n) |
283 |
CALL PRINT_MESSAGE( msgBuf, standardMessageUnit, |
284 |
& SQUEEZE_RIGHT, myThid ) |
285 |
ENDDO |
286 |
_END_MASTER(myThid) |
287 |
ENDIF |
288 |
|
289 |
C- reset connected Id in order to use all number from 1 to numConnect |
290 |
DO bj = myByLo(myThid), myByHi(myThid) |
291 |
DO bi = myBxLo(myThid), myBxHi(myThid) |
292 |
|
293 |
C- make a local copy |
294 |
DO i=1,sNx |
295 |
tmpConnect(i) = OBN_connect(i,k,bi,bj) |
296 |
tmpConnect(sNx+i) = OBS_connect(i,k,bi,bj) |
297 |
ENDDO |
298 |
DO j=1,sNy |
299 |
tmpConnect(sNx*2+j) = OBW_connect(j,k,bi,bj) |
300 |
tmpConnect(sNx*2+sNy+j) = OBE_connect(j,k,bi,bj) |
301 |
ENDDO |
302 |
DO n=1,numConnect |
303 |
C- change Id value: listConnect(n) to n |
304 |
IF ( listConnect(n).NE.n ) THEN |
305 |
DO i=1,(sNx+sNy)*2 |
306 |
IF ( tmpConnect(i).EQ.listConnect(n) ) tmpConnect(i) = n |
307 |
ENDDO |
308 |
ENDIF |
309 |
ENDDO |
310 |
C- copy back into OB[N,S,E,W]_connect arrays |
311 |
DO i=1,sNx |
312 |
OBN_connect(i,k,bi,bj) = tmpConnect(i) |
313 |
OBS_connect(i,k,bi,bj) = tmpConnect(sNx+i) |
314 |
ENDDO |
315 |
DO j=1,sNy |
316 |
OBW_connect(j,k,bi,bj) = tmpConnect(sNx*2+j) |
317 |
OBE_connect(j,k,bi,bj) = tmpConnect(sNx*2+sNy+j) |
318 |
ENDDO |
319 |
|
320 |
ENDDO |
321 |
ENDDO |
322 |
|
323 |
C- store numConnect in common block |
324 |
_BEGIN_MASTER(myThid) |
325 |
OB_connectNumber(k) = numConnect |
326 |
_END_MASTER(myThid) |
327 |
|
328 |
C-- end k loop |
329 |
ENDDO |
330 |
|
331 |
_BARRIER |
332 |
|
333 |
#ifdef ALLOW_DEBUG |
334 |
IF (debugMode) CALL DEBUG_LEAVE('OBCS_SET_CONNECT',myThid) |
335 |
#endif |
336 |
|
337 |
#endif /* ALLOW_OBCS */ |
338 |
RETURN |
339 |
END |