1 |
C $Header: $ |
2 |
C $Name: $ |
3 |
|
4 |
#include "PACKAGES_CONFIG.h" |
5 |
#include "CTRL_CPPOPTIONS.h" |
6 |
#ifdef ALLOW_OBCS |
7 |
#include "OBCS_OPTIONS.h" |
8 |
#endif |
9 |
|
10 |
|
11 |
subroutine grdchk_loc( |
12 |
I icomp, |
13 |
I ichknum, |
14 |
O icvrec, |
15 |
O itile, |
16 |
O jtile, |
17 |
O layer, |
18 |
O obcspos, |
19 |
O itilepos, |
20 |
O jtilepos, |
21 |
O icglom1, |
22 |
O itest, |
23 |
O ierr, |
24 |
I mythid |
25 |
& ) |
26 |
|
27 |
c ================================================================== |
28 |
c SUBROUTINE grdchk_loc |
29 |
c ================================================================== |
30 |
c |
31 |
c o Get the location of a given component of the control vector for |
32 |
c the current process. |
33 |
c |
34 |
c started: Christian Eckert eckert@mit.edu 04-Apr-2000 |
35 |
c continued: heimbach@mit.edu: 13-Jun-2001 |
36 |
c |
37 |
c ================================================================== |
38 |
c SUBROUTINE grdchk_loc |
39 |
c ================================================================== |
40 |
|
41 |
implicit none |
42 |
|
43 |
c == global variables == |
44 |
|
45 |
#include "EEPARAMS.h" |
46 |
#include "SIZE.h" |
47 |
#include "GRID.h" |
48 |
#include "ctrl.h" |
49 |
#include "grdchk.h" |
50 |
#ifdef ALLOW_OBCS |
51 |
#include "OBCS.h" |
52 |
#endif |
53 |
|
54 |
c == routine arguments == |
55 |
|
56 |
integer icomp |
57 |
integer ichknum |
58 |
integer icvrec |
59 |
integer jtile |
60 |
integer itile |
61 |
integer layer |
62 |
integer obcspos |
63 |
integer itilepos |
64 |
integer jtilepos |
65 |
integer itest |
66 |
integer iwettot |
67 |
integer ierr |
68 |
integer mythid |
69 |
|
70 |
#ifdef ALLOW_GRDCHK |
71 |
c == local variables == |
72 |
|
73 |
integer bi,bj |
74 |
integer i,j,k |
75 |
integer itmp,jtmp |
76 |
integer iobcs |
77 |
integer biwrk,bjwrk |
78 |
integer iwrk, jwrk, kwrk |
79 |
integer iobcswrk |
80 |
integer irec, irecwrk |
81 |
integer icglo, icglom1 |
82 |
integer itlo,ithi |
83 |
integer jtlo,jthi |
84 |
integer jmin,jmax |
85 |
integer imin,imax |
86 |
integer icomptest |
87 |
integer icomploc |
88 |
integer nobcsmax |
89 |
|
90 |
c == end of interface == |
91 |
|
92 |
jtlo = 1 |
93 |
jthi = nsy |
94 |
itlo = 1 |
95 |
ithi = nsx |
96 |
jmin = 1 |
97 |
jmax = sny |
98 |
imin = 1 |
99 |
imax = snx |
100 |
|
101 |
_BEGIN_MASTER( mythid ) |
102 |
|
103 |
c initialise parameters |
104 |
ierr = -5 |
105 |
icglom1 = 0 |
106 |
icomploc= 0 |
107 |
|
108 |
if ( icomp .gt. 0 ) then |
109 |
if ( icomp .le. ncvarcomp ) then |
110 |
c-- A valid component of the control variable has been selected. |
111 |
if ( ichknum .EQ. 1 ) then |
112 |
itest = 0 |
113 |
icomptest = 0 |
114 |
irecwrk = 1 |
115 |
bjwrk = 1 |
116 |
biwrk = 1 |
117 |
kwrk = 1 |
118 |
iobcswrk = 1 |
119 |
jwrk = 1 |
120 |
iwrk = 1 |
121 |
iwettot = 0 |
122 |
icglo = 0 |
123 |
else |
124 |
itest = itestmem (ichknum-1) |
125 |
icomptest = icompmem (ichknum-1) |
126 |
irecwrk = irecmem (ichknum-1) |
127 |
bjwrk = bjmem (ichknum-1) |
128 |
biwrk = bimem (ichknum-1) |
129 |
kwrk = klocmem (ichknum-1) |
130 |
iobcswrk = iobcsmem (ichknum-1) |
131 |
icglo = icglomem (ichknum-1) |
132 |
jwrk = jlocmem (ichknum-1) |
133 |
iwrk = ilocmem (ichknum-1) |
134 |
iwrk = iwrk + 1 |
135 |
iwettot = iwetsum(biwrk,bjwrk,kwrk) |
136 |
end if |
137 |
|
138 |
c-- set max loop index for obcs multiplicities |
139 |
if ( ncvargrd(grdchkvarindex) .eq. 'm' ) then |
140 |
nobcsmax = nobcs |
141 |
if (grdchkvarindex.EQ.11.OR.grdchkvarindex.EQ.12) then |
142 |
jwrk = 1 |
143 |
else if (grdchkvarindex.EQ.13.OR.grdchkvarindex.EQ.14) then |
144 |
iwrk = 1 |
145 |
else |
146 |
STOP 'in grdchk_loc for obcs: should never get here' |
147 |
endif |
148 |
else |
149 |
nobcsmax = 1 |
150 |
endif |
151 |
|
152 |
cph( |
153 |
cph-print print *, 'ph-grd _loc: icomp, ichknum ', |
154 |
cph-print & icomp, ichknum, ncvarcomp |
155 |
cpj) |
156 |
c-- Start to loop over records. |
157 |
do irec = irecwrk, ncvarrecs(grdchkvarindex) |
158 |
cph do iobcs = iobcswrk, nobcsmax |
159 |
iobcs = MOD((irec-1),nobcsmax) + 1 |
160 |
do bj = bjwrk, jthi |
161 |
do bi = biwrk, ithi |
162 |
do k = kwrk, ncvarnrmax(grdchkvarindex) |
163 |
icglo = icglo + nwettile(bi,bj,k,iobcs) |
164 |
icglom1 = icglo - nwettile(bi,bj,k,iobcs) |
165 |
cph( |
166 |
cph-print print *, 'ph-grd _loc: bi, bj, icomptest, ichknum ', |
167 |
cph-print & icomptest, ichknum |
168 |
cph-print print *, 'ph-grd _loc: icglo ', |
169 |
cph-print & k, icglo, icglom1, iwetsum(bi,bj,k) |
170 |
cpj) |
171 |
if ( (ierr .ne. 0) .and. |
172 |
& (icomp .gt. icglom1 .AND. icomp .LE. icglo) ) then |
173 |
cph |
174 |
cph if ( (ierr .ne. 0) .and. |
175 |
cph & (icomp .gt. |
176 |
cph & (iobcs-1)*iwetsum(bi,bj,nr)+iwetsum(bi,bj,k-1)) |
177 |
cph & .and. |
178 |
cph & (icomp .le. |
179 |
cph & (iobcs-1)*iwetsum(bi,bj,nr)+iwetsum(bi,bj,k))) then |
180 |
cph |
181 |
if ( icomptest .EQ. 0 ) then |
182 |
icomptest = icglom1 |
183 |
endif |
184 |
icomploc = icomp |
185 |
icvrec = irec |
186 |
itile = bi |
187 |
jtile = bj |
188 |
cph( |
189 |
cph-print print *, 'ph-grd irec, bj, bi, k ', irec, bj, bi, k |
190 |
cpj) |
191 |
do j = jwrk, ncvarymax(grdchkvarindex) |
192 |
do i = iwrk, ncvarxmax(grdchkvarindex) |
193 |
if (ierr .ne. 0) then |
194 |
if ( ncvargrd(grdchkvarindex) .eq. 'c' ) then |
195 |
if ( maskC(i,j,k,bi,bj) .gt. 0.) then |
196 |
icomptest = icomptest + 1 |
197 |
itmp = i |
198 |
jtmp = j |
199 |
endif |
200 |
else if ( ncvargrd(grdchkvarindex) .eq. 's' ) then |
201 |
if ( _maskS(i,j,k,bi,bj) .gt. 0.) then |
202 |
icomptest = icomptest + 1 |
203 |
itmp = i |
204 |
jtmp = j |
205 |
endif |
206 |
else if ( ncvargrd(grdchkvarindex) .eq. 'w' ) then |
207 |
if ( _maskW(i,j,k,bi,bj) .gt. 0.) then |
208 |
icomptest = icomptest + 1 |
209 |
itmp = i |
210 |
jtmp = j |
211 |
endif |
212 |
else if ( ncvargrd(grdchkvarindex) .eq. 'm' ) then |
213 |
if ( grdchkvarindex .EQ. 11 ) then |
214 |
#ifdef ALLOW_OBCSN_CONTROL |
215 |
if (grdchk_maskxz(i,k,bi,bj,iobcs) .gt. 0.) then |
216 |
icomptest = icomptest + 1 |
217 |
itmp = i |
218 |
jtmp = OB_Jn(I,bi,bj) |
219 |
endif |
220 |
#endif |
221 |
else if ( grdchkvarindex .EQ. 12 ) then |
222 |
#ifdef ALLOW_OBCSS_CONTROL |
223 |
if (grdchk_maskxz(i,k,bi,bj,iobcs) .gt. 0.) then |
224 |
icomptest = icomptest + 1 |
225 |
itmp = i |
226 |
jtmp = OB_Js(I,bi,bj) |
227 |
endif |
228 |
#endif |
229 |
else if ( grdchkvarindex .EQ. 13 ) then |
230 |
#ifdef ALLOW_OBCSW_CONTROL |
231 |
if (grdchk_maskyz(j,k,bi,bj,iobcs) .gt. 0.) then |
232 |
icomptest = icomptest + 1 |
233 |
itmp = OB_Iw(J,bi,bj) |
234 |
jtmp = j |
235 |
endif |
236 |
#endif |
237 |
else if ( grdchkvarindex .EQ. 14 ) then |
238 |
#ifdef ALLOW_OBCSE_CONTROL |
239 |
if (grdchk_maskyz(j,k,bi,bj,iobcs) .gt. 0.) then |
240 |
icomptest = icomptest + 1 |
241 |
itmp = OB_Ie(J,bi,bj) |
242 |
jtmp = j |
243 |
endif |
244 |
#endif |
245 |
endif |
246 |
endif |
247 |
cph( |
248 |
cph-print print *, 'ph-grd icomp, icomptest, icomploc, i, j ', |
249 |
cph-print & icomp, icomptest, icomploc, i, j |
250 |
cpj) |
251 |
if ( icomploc .eq. icomptest ) then |
252 |
itilepos = itmp |
253 |
jtilepos = jtmp |
254 |
layer = k |
255 |
obcspos = iobcs |
256 |
ierr = 0 |
257 |
itest = iwetsum(bi,bj,k) |
258 |
cph( |
259 |
print *, 'ph-grd -->hit<-- ', itmp,jtmp,k,iobcs |
260 |
goto 1234 |
261 |
cph) |
262 |
endif |
263 |
endif |
264 |
enddo |
265 |
iwrk = 1 |
266 |
enddo |
267 |
jwrk = 1 |
268 |
else if (ierr .NE. 0) then |
269 |
if (icomptest .EQ. icomp-1) then |
270 |
icomptest = icomptest |
271 |
else |
272 |
icomptest = icomptest + nwettile(bi,bj,k,iobcs) |
273 |
endif |
274 |
cph( |
275 |
cph-print print *, 'ph-grd after loop icomptest, icomploc, k ', |
276 |
cph-print & icomptest, icomploc, k |
277 |
cph) |
278 |
iwrk = 1 |
279 |
jwrk = 1 |
280 |
else |
281 |
c |
282 |
endif |
283 |
c-- End of loop over k |
284 |
enddo |
285 |
kwrk = 1 |
286 |
c-- End of loop over bi |
287 |
enddo |
288 |
biwrk = 1 |
289 |
c-- End of loop over bj |
290 |
enddo |
291 |
bjwrk = 1 |
292 |
c-- End of loop over iobcs |
293 |
cph enddo |
294 |
cph iobcswrk = 1 |
295 |
c-- End of loop over irec records. |
296 |
enddo |
297 |
c |
298 |
else |
299 |
if ( icomp .gt. maxncvarcomps ) then |
300 |
c-- Such a component does not exist. |
301 |
ierr = -4 |
302 |
icvrec = -1 |
303 |
jtile = -1 |
304 |
itile = -1 |
305 |
layer = -1 |
306 |
obcspos = -1 |
307 |
jtilepos = -1 |
308 |
itilepos = -1 |
309 |
else |
310 |
c-- The component is a land point. |
311 |
ierr = -3 |
312 |
icvrec = -1 |
313 |
jtile = -1 |
314 |
itile = -1 |
315 |
layer = -1 |
316 |
obcspos = -1 |
317 |
jtilepos = -1 |
318 |
itilepos = -1 |
319 |
endif |
320 |
endif |
321 |
else |
322 |
if ( icomp .lt. 0 ) then |
323 |
c-- Such a component does not exist. |
324 |
ierr = -2 |
325 |
icvrec = -1 |
326 |
jtile = -1 |
327 |
itile = -1 |
328 |
layer = -1 |
329 |
obcspos = -1 |
330 |
jtilepos = -1 |
331 |
itilepos = -1 |
332 |
else |
333 |
c-- Component zero. |
334 |
ierr = -1 |
335 |
icvrec = -1 |
336 |
jtile = -1 |
337 |
itile = -1 |
338 |
layer = -1 |
339 |
obcspos = -1 |
340 |
jtilepos = -1 |
341 |
itilepos = -1 |
342 |
endif |
343 |
endif |
344 |
|
345 |
1234 continue |
346 |
|
347 |
_END_MASTER( mythid ) |
348 |
|
349 |
_BARRIER |
350 |
|
351 |
#endif /* ALLOW_GRDCHK */ |
352 |
|
353 |
end |
354 |
|