/[MITgcm]/MITgcm_contrib/heimbach/OpenAD/code_shallow_openad/ctrl_init_wet.F
ViewVC logotype

Contents of /MITgcm_contrib/heimbach/OpenAD/code_shallow_openad/ctrl_init_wet.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.3 - (show annotations) (download)
Tue May 8 14:04:56 2007 UTC (19 years, 6 months ago) by utke
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +1 -1 lines
FILE REMOVED
removing extra copies and synching form main

1 C
2 C $Header: /u/gcmpack/MITgcm_contrib/heimbach/OpenAD/code_shallow_openad/ctrl_init_wet.F,v 1.2 2007/01/27 04:37:54 utke Exp $
3 C $Name: $
4
5 #include "CTRL_CPPOPTIONS.h"
6
7 subroutine ctrl_init_wet( mythid )
8
9 c ==================================================================
10 c SUBROUTINE ctrl_init_wet
11 c ==================================================================
12
13 implicit none
14
15 c == global variables ==
16
17 #include "EEPARAMS.h"
18 #include "SIZE.h"
19 #include "PARAMS.h"
20 #include "GRID.h"
21 #include "ctrl.h"
22
23 #ifdef ALLOW_OBCS_CONTROL
24 # include "OBCS.h"
25 #endif
26
27 c == routine arguments ==
28
29 integer mythid
30
31 c == local variables ==
32
33 integer bi,bj
34 integer i,j,k
35 integer itlo,ithi
36 integer jtlo,jthi
37 integer jmin,jmax
38 integer imin,imax
39 integer ntmp
40 integer iobcs
41 integer nwetc3d
42 integer nwettmp
43
44 _RL dummy
45
46 character*(80) ymaskobcs
47 character*(max_len_mbuf) msgbuf
48
49 c-- Set loop ranges.
50 jtlo = mybylo(mythid)
51 jthi = mybyhi(mythid)
52 itlo = mybxlo(mythid)
53 ithi = mybxhi(mythid)
54 jmin = 1
55 jmax = sny
56 imin = 1
57 imax = snx
58
59 c-- Determine the number of wet points in each tile:
60 c-- maskc, masks, and maskw.
61
62 c-- Initialise the counters.
63 do bj = jtlo,jthi
64 do bi = itlo,ithi
65 do k = 1,nr
66 nwetctile(bi,bj,k) = 0
67 nwetstile(bi,bj,k) = 0
68 nwetwtile(bi,bj,k) = 0
69 nwetvtile(bi,bj,k) = 0
70 enddo
71 enddo
72 enddo
73
74 #ifdef ALLOW_OBCS_CONTROL
75 c-- Initialise obcs counters.
76 do bj = jtlo,jthi
77 do bi = itlo,ithi
78 do k = 1,nr
79 do iobcs = 1,nobcs
80 #ifdef ALLOW_OBCSN_CONTROL
81 nwetobcsn(bi,bj,k,iobcs) = 0
82 #endif
83 #ifdef ALLOW_OBCSS_CONTROL
84 nwetobcss(bi,bj,k,iobcs) = 0
85 #endif
86 #ifdef ALLOW_OBCSW_CONTROL
87 nwetobcsw(bi,bj,k,iobcs) = 0
88 #endif
89 #ifdef ALLOW_OBCSE_CONTROL
90 nwetobcse(bi,bj,k,iobcs) = 0
91 #endif
92 enddo
93 enddo
94 enddo
95 enddo
96 #endif
97
98 c-- Count wet points on each tile.
99 do bj = jtlo,jthi
100 do bi = itlo,ithi
101 do k = 1,nr
102 do j = jmin,jmax
103 do i = imin,imax
104 c-- Center mask.
105 if (hFacC(i,j,k,bi,bj) .ne. 0.) then
106 nwetctile(bi,bj,k) = nwetctile(bi,bj,k) + 1
107 endif
108 c-- South mask.
109 if (maskS(i,j,k,bi,bj) .eq. 1.) then
110 nwetstile(bi,bj,k) = nwetstile(bi,bj,k) + 1
111 endif
112 c-- West mask.
113 if (maskW(i,j,k,bi,bj) .eq. 1.) then
114 nwetwtile(bi,bj,k) = nwetwtile(bi,bj,k) + 1
115 endif
116 #if (defined (ALLOW_EFLUXP0_CONTROL))
117 c-- Vertical mask.
118 if (hFacV(i,j,k,bi,bj) .ne. 0.) then
119 nwetvtile(bi,bj,k) = nwetvtile(bi,bj,k) + 1
120 endif
121 #endif
122 enddo
123 enddo
124 enddo
125 enddo
126 enddo
127
128 #ifdef ALLOW_OBCSN_CONTROL
129 c-- Count wet points at Northern boundary.
130 c-- mask conventions are adopted from obcs_apply_ts, obcs_apply_uv
131 ymaskobcs = 'maskobcsn'
132 call ctrl_mask_set_xz( 0, OB_Jn, nwetobcsn, ymaskobcs, mythid )
133 #endif
134
135 #ifdef ALLOW_OBCSS_CONTROL
136 c-- Count wet points at Southern boundary.
137 c-- mask conventions are adopted from obcs_apply_ts, obcs_apply_uv
138 ymaskobcs = 'maskobcss'
139 call ctrl_mask_set_xz( 1, OB_Js, nwetobcss, ymaskobcs, mythid )
140 #endif
141
142 #ifdef ALLOW_OBCSW_CONTROL
143 c-- Count wet points at Western boundary.
144 c-- mask conventions are adopted from obcs_apply_ts, obcs_apply_uv
145 ymaskobcs = 'maskobcsw'
146 call ctrl_mask_set_yz( 1, OB_Iw, nwetobcsw, ymaskobcs, mythid )
147 #endif
148
149 #ifdef ALLOW_OBCSE_CONTROL
150 c-- Count wet points at Eastern boundary.
151 c-- mask conventions are adopted from obcs_apply_ts, obcs_apply_uv
152 ymaskobcs = 'maskobcse'
153 call ctrl_mask_set_yz( 0, OB_Ie, nwetobcse, ymaskobcs, mythid )
154 #endif
155
156 _BEGIN_MASTER( mythid )
157 c-- Determine the total number of control variables.
158 nvartype = 0
159 nvarlength = 0
160 do i = 1,maxcvars
161 c
162 if ( ncvarindex(i) .ne. -1 ) then
163 nvartype = nvartype + 1
164 do bj = jtlo,jthi
165 do bi = itlo,ithi
166 do k = 1,ncvarnrmax(i)
167 if ( ncvargrd(i) .eq. 'c' ) then
168 nvarlength = nvarlength +
169 & ncvarrecs(i)*nwetctile(bi,bj,k)
170 else if ( ncvargrd(i) .eq. 's' ) then
171 nvarlength = nvarlength +
172 & ncvarrecs(i)*nwetstile(bi,bj,k)
173 else if ( ncvargrd(i) .eq. 'w' ) then
174 nvarlength = nvarlength +
175 & ncvarrecs(i)*nwetwtile(bi,bj,k)
176 else if ( ncvargrd(i) .eq. 'v' ) then
177 nvarlength = nvarlength +
178 & ncvarrecs(i)*nwetvtile(bi,bj,k)
179 else if ( ncvargrd(i) .eq. 'm' ) then
180 #ifdef ALLOW_OBCS_CONTROL
181 do iobcs = 1, nobcs
182 cgg This overcounts the number of o.b. control points by a factor of "nobcs".
183 cgg As an ad-hoc solution I've divided by nobcs everywhere.
184 if ( i .eq. 11 ) then
185 #ifdef ALLOW_OBCSN_CONTROL
186 nvarlength = nvarlength +
187 & (ncvarrecs(i)/nobcs)
188 & *nwetobcsn(bi,bj,k,iobcs)
189 #endif
190 else if ( i .eq. 12 ) then
191 #ifdef ALLOW_OBCSS_CONTROL
192 nvarlength = nvarlength +
193 & (ncvarrecs(i)/nobcs)
194 & *nwetobcss(bi,bj,k,iobcs)
195 #endif
196 else if ( i .eq. 13 ) then
197 #ifdef ALLOW_OBCSW_CONTROL
198 nvarlength = nvarlength +
199 & (ncvarrecs(i)/nobcs)
200 & *nwetobcsw(bi,bj,k,iobcs)
201 #endif
202 else if ( i .eq. 14 ) then
203 #ifdef ALLOW_OBCSE_CONTROL
204 nvarlength = nvarlength +
205 & (ncvarrecs(i)/nobcs)
206 & *nwetobcse(bi,bj,k,iobcs)
207 #endif
208 end if
209 enddo
210 #endif
211 else
212 print*,'ctrl_init: invalid grid location'
213 print*,' control variable = ',ncvarindex(i)
214 print*,' grid location = ',ncvargrd(i)
215 stop ' ... stopped in ctrl_init'
216 endif
217 enddo
218 enddo
219 enddo
220 endif
221 enddo
222
223 cph(
224 write(msgbuf,'(a,2x,I10)')
225 & 'ctrl-wet 1: nvarlength = ', nvarlength
226 call print_message( msgbuf, standardmessageunit,
227 & SQUEEZE_RIGHT , mythid)
228 write(msgbuf,'(a,2x,I10)')
229 & 'ctrl-wet 2: surface wet C = ', nwetctile(1,1,1)
230 call print_message( msgbuf, standardmessageunit,
231 & SQUEEZE_RIGHT , mythid)
232 write(msgbuf,'(a,2x,I10)')
233 & 'ctrl-wet 3: surface wet W = ', nwetwtile(1,1,1)
234 call print_message( msgbuf, standardmessageunit,
235 & SQUEEZE_RIGHT , mythid)
236 write(msgbuf,'(a,2x,I10)')
237 & 'ctrl-wet 4: surface wet S = ', nwetstile(1,1,1)
238 call print_message( msgbuf, standardmessageunit,
239 & SQUEEZE_RIGHT , mythid)
240 write(msgbuf,'(a,2x,I10)')
241 & 'ctrl-wet 4a:surface wet V = ', nwetvtile(1,1,1)
242 call print_message( msgbuf, standardmessageunit,
243 & SQUEEZE_RIGHT , mythid)
244
245 nwetc3d = 0
246 do k = 1, Nr
247 nwetc3d = nwetc3d + nwetctile(1,1,k)
248 end do
249 write(msgbuf,'(a,2x,I10)')
250 & 'ctrl-wet 5: 3D wet points = ', nwetc3d
251 call print_message( msgbuf, standardmessageunit,
252 & SQUEEZE_RIGHT , mythid)
253
254 do i = 1, maxcvars
255 write(msgbuf,'(a,2x,I3,2x,I10)')
256 & 'ctrl-wet 6: no recs for i = ', i, ncvarrecs(i)
257 call print_message( msgbuf, standardmessageunit,
258 & SQUEEZE_RIGHT , mythid)
259 end do
260
261 nwettmp =
262 & 2*nwetc3d +
263 & ncvarrecs(3)*nwetctile(1,1,1) +
264 & ncvarrecs(4)*nwetctile(1,1,1) +
265 & ncvarrecs(5)*nwetwtile(1,1,1) +
266 & ncvarrecs(6)*nwetstile(1,1,1)
267 write(msgbuf,'(a,2x,I10)')
268 & 'ctrl-wet 7: flux ', nwettmp
269 call print_message( msgbuf, standardmessageunit,
270 & SQUEEZE_RIGHT , mythid)
271
272 nwettmp =
273 & 2*nwetc3d +
274 & ncvarrecs(7)*nwetctile(1,1,1) +
275 & ncvarrecs(8)*nwetctile(1,1,1) +
276 & ncvarrecs(9)*nwetwtile(1,1,1) +
277 & ncvarrecs(10)*nwetstile(1,1,1)
278 write(msgbuf,'(a,2x,I10)')
279 & 'ctrl-wet 8: atmos ', nwettmp
280 call print_message( msgbuf, standardmessageunit,
281 & SQUEEZE_RIGHT , mythid)
282
283 #ifdef ALLOW_OBCSN_CONTROL
284 write(msgbuf,'(a,2x,4I10)')
285 & 'ctrl-wet 9: surface wet obcsn = '
286 & , nwetobcsn(1,1,1,1), nwetobcsn(1,1,1,2)
287 & , nwetobcsn(1,1,1,3), nwetobcsn(1,1,1,4)
288 call print_message( msgbuf, standardmessageunit,
289 & SQUEEZE_RIGHT , mythid)
290 #endif
291 #ifdef ALLOW_OBCSS_CONTROL
292 write(msgbuf,'(a,2x,4I10)')
293 & 'ctrl-wet 10: surface wet obcss = '
294 & , nwetobcss(1,1,1,1), nwetobcss(1,1,1,2)
295 & , nwetobcss(1,1,1,3), nwetobcss(1,1,1,4)
296 call print_message( msgbuf, standardmessageunit,
297 & SQUEEZE_RIGHT , mythid)
298 #endif
299 #ifdef ALLOW_OBCSW_CONTROL
300 write(msgbuf,'(a,2x,4I10)')
301 & 'ctrl-wet 11: surface wet obcsw = '
302 & , nwetobcsw(1,1,1,1), nwetobcsw(1,1,1,2)
303 & , nwetobcsw(1,1,1,3), nwetobcsw(1,1,1,4)
304 call print_message( msgbuf, standardmessageunit,
305 & SQUEEZE_RIGHT , mythid)
306 #endif
307 #ifdef ALLOW_OBCSE_CONTROL
308 write(msgbuf,'(a,2x,4I10)')
309 & 'ctrl-wet 12: surface wet obcse = '
310 & , nwetobcse(1,1,1,1), nwetobcse(1,1,1,2)
311 & , nwetobcse(1,1,1,3), nwetobcse(1,1,1,4)
312 call print_message( msgbuf, standardmessageunit,
313 & SQUEEZE_RIGHT , mythid)
314 #endif
315 cph)
316
317 CALL GLOBAL_SUM_INT( nvarlength, myThid )
318
319 write(msgbuf,'(a,2x,I3,2x,I10)')
320 & 'ctrl-wet 13: global nvarlength vor k=', k, nvarlength
321 call print_message( msgbuf, standardmessageunit,
322 & SQUEEZE_RIGHT , mythid)
323
324 c
325 c Summation of wet point counters
326 c
327 do k = 1, nr
328
329 ntmp=0
330 do bj=1,nSy
331 do bi=1,nSx
332 ntmp=ntmp+nWetcTile(bi,bj,k)
333 enddo
334 enddo
335 CALL GLOBAL_SUM_INT( ntmp, myThid )
336 nWetcGlobal(k)=ntmp
337 write(msgbuf,'(a,2x,I3,2x,I10)')
338 & 'ctrl-wet 14a: global nWet... k=', k, ntmp
339
340 ntmp=0
341 do bj=1,nSy
342 do bi=1,nSx
343 ntmp=ntmp+nWetsTile(bi,bj,k)
344 enddo
345 enddo
346 CALL GLOBAL_SUM_INT( ntmp, myThid )
347 nWetsGlobal(k)=ntmp
348 write(msgbuf,'(a,2x,I3,2x,I10)')
349 & 'ctrl-wet 14b: global nWet... k=', k, ntmp
350
351 ntmp=0
352 do bj=1,nSy
353 do bi=1,nSx
354 ntmp=ntmp+nWetwTile(bi,bj,k)
355 enddo
356 enddo
357 CALL GLOBAL_SUM_INT( ntmp, myThid )
358 nWetwGlobal(k)=ntmp
359 write(msgbuf,'(a,2x,I3,2x,I10)')
360 & 'ctrl-wet 14c: global nWet... k=', k, ntmp
361
362 ntmp=0
363 do bj=1,nSy
364 do bi=1,nSx
365 ntmp=ntmp+nWetvTile(bi,bj,k)
366 enddo
367 enddo
368 CALL GLOBAL_SUM_INT( ntmp, myThid )
369 nWetvGlobal(k)=ntmp
370 write(msgbuf,'(a,2x,I3,2x,I10)')
371 & 'ctrl-wet 14d: global nWet... k=', k, ntmp
372
373 #ifdef ALLOW_OBCSN_CONTROL
374 do iobcs = 1, nobcs
375 ntmp=0
376 do bj=1,nSy
377 do bi=1,nSx
378 ntmp=ntmp+nwetobcsn(bi,bj,k,iobcs)
379 enddo
380 enddo
381 CALL GLOBAL_SUM_INT( ntmp, myThid )
382 nwetobcsnglo(k,iobcs)=ntmp
383 write(msgbuf,'(a,2(2x,I3),2x,I10)')
384 & 'ctrl-wet 15a: global nWet... k=', k, iobcs, ntmp
385 enddo
386 #endif
387 #ifdef ALLOW_OBCSS_CONTROL
388 do iobcs = 1, nobcs
389 ntmp=0
390 do bj=1,nSy
391 do bi=1,nSx
392 ntmp=ntmp+nwetobcss(bi,bj,k,iobcs)
393 enddo
394 enddo
395 CALL GLOBAL_SUM_INT( ntmp, myThid )
396 nwetobcssglo(k,iobcs)=ntmp
397 write(msgbuf,'(a,2(2x,I3),2x,I10)')
398 & 'ctrl-wet 15b: global nWet... k=', k, iobcs, ntmp
399 enddo
400 #endif
401 #ifdef ALLOW_OBCSW_CONTROL
402 do iobcs = 1, nobcs
403 ntmp=0
404 do bj=1,nSy
405 do bi=1,nSx
406 ntmp=ntmp+nwetobcsw(bi,bj,k,iobcs)
407 enddo
408 enddo
409 CALL GLOBAL_SUM_INT( ntmp, myThid )
410 nwetobcswglo(k,iobcs)=ntmp
411 write(msgbuf,'(a,2(2x,I3),2x,I10)')
412 & 'ctrl-wet 15c: global nWet... k=', k, iobcs, ntmp
413 enddo
414 #endif
415 #ifdef ALLOW_OBCSE_CONTROL
416 do iobcs = 1, nobcs
417 ntmp=0
418 do bj=1,nSy
419 do bi=1,nSx
420 ntmp=ntmp+nwetobcse(bi,bj,k,iobcs)
421 enddo
422 enddo
423 CALL GLOBAL_SUM_INT( ntmp, myThid )
424 nwetobcseglo(k,iobcs)=ntmp
425 write(msgbuf,'(a,2(2x,I3),2x,I10)')
426 & 'ctrl-wet 15d: global nWet... k=', k, iobcs, ntmp
427 enddo
428 #endif
429
430 enddo
431
432 write(msgbuf,'(a,2x,I10)')
433 & 'ctrl_init: no. of control variables: ', nvartype
434 call print_message( msgbuf, standardmessageunit,
435 & SQUEEZE_RIGHT , mythid)
436 write(msgbuf,'(a,2x,I10)')
437 & 'ctrl_init: control vector length: ', nvarlength
438 call print_message( msgbuf, standardmessageunit,
439 & SQUEEZE_RIGHT , mythid)
440
441 _END_MASTER( mythid )
442
443 c Set unit weight to 1
444 c
445 do bj=1,nSy
446 do bi=1,nSx
447 do k=1, nr
448 wunit(k,bi,bj) = 1. _d 0
449 enddo
450 enddo
451 enddo
452
453 c write masks and weights to files to be read by a master process
454 c
455 call active_write_xyz( 'maskCtrlC', maskC, 1, 0, mythid, dummy)
456 call active_write_xyz( 'maskCtrlW', maskW, 1, 0, mythid, dummy)
457 call active_write_xyz( 'maskCtrlS', maskS, 1, 0, mythid, dummy)
458 #if (defined (ALLOW_EFLUXP0_CONTROL))
459 call active_write_xyz( 'maskhFacV', hFacV, 1, 0, mythid, dummy)
460 #endif
461
462 return
463 end

  ViewVC Help
Powered by ViewVC 1.1.22