ROMS
Loading...
Searching...
No Matches
state_product.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE state_product_mod
3!
4!git $Id$
5!================================================== Hernan G. Arango ===
6! Copyright (c) 2002-2025 The ROMS Group !
7! Licensed under a MIT/X style license !
8! See License_ROMS.md !
9!=======================================================================
10! !
11! This routine computes the product of each element of two model !
12! states: !
13! !
14! s3(...) = s1(...) * s2(...) !
15! !
16!=======================================================================
17!
18 implicit none
19!
20 PUBLIC :: state_product
21!
22 CONTAINS
23!
24!***********************************************************************
25 SUBROUTINE state_product (ng, tile, model, &
26 & LBi, UBi, LBj, UBj, LBij, UBij, &
27#ifdef MASKING
28 & rmask, umask, vmask, &
29#endif
30#ifdef ADJUST_BOUNDARY
31# ifdef SOLVE3D
32 & s1_t_obc, s2_t_obc, s3_t_obc, &
33 & s1_u_obc, s2_u_obc, s3_u_obc, &
34 & s1_v_obc, s2_v_obc, s3_v_obc, &
35# endif
36 & s1_ubar_obc, s2_ubar_obc, s3_ubar_obc, &
37 & s1_vbar_obc, s2_vbar_obc, s3_vbar_obc, &
38 & s1_zeta_obc, s2_zeta_obc, s3_zeta_obc, &
39#endif
40#ifdef ADJUST_WSTRESS
41 & s1_sustr, s2_sustr, s3_sustr, &
42 & s1_svstr, s2_svstr, s3_svstr, &
43#endif
44#ifdef SOLVE3D
45# ifdef ADJUST_STFLUX
46 & s1_tflux, s2_tflux, s3_tflux, &
47# endif
48 & s1_t, s2_t, s3_t, &
49 & s1_u, s2_u, s3_u, &
50 & s1_v, s2_v, s3_v, &
51#else
52 & s1_ubar, s2_ubar, s3_ubar, &
53 & s1_vbar, s2_vbar, s3_vbar, &
54#endif
55 & s1_zeta, s2_zeta, s3_zeta)
56!***********************************************************************
57!
58 USE mod_param
59 USE mod_parallel
60 USE mod_ncparam
61#if defined ADJUST_BOUNDARY || defined ADJUST_STFLUX || \
62 defined adjust_wstress
63 USE mod_scalars
64#endif
65#ifdef DISTRIBUTE
66!
67 USE distribute_mod, ONLY : mp_reduce
68#endif
69!
70! Imported variable declarations.
71!
72 integer, intent(in) :: ng, tile, model
73 integer, intent(in) :: lbi, ubi, lbj, ubj, lbij, ubij
74!
75#ifdef ASSUMED_SHAPE
76# ifdef MASKING
77 real(r8), intent(in) :: rmask(lbi:,lbj:)
78 real(r8), intent(in) :: umask(lbi:,lbj:)
79 real(r8), intent(in) :: vmask(lbi:,lbj:)
80# endif
81# ifdef ADJUST_BOUNDARY
82# ifdef SOLVE3D
83 real(r8), intent(in) :: s1_t_obc(lbij:,:,:,:,:)
84 real(r8), intent(in) :: s2_t_obc(lbij:,:,:,:,:)
85 real(r8), intent(in) :: s1_u_obc(lbij:,:,:,:)
86 real(r8), intent(in) :: s2_u_obc(lbij:,:,:,:)
87 real(r8), intent(in) :: s1_v_obc(lbij:,:,:,:)
88 real(r8), intent(in) :: s2_v_obc(lbij:,:,:,:)
89
90 real(r8), intent(inout) :: s3_t_obc(lbij:,:,:,:,:)
91 real(r8), intent(inout) :: s3_u_obc(lbij:,:,:,:)
92 real(r8), intent(inout) :: s3_v_obc(lbij:,:,:,:)
93# endif
94 real(r8), intent(in) :: s1_ubar_obc(lbij:,:,:)
95 real(r8), intent(in) :: s2_ubar_obc(lbij:,:,:)
96 real(r8), intent(in) :: s1_vbar_obc(lbij:,:,:)
97 real(r8), intent(in) :: s2_vbar_obc(lbij:,:,:)
98 real(r8), intent(in) :: s1_zeta_obc(lbij:,:,:)
99 real(r8), intent(in) :: s2_zeta_obc(lbij:,:,:)
100
101 real(r8), intent(inout) :: s3_ubar_obc(lbij:,:,:)
102 real(r8), intent(inout) :: s3_vbar_obc(lbij:,:,:)
103 real(r8), intent(inout) :: s3_zeta_obc(lbij:,:,:)
104# endif
105# ifdef ADJUST_WSTRESS
106 real(r8), intent(in) :: s1_sustr(lbi:,lbj:,:)
107 real(r8), intent(in) :: s2_sustr(lbi:,lbj:,:)
108 real(r8), intent(in) :: s1_svstr(lbi:,lbj:,:)
109 real(r8), intent(in) :: s2_svstr(lbi:,lbj:,:)
110
111 real(r8), intent(inout) :: s3_sustr(lbi:,lbj:,:)
112 real(r8), intent(inout) :: s3_svstr(lbi:,lbj:,:)
113# endif
114# ifdef SOLVE3D
115# ifdef ADJUST_STFLUX
116 real(r8), intent(in) :: s1_tflux(lbi:,lbj:,:,:)
117 real(r8), intent(in) :: s2_tflux(lbi:,lbj:,:,:)
118
119 real(r8), intent(inout) :: s3_tflux(lbi:,lbj:,:,:)
120# endif
121 real(r8), intent(in) :: s1_t(lbi:,lbj:,:,:)
122 real(r8), intent(in) :: s2_t(lbi:,lbj:,:,:)
123 real(r8), intent(in) :: s1_u(lbi:,lbj:,:)
124 real(r8), intent(in) :: s2_u(lbi:,lbj:,:)
125 real(r8), intent(in) :: s1_v(lbi:,lbj:,:)
126 real(r8), intent(in) :: s2_v(lbi:,lbj:,:)
127
128 real(r8), intent(inout) :: s3_t(lbi:,lbj:,:,:)
129 real(r8), intent(inout) :: s3_u(lbi:,lbj:,:)
130 real(r8), intent(inout) :: s3_v(lbi:,lbj:,:)
131# else
132 real(r8), intent(in) :: s1_ubar(lbi:,lbj:)
133 real(r8), intent(in) :: s2_ubar(lbi:,lbj:)
134 real(r8), intent(in) :: s1_vbar(lbi:,lbj:)
135 real(r8), intent(in) :: s2_vbar(lbi:,lbj:)
136
137 real(r8), intent(inout) :: s3_ubar(lbi:,lbj:)
138 real(r8), intent(inout) :: s3_vbar(lbi:,lbj:)
139# endif
140 real(r8), intent(in) :: s1_zeta(lbi:,lbj:)
141 real(r8), intent(in) :: s2_zeta(lbi:,lbj:)
142
143 real(r8), intent(inout) :: s3_zeta(lbi:,lbj:)
144
145#else
146
147# ifdef MASKING
148 real(r8), intent(in) :: rmask(lbi:ubi,lbj:ubj)
149 real(r8), intent(in) :: umask(lbi:ubi,lbj:ubj)
150 real(r8), intent(in) :: vmask(lbi:ubi,lbj:ubj)
151# endif
152
153# ifdef ADJUST_BOUNDARY
154# ifdef SOLVE3D
155 real(r8), intent(in) :: s1_t_obc(lbij:ubij,n(ng),4, &
156 & Nbrec(ng),NT(ng))
157 real(r8), intent(in) :: s2_t_obc(lbij:ubij,n(ng),4, &
158 & Nbrec(ng),NT(ng))
159 real(r8), intent(in) :: s1_u_obc(lbij:ubij,n(ng),4,nbrec(ng))
160 real(r8), intent(in) :: s2_u_obc(lbij:ubij,n(ng),4,nbrec(ng))
161 real(r8), intent(in) :: s1_v_obc(lbij:ubij,n(ng),4,nbrec(ng))
162 real(r8), intent(in) :: s2_v_obc(lbij:ubij,n(ng),4,nbrec(ng))
163
164 real(r8), intent(inout) :: s3_t_obc(lbij:ubij,n(ng),4, &
165 & Nbrec(ng),NT(ng))
166 real(r8), intent(inout) :: s3_u_obc(lbij:ubij,n(ng),4,nbrec(ng))
167 real(r8), intent(inout) :: s3_v_obc(lbij:ubij,n(ng),4,nbrec(ng))
168# endif
169 real(r8), intent(in) :: s1_ubar_obc(lbij:ubij,4,nbrec(ng))
170 real(r8), intent(in) :: s2_ubar_obc(lbij:ubij,4,nbrec(ng))
171 real(r8), intent(in) :: s1_vbar_obc(lbij:ubij,4,nbrec(ng))
172 real(r8), intent(in) :: s2_vbar_obc(lbij:ubij,4,nbrec(ng))
173 real(r8), intent(in) :: s1_zeta_obc(lbij:ubij,4,nbrec(ng))
174 real(r8), intent(in) :: s2_zeta_obc(lbij:ubij,4,nbrec(ng))
175
176 real(r8), intent(inout) :: s3_ubar_obc(lbij:ubij,4,nbrec(ng))
177 real(r8), intent(inout) :: s3_vbar_obc(lbij:ubij,4,nbrec(ng))
178 real(r8), intent(inout) :: s3_zeta_obc(lbij:ubij,4,nbrec(ng))
179# endif
180# ifdef ADJUST_WSTRESS
181 real(r8), intent(in) :: s1_sustr(lbi:ubi,lbj:ubj,nfrec(ng))
182 real(r8), intent(in) :: s2_sustr(lbi:ubi,lbj:ubj,nfrec(ng))
183 real(r8), intent(in) :: s1_svstr(lbi:ubi,lbj:ubj,nfrec(ng))
184 real(r8), intent(in) :: s2_svstr(lbi:ubi,lbj:ubj,nfrec(ng))
185
186 real(r8), intent(inout) :: s3_sustr(lbi:ubi,lbj:ubj,nfrec(ng))
187 real(r8), intent(inout) :: s3_svstr(lbi:ubi,lbj:ubj,nfrec(ng))
188# endif
189# ifdef SOLVE3D
190# ifdef ADJUST_STFLUX
191 real(r8), intent(in) :: s1_tflux(lbi:ubi,lbj:ubj,nfrec(ng),nt(ng))
192 real(r8), intent(in) :: s2_tflux(lbi:ubi,lbj:ubj,nfrec(ng),nt(ng))
193
194 real(r8), intent(inout) :: s3_tflux(lbi:ubi,lbj:ubj, &
195 & Nfrec(ng),NT(ng))
196# endif
197 real(r8), intent(in) :: s1_t(lbi:ubi,lbj:ubj,n(ng),nt(ng))
198 real(r8), intent(in) :: s2_t(lbi:ubi,lbj:ubj,n(ng),nt(ng))
199 real(r8), intent(in) :: s1_u(lbi:ubi,lbj:ubj,n(ng))
200 real(r8), intent(in) :: s2_u(lbi:ubi,lbj:ubj,n(ng))
201 real(r8), intent(in) :: s1_v(lbi:ubi,lbj:ubj,n(ng))
202 real(r8), intent(in) :: s2_v(lbi:ubi,lbj:ubj,n(ng))
203
204 real(r8), intent(inout) :: s3_t(lbi:ubi,lbj:ubj,n(ng),nt(ng))
205 real(r8), intent(inout) :: s3_u(lbi:ubi,lbj:ubj,n(ng))
206 real(r8), intent(inout) :: s3_v(lbi:ubi,lbj:ubj,n(ng))
207# else
208 real(r8), intent(in) :: s1_ubar(lbi:ubi,lbj:ubj)
209 real(r8), intent(in) :: s2_ubar(lbi:ubi,lbj:ubj)
210 real(r8), intent(in) :: s1_vbar(lbi:ubi,lbj:ubj)
211 real(r8), intent(in) :: s2_vbar(lbi:ubi,lbj:ubj)
212
213 real(r8), intent(inout) :: s3_ubar(lbi:ubi,lbj:ubj)
214 real(r8), intent(inout) :: s3_vbar(lbi:ubi,lbj:ubj)
215# endif
216 real(r8), intent(in) :: s1_zeta(lbi:ubi,lbj:ubj)
217 real(r8), intent(in) :: s2_zeta(lbi:ubi,lbj:ubj)
218
219 real(r8), intent(inout) :: s3_zeta(lbi:ubi,lbj:ubj)
220#endif
221!
222! Local variable declarations.
223!
224 integer :: nsub, i, j, k
225 integer :: ir, it
226
227 real(r8) :: cff
228
229#include "set_bounds.h"
230!
231!-----------------------------------------------------------------------
232! Compute product between S1 and S2 model state trajectories and save
233! in S3.
234!-----------------------------------------------------------------------
235!
236! Free-surface.
237!
238 DO j=jstrt,jendt
239 DO i=istrt,iendt
240 cff=s1_zeta(i,j)*s2_zeta(i,j)
241#ifdef MASKING
242 cff=cff*rmask(i,j)
243#endif
244 s3_zeta(i,j)=cff
245 END DO
246 END DO
247
248#ifdef ADJUST_BOUNDARY
249!
250! Free-surface open boundaries.
251!
252 IF (any(lobc(:,isfsur,ng))) THEN
253 DO ir=1,nbrec(ng)
254 IF ((lobc(iwest,isfsur,ng)).and. &
255 & domain(ng)%Western_Edge(tile)) THEN
256 DO j=jstr,jend
257 cff=s1_zeta_obc(j,iwest,ir)*s2_zeta_obc(j,iwest,ir)
258# ifdef MASKING
259 cff=cff*rmask(istr-1,j)
260# endif
261 s3_zeta_obc(j,iwest,ir)=cff
262 END DO
263 END IF
264 IF ((lobc(ieast,isfsur,ng)).and. &
265 & domain(ng)%Eastern_Edge(tile)) THEN
266 DO j=jstr,jend
267 cff=s1_zeta_obc(j,ieast,ir)* &
268 & s2_zeta_obc(j,ieast,ir)
269# ifdef MASKING
270 cff=cff*rmask(iend+1,j)
271# endif
272 s3_zeta_obc(j,ieast,ir)=cff
273 END DO
274 END IF
275 IF ((lobc(isouth,isfsur,ng)).and. &
276 & domain(ng)%Southern_Edge(tile)) THEN
277 DO i=istr,iend
278 cff=s1_zeta_obc(i,isouth,ir)* &
279 & s2_zeta_obc(i,isouth,ir)
280# ifdef MASKING
281 cff=cff*rmask(i,jstr-1)
282# endif
283 s3_zeta_obc(i,isouth,ir)=cff
284 END DO
285 END IF
286 IF ((lobc(inorth,isfsur,ng)).and. &
287 & domain(ng)%Northern_Edge(tile)) THEN
288 DO i=istr,iend
289 cff=s1_zeta_obc(i,inorth,ir)* &
290 & s2_zeta_obc(i,inorth,ir)
291# ifdef MASKING
292 cff=cff*rmask(i,jend+1)
293# endif
294 s3_zeta_obc(i,inorth,ir)=cff
295 END DO
296 END IF
297 END DO
298 END IF
299#endif
300
301#ifndef SOLVE3D
302!
303! 2D U-momentum component.
304!
305 DO j=jstrt,jendt
306 DO i=istrp,iendt
307 cff=s1_ubar(i,j)*s2_ubar(i,j)
308# ifdef MASKING
309 cff=cff*umask(i,j)
310# endif
311 s3_ubar(i,j)=cff
312 END DO
313 END DO
314#endif
315
316#ifdef ADJUST_BOUNDARY
317!
318! 2D U-momentum open boundaries.
319!
320 IF (any(lobc(:,isubar,ng))) THEN
321 DO ir=1,nbrec(ng)
322 IF ((lobc(iwest,isubar,ng)).and. &
323 & domain(ng)%Western_Edge(tile)) THEN
324 DO j=jstr,jend
325 cff=s1_ubar_obc(j,iwest,ir)* &
326 & s2_ubar_obc(j,iwest,ir)
327# ifdef MASKING
328 cff=cff*umask(istr,j)
329# endif
330 s3_ubar_obc(j,iwest,ir)=cff
331 END DO
332 END IF
333 IF ((lobc(ieast,isubar,ng)).and. &
334 & domain(ng)%Eastern_Edge(tile)) THEN
335 DO j=jstr,jend
336 cff=s1_ubar_obc(j,ieast,ir)* &
337 & s2_ubar_obc(j,ieast,ir)
338# ifdef MASKING
339 cff=cff*umask(iend+1,j)
340# endif
341 s3_ubar_obc(j,ieast,ir)=cff
342 END DO
343 END IF
344 IF ((lobc(isouth,isubar,ng)).and. &
345 & domain(ng)%Southern_Edge(tile)) THEN
346 DO i=istru,iend
347 cff=s1_ubar_obc(i,isouth,ir)* &
348 & s2_ubar_obc(i,isouth,ir)
349# ifdef MASKING
350 cff=cff*umask(i,jstr-1)
351# endif
352 s3_ubar_obc(i,isouth,ir)=cff
353 END DO
354 END IF
355 IF ((lobc(inorth,isubar,ng)).and. &
356 & domain(ng)%Northern_Edge(tile)) THEN
357 DO i=istru,iend
358 cff=s1_ubar_obc(i,inorth,ir)* &
359 & s2_ubar_obc(i,inorth,ir)
360# ifdef MASKING
361 cff=cff*umask(i,jend+1)
362# endif
363 s3_ubar_obc(i,inorth,ir)=cff
364 END DO
365 END IF
366 END DO
367 END IF
368#endif
369
370#ifndef SOLVE3D
371!
372! 2D V-momentum component.
373!
374 DO j=jstrp,jendt
375 DO i=istrt,iendt
376 cff=s1_vbar(i,j)*s2_vbar(i,j)
377# ifdef MASKING
378 cff=cff*vmask(i,j)
379# endif
380 s3_vbar(i,j)=cff
381 END DO
382 END DO
383#endif
384
385#ifdef ADJUST_BOUNDARY
386!
387! 2D V-momentum open boundaries.
388!
389 IF (any(lobc(:,isvbar,ng))) THEN
390 DO ir=1,nbrec(ng)
391 IF ((lobc(iwest,isvbar,ng)).and. &
392 & domain(ng)%Western_Edge(tile)) THEN
393 DO j=jstrv,jend
394 cff=s1_vbar_obc(j,iwest,ir)* &
395 & s2_vbar_obc(j,iwest,ir)
396# ifdef MASKING
397 cff=cff*vmask(istr-1,j)
398# endif
399 s3_vbar_obc(j,iwest,ir)=cff
400 END DO
401 END IF
402 IF ((lobc(ieast,isvbar,ng)).and. &
403 & domain(ng)%Eastern_Edge(tile)) THEN
404 DO j=jstrv,jend
405 cff=s1_vbar_obc(j,ieast,ir)* &
406 & s2_vbar_obc(j,ieast,ir)
407# ifdef MASKING
408 cff=cff*vmask(iend+1,j)
409# endif
410 s3_vbar_obc(j,ieast,ir)=cff
411 END DO
412 END IF
413 IF ((lobc(isouth,isvbar,ng)).and. &
414 & domain(ng)%Southern_Edge(tile)) THEN
415 DO i=istr,iend
416 cff=s1_vbar_obc(i,isouth,ir)* &
417 & s2_vbar_obc(i,isouth,ir)
418# ifdef MASKING
419 cff=cff*vmask(i,jstr)
420# endif
421 s3_vbar_obc(i,isouth,ir)=cff
422 END DO
423 END IF
424 IF ((lobc(inorth,isvbar,ng)).and. &
425 & domain(ng)%Northern_Edge(tile)) THEN
426 DO i=istr,iend
427 cff=s1_vbar_obc(i,inorth,ir)* &
428 & s2_vbar_obc(i,inorth,ir)
429# ifdef MASKING
430 cff=cff*vmask(i,jend+1)
431# endif
432 s3_vbar_obc(i,inorth,ir)=cff
433 END DO
434 END IF
435 END DO
436 END IF
437#endif
438
439#ifdef ADJUST_WSTRESS
440!
441! Surface momentum stress.
442!
443 DO ir=1,nfrec(ng)
444 DO j=jstrt,jendt
445 DO i=istrp,iendt
446 cff=s1_sustr(i,j,ir)*s2_sustr(i,j,ir)
447# ifdef MASKING
448 cff=cff*umask(i,j)
449# endif
450 s3_sustr(i,j,ir)=cff
451 END DO
452 END DO
453 DO j=jstrp,jendt
454 DO i=istrt,iendt
455 cff=s1_svstr(i,j,ir)*s2_svstr(i,j,ir)
456# ifdef MASKING
457 cff=cff*vmask(i,j)
458# endif
459 s3_svstr(i,j,ir)=cff
460 END DO
461 END DO
462 END DO
463#endif
464
465#ifdef SOLVE3D
466!
467! 3D U-momentum component.
468!
469 DO k=1,n(ng)
470 DO j=jstrt,jendt
471 DO i=istrp,iendt
472 cff=s1_u(i,j,k)*s2_u(i,j,k)
473# ifdef MASKING
474 cff=cff*umask(i,j)
475# endif
476 s3_u(i,j,k)=cff
477 END DO
478 END DO
479 END DO
480
481# ifdef ADJUST_BOUNDARY
482!
483! 3D U-momentum open boundaries.
484!
485 IF (any(lobc(:,isuvel,ng))) THEN
486 DO ir=1,nbrec(ng)
487 IF ((lobc(iwest,isuvel,ng)).and. &
488 & domain(ng)%Western_Edge(tile)) THEN
489 DO k=1,n(ng)
490 DO j=jstr,jend
491 cff=s1_u_obc(j,k,iwest,ir)* &
492 & s2_u_obc(j,k,iwest,ir)
493# ifdef MASKING
494 cff=cff*umask(istr,j)
495# endif
496 s3_u_obc(j,k,iwest,ir)=cff
497 END DO
498 END DO
499 END IF
500 IF ((lobc(ieast,isuvel,ng)).and. &
501 & domain(ng)%Eastern_Edge(tile)) THEN
502 DO k=1,n(ng)
503 DO j=jstr,jend
504 cff=s1_u_obc(j,k,ieast,ir)* &
505 & s2_u_obc(j,k,ieast,ir)
506# ifdef MASKING
507 cff=cff*umask(iend+1,j)
508# endif
509 s3_u_obc(j,k,ieast,ir)=cff
510 END DO
511 END DO
512 END IF
513 IF ((lobc(isouth,isuvel,ng)).and. &
514 & domain(ng)%Southern_Edge(tile)) THEN
515 DO k=1,n(ng)
516 DO i=istru,iend
517 cff=s1_u_obc(i,k,isouth,ir)* &
518 & s2_u_obc(i,k,isouth,ir)
519# ifdef MASKING
520 cff=cff*umask(i,jstr-1)
521# endif
522 s3_u_obc(i,k,isouth,ir)=cff
523 END DO
524 END DO
525 END IF
526 IF ((lobc(inorth,isuvel,ng)).and. &
527 & domain(ng)%Northern_Edge(tile)) THEN
528 DO k=1,n(ng)
529 DO i=istru,iend
530 cff=s1_u_obc(i,k,inorth,ir)* &
531 & s2_u_obc(i,k,inorth,ir)
532# ifdef MASKING
533 cff=cff*umask(i,jend+1)
534# endif
535 s3_u_obc(i,k,inorth,ir)=cff
536 END DO
537 END DO
538 END IF
539 END DO
540 END IF
541# endif
542!
543! 3D V-momentum component.
544!
545 DO k=1,n(ng)
546 DO j=jstrp,jendt
547 DO i=istrt,iendt
548 cff=s1_v(i,j,k)*s2_v(i,j,k)
549# ifdef MASKING
550 cff=cff*vmask(i,j)
551# endif
552 s3_v(i,j,k)=cff
553 END DO
554 END DO
555 END DO
556
557# ifdef ADJUST_BOUNDARY
558!
559! 3D V-momentum open boundaries.
560!
561 IF (any(lobc(:,isvvel,ng))) THEN
562 DO ir=1,nbrec(ng)
563 IF ((lobc(iwest,isvvel,ng)).and. &
564 & domain(ng)%Western_Edge(tile)) THEN
565 DO k=1,n(ng)
566 DO j=jstrv,jend
567 cff=s1_v_obc(j,k,iwest,ir)* &
568 & s2_v_obc(j,k,iwest,ir)
569# ifdef MASKING
570 cff=cff*vmask(istr-1,j)
571# endif
572 s3_v_obc(j,k,iwest,ir)=cff
573 END DO
574 END DO
575 END IF
576 IF ((lobc(ieast,isvvel,ng)).and. &
577 & domain(ng)%Eastern_Edge(tile)) THEN
578 DO k=1,n(ng)
579 DO j=jstrv,jend
580 cff=s1_v_obc(j,k,ieast,ir)* &
581 & s2_v_obc(j,k,ieast,ir)
582# ifdef MASKING
583 cff=cff*vmask(iend+1,j)
584# endif
585 s3_v_obc(j,k,ieast,ir)=cff
586 END DO
587 END DO
588 END IF
589 IF ((lobc(isouth,isvvel,ng)).and. &
590 & domain(ng)%Southern_Edge(tile)) THEN
591 DO k=1,n(ng)
592 DO i=istr,iend
593 cff=s1_v_obc(i,k,isouth,ir)* &
594 & s2_v_obc(i,k,isouth,ir)
595# ifdef MASKING
596 cff=cff*vmask(i,jstr)
597# endif
598 s3_v_obc(i,k,isouth,ir)=cff
599 END DO
600 END DO
601 END IF
602 IF ((lobc(inorth,isvvel,ng)).and. &
603 & domain(ng)%Northern_Edge(tile)) THEN
604 DO k=1,n(ng)
605 DO i=istr,iend
606 cff=s1_v_obc(i,k,inorth,ir)* &
607 & s2_v_obc(i,k,inorth,ir)
608# ifdef MASKING
609 cff=cff*vmask(i,jend+1)
610# endif
611 s3_v_obc(i,k,inorth,ir)=cff
612 END DO
613 END DO
614 END IF
615 END DO
616 END IF
617# endif
618!
619! Tracers.
620!
621 DO it=1,nt(ng)
622 DO k=1,n(ng)
623 DO j=jstrt,jendt
624 DO i=istrt,iendt
625 cff=s1_t(i,j,k,it)*s2_t(i,j,k,it)
626# ifdef MASKING
627 cff=cff*rmask(i,j)
628# endif
629 s3_t(i,j,k,it)=cff
630 END DO
631 END DO
632 END DO
633 END DO
634
635# ifdef ADJUST_BOUNDARY
636!
637! Tracers open boundaries.
638!
639 DO it=1,nt(ng)
640 IF (any(lobc(:,istvar(it),ng))) THEN
641 DO ir=1,nbrec(ng)
642 IF ((lobc(iwest,istvar(it),ng)).and. &
643 & domain(ng)%Western_Edge(tile)) THEN
644 DO k=1,n(ng)
645 DO j=jstr,jend
646 cff=s1_t_obc(j,k,iwest,ir,it)* &
647 & s2_t_obc(j,k,iwest,ir,it)
648# ifdef MASKING
649 cff=cff*rmask(istr-1,j)
650# endif
651 s3_t_obc(j,k,iwest,ir,it)=cff
652 END DO
653 END DO
654 END IF
655 IF ((lobc(ieast,istvar(it),ng)).and. &
656 & domain(ng)%Eastern_Edge(tile)) THEN
657 DO k=1,n(ng)
658 DO j=jstr,jend
659 cff=s1_t_obc(j,k,ieast,ir,it)* &
660 & s2_t_obc(j,k,ieast,ir,it)
661# ifdef MASKING
662 cff=cff*rmask(iend+1,j)
663# endif
664 s3_t_obc(j,k,ieast,ir,it)=cff
665 END DO
666 END DO
667 END IF
668 IF ((lobc(isouth,istvar(it),ng)).and. &
669 & domain(ng)%Southern_Edge(tile)) THEN
670 DO k=1,n(ng)
671 DO i=istr,iend
672 cff=s1_t_obc(i,k,isouth,ir,it)* &
673 & s2_t_obc(i,k,isouth,ir,it)
674# ifdef MASKING
675 cff=cff*rmask(i,jstr-1)
676# endif
677 s3_t_obc(i,k,isouth,ir,it)=cff
678 END DO
679 END DO
680 END IF
681 IF ((lobc(inorth,istvar(it),ng)).and. &
682 & domain(ng)%Northern_Edge(tile)) THEN
683 DO k=1,n(ng)
684 DO i=istr,iend
685 cff=s1_t_obc(i,k,inorth,ir,it)* &
686 & s2_t_obc(i,k,inorth,ir,it)
687# ifdef MASKING
688 cff=cff*rmask(i,jend+1)
689# endif
690 s3_t_obc(i,k,inorth,ir,it)=cff
691 END DO
692 END DO
693 END IF
694 END DO
695 END IF
696 END DO
697# endif
698
699# ifdef ADJUST_STFLUX
700!
701! Surface tracers flux.
702!
703 DO it=1,nt(ng)
704 IF (lstflux(it,ng)) THEN
705 DO ir=1,nfrec(ng)
706 DO j=jstrt,jendt
707 DO i=istrt,iendt
708 cff=s1_tflux(i,j,ir,it)*s2_tflux(i,j,ir,it)
709# ifdef MASKING
710 cff=cff*rmask(i,j)
711# endif
712 s3_tflux(i,j,ir,it)=cff
713 END DO
714 END DO
715 END DO
716 END IF
717 END DO
718# endif
719
720#endif
721!
722 RETURN
723 END SUBROUTINE state_product
724
725 END MODULE state_product_mod
distribute_mod::mp_reduce
Definition distribute.F:113
distribute_mod
Definition distribute.F:3
mod_ncparam
Definition mod_ncparam.F:2
mod_ncparam::isvvel
integer isvvel
Definition mod_ncparam.F:507
mod_ncparam::isvbar
integer isvbar
Definition mod_ncparam.F:505
mod_ncparam::istvar
integer, dimension(:), allocatable istvar
Definition mod_ncparam.F:520
mod_ncparam::isuvel
integer isuvel
Definition mod_ncparam.F:506
mod_ncparam::isfsur
integer isfsur
Definition mod_ncparam.F:503
mod_ncparam::isubar
integer isubar
Definition mod_ncparam.F:504
mod_parallel
Definition mod_parallel.F:2
mod_param
Definition mod_param.F:2
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::domain
type(t_domain), dimension(:), allocatable domain
Definition mod_param.F:329
mod_param::nt
integer, dimension(:), allocatable nt
Definition mod_param.F:489
mod_scalars
Definition mod_scalars.F:2
mod_scalars::lobc
logical, dimension(:,:,:), allocatable lobc
Definition mod_scalars.F:1127
mod_scalars::iwest
integer, parameter iwest
Definition mod_scalars.F:1432
mod_scalars::lstflux
logical, dimension(:,:), allocatable lstflux
Definition mod_scalars.F:1156
mod_scalars::nfrec
integer, dimension(:), allocatable nfrec
Definition mod_scalars.F:1148
mod_scalars::isouth
integer, parameter isouth
Definition mod_scalars.F:1433
mod_scalars::ieast
integer, parameter ieast
Definition mod_scalars.F:1434
mod_scalars::inorth
integer, parameter inorth
Definition mod_scalars.F:1435
mod_scalars::nbrec
integer, dimension(:), allocatable nbrec
Definition mod_scalars.F:1119
state_product_mod
Definition state_product.F:2
state_product_mod::state_product
subroutine, public state_product(ng, tile, model, lbi, ubi, lbj, ubj, lbij, ubij, rmask, umask, vmask, s1_t_obc, s2_t_obc, s3_t_obc, s1_u_obc, s2_u_obc, s3_u_obc, s1_v_obc, s2_v_obc, s3_v_obc, s1_ubar_obc, s2_ubar_obc, s3_ubar_obc, s1_vbar_obc, s2_vbar_obc, s3_vbar_obc, s1_zeta_obc, s2_zeta_obc, s3_zeta_obc, s1_sustr, s2_sustr, s3_sustr, s1_svstr, s2_svstr, s3_svstr, s1_tflux, s2_tflux, s3_tflux, s1_t, s2_t, s3_t, s1_u, s2_u, s3_u, s1_v, s2_v, s3_v, s1_zeta, s2_zeta, s3_zeta)
Definition state_product.F:56