ROMS
Loading...
Searching...
No Matches
packing.F
Go to the documentation of this file.
1#include "cppdefs.h"
2
3#if defined OPT_PERTURBATION || defined FORCING_SV
4# define ENERGYNORM_SCALE
5#endif
6#if defined STOCHASTIC_OPT
7# ifndef HESSIAN_SO
8# define ENERGYNORM_SCALE
9# endif
10#endif
11
12#ifdef FULL_GRID
13# define IR_RANGE IstrT,IendT
14# define IU_RANGE IstrP,IendT
15# define JR_RANGE JstrT,JendT
16# define JV_RANGE JstrP,JendT
17#else
18# define IR_RANGE Istr,Iend
19# define IU_RANGE IstrU,Iend
20# define JR_RANGE Jstr,Jend
21# define JV_RANGE JstrV,Jend
22#endif
23
24 MODULE packing_mod
25
26#ifdef PROPAGATOR
27!
28!git $Id$
29!================================================== Hernan G. Arango ===
30! Copyright (c) 2002-2025 The ROMS Group Andrew M. Moore !
31! Licensed under a MIT/X style license !
32! See License_ROMS.md !
33!=======================================================================
34! !
35! These routines pack and unpack model state varaibles into/from a !
36! single vector to interface with ARPACKs Arnoldi Method for the !
37! computation Ritz eigenfunctions. !
38! !
39!=======================================================================
40!
41 implicit none
42!
43 PRIVATE
44 PUBLIC :: c_norm2
45 PUBLIC :: r_norm2
46# ifdef ADJOINT
47# ifdef STOCHASTIC_OPT
48# ifdef STOCH_OPT_WHITE
49 PUBLIC :: ad_so_pack
50# else
51 PUBLIC :: ad_so_pack_red
52# endif
53# else
54 PUBLIC :: ad_pack
55# endif
56 PUBLIC :: ad_unpack
57# endif
58# ifdef TANGENT
59 PUBLIC :: tl_pack
60 PUBLIC :: tl_unpack
61# endif
62# ifdef SO_SEMI
63# ifdef SO_SEMI_WHITE
64 PUBLIC :: so_semi_white
65# else
66 PUBLIC :: so_semi_red
67# endif
68# endif
69!
70 CONTAINS
71!
72 SUBROUTINE c_norm2 (ng, model, Mstr, Mend, &
73 & EvalueR, EvalueI, EvectorR, EvectorI, &
74 & state, norm2)
75!
76!=======================================================================
77! !
78! This function computes the Euclidean norm between the propagator !
79! real/imaginary Ritz eigenvalue (EvalueR, EvalueI) and eigenvector !
80! (EvectorR, EvectorI) with state vector (state): !
81! !
82! norm2 = Euclidean NORM (state(:) + EvalueR * EvectorR(:) + !
83! EvalueI * EvectorI(:)) !
84! !
85! WARNING: This function is only intended for serial or distributed !
86! memory applications. There is not tiled partitions. All !
87! quantities are vectors. It replaces the calls to "daxpy" !
88! and "dnrm2" from the BLAS library. This "legacy" library !
89! gives different results when called inside modules and !
90! the input arguments are pointers (specially using ifort). !
91! !
92!=======================================================================
93!
94 USE mod_param
95 USE mod_parallel
96
97# ifdef DISTRIBUTE
98!
99 USE distribute_mod, ONLY : mp_reduce
100# endif
101!
102! Imported variable declarations.
103!
104 integer, intent(in) :: ng, model
105 integer, intent(in) :: Mstr, Mend
106
107 real(r8), intent(in) :: EvalueR
108 real(r8), intent(in) :: EvalueI
109
110# ifdef ASSUMED_SHAPE
111 real(r8), intent(in) :: EvectorR(Mstr:)
112 real(r8), intent(in) :: EvectorI(Mstr:)
113 real(r8), intent(in) :: state(Mstr:)
114# else
115 real(r8), intent(in) :: EvectorR(Mstr:Mend)
116 real(r8), intent(in) :: EvectorI(Mstr:Mend)
117 real(r8), intent(in) :: state(Mstr:Mend)
118# endif
119 real(r8), intent(out) :: norm2
120!
121! Local variable declarations.
122!
123 integer :: NSUB, is
124
125 real(r8) :: cff, my_norm2
126
127# ifdef DISTRIBUTE
128 character (len=3) :: op_handle
129# endif
130!
131!-----------------------------------------------------------------------
132! Compute the Euclidean norm of: state(:) + Rvalue * Rvector(:)
133!-----------------------------------------------------------------------
134!
135! Accumulate squared sum.
136!
137 my_norm2=0.0_r8
138 DO is=mstr,mend
139 cff=state(is)+evaluer*evectorr(is)+ &
140 & evaluei*evectori(is)
141 my_norm2=my_norm2+cff*cff
142 END DO
143!
144! Take sum squared-root: perform global reduction.
145!
146# ifdef DISTRIBUTE
147 nsub=1 ! distributed-memory
148# else
149 nsub=ntilex(ng)*ntilee(ng) ! tiled application
150# endif
151!$OMP CRITICAL (C_NORM)
152 IF (tile_count.eq.0) THEN
153 norm2=my_norm2
154 ELSE
155 norm2=norm2+my_norm2
156 END IF
157 tile_count=tile_count+1
158 IF (tile_count.eq.nsub) THEN
159 tile_count=0
160# ifdef DISTRIBUTE
161 op_handle='SUM'
162 CALL mp_reduce (ng, model, 1, norm2, op_handle)
163# endif
164 END IF
165!$OMP END CRITICAL (C_NORM)
166 norm2=sqrt(norm2)
167!
168 RETURN
169 END SUBROUTINE c_norm2
170!
171# if defined HESSIAN_FSV || defined HESSIAN_SO || defined HESSIAN_SV
172
173 SUBROUTINE r_norm2 (ng, model, Mstr, Mend, &
174 & Evalue, Evector, state, norm2)
175!
176!=======================================================================
177! !
178! This function computes the Euclidean norm between the propagator !
179! real Ritz eigenvalue (Evalue) and eigenvector (Evector) with the !
180! state vector (state): !
181! !
182! norm2 = Euclidean NORM (state(:) + Evalue * Evector(:)) !
183! !
184! WARNING: The norm is computed by the master thread and broadcasted !
185! to all the nodes in the group. It is used when the state !
186! vector is not partitioned between all nodes. !
187! !
188!=======================================================================
189!
190 USE mod_param
191 USE mod_parallel
192
193# ifdef DISTRIBUTE
194!
195 USE distribute_mod, ONLY : mp_bcastf
196# endif
197!
198! Imported variable declarations.
199!
200 integer, intent(in) :: ng, model
201 integer, intent(in) :: Mstr, Mend
202
203 real(r8), intent(in) :: Evalue
204
205# ifdef ASSUMED_SHAPE
206 real(r8), intent(in) :: Evector(Mstr:)
207 real(r8), intent(in) :: state(Mstr:)
208# else
209 real(r8), intent(in) :: Evector(Mstr:Mend)
210 real(r8), intent(in) :: state(Mstr:Mend)
211# endif
212 real(r8), intent(out) :: norm2
213!
214! Local variable declarations.
215!
216 integer :: NSUB, is
217
218 real(r8) :: cff, my_norm2
219!
220!-----------------------------------------------------------------------
221! Compute the Euclidean norm of: state(:) + Rvalue * Rvector(:)
222!-----------------------------------------------------------------------
223!
224! Accumulate squared sum.
225!
226 IF (master) THEN
227 my_norm2=0.0_r8
228 DO is=mstr,mend
229 cff=state(is)+evalue*evector(is)
230 my_norm2=my_norm2+cff*cff
231 END DO
232 norm2=sqrt(my_norm2)
233 END IF
234
235# ifdef DISTRIBUTE
236 CALL mp_bcastf (ng, model, norm2)
237# endif
238!
239 RETURN
240 END SUBROUTINE r_norm2
241
242# else
243
244 SUBROUTINE r_norm2 (ng, model, Mstr, Mend, &
245 & Evalue, Evector, state, norm2)
246!
247!=======================================================================
248! !
249! This function computes the Euclidean norm between the propagator !
250! real Ritz eigenvalue (Evalue) and eigenvector (Evector) with the !
251! state vector (state): !
252! !
253! norm2 = Euclidean NORM (state(:) + Evalue * Evector(:)) !
254! !
255! WARNING: This function is only intended for serial or distributed !
256! memory applications. There is not tiled partitions. All !
257! quantities are vectors. It replaces the calls to "daxpy" !
258! and "dnrm2" from the BLAS library. This "legacy" library !
259! gives different results when called inside modules and !
260! the input arguments are pointers (specially using ifort). !
261! !
262!=======================================================================
263!
264 USE mod_param
265 USE mod_parallel
266
267# ifdef DISTRIBUTE
268!
269 USE distribute_mod, ONLY : mp_reduce
270# endif
271!
272! Imported variable declarations.
273!
274 integer, intent(in) :: ng, model
275 integer, intent(in) :: Mstr, Mend
276
277 real(r8), intent(in) :: Evalue
278
279# ifdef ASSUMED_SHAPE
280 real(r8), intent(in) :: Evector(Mstr:)
281 real(r8), intent(in) :: state(Mstr:)
282# else
283 real(r8), intent(in) :: Evector(Mstr:Mend)
284 real(r8), intent(in) :: state(Mstr:Mend)
285# endif
286 real(r8), intent(out) :: norm2
287!
288! Local variable declarations.
289!
290 integer :: NSUB, is
291
292 real(r8) :: cff, my_norm2
293
294# ifdef DISTRIBUTE
295 character (len=3) :: op_handle
296# endif
297!
298!-----------------------------------------------------------------------
299! Compute the Euclidean norm of: state(:) + Rvalue * Rvector(:)
300!-----------------------------------------------------------------------
301!
302! Accumulate squared sum.
303!
304 my_norm2=0.0_r8
305 DO is=mstr,mend
306 cff=state(is)+evalue*evector(is)
307 my_norm2=my_norm2+cff*cff
308 END DO
309!
310! Take sum squared-root: perform global reduction.
311!
312# ifdef DISTRIBUTE
313 nsub=1 ! distributed-memory
314# else
315 nsub=ntilex(ng)*ntilee(ng) ! tiled application
316# endif
317!$OMP CRITICAL (R_NORM)
318 IF (tile_count.eq.0) THEN
319 norm2=my_norm2
320 ELSE
321 norm2=norm2+my_norm2
322 END IF
323 tile_count=tile_count+1
324 IF (tile_count.eq.nsub) THEN
325 tile_count=0
326# ifdef DISTRIBUTE
327 op_handle='SUM'
328 CALL mp_reduce (ng, model, 1, norm2, op_handle)
329# endif
330 END IF
331!$OMP END CRITICAL (R_NORM)
332 norm2=sqrt(norm2)
333!
334 RETURN
335 END SUBROUTINE r_norm2
336# endif
337
338# if defined ADJOINT && defined FORCING_SV
339!
340 SUBROUTINE ad_pack (ng, tile, Mstr, Mend, ad_state)
341!
342!=======================================================================
343! !
344! This routine packs the adjoint variables into the state vector. !
345! The state vector contains only interior water points. !
346! !
347!=======================================================================
348!
349 USE mod_param
350 USE mod_forces
351 USE mod_grid
352 USE mod_ocean
353 USE mod_stepping
354# ifdef DISTRIBUTE
355 USE mod_storage
356# endif
357# ifdef DISTRIBUTE
358!
359 USE distribute_mod, ONLY : mp_scatter_state
360# endif
361!
362! Imported variable declarations.
363!
364 integer, intent(in) :: ng, tile
365 integer, intent(in) :: Mstr, Mend
366# ifdef ASSUMED_SHAPE
367 real(r8), intent(out) :: ad_state(Mstr:)
368# else
369 real(r8), intent(out) :: ad_state(Mstr:Mend)
370# endif
371!
372! Local variable declarations.
373!
374 character (len=*), parameter :: MyFile = &
375 & __FILE__//", ad_pack"
376!
377# include "tile.h"
378!
379# ifdef PROFILE
380 CALL wclock_on (ng, iadm, 2, __line__, myfile)
381# endif
382
383 CALL ad_pack_tile (ng, tile, &
384 & lbi, ubi, lbj, ubj, &
385 & imins, imaxs, jmins, jmaxs, &
386 & kstp(ng), &
387# ifdef SOLVE3D
388 & nstp(ng), &
389# endif
390# ifdef DISTRIBUTE
391 & 1, mstate(ng), swork, &
392# else
393 & mstr, mend, ad_state, &
394# endif
395# ifdef MASKING
396 & grid(ng) % IJwaterR, &
397 & grid(ng) % IJwaterU, &
398 & grid(ng) % IJwaterV, &
399 & grid(ng) % rmask, &
400 & grid(ng) % umask, &
401 & grid(ng) % vmask, &
402# endif
403 & grid(ng) % h, &
404# ifdef SOLVE3D
405 & grid(ng) % Hz, &
406 & ocean(ng) % f_t, &
407 & ocean(ng) % f_u, &
408 & ocean(ng) % f_v, &
409 & forces(ng) % ad_stflx, &
410# endif
411 & ocean(ng) % f_ubar, &
412 & ocean(ng) % f_vbar, &
413 & ocean(ng) % f_zeta, &
414 & forces(ng) % ad_sustr, &
415 & forces(ng) % ad_svstr)
416
417# ifdef PROFILE
418 CALL wclock_off (ng, iadm, 2, __line__, myfile)
419# endif
420
421# ifdef DISTRIBUTE
422!
423! Scatter (global to threaded) adjoint state solution to all
424! distributed nodes.
425!
426 CALL mp_scatter_state (ng, iadm, mstr, mend, mstate(ng), &
427 & swork, ad_state)
428# endif
429!
430 RETURN
431 END SUBROUTINE ad_pack
432!
433!***********************************************************************
434 SUBROUTINE ad_pack_tile (ng, tile, &
435 & LBi, UBi, LBj, UBj, &
436 & IminS, ImaxS, JminS, JmaxS, &
437 & kstp, &
438# ifdef SOLVE3D
439 & nstp, &
440# endif
441 & Mstr, Mend, ad_state, &
442# ifdef MASKING
443 & IJwaterR, IJwaterU, IJwaterV, &
444 & rmask, umask, vmask, &
445# endif
446 & h, &
447# ifdef SOLVE3D
448 & Hz, &
449 & f_t, f_u, f_v, ad_stflx, &
450# endif
451 & f_ubar, f_vbar, &
452 & f_zeta, ad_sustr, ad_svstr)
453!***********************************************************************
454!
455 USE mod_param
456 USE mod_parallel
457 USE mod_forces
458 USE mod_ncparam
459 USE mod_scalars
460 USE mod_ocean
461!
462# ifdef FORCING_SV
463 USE ad_exchange_2d_mod
464# ifdef SOLVE3D
465 USE ad_exchange_3d_mod
466# endif
467# ifdef DISTRIBUTE
468 USE mp_exchange_mod, ONLY : ad_mp_exchange2d
469# ifdef SOLVE3D
470 USE mp_exchange_mod, ONLY : ad_mp_exchange3d, ad_mp_exchange4d
471# endif
472# endif
473# endif
474!
475! Imported variable declarations.
476!
477 integer, intent(in) :: ng, tile
478 integer, intent(in) :: LBi, UBi, LBj, UBj
479 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
480 integer, intent(in) :: Mstr, Mend
481 integer, intent(in) :: kstp
482# ifdef SOLVE3D
483 integer, intent(in) :: nstp
484# endif
485!
486# ifdef ASSUMED_SHAPE
487# ifdef MASKING
488 integer, intent(in) :: IJwaterR(LBi:,LBj:)
489 integer, intent(in) :: IJwaterU(LBi:,LBj:)
490 integer, intent(in) :: IJwaterV(LBi:,LBj:)
491
492 real(r8), intent(in) :: rmask(LBi:,LBj:)
493 real(r8), intent(in) :: umask(LBi:,LBj:)
494 real(r8), intent(in) :: vmask(LBi:,LBj:)
495# endif
496 real(r8), intent(in) :: h(LBi:,LBj:)
497# ifdef SOLVE3D
498 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
499
500 real(r8), intent(inout) :: f_t(LBi:,LBj:,:,:)
501 real(r8), intent(inout) :: f_u(LBi:,LBj:,:)
502 real(r8), intent(inout) :: f_v(LBi:,LBj:,:)
503 real(r8), intent(inout) :: ad_stflx(LBi:,LBj:,:)
504# endif
505 real(r8), intent(inout) :: f_ubar(LBi:,LBj:)
506 real(r8), intent(inout) :: f_vbar(LBi:,LBj:)
507 real(r8), intent(inout) :: f_zeta(LBi:,LBj:)
508 real(r8), intent(inout) :: ad_sustr(LBi:,LBj:)
509 real(r8), intent(inout) :: ad_svstr(LBi:,LBj:)
510 real(r8), intent(out) :: ad_state(Mstr:)
511# else
512# ifdef MASKING
513 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
514 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
515 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
516
517 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
518 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
519 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
520# endif
521 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
522# ifdef SOLVE3D
523 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
524
525 real(r8), intent(inout) :: f_t(LBi:UBi,LBj:UBj,N(ng),NT(ng))
526 real(r8), intent(inout) :: f_u(LBi:UBi,LBj:UBj,N(ng))
527 real(r8), intent(inout) :: f_v(LBi:UBi,LBj:UBj,N(ng))
528 real(r8), intent(inout) :: ad_stflx(LBi:UBi,LBj:UBj,NT(ng))
529# endif
530 real(r8), intent(inout) :: f_ubar(LBi:UBi,LBj:UBj)
531 real(r8), intent(inout) :: f_vbar(LBi:UBi,LBj:UBj)
532 real(r8), intent(inout) :: f_zeta(LBi:UBi,LBj:UBj)
533 real(r8), intent(inout) :: ad_sustr(LBi:UBi,LBj:UBj)
534 real(r8), intent(inout) :: ad_svstr(LBi:UBi,LBj:UBj)
535 real(r8), intent(out) :: ad_state(Mstr:Mend)
536# endif
537!
538! Local variable declarations.
539!
540# ifndef MASKING
541 integer :: Imax, Ioff, Jmax, Joff
542# endif
543 integer :: Uoff, Voff
544 integer :: i, iadd, icount, is, itrc, j, k
545
546# ifdef SALINITY
547 integer, dimension(7+2*NT(ng)) :: offset
548# else
549 integer, dimension(7+2*(NT(ng)+1)) :: offset
550# endif
551
552 real(r8), parameter :: Aspv = 0.0_r8
553
554 real(r8) :: cff, scale
555
556# ifdef SOLVE3D
557 real(r8) :: cff1, cff2
558 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: CF
559 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DC
560# endif
561
562# include "set_bounds.h"
563
564# ifdef DISTRIBUTE
565!
566!-----------------------------------------------------------------------
567! Initialize adjoint state vector with special value (zero) to
568! facilitate gathering/scattering communications between all nodes.
569! This is achieved by summing all the buffers.
570!-----------------------------------------------------------------------
571!
572 DO is=mstr,mend
573 ad_state(is)=aspv
574 END DO
575# endif
576
577# ifdef FORCING_SV
578!
579! Impose adjoint periodic boundary conditions as appropriate.
580!
581# ifdef DISTRIBUTE
582 CALL ad_mp_exchange2d (ng, tile, iadm, 1, &
583 & lbi, ubi, lbj, ubj, &
584 & nghostpoints, &
585 & ewperiodic(ng), nsperiodic(ng), &
586 & f_zeta)
587# ifndef SOLVE3D
588 CALL ad_mp_exchange2d (ng, tile, iadm, 2, &
589 & lbi, ubi, lbj, ubj, &
590 & nghostpoints, &
591 & ewperiodic(ng), nsperiodic(ng), &
592 & f_ubar, f_vbar)
593# else
594 CALL ad_mp_exchange3d (ng, tile, iadm, 2, &
595 & lbi, ubi, lbj, ubj, 1, n(ng), &
596 & nghostpoints, &
597 & ewperiodic(ng), nsperiodic(ng), f_u, f_v)
598 CALL ad_mp_exchange4d (ng, tile, iadm, 1, &
599 & lbi, ubi, lbj, ubj, 1, n(ng), 1, nt(ng), &
600 & nghostpoints, &
601 & ewperiodic(ng), nsperiodic(ng), f_t)
602# endif
603# endif
604!
605 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
606 CALL ad_exchange_r2d_tile (ng, tile, &
607 & lbi, ubi, lbj, ubj, f_zeta)
608# ifndef SOLVE3D
609 CALL ad_exchange_u2d_tile (ng, tile, &
610 & lbi, ubi, lbj, ubj, f_ubar)
611 CALL ad_exchange_v2d_tile (ng, tile, &
612 & lbi, ubi, lbj, ubj, f_vbar)
613# else
614 CALL ad_exchange_u3d_tile (ng, tile, &
615 & lbi, ubi, lbj, ubj, 1, n(ng), f_u)
616 CALL ad_exchange_v3d_tile (ng, tile, &
617 & lbi, ubi, lbj, ubj, 1, n(ng), f_v)
618 DO itrc=1,nt(ng)
619 CALL ad_exchange_r3d_tile (ng, tile, &
620 & lbi, ubi, lbj, ubj, 1, n(ng), &
621 & f_t(:,:,:,itrc))
622 END DO
623# endif
624 END IF
625
626# endif
627!
628!-----------------------------------------------------------------------
629! Load adjoint STATE variables into full 1D state vector.
630!-----------------------------------------------------------------------
631!
632! Set offsets for momentum variables due to periodic boundary
633! conditions. Recall that in East-West periodic boundary conditions
634! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
635! applications IstrV=1 or else IstrV=2.
636!
637 IF (ewperiodic(ng)) THEN
638 uoff=0
639 ELSE
640 uoff=1
641 END IF
642!
643 IF (nsperiodic(ng)) THEN
644 voff=0
645 ELSE
646 voff=1
647 END IF
648!
649! Determine the index offset for each variable in the state vector.
650# ifdef MASKING
651! Notice that in Land/Sea masking application the state vector only
652! contains water points to avoid large null space.
653# endif
654!
655! First clear the "offset" array.
656!
657 offset=0
658!
659# ifdef SOLVE3D
660# ifdef MASKING
661 IF (scalars(ng)%Fstate(isfsur)) THEN
662 offset(isfsur)=0
663 END IF
664 IF (scalars(ng)%Fstate(isuvel)) THEN
665 offset(isuvel)=offset(isfsur)+nwaterr(ng)
666 END IF
667 IF (scalars(ng)%Fstate(isvvel)) THEN
668 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
669 END IF
670 iadd=nwaterv(ng)*n(ng)
671 DO itrc=1,nt(ng)
672 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
673 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
674 iadd=nwaterr(ng)*n(ng)
675 END IF
676 END DO
677 IF (scalars(ng)%Fstate(isustr)) THEN
678 offset(isustr)=0
679 END IF
680 IF (scalars(ng)%Fstate(isvstr)) THEN
681 offset(isvstr)=offset(isustr)+nwateru(ng)
682 END IF
683 DO itrc=1,nt(ng)
684 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
685 IF (itrc.eq.1) THEN
686 offset(istsur(itrc))=offset(isvstr)+nwaterv(ng)
687 ELSE
688 offset(istsur(itrc))=offset(istsur(itrc-1))+nwaterr(ng)
689 END IF
690 END IF
691 END DO
692# else
693# ifdef FULL_GRID
694 IF (scalars(ng)%Fstate(isfsur)) THEN
695 offset(isfsur)=0
696 END IF
697 IF (scalars(ng)%Fstate(isuvel)) THEN
698 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
699 END IF
700 IF (scalars(ng)%Fstate(isvvel)) THEN
701 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
702 END IF
703 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
704 DO itrc=1,nt(ng)
705 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
706 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
707 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
708 END IF
709 END DO
710 IF (scalars(ng)%Fstate(isustr)) THEN
711 offset(isustr)=0
712 END IF
713 IF (scalars(ng)%Fstate(isvstr)) THEN
714 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
715 END IF
716 DO itrc=1,nt(ng)
717 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
718 IF (itrc.eq.1) THEN
719 offset(istsur(itrc))=offset(isvstr)+ &
720 & (lm(ng)+2)*(mm(ng)+1)
721 ELSE
722 offset(istsur(itrc))=offset(istsur(itrc-1))+ &
723 & (lm(ng)+2)*(mm(ng)+2)
724 END IF
725 END IF
726 END DO
727# else
728 IF (scalars(ng)%Fstate(isfsur)) THEN
729 offset(isfsur)=0
730 END IF
731 IF (scalars(ng)%Fstate(isuvel)) THEN
732 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
733 END IF
734 IF (scalars(ng)%Fstate(isvvel)) THEN
735 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
736 END IF
737 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
738 DO itrc=1,nt(ng)
739 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
740 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
741 iadd=lm(ng)*mm(ng)*n(ng)
742 END IF
743 END DO
744 IF (scalars(ng)%Fstate(isustr)) THEN
745 offset(isustr)=0
746 END IF
747 IF (scalars(ng)%Fstate(isvstr)) THEN
748 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
749 END IF
750 DO itrc=1,nt(ng)
751 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
752 IF (itrc.eq.1) THEN
753 offset(istsur(itrc))=offset(isvstr)+lm(ng)*(mm(ng)-voff)
754 ELSE
755 offset(istsur(itrc))=offset(istsur(itrc-1))+lm(ng)*mm(ng)
756 END IF
757 END IF
758 END DO
759# endif
760# endif
761# else
762# ifdef MASKING
763 IF (scalars(ng)%Fstate(isfsur)) THEN
764 offset(isfsur)=0
765 END IF
766 IF (scalars(ng)%Fstate(isubar)) THEN
767 offset(isubar)=offset(isfsur)+nwaterr(ng)
768 END IF
769 IF (scalars(ng)%Fstate(isvbar)) THEN
770 offset(isvbar)=offset(isubar)+nwateru(ng)
771 END IF
772 IF (scalars(ng)%Fstate(isustr)) THEN
773 offset(isustr)=0
774 END IF
775 IF (scalars(ng)%Fstate(isvstr)) THEN
776 offset(isvstr)=offset(isustr)+nwateru(ng)
777 END IF
778# else
779# ifdef FULL_GRID
780 IF (scalars(ng)%Fstate(isfsur)) THEN
781 offset(isfsur)=0
782 END IF
783 IF (scalars(ng)%Fstate(isubar)) THEN
784 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
785 END IF
786 IF (scalars(ng)%Fstate(isvbar) THEN
787 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
788 END IF
789 IF (scalars(ng)%Fstate(isustr)) THEN
790 offset(isustr)=0
791 END IF
792 IF (scalars(ng)%Fstate(isvstr)) THEN
793 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
794 END IF
795# else
796 IF (scalars(ng)%Fstate(isfsur)) THEN
797 offset(isfsur)=0
798 END IF
799 IF (scalars(ng)%Fstate(isubar)) THEN
800 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
801 END IF
802 IF (scalars(ng)%Fstate(isvbar) THEN
803 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
804 END IF
805 IF (scalars(ng)%Fstate(isustr)) THEN
806 offset(isustr)=0
807 END IF
808 IF (scalars(ng)%Fstate(isustr)) THEN
809 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
810 END IF
811# endif
812# endif
813# endif
814!
815! Load adjoint of free-surface.
816!
817 IF (scalars(ng)%Fstate(isfsur)) THEN
818# ifndef MASKING
819# ifdef FULL_GRID
820 imax=lm(ng)+2
821 ioff=1
822 joff=0
823# else
824 imax=lm(ng)
825 ioff=0
826 joff=1
827# endif
828# endif
829# ifdef ENERGYNORM_SCALE
830 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
831# else
832 scale=1.0_r8
833# endif
834 DO j=jr_range
835 DO i=ir_range
836# ifdef MASKING
837 IF (rmask(i,j).gt.0.0_r8) THEN
838 is=ijwaterr(i,j)+offset(isfsur)
839 ad_state(is)=scale*f_zeta(i,j)
840 f_zeta(i,j)=0.0_r8
841 ELSE
842 f_zeta(i,j)=0.0_r8
843 END IF
844# else
845 is=(i+ioff)+(j-joff)*imax+offset(isfsur)
846 ad_state(is)=scale*f_zeta(i,j)
847 f_zeta(i,j)=0.0_r8
848# endif
849 END DO
850 END DO
851 END IF
852
853# ifndef SOLVE3D
854!
855! Load adjoint of 2D U-velocity.
856!
857 IF (scalars(ng)%Fstate(isubar)) THEN
858# ifndef MASKING
859# ifdef FULL_GRID
860 imax=lm(ng)+1
861 ioff=0
862 joff=0
863# else
864 imax=lm(ng)-uoff
865 ioff=uoff
866 joff=1
867# endif
868# endif
869# ifdef ENERGYNORM_SCALE
870 cff=0.25_r8*rho0
871# else
872 scale=1.0_r8
873# endif
874 DO j=jr_range
875 DO i=iu_range
876# ifdef ENERGYNORM_SCALE
877 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
878# endif
879# ifdef MASKING
880 IF (umask(i,j).gt.0.0_r8) THEN
881 is=ijwateru(i,j)+offset(isubar)
882 ad_state(is)=scale*f_ubar(i,j)
883 f_ubar(i,j)=0.0_r8
884 ELSE
885 f_ubar(i,j)=0.0_r8
886 END IF
887# else
888 is=(i-ioff)+(j-joff)*imax+offset(isubar)
889 ad_state(is)=scale*f_ubar(i,j)
890 f_ubar(i,j)=0.0_r8
891# endif
892 END DO
893 END DO
894 END IF
895!
896! Load adjoint of 2D V-velocity.
897!
898 IF (scalars(ng)%Fstate(isvbar)) THEN
899# ifndef MASKING
900# ifdef FULL_GRID
901 imax=lm(ng)+2
902 ioff=1
903 joff=1
904# else
905 imax=lm(ng)
906 ioff=0
907 joff=1+voff
908# endif
909# endif
910# ifdef ENERGYNORM_SCALE
911 cff=0.25_r8*rho0
912# else
913 scale=1.0_r8
914# endif
915 DO j=jv_range
916 DO i=ir_range
917# ifdef ENERGYNORM_SCALE
918 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
919# endif
920# ifdef MASKING
921 IF (vmask(i,j).gt.0.0_r8) THEN
922 is=ijwaterv(i,j)+offset(isvbar)
923 ad_state(is)=scale*f_vbar(i,j)
924 f_vbar(i,j)=0.0_r8
925 ELSE
926 f_vbar(i,j)=0.0_r8
927 END IF
928# else
929 is=(i+ioff)+(j-joff)*imax+offset(isvbar)
930 ad_state(is)=scale*f_vbar(i,j)
931 f_vbar(i,j)=0.0_r8
932# endif
933 END DO
934 END DO
935 END IF
936
937# else
938!
939! Load adjoint of 3D U-velocity.
940!
941 IF (scalars(ng)%Fstate(isuvel)) THEN
942!
943! Compute the adjoint forcing for tl_ubar based on f_u.
944!
945 DO j=jr_range
946 DO i=iu_range
947 dc(i,0)=0.0_r8
948 cf(i,0)=0.0_r8
949 END DO
950 DO k=1,n(ng)
951 DO i=iu_range
952 dc(i,k)=0.5_r8*(hz(i,j,k)+hz(i-1,j,k))
953 dc(i,0)=dc(i,0)+dc(i,k)
954 END DO
955 END DO
956 DO i=iu_range
957 cff2=f_ubar(i,j)
958 f_ubar(i,j)=0.0_r8
959# ifdef MASKING
960 cff2=cff2*umask(i,j)
961# endif
962 cff1=1.0_r8/dc(i,0)
963 cf(i,0)=cff2*cff1
964 cff2=0.0_r8
965 END DO
966 DO k=1,n(ng)
967 DO i=iu_range
968 f_u(i,j,k)=f_u(i,j,k)+dc(i,k)*cf(i,0)
969 END DO
970 END DO
971 DO i=iu_range
972 cf(i,0)=0.0_r8
973 END DO
974 END DO
975# ifndef MASKING
976# ifdef FULL_GRID
977 imax=lm(ng)+1
978 jmax=mm(ng)+2
979 ioff=0
980 joff=0
981# else
982 imax=lm(ng)-uoff
983 jmax=mm(ng)
984 ioff=uoff
985 joff=1
986# endif
987# endif
988# ifdef ENERGYNORM_SCALE
989 cff=0.25_r8*rho0
990# else
991 scale=1.0_r8
992# endif
993 DO k=1,n(ng)
994# ifdef MASKING
995 iadd=(k-1)*nwateru(ng)+offset(isuvel)
996# else
997 iadd=(k-1)*imax*jmax+offset(isuvel)
998# endif
999 DO j=jr_range
1000 DO i=iu_range
1001# ifdef ENERGYNORM_SCALE
1002 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
1003# endif
1004# ifdef MASKING
1005 IF (umask(i,j).gt.0.0_r8) THEN
1006 is=ijwateru(i,j)+iadd
1007 ad_state(is)=scale*f_u(i,j,k)
1008 f_u(i,j,k)=0.0_r8
1009 ELSE
1010 f_u(i,j,k)=0.0_r8
1011 END IF
1012# else
1013 is=(i-ioff)+(j-joff)*imax+iadd
1014 ad_state(is)=scale*f_u(i,j,k)
1015 f_u(i,j,k)=0.0_r8
1016# endif
1017 END DO
1018 END DO
1019 END DO
1020 END IF
1021!
1022! Load adjoint of 3D V-velocity.
1023!
1024 IF (scalars(ng)%Fstate(isvvel)) THEN
1025!
1026! Compute the adjoint forcing for tl_vbar based on f_v.
1027!
1028 DO j=jv_range
1029 IF (j.ge.jstrm) THEN
1030 DO i=ir_range
1031 dc(i,0)=0.0_r8
1032 cf(i,0)=0.0_r8
1033 END DO
1034 DO k=1,n(ng)
1035 DO i=ir_range
1036 dc(i,k)=0.5_r8*(hz(i,j,k)+hz(i,j-1,k))
1037 dc(i,0)=dc(i,0)+dc(i,k)
1038 END DO
1039 END DO
1040 DO i=ir_range
1041 cff2=f_vbar(i,j)
1042 f_vbar(i,j)=0.0_r8
1043# ifdef MASKING
1044 cff2=cff2*vmask(i,j)
1045# endif
1046 cff1=1.0_r8/dc(i,0)
1047 cf(i,0)=cff2*cff1
1048 cff2=0.0_r8
1049 END DO
1050 DO k=1,n(ng)
1051 DO i=ir_range
1052 f_v(i,j,k)=f_v(i,j,k)+dc(i,k)*cf(i,0)
1053 END DO
1054 END DO
1055 DO i=ir_range
1056 cf(i,0)=0.0_r8
1057 END DO
1058 END IF
1059 END DO
1060# ifndef MASKING
1061# ifdef FULL_GRID
1062 imax=lm(ng)+2
1063 jmax=mm(ng)+1
1064 ioff=1
1065 joff=1
1066# else
1067 imax=lm(ng)
1068 jmax=mm(ng)-voff
1069 ioff=0
1070 joff=1+voff
1071# endif
1072# endif
1073# ifdef ENERGYNORM_SCALE
1074 cff=0.25_r8*rho0
1075# else
1076 scale=1.0_r8
1077# endif
1078 DO k=1,n(ng)
1079# ifdef MASKING
1080 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
1081# else
1082 iadd=(k-1)*imax*jmax+offset(isvvel)
1083# endif
1084 DO j=jv_range
1085 DO i=ir_range
1086# ifdef ENERGYNORM_SCALE
1087 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
1088# endif
1089# ifdef MASKING
1090 IF (vmask(i,j).gt.0.0_r8) THEN
1091 is=ijwaterv(i,j)+iadd
1092 ad_state(is)=scale*f_v(i,j,k)
1093 f_v(i,j,k)=0.0_r8
1094 ELSE
1095 f_v(i,j,k)=0.0_r8
1096 END IF
1097# else
1098 is=(i+ioff)+(j-joff)*imax+iadd
1099 ad_state(is)=scale*f_v(i,j,k)
1100 f_v(i,j,k)=0.0_r8
1101# endif
1102 END DO
1103 END DO
1104 END DO
1105 END IF
1106!
1107! Load adjoint of tracers variables.
1108!
1109 DO itrc=1,nt(ng)
1110 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
1111# ifndef MASKING
1112# ifdef FULL_GRID
1113 imax=lm(ng)+2
1114 jmax=mm(ng)+2
1115 ioff=1
1116 joff=0
1117# else
1118 imax=lm(ng)
1119 jmax=mm(ng)
1120 ioff=0
1121 joff=1
1122# endif
1123# endif
1124# ifdef ENERGYNORM_SCALE
1125 IF (itrc.eq.itemp) THEN
1126 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
1127 ELSE IF (itrc.eq.isalt) THEN
1128 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
1129 ELSE
1130 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
1131 END IF
1132# else
1133 scale=1.0_r8
1134# endif
1135 DO k=1,n(ng)
1136# ifdef MASKING
1137 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
1138# else
1139 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
1140# endif
1141 DO j=jr_range
1142 DO i=ir_range
1143# ifdef ENERGYNORM_SCALE
1144 scale=1.0_r8/sqrt(cff*hz(i,j,k))
1145# endif
1146# ifdef MASKING
1147 IF (rmask(i,j).gt.0.0_r8) THEN
1148 is=ijwaterr(i,j)+iadd
1149 ad_state(is)=scale*f_t(i,j,k,itrc)
1150 f_t(i,j,k,itrc)=0.0_r8
1151 ELSE
1152 f_t(i,j,k,itrc)=0.0_r8
1153 END IF
1154# else
1155 is=(i+ioff)+(j-joff)*imax+iadd
1156 ad_state(is)=scale*f_t(i,j,k,itrc)
1157 f_t(i,j,k,itrc)=0.0_r8
1158# endif
1159 END DO
1160 END DO
1161 END DO
1162 END IF
1163 END DO
1164# endif
1165!
1166! Load adjoint of surface U-stress.
1167!
1168 IF (scalars(ng)%Fstate(isustr)) THEN
1169# ifndef MASKING
1170# ifdef FULL_GRID
1171 imax=lm(ng)+1
1172 ioff=0
1173 joff=0
1174# else
1175 imax=lm(ng)-uoff
1176 ioff=uoff
1177 joff=1
1178# endif
1179# endif
1180 scale=1.0_r8
1181 DO j=jr_range
1182 DO i=iu_range
1183# ifdef MASKING
1184 IF (umask(i,j).gt.0.0_r8) THEN
1185 is=ijwateru(i,j)+offset(isustr)
1186 ad_state(is)=scale*ad_sustr(i,j)
1187 END IF
1188# else
1189 is=(i-ioff)+(j-joff)*imax+offset(isustr)
1190 ad_state(is)=scale*ad_sustr(i,j)
1191# endif
1192 END DO
1193 END DO
1194 END IF
1195!
1196! Load adjoint of surface V-stress.
1197!
1198 IF (scalars(ng)%Fstate(isvstr)) THEN
1199# ifndef MASKING
1200# ifdef FULL_GRID
1201 imax=lm(ng)+2
1202 ioff=1
1203 joff=1
1204# else
1205 imax=lm(ng)
1206 ioff=0
1207 joff=1+voff
1208# endif
1209# endif
1210 scale=1.0_r8
1211 DO j=jv_range
1212 DO i=ir_range
1213# ifdef MASKING
1214 IF (vmask(i,j).gt.0.0_r8) THEN
1215 is=ijwaterv(i,j)+offset(isvstr)
1216 ad_state(is)=scale*ad_svstr(i,j)
1217 END IF
1218# else
1219 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
1220 ad_state(is)=scale*ad_svstr(i,j)
1221# endif
1222 END DO
1223 END DO
1224 END IF
1225
1226# ifdef SOLVE3D
1227!
1228! Load adjoint of surface tracer flux variables.
1229!
1230 DO itrc=1,nt(ng)
1231 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
1232# ifndef MASKING
1233# ifdef FULL_GRID
1234 imax=lm(ng)+2
1235 jmax=mm(ng)+2
1236 ioff=1
1237 joff=0
1238# else
1239 imax=lm(ng)
1240 jmax=mm(ng)
1241 ioff=0
1242 joff=1
1243# endif
1244# endif
1245 scale=1.0_r8
1246 DO j=jr_range
1247 DO i=ir_range
1248# ifdef MASKING
1249 IF (rmask(i,j).gt.0.0_r8) THEN
1250 is=ijwaterr(i,j)+offset(istsur(itrc))
1251 ad_state(is)=scale*ad_stflx(i,j,itrc)
1252 END IF
1253# else
1254 is=(i+ioff)+(j-joff)*imax+offset(istsur(itrc))
1255 ad_state(is)=scale*ad_stflx(i,j,itrc)
1256# endif
1257 END DO
1258 END DO
1259 END IF
1260 END DO
1261# endif
1262!
1263 RETURN
1264 END SUBROUTINE ad_pack_tile
1265
1266# elif defined SO_SEMI
1267!
1268 SUBROUTINE ad_pack (ng, tile, Mstr, Mend, ad_state)
1269!
1270!=======================================================================
1271! !
1272! This routine packs the adjoint variables into the state vector. !
1273! The state vector contains only interior water points. !
1274! !
1275!=======================================================================
1276!
1277 USE mod_param
1278 USE mod_grid
1279 USE mod_stepping
1280# ifdef DISTRIBUTE
1281 USE mod_storage
1282# endif
1283# ifdef DISTRIBUTE
1284!
1285 USE distribute_mod, ONLY : mp_scatter_state
1286# endif
1287!
1288! Imported variable declarations.
1289!
1290 integer, intent(in) :: ng, tile
1291 integer, intent(in) :: Mstr, Mend
1292# ifdef ASSUMED_SHAPE
1293 real(r8), intent(out) :: ad_state(Mstr:)
1294# else
1295 real(r8), intent(out) :: ad_state(Mstr:Mend)
1296# endif
1297!
1298! Local variable declarations.
1299!
1300 character (len=*), parameter :: MyFile = &
1301 & __FILE__//", ad_pack"
1302!
1303# include "tile.h"
1304!
1305# ifdef PROFILE
1306 CALL wclock_on (ng, iadm, 2, __line__, myfile)
1307# endif
1308
1309 CALL ad_pack_tile (ng, tile, &
1310 & lbi, ubi, lbj, ubj, &
1311 & imins, imaxs, jmins, jmaxs, &
1312 & kstp(ng), &
1313# ifdef SOLVE3D
1314 & nstp(ng), &
1315# endif
1316# ifdef MASKING
1317 & grid(ng) % IJwaterR, &
1318 & grid(ng) % IJwaterU, &
1319 & grid(ng) % IJwaterV, &
1320 & grid(ng) % rmask, &
1321 & grid(ng) % umask, &
1322 & grid(ng) % vmask, &
1323# endif
1324# ifdef DISTRIBUTE
1325 & 1, mstate(ng), swork)
1326# else
1327 & mstr, mend, ad_state)
1328# endif
1329
1330# ifdef PROFILE
1331 CALL wclock_off (ng, iadm, 2, __line__, myfile)
1332# endif
1333
1334# ifdef DISTRIBUTE
1335!
1336! Scatter (global to threaded) adjoint state solution to all
1337! distributed nodes.
1338!
1339 CALL mp_scatter_state (ng, iadm, mstr, mend, mstate(ng), &
1340 & swork, ad_state)
1341# endif
1342!
1343 RETURN
1344 END SUBROUTINE ad_pack
1345!
1346!***********************************************************************
1347 SUBROUTINE ad_pack_tile (ng, tile, &
1348 & LBi, UBi, LBj, UBj, &
1349 & IminS, ImaxS, JminS, JmaxS, &
1350 & kstp, &
1351# ifdef SOLVE3D
1352 & nstp, &
1353# endif
1354# ifdef MASKING
1355 & IJwaterR, IJwaterU, IJwaterV, &
1356 & rmask, umask, vmask, &
1357# endif
1358 & Mstr, Mend, ad_state)
1359!***********************************************************************
1360!
1361 USE mod_param
1362 USE mod_parallel
1363 USE mod_forces
1364 USE mod_ncparam
1365 USE mod_scalars
1366 USE mod_ocean
1367!
1368! Imported variable declarations.
1369!
1370 integer, intent(in) :: ng, tile
1371 integer, intent(in) :: LBi, UBi, LBj, UBj
1372 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
1373 integer, intent(in) :: Mstr, Mend
1374 integer, intent(in) :: kstp
1375# ifdef SOLVE3D
1376 integer, intent(in) :: nstp
1377# endif
1378!
1379# ifdef ASSUMED_SHAPE
1380# ifdef MASKING
1381 integer, intent(in) :: IJwaterR(LBi:,LBj:)
1382 integer, intent(in) :: IJwaterU(LBi:,LBj:)
1383 integer, intent(in) :: IJwaterV(LBi:,LBj:)
1384
1385 real(r8), intent(in) :: rmask(LBi:,LBj:)
1386 real(r8), intent(in) :: umask(LBi:,LBj:)
1387 real(r8), intent(in) :: vmask(LBi:,LBj:)
1388# endif
1389 real(r8), intent(out) :: ad_state(Mstr:)
1390# else
1391# ifdef MASKING
1392 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
1393 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
1394 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
1395
1396 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
1397 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
1398 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
1399# endif
1400 real(r8), intent(out) :: ad_state(Mstr:Mend)
1401# endif
1402!
1403! Local variable declarations.
1404!
1405# ifndef MASKING
1406 integer :: Imax, Ioff, Jmax, Joff
1407# endif
1408 integer :: Uoff, Voff
1409 integer :: i, iadd, is, itrc, j, k
1410
1411 integer, dimension(7+2*NT(ng)) :: offset
1412
1413 real(r8), parameter :: Aspv = 0.0_r8
1414
1415 real(r8) :: cff, scale
1416
1417# include "set_bounds.h"
1418
1419# ifdef DISTRIBUTE
1420!
1421!-----------------------------------------------------------------------
1422! Initialize adjoint state vector with special value (zero) to
1423! facilitate gathering/scattering communications between all nodes.
1424! This is achieved by summing all the buffers.
1425!-----------------------------------------------------------------------
1426!
1427 DO is=mstr,mend
1428 ad_state(is)=aspv
1429 END DO
1430# endif
1431!
1432!-----------------------------------------------------------------------
1433! Load adjoint STATE and FORCING variables from full 1D state vector.
1434!-----------------------------------------------------------------------
1435!
1436! Set offsets for momentum variables due to periodic boundary
1437! conditions. Recall that in East-West periodic boundary conditions
1438! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
1439! applications IstrV=1 or else IstrV=2.
1440!
1441 IF (ewperiodic(ng)) THEN
1442 uoff=0
1443 ELSE
1444 uoff=1
1445 END IF
1446!
1447 IF (nsperiodic(ng)) THEN
1448 voff=0
1449 ELSE
1450 voff=1
1451 END IF
1452!
1453! Determine the index offset for each variable in the state vector.
1454# ifdef MASKING
1455! Notice that in Land/Sea masking application the state vector only
1456! contains water points to avoid large null space.
1457# endif
1458!
1459! First clear the "offset" array.
1460!
1461 offset=0
1462!
1463# ifdef SOLVE3D
1464# ifdef MASKING
1465 IF (scalars(ng)%Fstate(isfsur)) THEN
1466 offset(isfsur)=0
1467 END IF
1468 IF (scalars(ng)%Fstate(isuvel)) THEN
1469 offset(isuvel)=offset(isfsur)+nwaterr(ng)
1470 END IF
1471 IF (scalars(ng)%Fstate(isvvel)) THEN
1472 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
1473 END IF
1474 iadd=nwaterv(ng)*n(ng)
1475 DO itrc=1,nt(ng)
1476 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
1477 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
1478 iadd=nwaterr(ng)*n(ng)
1479 END IF
1480 END DO
1481 IF (scalars(ng)%Fstate(isustr)) THEN
1482 offset(isustr)=0
1483 END IF
1484 IF (scalars(ng)%Fstate(isvstr)) THEN
1485 offset(isvstr)=offset(isustr)+nwateru(ng)
1486 END IF
1487 DO itrc=1,nt(ng)
1488 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
1489 IF (itrc.eq.1) THEN
1490 offset(istsur(itrc))=offset(isvstr)+nwaterv(ng)
1491 ELSE
1492 offset(istsur(itrc))=offset(istsur(itrc-1))+nwaterr(ng)
1493 END IF
1494 END IF
1495 END DO
1496# else
1497# ifdef FULL_GRID
1498 IF (scalars(ng)%Fstate(isfsur)) THEN
1499 offset(isfsur)=0
1500 END IF
1501 IF (scalars(ng)%Fstate(isuvel)) THEN
1502 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
1503 END IF
1504 IF (scalars(ng)%Fstate(isvvel)) THEN
1505 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
1506 END IF
1507 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
1508 DO itrc=1,nt(ng)
1509 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
1510 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
1511 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
1512 END IF
1513 END DO
1514 IF (scalars(ng)%Fstate(isustr)) THEN
1515 offset(isustr)=0
1516 END IF
1517 IF (scalars(ng)%Fstate(isvstr)) THEN
1518 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
1519 END IF
1520 DO itrc=1,nt(ng)
1521 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
1522 IF (itrc.eq.1) THEN
1523 offset(istsur(itrc))=offset(isvstr)+ &
1524 & (lm(ng)+2)*(mm(ng)+1)
1525 ELSE
1526 offset(istsur(itrc))=offset(istsur(itrc-1))+ &
1527 & (lm(ng)+2)*(mm(ng)+2)
1528 END IF
1529 END IF
1530 END DO
1531# else
1532 IF (scalars(ng)%Fstate(isfsur)) THEN
1533 offset(isfsur)=0
1534 END IF
1535 IF (scalars(ng)%Fstate(isuvel)) THEN
1536 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
1537 END IF
1538 IF (scalars(ng)%Fstate(isvvel)) THEN
1539 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
1540 END IF
1541 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
1542 DO itrc=1,nt(ng)
1543 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
1544 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
1545 iadd=lm(ng)*mm(ng)*n(ng)
1546 END IF
1547 END DO
1548 IF (scalars(ng)%Fstate(isustr)) THEN
1549 offset(isustr)=0
1550 END IF
1551 IF (scalars(ng)%Fstate(isvstr)) THEN
1552 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
1553 END IF
1554 DO itrc=1,nt(ng)
1555 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
1556 IF (itrc.eq.1) THEN
1557 offset(istsur(itrc))=offset(isvstr)+lm(ng)*(mm(ng)-voff)
1558 ELSE
1559 offset(istsur(itrc))=offset(istsur(itrc-1))+lm(ng)*mm(ng)
1560 END IF
1561 END IF
1562 END DO
1563# endif
1564# endif
1565# else
1566# ifdef MASKING
1567 IF (scalars(ng)%Fstate(isfsur)) THEN
1568 offset(isfsur)=0
1569 END IF
1570 IF (scalars(ng)%Fstate(isubar)) THEN
1571 offset(isubar)=offset(isfsur)+nwaterr(ng)
1572 END IF
1573 IF (scalars(ng)%Fstate(isvbar)) THEN
1574 offset(isvbar)=offset(isubar)+nwateru(ng)
1575 END IF
1576 IF (scalars(ng)%Fstate(isustr)) THEN
1577 offset(isustr)=0
1578 END IF
1579 IF (scalars(ng)%Fstate(isvstr)) THEN
1580 offset(isvstr)=offset(isustr)+nwateru(ng)
1581 END IF
1582# else
1583# ifdef FULL_GRID
1584 IF (scalars(ng)%Fstate(isfsur)) THEN
1585 offset(isfsur)=0
1586 END IF
1587 IF (scalars(ng)%Fstate(isubar)) THEN
1588 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
1589 END IF
1590 IF (scalars(ng)%Fstate(isvbar) THEN
1591 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
1592 END IF
1593 IF (scalars(ng)%Fstate(isustr)) THEN
1594 offset(isustr)=0
1595 END IF
1596 IF (scalars(ng)%Fstate(isvstr)) THEN
1597 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
1598 END IF
1599# else
1600 IF (scalars(ng)%Fstate(isfsur)) THEN
1601 offset(isfsur)=0
1602 END IF
1603 IF (scalars(ng)%Fstate(isubar)) THEN
1604 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
1605 END IF
1606 IF (scalars(ng)%Fstate(isvbar) THEN
1607 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
1608 END IF
1609 IF (scalars(ng)%Fstate(isustr)) THEN
1610 offset(isustr)=0
1611 END IF
1612 IF (scalars(ng)%Fstate(isustr)) THEN
1613 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
1614 END IF
1615# endif
1616# endif
1617# endif
1618!
1619! Load adjoint of free-surface.
1620!
1621 IF (scalars(ng)%Fstate(isfsur)) THEN
1622# ifndef MASKING
1623# ifdef FULL_GRID
1624 imax=lm(ng)+2
1625 ioff=1
1626 joff=0
1627# else
1628 imax=lm(ng)
1629 ioff=0
1630 joff=1
1631# endif
1632# endif
1633# ifdef ENERGYNORM_SCALE
1634 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
1635# else
1636 scale=1.0_r8
1637# endif
1638 DO j=jr_range
1639 DO i=ir_range
1640# ifdef MASKING
1641 IF (rmask(i,j).gt.0.0_r8) THEN
1642 is=ijwaterr(i,j)+offset(isfsur)
1643 ad_state(is)=scale*ocean(ng)%ad_zeta(i,j,kstp)
1644 END IF
1645# else
1646 is=(i+ioff)+(j-joff)*imax+offset(isfsur)
1647 ad_state(is)=scale*ocean(ng)%ad_zeta(i,j,kstp)
1648# endif
1649 END DO
1650 END DO
1651 END IF
1652
1653# ifndef SOLVE3D
1654!
1655! Load adjoint of 2D U-velocity.
1656!
1657 IF (scalars(ng)%Fstate(isubar)) THEN
1658# ifndef MASKING
1659# ifdef FULL_GRID
1660 imax=lm(ng)+1
1661 ioff=0
1662 joff=0
1663# else
1664 imax=lm(ng)-uoff
1665 ioff=uoff
1666 joff=1
1667# endif
1668# endif
1669# ifdef ENERGYNORM_SCALE
1670 cff=0.25_r8*rho0
1671# else
1672 scale=1.0_r8
1673# endif
1674 DO j=jr_range
1675 DO i=iu_range
1676# ifdef MASKING
1677 IF (umask(i,j).gt.0.0_r8) THEN
1678 is=ijwateru(i,j)+offset(isubar)
1679 ad_state(is)=scale*ocean(ng)%ad_ubar(i,j,kstp)
1680 END IF
1681# else
1682 is=(i-ioff)+(j-joff)*imax+offset(isubar)
1683 ad_state(is)=scale*ocean(ng)%ad_ubar(i,j,kstp)
1684# endif
1685 END DO
1686 END DO
1687 END IF
1688!
1689! Load adjoint of 2D V-velocity.
1690!
1691 IF (scalars(ng)%Fstate(isvbar)) THEN
1692# ifndef MASKING
1693# ifdef FULL_GRID
1694 imax=lm(ng)+2
1695 ioff=1
1696 joff=1
1697# else
1698 imax=lm(ng)
1699 ioff=0
1700 joff=1+voff
1701# endif
1702# endif
1703# ifdef ENERGYNORM_SCALE
1704 cff=0.25_r8*rho0
1705# else
1706 scale=1.0_r8
1707# endif
1708 DO j=jv_range
1709 DO i=ir_range
1710# ifdef MASKING
1711 IF (vmask(i,j).gt.0.0_r8) THEN
1712 is=ijwaterv(i,j)+offset(isvbar)
1713 ad_state(is)=scale*ocean(ng)%ad_vbar(i,j,kstp)
1714 END IF
1715# else
1716 is=(i+ioff)+(j-joff)*imax+offset(isvbar)
1717 ad_state(is)=scale*ocean(ng)%ad_vbar(i,j,kstp)
1718# endif
1719 END DO
1720 END DO
1721 END IF
1722
1723# else
1724!
1725! Load adjoint of 3D U-velocity.
1726!
1727 IF (scalars(ng)%Fstate(isuvel)) THEN
1728# ifndef MASKING
1729# ifdef FULL_GRID
1730 imax=lm(ng)+1
1731 jmax=mm(ng)+2
1732 ioff=0
1733 joff=0
1734# else
1735 imax=lm(ng)-uoff
1736 jmax=mm(ng)
1737 ioff=uoff
1738 joff=1
1739# endif
1740# endif
1741# ifdef ENERGYNORM_SCALE
1742 cff=0.25_r8*rho0
1743# else
1744 scale=1.0_r8
1745# endif
1746 DO k=1,n(ng)
1747# ifdef MASKING
1748 iadd=(k-1)*nwateru(ng)+offset(isuvel)
1749# else
1750 iadd=(k-1)*imax*jmax+offset(isuvel)
1751# endif
1752 DO j=jr_range
1753 DO i=iu_range
1754# ifdef MASKING
1755 IF (umask(i,j).gt.0.0_r8) THEN
1756 is=ijwateru(i,j)+iadd
1757 ad_state(is)=scale*ocean(ng)%ad_u(i,j,k,nstp)
1758 END IF
1759# else
1760 is=(i-ioff)+(j-joff)*imax+iadd
1761 ad_state(is)=scale*ocean(ng)%ad_u(i,j,k,nstp)
1762# endif
1763 END DO
1764 END DO
1765 END DO
1766 END IF
1767!
1768! Load adjoint of 3D V-velocity.
1769!
1770 IF (scalars(ng)%Fstate(isvvel)) THEN
1771# ifndef MASKING
1772# ifdef FULL_GRID
1773 imax=lm(ng)+2
1774 jmax=mm(ng)+1
1775 ioff=1
1776 joff=1
1777# else
1778 imax=lm(ng)
1779 jmax=mm(ng)-voff
1780 ioff=0
1781 joff=1+voff
1782# endif
1783# endif
1784# ifdef ENERGYNORM_SCALE
1785 cff=0.25_r8*rho0
1786# else
1787 scale=1.0_r8
1788# endif
1789 DO k=1,n(ng)
1790# ifdef MASKING
1791 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
1792# else
1793 iadd=(k-1)*imax*jmax+offset(isvvel)
1794# endif
1795 DO j=jv_range
1796 DO i=ir_range
1797# ifdef MASKING
1798 IF (vmask(i,j).gt.0.0_r8) THEN
1799 is=ijwaterv(i,j)+iadd
1800 ad_state(is)=scale*ocean(ng)%ad_v(i,j,k,nstp)
1801 END IF
1802# else
1803 is=(i+ioff)+(j-joff)*imax+iadd
1804 ad_state(is)=scale*ocean(ng)%ad_v(i,j,k,nstp)
1805# endif
1806 END DO
1807 END DO
1808 END DO
1809 END IF
1810!
1811! Load adjoint of tracers variables.
1812!
1813 DO itrc=1,nt(ng)
1814 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
1815# ifndef MASKING
1816# ifdef FULL_GRID
1817 imax=lm(ng)+2
1818 jmax=mm(ng)+2
1819 ioff=1
1820 joff=0
1821# else
1822 imax=lm(ng)
1823 jmax=mm(ng)
1824 ioff=0
1825 joff=1
1826# endif
1827# endif
1828# ifdef ENERGYNORM_SCALE
1829 IF (itrc.eq.itemp) THEN
1830 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
1831 ELSE IF (itrc.eq.isalt) THEN
1832 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
1833 ELSE
1834 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
1835 END IF
1836# else
1837 scale=1.0_r8
1838# endif
1839 DO k=1,n(ng)
1840# ifdef MASKING
1841 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
1842# else
1843 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
1844# endif
1845 DO j=jr_range
1846 DO i=ir_range
1847# ifdef MASKING
1848 IF (rmask(i,j).gt.0.0_r8) THEN
1849 is=ijwaterr(i,j)+iadd
1850 ad_state(is)=scale*ocean(ng)%ad_t(i,j,k,nstp,itrc)
1851 END IF
1852# else
1853 is=(i+ioff)+(j-joff)*imax+iadd
1854 ad_state(is)=scale*ocean(ng)%ad_t(i,j,k,nstp,itrc)
1855# endif
1856 END DO
1857 END DO
1858 END DO
1859 END IF
1860 END DO
1861# endif
1862!
1863! Load adjoint of surface U-stress.
1864!
1865 IF (scalars(ng)%Fstate(isustr)) THEN
1866# ifndef MASKING
1867# ifdef FULL_GRID
1868 imax=lm(ng)+1
1869 ioff=0
1870 joff=0
1871# else
1872 imax=lm(ng)-uoff
1873 ioff=uoff
1874 joff=1
1875# endif
1876# endif
1877 scale=1.0_r8
1878 DO j=jr_range
1879 DO i=iu_range
1880# ifdef MASKING
1881 IF (umask(i,j).gt.0.0_r8) THEN
1882 is=ijwateru(i,j)+offset(isustr)
1883 ad_state(is)=scale*forces(ng)%ad_sustr(i,j)
1884 END IF
1885# else
1886 is=(i-ioff)+(j-joff)*imax+offset(isustr)
1887 ad_state(is)=scale*forces(ng)%ad_sustr(i,j)
1888# endif
1889 END DO
1890 END DO
1891 END IF
1892!
1893! Load adjoint of surface V-stress.
1894!
1895 IF (scalars(ng)%Fstate(isvstr)) THEN
1896# ifndef MASKING
1897# ifdef FULL_GRID
1898 imax=lm(ng)+2
1899 ioff=1
1900 joff=1
1901# else
1902 imax=lm(ng)
1903 ioff=0
1904 joff=1+voff
1905# endif
1906# endif
1907 scale=1.0_r8
1908 DO j=jv_range
1909 DO i=ir_range
1910# ifdef MASKING
1911 IF (vmask(i,j).gt.0.0_r8) THEN
1912 is=ijwaterv(i,j)+offset(isvstr)
1913 ad_state(is)=scale*forces(ng)%ad_svstr(i,j)
1914 END IF
1915# else
1916 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
1917 ad_state(is)=scale*forces(ng)%ad_svstr(i,j)
1918# endif
1919 END DO
1920 END DO
1921 END IF
1922
1923# ifdef SOLVE3D
1924!
1925! Load adjoint of surface tracer flux variables.
1926!
1927 DO itrc=1,nt(ng)
1928 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
1929# ifndef MASKING
1930# ifdef FULL_GRID
1931 imax=lm(ng)+2
1932 jmax=mm(ng)+2
1933 ioff=1
1934 joff=0
1935# else
1936 imax=lm(ng)
1937 jmax=mm(ng)
1938 ioff=0
1939 joff=1
1940# endif
1941# endif
1942 scale=1.0_r8
1943 DO j=jr_range
1944 DO i=ir_range
1945# ifdef MASKING
1946 IF (rmask(i,j).gt.0.0_r8) THEN
1947 is=ijwaterr(i,j)+offset(istsur(itrc))
1948 ad_state(is)=scale*forces(ng)%ad_stflx(i,j,itrc)
1949 END IF
1950# else
1951 is=(i+ioff)+(j-joff)*imax+offset(istsur(itrc))
1952 ad_state(is)=scale*forces(ng)%ad_stflx(i,j,itrc)
1953# endif
1954 END DO
1955 END DO
1956 END IF
1957 END DO
1958# endif
1959!
1960 RETURN
1961 END SUBROUTINE ad_pack_tile
1962
1963# elif defined STOCHASTIC_OPT
1964# ifdef STOCH_OPT_WHITE
1965!
1966 SUBROUTINE ad_so_pack (ng, tile, Mstr, Mend, IntTrap, ad_state)
1967!
1968!=======================================================================
1969! !
1970! This routine packs the adjoint variables into the state vector. !
1971! The state vector contains only interior water points. !
1972! !
1973!=======================================================================
1974!
1975 USE mod_param
1976 USE mod_forces
1977 USE mod_grid
1978 USE mod_ocean
1979 USE mod_stepping
1980# ifdef DISTRIBUTE
1981 USE mod_storage
1982# endif
1983# ifdef DISTRIBUTE
1984!
1985 USE distribute_mod, ONLY : mp_scatter_state
1986# endif
1987!
1988! Imported variable declarations.
1989!
1990 integer, intent(in) :: ng, tile
1991 integer, intent(in) :: Mstr, Mend
1992 integer, intent(in) :: IntTrap
1993# ifdef ASSUMED_SHAPE
1994 real(r8), intent(out) :: ad_state(Mstr:)
1995# else
1996 real(r8), intent(out) :: ad_state(Mstr:Mend)
1997# endif
1998!
1999! Local variable declarations.
2000!
2001 character (len=*), parameter :: MyFile = &
2002 & __FILE__//", ad_so_pack"
2003!
2004# include "tile.h"
2005!
2006# ifdef PROFILE
2007 CALL wclock_on (ng, iadm, 2, __line__, myfile)
2008# endif
2009
2010 CALL ad_so_pack_tile (ng, tile, &
2011 & lbi, ubi, lbj, ubj, &
2012 & imins, imaxs, jmins, jmaxs, &
2013 & kstp(ng), &
2014# ifdef SOLVE3D
2015 & nstp(ng), &
2016# endif
2017 & inttrap, &
2018# ifdef DISTRIBUTE
2019 & 1, mstate(ng), swork, &
2020# else
2021 & mstr, mend, ad_state, &
2022# endif
2023# ifdef MASKING
2024 & grid(ng) % IJwaterR, &
2025 & grid(ng) % IJwaterU, &
2026 & grid(ng) % IJwaterV, &
2027 & grid(ng) % rmask, &
2028 & grid(ng) % umask, &
2029 & grid(ng) % vmask, &
2030# endif
2031 & grid(ng) % h, &
2032# ifdef SOLVE3D
2033 & grid(ng) % Hz, &
2034 & ocean(ng) % ad_t, &
2035 & ocean(ng) % ad_u, &
2036 & ocean(ng) % ad_v, &
2037 & forces(ng) % ad_stflx, &
2038# else
2039 & ocean(ng) % ad_ubar, &
2040 & ocean(ng) % ad_vbar, &
2041# endif
2042 & ocean(ng) % ad_zeta, &
2043 & forces(ng) % ad_sustr, &
2044 & forces(ng) % ad_svstr)
2045
2046# ifdef PROFILE
2047 CALL wclock_off (ng, iadm, 2, __line__, myfile)
2048# endif
2049
2050# ifdef DISTRIBUTE
2051!
2052! Scatter (global to threaded) adjoint state solution to all
2053! distributed nodes.
2054!
2055 CALL mp_scatter_state (ng, iadm, mstr, mend, mstate(ng), &
2056 & swork, ad_state)
2057# endif
2058!
2059 RETURN
2060 END SUBROUTINE ad_so_pack
2061!
2062!***********************************************************************
2063 SUBROUTINE ad_so_pack_tile (ng, tile, &
2064 & LBi, UBi, LBj, UBj, &
2065 & IminS, ImaxS, JminS, JmaxS, &
2066 & kstp, &
2067# ifdef SOLVE3D
2068 & nstp, &
2069# endif
2070 & IntTrap, &
2071 & Mstr, Mend, ad_state, &
2072# ifdef MASKING
2073 & IJwaterR, IJwaterU, IJwaterV, &
2074 & rmask, umask, vmask, &
2075# endif
2076 & h, &
2077# ifdef SOLVE3D
2078 & Hz, &
2079 & ad_t, ad_u, ad_v, ad_stflx, &
2080# else
2081 & ad_ubar, ad_vbar, &
2082# endif
2083 & ad_zeta, ad_sustr, ad_svstr)
2084!***********************************************************************
2085!
2086 USE mod_param
2087 USE mod_parallel
2088 USE mod_forces
2089 USE mod_ncparam
2090 USE mod_scalars
2091 USE mod_ocean
2092 USE mod_storage
2093!
2094! Imported variable declarations.
2095!
2096 integer, intent(in) :: ng, tile
2097 integer, intent(in) :: LBi, UBi, LBj, UBj
2098 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
2099 integer, intent(in) :: Mstr, Mend
2100 integer, intent(in) :: kstp
2101 integer, intent(in) :: IntTrap
2102# ifdef SOLVE3D
2103 integer, intent(in) :: nstp
2104# endif
2105!
2106# ifdef ASSUMED_SHAPE
2107# ifdef MASKING
2108 integer, intent(in) :: IJwaterR(LBi:,LBj:)
2109 integer, intent(in) :: IJwaterU(LBi:,LBj:)
2110 integer, intent(in) :: IJwaterV(LBi:,LBj:)
2111
2112 real(r8), intent(in) :: rmask(LBi:,LBj:)
2113 real(r8), intent(in) :: umask(LBi:,LBj:)
2114 real(r8), intent(in) :: vmask(LBi:,LBj:)
2115# endif
2116 real(r8), intent(in) :: h(LBi:,LBj:)
2117# ifdef SOLVE3D
2118 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
2119
2120 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
2121 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
2122 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
2123 real(r8), intent(inout) :: ad_stflx(LBi:,LBj:,:)
2124# else
2125 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
2126 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
2127# endif
2128 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
2129 real(r8), intent(inout) :: ad_sustr(LBi:,LBj:)
2130 real(r8), intent(inout) :: ad_svstr(LBi:,LBj:)
2131 real(r8), intent(out) :: ad_state(Mstr:)
2132# else
2133# ifdef MASKING
2134 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
2135 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
2136 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
2137
2138 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
2139 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
2140 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
2141# endif
2142 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
2143# ifdef SOLVE3D
2144 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
2145
2146 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
2147 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
2148 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
2149 real(r8), intent(inout) :: ad_stflx(LBi:UBi,LBj:UBj,NT(ng))
2150# else
2151 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
2152 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
2153# endif
2154 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
2155 real(r8), intent(inout) :: ad_sustr(LBi:UBi,LBj:UBj)
2156 real(r8), intent(inout) :: ad_svstr(LBi:UBi,LBj:UBj)
2157 real(r8), intent(out) :: ad_state(Mstr:Mend)
2158# endif
2159!
2160! Local variable declarations.
2161!
2162# ifndef MASKING
2163 integer :: Imax, Ioff, Jmax, Joff
2164# endif
2165 integer :: Uoff, Voff
2166 integer :: i, iadd, icount, is, itrc, j, k
2167
2168# ifdef SALINITY
2169 integer, dimension(7+2*NT(ng)) :: offset
2170# else
2171 integer, dimension(7+2*(NT(ng)+1)) :: offset
2172# endif
2173
2174 real(r8), parameter :: Aspv = 0.0_r8
2175
2176 real(r8) :: cff, cff1, scale
2177
2178# include "set_bounds.h"
2179
2180# ifdef DISTRIBUTE
2181!
2182!-----------------------------------------------------------------------
2183! Initialize adjoint state vector with special value (zero) to
2184! facilitate gathering/scattering communications between all nodes.
2185! This is achieved by summing all the buffers.
2186!-----------------------------------------------------------------------
2187!
2188 DO is=mstr,mend
2189 ad_state(is)=aspv
2190 END DO
2191# endif
2192!
2193!-----------------------------------------------------------------------
2194! Load adjoint STATE variables into full 1D state vector.
2195!-----------------------------------------------------------------------
2196!
2197! Initialize local summations.
2198!
2199 IF (inttrap.eq.1) THEN
2200 DO is=mstr,mend
2201 storage(ng)%ad_Work(is)=0.0_r8
2202 END DO
2203 END IF
2204!
2205! Set offsets for momentum variables due to periodic boundary
2206! conditions. Recall that in East-West periodic boundary conditions
2207! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
2208! applications IstrV=1 or else IstrV=2.
2209!
2210 IF (ewperiodic(ng)) THEN
2211 uoff=0
2212 ELSE
2213 uoff=1
2214 END IF
2215!
2216 IF (nsperiodic(ng)) THEN
2217 voff=0
2218 ELSE
2219 voff=1
2220 END IF
2221!
2222! Determine the index offset for each variable in the state vector.
2223# ifdef MASKING
2224! Notice that in Land/Sea masking application the state vector only
2225! contains water points to avoid large null space.
2226# endif
2227!
2228! First clear the "offset" array.
2229!
2230 offset=0
2231!
2232# ifdef SOLVE3D
2233# ifdef MASKING
2234 IF (scalars(ng)%Fstate(isfsur)) THEN
2235 offset(isfsur)=0
2236 END IF
2237 IF (scalars(ng)%Fstate(isuvel)) THEN
2238 offset(isuvel)=offset(isfsur)+nwaterr(ng)
2239 END IF
2240 IF (scalars(ng)%Fstate(isvvel)) THEN
2241 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
2242 END IF
2243 iadd=nwaterv(ng)*n(ng)
2244 DO itrc=1,nt(ng)
2245 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
2246 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
2247 iadd=nwaterr(ng)*n(ng)
2248 END IF
2249 END DO
2250 IF (scalars(ng)%Fstate(isustr)) THEN
2251 offset(isustr)=0
2252 END IF
2253 IF (scalars(ng)%Fstate(isvstr)) THEN
2254 offset(isvstr)=offset(isustr)+nwateru(ng)
2255 END IF
2256 DO itrc=1,nt(ng)
2257 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
2258 IF (itrc.eq.1) THEN
2259 offset(istsur(itrc))=offset(isvstr)+nwaterv(ng)
2260 ELSE
2261 offset(istsur(itrc))=offset(istsur(itrc-1))+nwaterr(ng)
2262 END IF
2263 END IF
2264 END DO
2265# else
2266# ifdef FULL_GRID
2267 IF (scalars(ng)%Fstate(isfsur)) THEN
2268 offset(isfsur)=0
2269 END IF
2270 IF (scalars(ng)%Fstate(isuvel)) THEN
2271 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
2272 END IF
2273 IF (scalars(ng)%Fstate(isvvel)) THEN
2274 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
2275 END IF
2276 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
2277 DO itrc=1,nt(ng)
2278 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
2279 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
2280 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
2281 END IF
2282 END DO
2283 IF (scalars(ng)%Fstate(isustr)) THEN
2284 offset(isustr)=0
2285 END IF
2286 IF (scalars(ng)%Fstate(isvstr)) THEN
2287 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
2288 END IF
2289 DO itrc=1,nt(ng)
2290 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
2291 IF (itrc.eq.1) THEN
2292 offset(istsur(itrc))=offset(isvstr)+ &
2293 & (lm(ng)+2)*(mm(ng)+1)
2294 ELSE
2295 offset(istsur(itrc))=offset(istsur(itrc-1))+ &
2296 & (lm(ng)+2)*(mm(ng)+2)
2297 END IF
2298 END IF
2299 END DO
2300# else
2301 IF (scalars(ng)%Fstate(isfsur)) THEN
2302 offset(isfsur)=0
2303 END IF
2304 IF (scalars(ng)%Fstate(isuvel)) THEN
2305 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
2306 END IF
2307 IF (scalars(ng)%Fstate(isvvel)) THEN
2308 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
2309 END IF
2310 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
2311 DO itrc=1,nt(ng)
2312 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
2313 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
2314 iadd=lm(ng)*mm(ng)*n(ng)
2315 END IF
2316 END DO
2317 IF (scalars(ng)%Fstate(isustr)) THEN
2318 offset(isustr)=0
2319 END IF
2320 IF (scalars(ng)%Fstate(isvstr)) THEN
2321 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
2322 END IF
2323 DO itrc=1,nt(ng)
2324 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
2325 IF (itrc.eq.1) THEN
2326 offset(istsur(itrc))=offset(isvstr)+lm(ng)*(mm(ng)-voff)
2327 ELSE
2328 offset(istsur(itrc))=offset(istsur(itrc-1))+lm(ng)*mm(ng)
2329 END IF
2330 END IF
2331 END DO
2332# endif
2333# endif
2334# else
2335# ifdef MASKING
2336 IF (scalars(ng)%Fstate(isfsur)) THEN
2337 offset(isfsur)=0
2338 END IF
2339 IF (scalars(ng)%Fstate(isubar)) THEN
2340 offset(isubar)=offset(isfsur)+nwaterr(ng)
2341 END IF
2342 IF (scalars(ng)%Fstate(isvbar)) THEN
2343 offset(isvbar)=offset(isubar)+nwateru(ng)
2344 END IF
2345 IF (scalars(ng)%Fstate(isustr)) THEN
2346 offset(isustr)=0
2347 END IF
2348 IF (scalars(ng)%Fstate(isvstr)) THEN
2349 offset(isvstr)=offset(isustr)+nwateru(ng)
2350 END IF
2351# else
2352# ifdef FULL_GRID
2353 IF (scalars(ng)%Fstate(isfsur)) THEN
2354 offset(isfsur)=0
2355 END IF
2356 IF (scalars(ng)%Fstate(isubar)) THEN
2357 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
2358 END IF
2359 IF (scalars(ng)%Fstate(isvbar) THEN
2360 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
2361 END IF
2362 IF (scalars(ng)%Fstate(isustr)) THEN
2363 offset(isustr)=0
2364 END IF
2365 IF (scalars(ng)%Fstate(isvstr)) THEN
2366 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
2367 END IF
2368# else
2369 IF (scalars(ng)%Fstate(isfsur)) THEN
2370 offset(isfsur)=0
2371 END IF
2372 IF (scalars(ng)%Fstate(isubar)) THEN
2373 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
2374 END IF
2375 IF (scalars(ng)%Fstate(isvbar) THEN
2376 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
2377 END IF
2378 IF (scalars(ng)%Fstate(isustr)) THEN
2379 offset(isustr)=0
2380 END IF
2381 IF (scalars(ng)%Fstate(isustr)) THEN
2382 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
2383 END IF
2384# endif
2385# endif
2386# endif
2387!
2388 cff1=dt(ng)*real(ntimes(ng)/nintervals,r8)
2389 IF ((inttrap.eq.1).or.(inttrap.eq.nintervals+1)) THEN
2390 cff1=0.5_r8*cff1
2391 ENDIF
2392!
2393! Load adjoint of free-surface.
2394!
2395 IF (scalars(ng)%Fstate(isfsur)) THEN
2396# ifndef MASKING
2397# ifdef FULL_GRID
2398 imax=lm(ng)+2
2399 ioff=1
2400 joff=0
2401# else
2402 imax=lm(ng)
2403 ioff=0
2404 joff=1
2405# endif
2406# endif
2407 scale=cff1
2408# ifdef ENERGYNORM_SCALE
2409 scale=scale/sqrt(0.5_r8*g*rho0)
2410# endif
2411 DO j=jr_range
2412 DO i=ir_range
2413# ifdef MASKING
2414 IF (rmask(i,j).gt.0.0_r8) THEN
2415 is=ijwaterr(i,j)+offset(isfsur)
2416 ad_state(is)=storage(ng)%ad_Work(is)+ &
2417 & scale*ad_zeta(i,j,kstp)
2418 storage(ng)%ad_Work(is)=ad_state(is)
2419 END IF
2420# else
2421 is=(i+ioff)+(j-joff)*imax+offset(isfsur)
2422 ad_state(is)=storage(ng)%ad_Work(is)+ &
2423 & scale*ad_zeta(i,j,kstp)
2424 storage(ng)%ad_Work(is)=ad_state(is)
2425# endif
2426 END DO
2427 END DO
2428 END IF
2429
2430# ifndef SOLVE3D
2431!
2432! Load adjoint of 2D U-velocity.
2433!
2434 IF (scalars(ng)%Fstate(isubar)) THEN
2435# ifndef MASKING
2436# ifdef FULL_GRID
2437 imax=lm(ng)+1
2438 ioff=0
2439 joff=0
2440# else
2441 imax=lm(ng)-uoff
2442 ioff=uoff
2443 joff=1
2444# endif
2445# endif
2446# ifdef ENERGYNORM_SCALE
2447 cff=0.25_r8*rho0
2448# endif
2449 DO j=jr_range
2450 DO i=iu_range
2451# ifdef ENERGYNORM_SCALE
2452 scale=cff1/sqrt(cff*(h(i-1,j)+h(i,j)))
2453# else
2454 scale=cff1
2455# endif
2456# ifdef MASKING
2457 IF (umask(i,j).gt.0.0_r8) THEN
2458 is=ijwateru(i,j)+offset(isubar)
2459 ad_state(is)=storage(ng)%ad_Work(is)+ &
2460 & scale*ad_ubar(i,j,kstp)
2461 storage(ng)%ad_Work(is)=ad_state(is)
2462 END IF
2463# else
2464 is=(i-ioff)+(j-joff)*imax+offset(isubar)
2465 ad_state(is)=storage(ng)%ad_Work(is)+ &
2466 & scale*ad_ubar(i,j,kstp)
2467 storage(ng)%ad_Work(is)=ad_state(is)
2468# endif
2469 END DO
2470 END DO
2471 END IF
2472!
2473! Load adjoint of 2D V-velocity.
2474!
2475 IF (scalars(ng)%Fstate(isvbar)) THEN
2476# ifndef MASKING
2477# ifdef FULL_GRID
2478 imax=lm(ng)+2
2479 ioff=1
2480 joff=1
2481# else
2482 imax=lm(ng)
2483 ioff=0
2484 joff=1+voff
2485# endif
2486# endif
2487# ifdef ENERGYNORM_SCALE
2488 cff=0.25_r8*rho0
2489# endif
2490 DO j=jv_range
2491 DO i=ir_range
2492# ifdef ENERGYNORM_SCALE
2493 scale=cff1/sqrt(cff*(h(i,j-1)+h(i,j)))
2494# else
2495 scale=cff1
2496# endif
2497# ifdef MASKING
2498 IF (vmask(i,j).gt.0.0_r8) THEN
2499 is=ijwaterv(i,j)+offset(isvbar)
2500 ad_state(is)=storage(ng)%ad_Work(is)+ &
2501 & scale*ad_vbar(i,j,kstp)
2502 storage(ng)%ad_Work(is)=ad_state(is)
2503 END IF
2504# else
2505 is=(i+ioff)+(j-joff)*imax+offset(isvbar)
2506 ad_state(is)=storage(ng)%ad_Work(is)+ &
2507 & scale*ad_vbar(i,j,kstp)
2508 storage(ng)%ad_Work(is)=ad_state(is)
2509# endif
2510 END DO
2511 END DO
2512 END IF
2513
2514# else
2515!
2516! Load adjoint of 3D U-velocity.
2517!
2518 IF (scalars(ng)%Fstate(isuvel)) THEN
2519# ifndef MASKING
2520# ifdef FULL_GRID
2521 imax=lm(ng)+1
2522 jmax=mm(ng)+2
2523 ioff=0
2524 joff=0
2525# else
2526 imax=lm(ng)-uoff
2527 jmax=mm(ng)
2528 ioff=uoff
2529 joff=1
2530# endif
2531# endif
2532# ifdef ENERGYNORM_SCALE
2533 cff=0.25_r8*rho0
2534# endif
2535 DO k=1,n(ng)
2536# ifdef MASKING
2537 iadd=(k-1)*nwateru(ng)+offset(isuvel)
2538# else
2539 iadd=(k-1)*imax*jmax+offset(isuvel)
2540# endif
2541 DO j=jr_range
2542 DO i=iu_range
2543# ifdef MASKING
2544 IF (umask(i,j).gt.0.0_r8) THEN
2545# ifdef ENERGYNORM_SCALE
2546 scale=cff1/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
2547# else
2548 scale=cff1
2549# endif
2550 is=ijwateru(i,j)+iadd
2551 ad_state(is)=storage(ng)%ad_Work(is)+ &
2552 & scale*ad_u(i,j,k,nstp)
2553 storage(ng)%ad_Work(is)=ad_state(is)
2554 END IF
2555# else
2556# ifdef ENERGYNORM_SCALE
2557 scale=cff1/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
2558# else
2559 scale=cff1
2560# endif
2561 is=(i-ioff)+(j-joff)*imax+iadd
2562 ad_state(is)=storage(ng)%ad_Work(is)+ &
2563 & scale*ad_u(i,j,k,nstp)
2564 storage(ng)%ad_Work(is)=ad_state(is)
2565# endif
2566 END DO
2567 END DO
2568 END DO
2569 END IF
2570!
2571! Load adjoint of 3D V-velocity.
2572!
2573 IF (scalars(ng)%Fstate(isvvel)) THEN
2574# ifndef MASKING
2575# ifdef FULL_GRID
2576 imax=lm(ng)+2
2577 jmax=mm(ng)+1
2578 ioff=1
2579 joff=1
2580# else
2581 imax=lm(ng)
2582 jmax=mm(ng)-voff
2583 ioff=0
2584 joff=1+voff
2585# endif
2586# endif
2587# ifdef ENERGYNORM_SCALE
2588 cff=0.25_r8*rho0
2589# endif
2590 DO k=1,n(ng)
2591# ifdef MASKING
2592 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
2593# else
2594 iadd=(k-1)*imax*jmax+offset(isvvel)
2595# endif
2596 DO j=jv_range
2597 DO i=ir_range
2598# ifdef MASKING
2599 IF (vmask(i,j).gt.0.0_r8) THEN
2600# ifdef ENERGYNORM_SCALE
2601 scale=cff1/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
2602# else
2603 scale=cff1
2604# endif
2605 is=ijwaterv(i,j)+iadd
2606 ad_state(is)=storage(ng)%ad_Work(is)+ &
2607 & scale*ad_v(i,j,k,nstp)
2608 storage(ng)%ad_Work(is)=ad_state(is)
2609 END IF
2610# else
2611# ifdef ENERGYNORM_SCALE
2612 scale=cff1/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
2613# else
2614 scale=cff1
2615# endif
2616 is=(i+ioff)+(j-joff)*imax+iadd
2617 ad_state(is)=storage(ng)%ad_Work(is)+ &
2618 & scale*ad_v(i,j,k,nstp)
2619 storage(ng)%ad_Work(is)=ad_state(is)
2620# endif
2621 END DO
2622 END DO
2623 END DO
2624 END IF
2625!
2626! Load adjoint of tracers variables.
2627!
2628 DO itrc=1,nt(ng)
2629 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
2630# ifndef MASKING
2631# ifdef FULL_GRID
2632 imax=lm(ng)+2
2633 jmax=mm(ng)+2
2634 ioff=1
2635 joff=0
2636# else
2637 imax=lm(ng)
2638 jmax=mm(ng)
2639 ioff=0
2640 joff=1
2641# endif
2642# endif
2643# ifdef ENERGYNORM_SCALE
2644 IF (itrc.eq.itemp) THEN
2645 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
2646 ELSE IF (itrc.eq.isalt) THEN
2647 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
2648 ELSE
2649 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
2650 END IF
2651# endif
2652 DO k=1,n(ng)
2653# ifdef MASKING
2654 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
2655# else
2656 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
2657# endif
2658 DO j=jr_range
2659 DO i=ir_range
2660# ifdef MASKING
2661 IF (rmask(i,j).gt.0.0_r8) THEN
2662# ifdef ENERGYNORM_SCALE
2663 scale=cff1/sqrt(cff*hz(i,j,k))
2664# else
2665 scale=cff1
2666# endif
2667
2668 is=ijwaterr(i,j)+iadd
2669 ad_state(is)=storage(ng)%ad_Work(is)+ &
2670 & scale*ad_t(i,j,k,nstp,itrc)
2671 storage(ng)%ad_Work(is)=ad_state(is)
2672 END IF
2673# else
2674# ifdef ENERGYNORM_SCALE
2675 scale=cff1/sqrt(cff*hz(i,j,k))
2676# else
2677 scale=cff1
2678# endif
2679 is=(i+ioff)+(j-joff)*imax+iadd
2680 ad_state(is)=storage(ng)%ad_Work(is)+ &
2681 & scale*ad_t(i,j,k,nstp,itrc)
2682 storage(ng)%ad_Work(is)=ad_state(is)
2683# endif
2684 END DO
2685 END DO
2686 END DO
2687 END IF
2688 END DO
2689# endif
2690!
2691! Load adjoint of surface U-stress.
2692!
2693 IF (scalars(ng)%Fstate(isustr)) THEN
2694# ifndef MASKING
2695# ifdef FULL_GRID
2696 imax=lm(ng)+1
2697 ioff=0
2698 joff=0
2699# else
2700 imax=lm(ng)-uoff
2701 ioff=uoff
2702 joff=1
2703# endif
2704# endif
2705 scale=cff1
2706 DO j=jr_range
2707 DO i=iu_range
2708# ifdef MASKING
2709 IF (umask(i,j).gt.0.0_r8) THEN
2710 is=ijwateru(i,j)+offset(isustr)
2711 ad_state(is)=storage(ng)%ad_Work(is)+ &
2712 & scale*ad_sustr(i,j)
2713 storage(ng)%ad_Work(is)=ad_state(is)
2714 END IF
2715# else
2716 is=(i-ioff)+(j-joff)*imax+offset(isustr)
2717 ad_state(is)=storage(ng)%ad_Work(is)+ &
2718 & scale*ad_sustr(i,j)
2719 storage(ng)%ad_Work(is)=ad_state(is)
2720# endif
2721 END DO
2722 END DO
2723 END IF
2724!
2725! Load adjoint of surface V-stress.
2726!
2727 IF (scalars(ng)%Fstate(isvstr)) THEN
2728# ifndef MASKING
2729# ifdef FULL_GRID
2730 imax=lm(ng)+2
2731 ioff=1
2732 joff=1
2733# else
2734 imax=lm(ng)
2735 ioff=0
2736 joff=1+voff
2737# endif
2738# endif
2739 scale=cff1
2740 DO j=jv_range
2741 DO i=ir_range
2742# ifdef MASKING
2743 IF (vmask(i,j).gt.0.0_r8) THEN
2744 is=ijwaterv(i,j)+offset(isvstr)
2745 ad_state(is)=storage(ng)%ad_Work(is)+ &
2746 & scale*ad_svstr(i,j)
2747 storage(ng)%ad_Work(is)=ad_state(is)
2748 END IF
2749# else
2750 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
2751 ad_state(is)=storage(ng)%ad_Work(is)+ &
2752 & scale*ad_svstr(i,j)
2753 storage(ng)%ad_Work(is)=ad_state(is)
2754# endif
2755 END DO
2756 END DO
2757 END IF
2758
2759# ifdef SOLVE3D
2760!
2761! Load adjoint of surface tracer flux variables.
2762!
2763 DO itrc=1,nt(ng)
2764 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
2765# ifndef MASKING
2766# ifdef FULL_GRID
2767 imax=lm(ng)+2
2768 jmax=mm(ng)+2
2769 ioff=1
2770 joff=0
2771# else
2772 imax=lm(ng)
2773 jmax=mm(ng)
2774 ioff=0
2775 joff=1
2776# endif
2777# endif
2778 scale=cff1
2779 DO j=jr_range
2780 DO i=ir_range
2781# ifdef MASKING
2782 IF (rmask(i,j).gt.0.0_r8) THEN
2783 is=ijwaterr(i,j)+offset(istsur(itrc))
2784 ad_state(is)=storage(ng)%ad_Work(is)+ &
2785 & scale*ad_stflx(i,j,itrc)
2786 storage(ng)%ad_Work(is)=ad_state(is)
2787 END IF
2788# else
2789 is=(i+ioff)+(j-joff)*imax+offset(istsur(itrc))
2790 ad_state(is)=storage(ng)%ad_Work(is)+ &
2791 & scale*ad_stflx(i,j,itrc)
2792 storage(ng)%ad_Work(is)=ad_state(is)
2793# endif
2794 END DO
2795 END DO
2796 END IF
2797 END DO
2798# endif
2799!
2800 RETURN
2801 END SUBROUTINE ad_so_pack_tile
2802
2803# else
2804!
2805 SUBROUTINE ad_so_pack_red (ng, tile, Mstr, Mend, IntTrap, &
2806 & ad_state)
2807!
2808!=======================================================================
2809! !
2810! This routine packs the adjoint variables into the state vector. !
2811! The state vector contains only interior water points. !
2812! !
2813!=======================================================================
2814!
2815 USE mod_param
2816 USE mod_forces
2817 USE mod_grid
2818 USE mod_ocean
2819 USE mod_stepping
2820# ifdef DISTRIBUTE
2821 USE mod_storage
2822# endif
2823# ifdef DISTRIBUTE
2824!
2825 USE distribute_mod, ONLY : mp_scatter_state
2826# endif
2827!
2828! Imported variable declarations.
2829!
2830 integer, intent(in) :: ng, tile
2831 integer, intent(in) :: Mstr, Mend
2832 integer, intent(in) :: IntTrap
2833# ifdef ASSUMED_SHAPE
2834 real(r8), intent(out) :: ad_state(Mstr:)
2835# else
2836 real(r8), intent(out) :: ad_state(Mstr:Mend)
2837# endif
2838!
2839! Local variable declarations.
2840!
2841 character (len=*), parameter :: MyFile = &
2842 & __FILE__//", ad_so_pack_red"
2843!
2844# include "tile.h"
2845!
2846# ifdef PROFILE
2847 CALL wclock_on (ng, iadm, 2, __line__, myfile)
2848# endif
2849
2850 CALL ad_so_pack_red_tile (ng, tile, &
2851 & lbi, ubi, lbj, ubj, &
2852 & imins, imaxs, jmins, jmaxs, &
2853 & kstp(ng), &
2854# ifdef SOLVE3D
2855 & nstp(ng), &
2856# endif
2857 & inttrap, &
2858# ifdef DISTRIBUTE
2859 & 1, mstate(ng), swork, &
2860# else
2861 & mstr, mend, ad_state, &
2862# endif
2863# ifdef MASKING
2864 & grid(ng) % IJwaterR, &
2865 & grid(ng) % IJwaterU, &
2866 & grid(ng) % IJwaterV, &
2867 & grid(ng) % rmask, &
2868 & grid(ng) % umask, &
2869 & grid(ng) % vmask, &
2870# endif
2871 & grid(ng) % h, &
2872# ifdef SOLVE3D
2873 & grid(ng) % Hz, &
2874 & ocean(ng) % ad_t, &
2875 & ocean(ng) % ad_u, &
2876 & ocean(ng) % ad_v, &
2877 & forces(ng) % ad_stflx, &
2878# else
2879 & ocean(ng) % ad_ubar, &
2880 & ocean(ng) % ad_vbar, &
2881# endif
2882 & ocean(ng) % ad_zeta, &
2883 & forces(ng) % ad_sustr, &
2884 & forces(ng) % ad_svstr)
2885
2886# ifdef PROFILE
2887 CALL wclock_off (ng, iadm, 2, __line__, myfile)
2888# endif
2889
2890# ifdef DISTRIBUTE
2891!
2892! Scatter (global to threaded) adjoint state solution to all
2893! distributed nodes.
2894!
2895 CALL mp_scatter_state (ng, iadm, mstr, mend, mstate(ng), &
2896 & swork, ad_state)
2897# endif
2898!
2899 RETURN
2900 END SUBROUTINE ad_so_pack_red
2901!
2902!***********************************************************************
2903 SUBROUTINE ad_so_pack_red_tile (ng, tile, &
2904 & LBi, UBi, LBj, UBj, &
2905 & IminS, ImaxS, JminS, JmaxS, &
2906 & kstp, &
2907# ifdef SOLVE3D
2908 & nstp, &
2909# endif
2910 & IntTrap, &
2911 & Mstr, Mend, ad_state, &
2912# ifdef MASKING
2913 & IJwaterR, IJwaterU, IJwaterV, &
2914 & rmask, umask, vmask, &
2915# endif
2916 & h, &
2917# ifdef SOLVE3D
2918 & Hz, &
2919 & ad_t, ad_u, ad_v, ad_stflx, &
2920# else
2921 & ad_ubar, ad_vbar, &
2922# endif
2923 & ad_zeta, ad_sustr, ad_svstr)
2924!***********************************************************************
2925!
2926 USE mod_param
2927 USE mod_parallel
2928 USE mod_forces
2929 USE mod_grid
2930 USE mod_iounits
2931 USE mod_ncparam
2932 USE mod_netcdf
2933!! USE mod_ocean
2934# if defined PIO_LIB && defined DISTRIBUTE
2935 USE mod_pio_netcdf
2936# endif
2937 USE mod_scalars
2938 USE mod_storage
2939!
2940 USE nf_fread2d_mod, ONLY : nf_fread2d
2941# ifdef SOLVE3D
2942 USE nf_fread3d_mod, ONLY : nf_fread3d
2943# endif
2944 USE strings_mod, ONLY : founderror
2945!
2946! Imported variable declarations.
2947!
2948 integer, intent(in) :: ng, tile
2949 integer, intent(in) :: LBi, UBi, LBj, UBj
2950 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
2951 integer, intent(in) :: Mstr, Mend
2952 integer, intent(in) :: kstp
2953 integer, intent(in) :: IntTrap
2954# ifdef SOLVE3D
2955 integer, intent(in) :: nstp
2956# endif
2957!
2958# ifdef ASSUMED_SHAPE
2959# ifdef MASKING
2960 integer, intent(in) :: IJwaterR(LBi:,LBj:)
2961 integer, intent(in) :: IJwaterU(LBi:,LBj:)
2962 integer, intent(in) :: IJwaterV(LBi:,LBj:)
2963
2964 real(r8), intent(in) :: rmask(LBi:,LBj:)
2965 real(r8), intent(in) :: umask(LBi:,LBj:)
2966 real(r8), intent(in) :: vmask(LBi:,LBj:)
2967# endif
2968 real(r8), intent(in) :: h(LBi:,LBj:)
2969# ifdef SOLVE3D
2970 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
2971
2972 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
2973 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
2974 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
2975 real(r8), intent(inout) :: ad_stflx(LBi:,LBj:,:)
2976# else
2977 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
2978 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
2979# endif
2980 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
2981 real(r8), intent(inout) :: ad_sustr(LBi:,LBj:)
2982 real(r8), intent(inout) :: ad_svstr(LBi:,LBj:)
2983 real(r8), intent(out) :: ad_state(Mstr:)
2984# else
2985# ifdef MASKING
2986 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
2987 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
2988 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
2989
2990 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
2991 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
2992 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
2993# endif
2994 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
2995# ifdef SOLVE3D
2996 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
2997
2998 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
2999 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
3000 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
3001 real(r8), intent(inout) :: ad_stflx(LBi:UBi,LBj:UBj,NT(ng))
3002# else
3003 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
3004 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
3005# endif
3006 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
3007 real(r8), intent(inout) :: ad_sustr(LBi:UBi,LBj:UBj)
3008 real(r8), intent(inout) :: ad_svstr(LBi:UBi,LBj:UBj)
3009 real(r8), intent(out) :: ad_state(Mstr:Mend)
3010# endif
3011!
3012! Local variable declarations.
3013!
3014# ifndef MASKING
3015 integer :: Imax, Ioff, Jmax, Joff
3016# endif
3017 integer :: Uoff, Voff
3018 integer :: i, iadd, icount, ifield, is, itrc, j, k
3019 integer :: Fcount, Irec, Nrec
3020 integer :: gtype, status
3021 integer :: Vsize(4), ntAD, ntTL, Iinp
3022
3023# ifdef SALINITY
3024 integer, dimension(7+2*NT(ng)) :: offset
3025# else
3026 integer, dimension(7+2*(NT(ng)+1)) :: offset
3027# endif
3028!
3029 real(r8), parameter :: Aspv = 0.0_r8
3030
3031 real(dp) :: scale
3032
3033 real(r8) :: Fmin, Fmax
3034 real(r8) :: cff, cff1, afac, scalev
3035!
3036 character (len=*), parameter :: MyFile = &
3037 & __FILE__//", ad_so_pack_red_tile"
3038
3039# if defined PIO_LIB && defined DISTRIBUTE
3040!
3041 TYPE (IO_Desc_t), pointer :: ioDesc
3042# endif
3043
3044# include "set_bounds.h"
3045
3046# ifdef DISTRIBUTE
3047!
3048!-----------------------------------------------------------------------
3049! Initialize adjoint state vector with special value (zero) to
3050! facilitate gathering/scattering communications between all nodes.
3051! This is achieved by summing all the buffers.
3052!-----------------------------------------------------------------------
3053!
3054 DO is=mstr,mend
3055 ad_state(is)=aspv
3056 END DO
3057# endif
3058!
3059!-----------------------------------------------------------------------
3060! Load adjoint STATE variables into full 1D state vector.
3061!-----------------------------------------------------------------------
3062!
3063! Initialize local summations.
3064!
3065 IF (inttrap.eq.1) THEN
3066 DO is=mstr,mend
3067 storage(ng)%ad_Work(is)=0.0_r8
3068 END DO
3069 END IF
3070!
3071! Set offsets for momentum variables due to periodic boundary
3072! conditions. Recall that in East-West periodic boundary conditions
3073! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
3074! applications IstrV=1 or else IstrV=2.
3075!
3076 IF (ewperiodic(ng)) THEN
3077 uoff=0
3078 ELSE
3079 uoff=1
3080 END IF
3081!
3082 IF (nsperiodic(ng)) THEN
3083 voff=0
3084 ELSE
3085 voff=1
3086 END IF
3087!
3088! Determine the index offset for each variable in the state vector.
3089# ifdef MASKING
3090! Notice that in Land/Sea masking application the state vector only
3091! contains water points to avoid large null space.
3092# endif
3093!
3094! First clear the "offset" array.
3095!
3096 offset=0
3097!
3098# ifdef SOLVE3D
3099# ifdef MASKING
3100 IF (scalars(ng)%Fstate(isfsur)) THEN
3101 offset(isfsur)=0
3102 END IF
3103 IF (scalars(ng)%Fstate(isuvel)) THEN
3104 offset(isuvel)=offset(isfsur)+nwaterr(ng)
3105 END IF
3106 IF (scalars(ng)%Fstate(isvvel)) THEN
3107 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
3108 END IF
3109 iadd=nwaterv(ng)*n(ng)
3110 DO itrc=1,nt(ng)
3111 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
3112 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
3113 iadd=nwaterr(ng)*n(ng)
3114 END IF
3115 END DO
3116 IF (scalars(ng)%Fstate(isustr)) THEN
3117 offset(isustr)=0
3118 END IF
3119 IF (scalars(ng)%Fstate(isvstr)) THEN
3120 offset(isvstr)=offset(isustr)+nwateru(ng)
3121 END IF
3122 DO itrc=1,nt(ng)
3123 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
3124 IF (itrc.eq.1) THEN
3125 offset(istsur(itrc))=offset(isvstr)+nwaterv(ng)
3126 ELSE
3127 offset(istsur(itrc))=offset(istsur(itrc-1))+nwaterr(ng)
3128 END IF
3129 END IF
3130 END DO
3131# else
3132# ifdef FULL_GRID
3133 IF (scalars(ng)%Fstate(isfsur)) THEN
3134 offset(isfsur)=0
3135 END IF
3136 IF (scalars(ng)%Fstate(isuvel)) THEN
3137 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
3138 END IF
3139 IF (scalars(ng)%Fstate(isvvel)) THEN
3140 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
3141 END IF
3142 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
3143 DO itrc=1,nt(ng)
3144 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
3145 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
3146 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
3147 END IF
3148 END DO
3149 IF (scalars(ng)%Fstate(isustr)) THEN
3150 offset(isustr)=0
3151 END IF
3152 IF (scalars(ng)%Fstate(isvstr)) THEN
3153 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
3154 END IF
3155 DO itrc=1,nt(ng)
3156 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
3157 IF (itrc.eq.1) THEN
3158 offset(istsur(itrc))=offset(isvstr)+(lm(ng)+2)*(mm(ng)+1)
3159 ELSE
3160 offset(istsur(itrc))=offset(istsur(itrc-1))+ &
3161 & (lm(ng)+2)*(mm(ng)+2)
3162 END IF
3163 END IF
3164 END DO
3165# else
3166 IF (scalars(ng)%Fstate(isfsur)) THEN
3167 offset(isfsur)=0
3168 END IF
3169 IF (scalars(ng)%Fstate(isuvel)) THEN
3170 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
3171 END IF
3172 IF (scalars(ng)%Fstate(isvvel)) THEN
3173 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
3174 END IF
3175 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
3176 DO itrc=1,nt(ng)
3177 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
3178 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
3179 iadd=lm(ng)*mm(ng)*n(ng)
3180 END IF
3181 END DO
3182 IF (scalars(ng)%Fstate(isustr)) THEN
3183 offset(isustr)=0
3184 END IF
3185 IF (scalars(ng)%Fstate(isvstr)) THEN
3186 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
3187 END IF
3188 DO itrc=1,nt(ng)
3189 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
3190 IF (itrc.eq.1) THEN
3191 offset(istsur(itrc))=offset(isvstr)+lm(ng)*(mm(ng)-voff)
3192 ELSE
3193 offset(istsur(itrc))=offset(istsur(itrc-1))+lm(ng)*mm(ng)
3194 END IF
3195 END IF
3196 END DO
3197# endif
3198# endif
3199# else
3200# ifdef MASKING
3201 IF (scalars(ng)%Fstate(isfsur)) THEN
3202 offset(isfsur)=0
3203 END IF
3204 IF (scalars(ng)%Fstate(isubar)) THEN
3205 offset(isubar)=offset(isfsur)+nwaterr(ng)
3206 END IF
3207 IF (scalars(ng)%Fstate(isvbar)) THEN
3208 offset(isvbar)=offset(isubar)+nwateru(ng)
3209 END IF
3210 IF (scalars(ng)%Fstate(isustr)) THEN
3211 offset(isustr)=0
3212 END IF
3213 IF (scalars(ng)%Fstate(isvstr)) THEN
3214 offset(isvstr)=offset(isustr)+nwateru(ng)
3215 END IF
3216# else
3217# ifdef FULL_GRID
3218 IF (scalars(ng)%Fstate(isfsur)) THEN
3219 offset(isfsur)=0
3220 END IF
3221 IF (scalars(ng)%Fstate(isubar)) THEN
3222 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
3223 END IF
3224 IF (scalars(ng)%Fstate(isvbar) THEN
3225 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
3226 END IF
3227 IF (scalars(ng)%Fstate(isustr)) THEN
3228 offset(isustr)=0
3229 END IF
3230 IF (scalars(ng)%Fstate(isvstr)) THEN
3231 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
3232 END IF
3233# else
3234 IF (scalars(ng)%Fstate(isfsur)) THEN
3235 offset(isfsur)=0
3236 END IF
3237 IF (scalars(ng)%Fstate(isubar)) THEN
3238 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
3239 END IF
3240 IF (scalars(ng)%Fstate(isvbar) THEN
3241 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
3242 END IF
3243 IF (scalars(ng)%Fstate(isustr)) THEN
3244 offset(isustr)=0
3245 END IF
3246 IF (scalars(ng)%Fstate(isustr)) THEN
3247 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
3248 END IF
3249# endif
3250# endif
3251# endif
3252!
3253! Read in adjoint state variables records.
3254!
3255 cff1=dt(ng)*real(ntimes(ng)/nintervals,r8)
3256 cff1=cff1*cff1
3257!
3258 DO i=1,4
3259 vsize(i)=0
3260 END DO
3261!
3262! Loop over the number of number of ADJ netcdf file records.
3263!
3264 iinp=1
3265 scale=1.0_dp
3266 nttl=(inttrap-1)*nadj(ng)+1
3267 fcount=adm(ng)%Fcount
3268 nrec=adm(ng)%Nrec(fcount)
3269!
3270 adrec_loop : DO irec=1,nrec
3271!
3272! Autocorrelation factor.
3273!
3274 ntad=(nrec-irec)*nadj(ng)+1
3275 CALL sp_bcoef (ng, ntad, nttl, afac)
3276!AMM afac=afac*cff1
3277!
3278! Process free-surface.
3279!
3280 IF (scalars(ng)%Fstate(isfsur)) THEN
3281 SELECT CASE (adm(ng)%IOtype)
3282 CASE (io_nf90)
3283 gtype=r2dvar
3284 status=nf_fread2d(ng, iadm, adm(ng)%name, &
3285 & adm(ng)%ncid, vname(1,idfsur), &
3286 & adm(ng)%Vid(idfsur), irec, &
3287 & gtype, vsize, &
3288 & lbi, ubi, lbj, ubj, &
3289 & scale, fmin, fmax, &
3290# ifdef MASKING
3291 & grid(ng) % rmask, &
3292# endif
3293 & ad_zeta(:,:,iinp))
3294
3295 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
3296 IF (master) WRITE (stdout,10) trim(vname(1,idfsur)), &
3297 & irec, trim(adm(ng)%name)
3298 exit_flag=2
3299 ioerror=status
3300 RETURN
3301 END IF
3302
3303# if defined PIO_LIB && defined DISTRIBUTE
3304 CASE (io_pio)
3305 IF (kind(ad_zeta).eq.8) THEN
3306 iodesc => iodesc_dp_r2dvar(ng)
3307 ELSE
3308 iodesc => iodesc_sp_r2dvar(ng)
3309 END IF
3310 status=nf_fread2d(ng, iadm, adm(ng)%name, &
3311 & adm(ng)%pioFile, vname(1,idfsur), &
3312 & adm(ng)%pioVar(idfsur), irec, &
3313 & iodesc, vsize, &
3314 & lbi, ubi, lbj, ubj, &
3315 & scale, fmin, fmax, &
3316# ifdef MASKING
3317 & grid(ng) % rmask, &
3318# endif
3319 & ad_zeta(:,:,iinp))
3320# endif
3321
3322 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3323 IF (master) WRITE (stdout,10) trim(vname(1,idfsur)), &
3324 & irec, trim(adm(ng)%name)
3325 exit_flag=2
3326 ioerror=status
3327 RETURN
3328 END IF
3329 END SELECT
3330!
3331! Load adjoint of free-surface.
3332!
3333# ifndef MASKING
3334# ifdef FULL_GRID
3335 imax=lm(ng)+2
3336 ioff=1
3337 joff=0
3338# else
3339 imax=lm(ng)
3340 ioff=0
3341 joff=1
3342# endif
3343# endif
3344 scalev=afac
3345# if defined ENERGYNORM_SCALE
3346 scalev=scalev/sqrt(0.5_r8*g*rho0)
3347# endif
3348 DO j=jr_range
3349 DO i=ir_range
3350# ifdef MASKING
3351 IF (rmask(i,j).gt.0.0_r8) THEN
3352 is=ijwaterr(i,j)+offset(isfsur)
3353 ad_state(is)=storage(ng)%ad_Work(is)+ &
3354 & scalev*ad_zeta(i,j,iinp)
3355 storage(ng)%ad_Work(is)=ad_state(is)
3356 END IF
3357# else
3358 is=(i+ioff)+(j-joff)*imax+offset(isfsur)
3359 ad_state(is)=storage(ng)%ad_Work(is)+ &
3360 & scalev*ad_zeta(i,j,iinp)
3361 storage(ng)%ad_Work(is)=ad_state(is)
3362# endif
3363 END DO
3364 END DO
3365 END IF
3366
3367# ifndef SOLVE3D
3368!
3369! Process 2D U-momentum.
3370!
3371 IF (scalars(ng)%Fstate(isubar)) THEN
3372 SELECT CASE (adm(ng)%IOtype)
3373 CASE (io_nf90)
3374 gtype=u2dvar
3375 status=nf_fread2d(ng, iadm, adm(ng)%name, &
3376 & adm(ng)%ncid, vname(1,idubar), &
3377 & adm(ng)%Vid(idubar), irec, &
3378 & gtype, vsize, &
3379 & lbi, ubi, lbj, ubj, &
3380 & scale, fmin, fmax, &
3381# ifdef MASKING
3382 & grid(ng) % umask, &
3383# endif
3384 & ad_ubar(:,:,iinp))
3385
3386 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
3387 IF (master) WRITE (stdout,10) trim(vname(1,idubar)), &
3388 & irec, trim(adm(ng)%name)
3389 exit_flag=2
3390 ioerror=status
3391 RETURN
3392 END IF
3393
3394# if defined PIO_LIB && defined DISTRIBUTE
3395 CASE (io_pio)
3396 IF (kind(ad_ubar).eq.8) THEN
3397 iodesc => iodesc_dp_u2dvar(ng)
3398 ELSE
3399 iodesc => iodesc_sp_u2dvar(ng)
3400 END IF
3401 status=nf_fread2d(ng, iadm, adm(ng)%name, &
3402 & adm(ng)%pioFile, vname(1,idubar), &
3403 & adm(ng)%pioVar(idubar), irec, &
3404 & iodesc, vsize, &
3405 & lbi, ubi, lbj, ubj, &
3406 & scale, fmin, fmax, &
3407# ifdef MASKING
3408 & grid(ng) % umask, &
3409# endif
3410 & ad_ubar(:,:,iinp))
3411# endif
3412
3413 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3414 IF (master) WRITE (stdout,10) trim(vname(1,idubar)), &
3415 & irec, trim(adm(ng)%name)
3416 exit_flag=2
3417 ioerror=status
3418 RETURN
3419 END IF
3420 END SELECT
3421!
3422! Load adjoint of 2D U-velocity.
3423!
3424# ifndef MASKING
3425# ifdef FULL_GRID
3426 imax=lm(ng)+1
3427 ioff=0
3428 joff=0
3429# else
3430 imax=lm(ng)-uoff
3431 ioff=uoff
3432 joff=1
3433# endif
3434# endif
3435# if defined ENERGYNORM_SCALE
3436 cff=0.25_r8*rho0
3437# endif
3438 DO j=jr_range
3439 DO i=iu_range
3440# if defined ENERGYNORM_SCALE
3441 scalev=afac/sqrt(cff*(h(i-1,j)+h(i,j)))
3442# else
3443 scalev=afac
3444# endif
3445# ifdef MASKING
3446 IF (umask(i,j).gt.0.0_r8) THEN
3447 is=ijwateru(i,j)+offset(isubar)
3448 ad_state(is)=storage(ng)%ad_Work(is)+ &
3449 & scalev*ad_ubar(i,j,iinp)
3450 storage(ng)%ad_Work(is)=ad_state(is)
3451 END IF
3452# else
3453 is=(i-ioff)+(j-joff)*imax+offset(isubar)
3454 ad_state(is)=storage(ng)%ad_Work(is)+ &
3455 & scalev*ad_ubar(i,j,iinp)
3456 storage(ng)%ad_Work(is)=ad_state(is)
3457# endif
3458 END DO
3459 END DO
3460 END IF
3461!
3462! Process 2D V-momentum.
3463!
3464 IF (scalars(ng)%Fstate(isvbar)) THEN
3465 SELECT CASE (adm(ng)%IOtype)
3466 CASE (io_nf90)
3467 gtype=v2dvar
3468 status=nf_fread2d(ng, iadm, adm(ng)%name, &
3469 & adm(ng)%ncid, vname(1,idvbar), &
3470 & adm(ng)%Vid(idvbar), irec, &
3471 & gtype, vsize, &
3472 & lbi, ubi, lbj, ubj, &
3473 & scale, fmin, fmax, &
3474# ifdef MASKING
3475 & grid(ng) % vmask, &
3476# endif
3477 & ad_vbar(:,:,iinp))
3478
3479 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
3480 IF (master) WRITE (stdout,10) trim(vname(1,idvbar)), &
3481 & irec, trim(adm(ng)%name)
3482 exit_flag=2
3483 ioerror=status
3484 RETURN
3485 END IF
3486
3487# if defined PIO_LIB && defined DISTRIBUTE
3488 CASE (io_pio)
3489 IF (kind(ad_vbar).eq.8) THEN
3490 iodesc => iodesc_dp_v2dvar(ng)
3491 ELSE
3492 iodesc => iodesc_sp_v2dvar(ng)
3493 END IF
3494 status=nf_fread2d(ng, iadm, adm(ng)%name, &
3495 & adm(ng)%pioFile, vname(1,idvbar), &
3496 & adm(ng)%pioVar(idvbar), irec, &
3497 & iodesc, vsize, &
3498 & lbi, ubi, lbj, ubj, &
3499 & scale, fmin, fmax, &
3500# ifdef MASKING
3501 & grid(ng) % vmask, &
3502# endif
3503 & ad_vbar(:,:,iinp))
3504# endif
3505
3506 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3507 IF (master) WRITE (stdout,10) trim(vname(1,idvbar)), &
3508 & irec, trim(adm(ng)%name)
3509 exit_flag=2
3510 ioerror=status
3511 RETURN
3512 END IF
3513 END SELECT
3514!
3515! Load adjoint of 2D V-velocity.
3516!
3517# ifndef MASKING
3518# ifdef FULL_GRID
3519 imax=lm(ng)+2
3520 ioff=1
3521 joff=1
3522# else
3523 imax=lm(ng)
3524 ioff=0
3525 joff=1+voff
3526# endif
3527# endif
3528# if defined ENERGYNORM_SCALE
3529 cff=0.25_r8*rho0
3530# endif
3531 DO j=jv_range
3532 DO i=ir_range
3533# if defined ENERGYNORM_SCALE
3534 scalev=afac/sqrt(cff*(h(i,j-1)+h(i,j)))
3535# else
3536 scalev=afac
3537# endif
3538# ifdef MASKING
3539 IF (vmask(i,j).gt.0.0_r8) THEN
3540 is=ijwaterv(i,j)+offset(isvbar)
3541 ad_state(is)=storage(ng)%ad_Work(is)+ &
3542 & scalev*ad_vbar(i,j,iinp)
3543 storage(ng)%ad_Work(is)=ad_state(is)
3544 END IF
3545# else
3546 is=(i+ioff)+(j-joff)*imax+offset(isvbar)
3547 ad_state(is)=storage(ng)%ad_Work(is)+ &
3548 & scalev*ad_vbar(i,j,iinp)
3549 storage(ng)%ad_Work(is)=ad_state(is)
3550# endif
3551 END DO
3552 END DO
3553 END IF
3554
3555# else
3556!
3557! Process 3D U-momentum.
3558!
3559 IF (scalars(ng)%Fstate(isuvel)) THEN
3560 SELECT CASE (adm(ng)%IOtype)
3561 CASE (io_nf90)
3562 gtype=u3dvar
3563 status=nf_fread3d(ng, iadm, adm(ng)%name, &
3564 & adm(ng)%ncid, vname(1,iduvel), &
3565 & adm(ng)%Vid(iduvel), irec, &
3566 & gtype, vsize, &
3567 & lbi, ubi, lbj, ubj, 1, n(ng), &
3568 & scale, fmin, fmax, &
3569# ifdef MASKING
3570 & grid(ng) % umask, &
3571# endif
3572 & ad_u(:,:,:,iinp))
3573
3574 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
3575 IF (master) WRITE (stdout,10) trim(vname(1,iduvel)), &
3576 & irec, trim(adm(ng)%name)
3577 exit_flag=2
3578 ioerror=status
3579 RETURN
3580 END IF
3581
3582# if defined PIO_LIB && defined DISTRIBUTE
3583 CASE (io_pio)
3584 IF (kind(ad_u).eq.8) THEN
3585 iodesc => iodesc_dp_u3dvar(ng)
3586 ELSE
3587 iodesc => iodesc_sp_u3dvar(ng)
3588 END IF
3589 status=nf_fread3d(ng, iadm, adm(ng)%name, &
3590 & adm(ng)%pioFile, vname(1,iduvel), &
3591 & adm(ng)%pioVar(iduvel), irec, &
3592 & iodesc, vsize, &
3593 & lbi, ubi, lbj, ubj, 1, n(ng), &
3594 & scale, fmin, fmax, &
3595# ifdef MASKING
3596 & grid(ng) % umask, &
3597# endif
3598 & ad_u(:,:,:,iinp))
3599# endif
3600
3601 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3602 IF (master) WRITE (stdout,10) trim(vname(1,iduvel)), &
3603 & irec, trim(adm(ng)%name)
3604 exit_flag=2
3605 ioerror=status
3606 RETURN
3607 END IF
3608 END SELECT
3609!
3610! Load adjoint of 3D U-velocity.
3611!
3612# ifndef MASKING
3613# ifdef FULL_GRID
3614 imax=lm(ng)+1
3615 jmax=mm(ng)+2
3616 ioff=0
3617 joff=0
3618# else
3619 imax=lm(ng)-uoff
3620 jmax=mm(ng)
3621 ioff=uoff
3622 joff=1
3623# endif
3624# endif
3625# if defined ENERGYNORM_SCALE
3626 cff=0.25_r8*rho0
3627# endif
3628 DO k=1,n(ng)
3629# ifdef MASKING
3630 iadd=(k-1)*nwateru(ng)+offset(isuvel)
3631# else
3632 iadd=(k-1)*imax*jmax+offset(isuvel)
3633# endif
3634 DO j=jr_range
3635 DO i=iu_range
3636# ifdef MASKING
3637 IF (umask(i,j).gt.0.0_r8) THEN
3638# if defined ENERGYNORM_SCALE
3639 scalev=afac/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
3640# else
3641 scalev=afac
3642# endif
3643 is=ijwateru(i,j)+iadd
3644 ad_state(is)=storage(ng)%ad_Work(is)+ &
3645 & scalev*ad_u(i,j,k,iinp)
3646 storage(ng)%ad_Work(is)=ad_state(is)
3647 END IF
3648# else
3649# if defined ENERGYNORM_SCALE
3650 scalev=afac/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
3651# else
3652 scalev=afac
3653# endif
3654 is=(i-ioff)+(j-joff)*imax+iadd
3655 ad_state(is)=storage(ng)%ad_Work(is)+ &
3656 & scalev*ad_u(i,j,k,iinp)
3657 storage(ng)%ad_Work(is)=ad_state(is)
3658# endif
3659 END DO
3660 END DO
3661 END DO
3662 END IF
3663!
3664! Process 3D V-momentum.
3665!
3666 IF (scalars(ng)%Fstate(isvvel)) THEN
3667 SELECT CASE (adm(ng)%IOtype)
3668 CASE (io_nf90)
3669 gtype=v3dvar
3670 status=nf_fread3d(ng, iadm, adm(ng)%name, &
3671 & adm(ng)%ncid, vname(1,idvvel), &
3672 & adm(ng)%Vid(idvvel), irec, &
3673 & gtype, vsize, &
3674 & lbi, ubi, lbj, ubj, 1, n(ng), &
3675 & scale, fmin, fmax, &
3676# ifdef MASKING
3677 & grid(ng) % vmask, &
3678# endif
3679 & ad_v(:,:,:,iinp))
3680
3681 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
3682 IF (master) WRITE (stdout,10) trim(vname(1,idvvel)), &
3683 & irec, trim(adm(ng)%name)
3684 exit_flag=2
3685 ioerror=status
3686 RETURN
3687 END IF
3688
3689# if defined PIO_LIB && defined DISTRIBUTE
3690 CASE (io_pio)
3691 IF (kind(ad_v).eq.8) THEN
3692 iodesc => iodesc_dp_v3dvar(ng)
3693 ELSE
3694 iodesc => iodesc_sp_v3dvar(ng)
3695 END IF
3696 status=nf_fread3d(ng, iadm, adm(ng)%name, &
3697 & adm(ng)%pioFile, vname(1,idvvel), &
3698 & adm(ng)%pioVar(idvvel), irec, &
3699 & iodesc, vsize, &
3700 & lbi, ubi, lbj, ubj, 1, n(ng), &
3701 & scale, fmin, fmax, &
3702# ifdef MASKING
3703 & grid(ng) % vmask, &
3704# endif
3705 & ad_v(:,:,:,iinp))
3706# endif
3707
3708 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3709 IF (master) WRITE (stdout,10) trim(vname(1,idvvel)), &
3710 & irec, trim(adm(ng)%name)
3711 exit_flag=2
3712 ioerror=status
3713 RETURN
3714 END IF
3715 END SELECT
3716!
3717! Load adjoint of 3D V-velocity.
3718!
3719# ifndef MASKING
3720# ifdef FULL_GRID
3721 imax=lm(ng)+2
3722 jmax=mm(ng)+1
3723 ioff=1
3724 joff=1
3725# else
3726 imax=lm(ng)
3727 jmax=mm(ng)-voff
3728 ioff=0
3729 joff=1+voff
3730# endif
3731# endif
3732# if defined ENERGYNORM_SCALE
3733 cff=0.25_r8*rho0
3734# endif
3735 DO k=1,n(ng)
3736# ifdef MASKING
3737 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
3738# else
3739 iadd=(k-1)*imax*jmax+offset(isvvel)
3740# endif
3741 DO j=jv_range
3742 DO i=ir_range
3743# ifdef MASKING
3744 IF (vmask(i,j).gt.0.0_r8) THEN
3745# if defined ENERGYNORM_SCALE
3746 scalev=afac/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
3747# else
3748 scalev=afac
3749# endif
3750 is=ijwaterv(i,j)+iadd
3751 ad_state(is)=storage(ng)%ad_Work(is)+ &
3752 & scalev*ad_v(i,j,k,iinp)
3753 storage(ng)%ad_Work(is)=ad_state(is)
3754 END IF
3755# else
3756# if defined ENERGYNORM_SCALE
3757 scalev=afac/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
3758# else
3759 scalev=afac
3760# endif
3761 is=(i+ioff)+(j-joff)*imax+iadd
3762 ad_state(is)=storage(ng)%ad_Work(is)+ &
3763 & scalev*ad_v(i,j,k,iinp)
3764 storage(ng)%ad_Work(is)=ad_state(is)
3765# endif
3766 END DO
3767 END DO
3768 END DO
3769 END IF
3770!
3771! Process tracer type variables.
3772!
3773 DO itrc=1,nt(ng)
3774 ifield=istvar(itrc)
3775 IF (scalars(ng)%Fstate(ifield)) THEN
3776 SELECT CASE (adm(ng)%IOtype)
3777 CASE (io_nf90)
3778 gtype=r3dvar
3779 status=nf_fread3d(ng, iadm, adm(ng)%name, &
3780 & adm(ng)%ncid, vname(1,ifield), &
3781 & adm(ng)%Tid(itrc), irec, &
3782 & gtype, vsize, &
3783 & lbi, ubi, lbj, ubj, 1, n(ng), &
3784 & scale, fmin, fmax, &
3785# ifdef MASKING
3786 & grid(ng) % rmask, &
3787# endif
3788 & ad_t(:,:,:,iinp,itrc))
3789
3790 IF (founderror(status, nf90_noerr, &
3791 & __line__, myfile)) THEN
3792 IF (master) WRITE (stdout,10) trim(vname(1,ifield)), &
3793 & irec, trim(adm(ng)%name)
3794 exit_flag=2
3795 ioerror=status
3796 RETURN
3797 END IF
3798
3799# if defined PIO_LIB && defined DISTRIBUTE
3800 CASE (io_pio)
3801 IF (kind(ad_t).eq.8) THEN
3802 iodesc => iodesc_dp_r3dvar(ng)
3803 ELSE
3804 iodesc => iodesc_sp_r3dvar(ng)
3805 END IF
3806 status=nf_fread3d(ng, iadm, adm(ng)%name, &
3807 & adm(ng)%pioFile, vname(1,ifield), &
3808 & adm(ng)%pioTrc(itrc), irec, &
3809 & iodesc, vsize, &
3810 & lbi, ubi, lbj, ubj, 1, n(ng), &
3811 & scale, fmin, fmax, &
3812# ifdef MASKING
3813 & grid(ng) % rmask, &
3814# endif
3815 & ad_t(:,:,:,iinp,itrc))
3816# endif
3817
3818 IF (founderror(status, pio_noerr, &
3819 & __line__, myfile)) THEN
3820 IF (master) WRITE (stdout,10) trim(vname(1,ifield)), &
3821 & irec, trim(adm(ng)%name)
3822 exit_flag=2
3823 ioerror=status
3824 RETURN
3825 END IF
3826 END SELECT
3827!
3828! Load adjoint of tracers variables.
3829!
3830# ifndef MASKING
3831# ifdef FULL_GRID
3832 imax=lm(ng)+2
3833 jmax=mm(ng)+2
3834 ioff=1
3835 joff=0
3836# else
3837 imax=lm(ng)
3838 jmax=mm(ng)
3839 ioff=0
3840 joff=1
3841# endif
3842# endif
3843# if defined ENERGYNORM_SCALE
3844 IF (itrc.eq.itemp) THEN
3845 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
3846 ELSE IF (itrc.eq.isalt) THEN
3847 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
3848 ELSE
3849 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
3850 END IF
3851# endif
3852 DO k=1,n(ng)
3853# ifdef MASKING
3854 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
3855# else
3856 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
3857# endif
3858 DO j=jr_range
3859 DO i=ir_range
3860# ifdef MASKING
3861 IF (rmask(i,j).gt.0.0_r8) THEN
3862# if defined ENERGYNORM_SCALE
3863 scalev=afac/sqrt(cff*hz(i,j,k))
3864# else
3865 scalev=afac
3866# endif
3867 is=ijwaterr(i,j)+iadd
3868 ad_state(is)=storage(ng)%ad_Work(is)+ &
3869 & scalev*ad_t(i,j,k,iinp,itrc)
3870 storage(ng)%ad_Work(is)=ad_state(is)
3871 END IF
3872# else
3873# if defined ENERGYNORM_SCALE
3874 scalev=afac/sqrt(cff*hz(i,j,k))
3875# else
3876 scalev=afac
3877# endif
3878 is=(i+ioff)+(j-joff)*imax+iadd
3879 ad_state(is)=storage(ng)%ad_Work(is)+ &
3880 & scalev*ad_t(i,j,k,iinp,itrc)
3881 storage(ng)%ad_Work(is)=ad_state(is)
3882# endif
3883 END DO
3884 END DO
3885 END DO
3886 END IF
3887 END DO
3888# endif
3889!
3890! Process 2D U-momentum stress.
3891!
3892 IF (scalars(ng)%Fstate(isustr)) THEN
3893 SELECT CASE (adm(ng)%IOtype)
3894 CASE (io_nf90)
3895 gtype=u2dvar
3896 status=nf_fread2d(ng, iadm, adm(ng)%name, &
3897 & adm(ng)%ncid, vname(1,idusms), &
3898 & adm(ng)%Vid(idusms), irec, &
3899 & gtype, vsize, &
3900 & lbi, ubi, lbj, ubj, &
3901 & scale, fmin, fmax, &
3902# ifdef MASKING
3903 & grid(ng) % umask, &
3904# endif
3905 & ad_sustr(:,:))
3906
3907 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
3908 IF (master) WRITE (stdout,10) trim(vname(1,idusms)), &
3909 & irec, trim(adm(ng)%name)
3910 exit_flag=2
3911 ioerror=status
3912 RETURN
3913 END IF
3914
3915# if defined PIO_LIB && defined DISTRIBUTE
3916 CASE (io_pio)
3917 IF (kind(ad_sustr).eq.8) THEN
3918 iodesc => iodesc_dp_u2dvar(ng)
3919 ELSE
3920 iodesc => iodesc_sp_u2dvar(ng)
3921 END IF
3922 status=nf_fread2d(ng, iadm, adm(ng)%name, &
3923 & adm(ng)%pioFile, vname(1,idusms), &
3924 & adm(ng)%pioVar(idusms), irec, &
3925 & iodesc, vsize, &
3926 & lbi, ubi, lbj, ubj, &
3927 & scale, fmin, fmax, &
3928# ifdef MASKING
3929 & grid(ng) % umask, &
3930# endif
3931 & ad_sustr(:,:))
3932# endif
3933
3934 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
3935 IF (master) WRITE (stdout,10) trim(vname(1,idusms)), &
3936 & irec, trim(adm(ng)%name)
3937 exit_flag=2
3938 ioerror=status
3939 RETURN
3940 END IF
3941 END SELECT
3942!
3943! Load adjoint of surface U-stress.
3944!
3945# ifndef MASKING
3946# ifdef FULL_GRID
3947 imax=lm(ng)+1
3948 ioff=0
3949 joff=0
3950# else
3951 imax=lm(ng)-uoff
3952 ioff=uoff
3953 joff=1
3954# endif
3955# endif
3956 DO j=jr_range
3957 DO i=iu_range
3958# ifdef MASKING
3959 IF (umask(i,j).gt.0.0_r8) THEN
3960 is=ijwateru(i,j)+offset(isustr)
3961 ad_state(is)=storage(ng)%ad_Work(is)+ &
3962 & afac*ad_sustr(i,j)
3963 storage(ng)%ad_Work(is)=ad_state(is)
3964 END IF
3965# else
3966 is=(i-ioff)+(j-joff)*imax+offset(isustr)
3967 ad_state(is)=storage(ng)%ad_Work(is)+ &
3968 & afac*ad_sustr(i,j)
3969 storage(ng)%ad_Work(is)=ad_state(is)
3970# endif
3971 END DO
3972 END DO
3973 END IF
3974!
3975! Process 2D V-momentum stress.
3976!
3977 IF (scalars(ng)%Fstate(isvstr)) THEN
3978 SELECT CASE (adm(ng)%IOtype)
3979 CASE (io_nf90)
3980 gtype=v2dvar
3981 status=nf_fread2d(ng, iadm, adm(ng)%name, &
3982 & adm(ng)%ncid, vname(1,idvsms), &
3983 & adm(ng)%Vid(idvsms), irec, &
3984 & gtype, vsize, &
3985 & lbi, ubi, lbj, ubj, &
3986 & scale, fmin, fmax, &
3987# ifdef MASKING
3988 & grid(ng) % vmask, &
3989# endif
3990 & ad_svstr(:,:))
3991
3992 IF (founderror(status, nf90_noerr, __line__, myfile)) THEN
3993 IF (master) WRITE (stdout,10) trim(vname(1,idvsms)), &
3994 & irec, trim(adm(ng)%name)
3995 exit_flag=2
3996 ioerror=status
3997 RETURN
3998 END IF
3999
4000# if defined PIO_LIB && defined DISTRIBUTE
4001 CASE (io_pio)
4002 IF (kind(ad_svstr).eq.8) THEN
4003 iodesc => iodesc_dp_v2dvar(ng)
4004 ELSE
4005 iodesc => iodesc_sp_v2dvar(ng)
4006 END IF
4007 status=nf_fread2d(ng, iadm, adm(ng)%name, &
4008 & adm(ng)%pioFile, vname(1,idvsms), &
4009 & adm(ng)%pioVar(idvsms), irec, &
4010 & iodesc, vsize, &
4011 & lbi, ubi, lbj, ubj, &
4012 & scale, fmin, fmax, &
4013# ifdef MASKING
4014 & grid(ng) % vmask, &
4015# endif
4016 & ad_svstr(:,:))
4017# endif
4018
4019 IF (founderror(status, pio_noerr, __line__, myfile)) THEN
4020 IF (master) WRITE (stdout,10) trim(vname(1,idvsms)), &
4021 & irec, trim(adm(ng)%name)
4022 exit_flag=2
4023 ioerror=status
4024 RETURN
4025 END IF
4026 END SELECT
4027!
4028! Load adjoint of surface V-stress.
4029!
4030# ifndef MASKING
4031# ifdef FULL_GRID
4032 imax=lm(ng)+2
4033 ioff=1
4034 joff=1
4035# else
4036 imax=lm(ng)
4037 ioff=0
4038 joff=1+voff
4039# endif
4040# endif
4041 DO j=jv_range
4042 DO i=ir_range
4043# ifdef MASKING
4044 IF (vmask(i,j).gt.0.0_r8) THEN
4045 is=ijwaterv(i,j)+offset(isvstr)
4046 ad_state(is)=storage(ng)%ad_Work(is)+ &
4047 & afac*ad_svstr(i,j)
4048 storage(ng)%ad_Work(is)=ad_state(is)
4049 END IF
4050# else
4051 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
4052 ad_state(is)=storage(ng)%ad_Work(is)+ &
4053 & afac*ad_svstr(i,j)
4054 storage(ng)%ad_Work(is)=ad_state(is)
4055# endif
4056 END DO
4057 END DO
4058 END IF
4059
4060# ifdef SOLVE3D
4061!
4062! Process surface tracer flux.
4063!
4064 DO itrc=1,nt(ng)
4065 ifield=idtsur(itrc)
4066 IF (scalars(ng)%Fstate(ifield)) THEN
4067 SELECT CASE (adm(ng)%IOtype)
4068 CASE (io_nf90)
4069 gtype=r2dvar
4070 status=nf_fread2d(ng, iadm, adm(ng)%name, &
4071 & adm(ng)%ncid, vname(1,ifield), &
4072 & adm(ng)%Vid(ifield), irec, &
4073 & gtype, vsize, &
4074 & lbi, ubi, lbj, ubj, &
4075 & scale, fmin, fmax, &
4076# ifdef MASKING
4077 & grid(ng) % rmask, &
4078# endif
4079 & ad_stflx(:,:,itrc))
4080
4081 IF (founderror(status, nf90_noerr, &
4082 & __line__, myfile)) THEN
4083 IF (master) WRITE (stdout,10) trim(vname(1,ifield)), &
4084 & irec, trim(adm(ng)%name)
4085 exit_flag=2
4086 ioerror=status
4087 RETURN
4088 END IF
4089
4090# if defined PIO_LIB && defined DISTRIBUTE
4091 CASE (io_pio)
4092 IF (kind(ad_stflx).eq.8) THEN
4093 iodesc => iodesc_dp_r2dvar(ng)
4094 ELSE
4095 iodesc => iodesc_sp_r2dvar(ng)
4096 END IF
4097 status=nf_fread2d(ng, iadm, adm(ng)%name, &
4098 & adm(ng)%pioFile, vname(1,ifield), &
4099 & adm(ng)%pioVar(ifield), irec, &
4100 & iodesc, vsize, &
4101 & lbi, ubi, lbj, ubj, &
4102 & scale, fmin, fmax, &
4103# ifdef MASKING
4104 & grid(ng) % rmask, &
4105# endif
4106 & ad_stflx(:,:,itrc))
4107# endif
4108
4109 IF (founderror(status, pio_noerr, &
4110 & __line__, myfile)) THEN
4111 IF (master) WRITE (stdout,10) trim(vname(1,ifield)), &
4112 & irec, trim(adm(ng)%name)
4113 exit_flag=2
4114 ioerror=status
4115 RETURN
4116 END IF
4117 END SELECT
4118!
4119! Load surface tracer flux.
4120!
4121# ifndef MASKING
4122# ifdef FULL_GRID
4123 imax=lm(ng)+2
4124 jmax=mm(ng)+2
4125 ioff=1
4126 joff=0
4127# else
4128 imax=lm(ng)
4129 jmax=mm(ng)
4130 ioff=0
4131 joff=1
4132# endif
4133# endif
4134 DO j=jr_range
4135 DO i=ir_range
4136# ifdef MASKING
4137 IF (rmask(i,j).gt.0.0_r8) THEN
4138 is=ijwaterr(i,j)+offset(istsur(itrc))
4139 ad_state(is)=storage(ng)%ad_Work(is)+ &
4140 & afac*ad_stflx(i,j,itrc)
4141 storage(ng)%ad_Work(is)=ad_state(is)
4142 END IF
4143# else
4144 is=(i+ioff)+(j-joff)*imax+offset(istsur(itrc))
4145 ad_state(is)=storage(ng)%ad_Work(is)+ &
4146 & afac*ad_stflx(i,j,itrc)
4147 storage(ng)%ad_Work(is)=ad_state(is)
4148# endif
4149 END DO
4150 END DO
4151 END IF
4152 END DO
4153# endif
4154 END DO adrec_loop
4155!
4156 10 FORMAT (/,' AD_SO_PACK_RED - error while reading variable: ',a,2x,&
4157 & 'at time record = ',i3,/,17x,'in input NetCDF file: ',a)
4158!
4159 RETURN
4160 END SUBROUTINE ad_so_pack_red_tile
4161
4162# endif
4163
4164# elif defined ADJOINT
4165!
4166 SUBROUTINE ad_pack (ng, tile, Mstr, Mend, ad_state)
4167!
4168!=======================================================================
4169! !
4170! This routine packs the adjoint variables into the state vector. !
4171! The state vector contains only interior water points. !
4172! !
4173!=======================================================================
4174!
4175 USE mod_param
4176 USE mod_grid
4177 USE mod_ocean
4178 USE mod_stepping
4179# ifdef DISTRIBUTE
4180 USE mod_storage
4181# endif
4182# ifdef DISTRIBUTE
4183!
4184 USE distribute_mod, ONLY : mp_scatter_state
4185# endif
4186!
4187! Imported variable declarations.
4188!
4189 integer, intent(in) :: ng, tile
4190 integer, intent(in) :: Mstr, Mend
4191# ifdef ASSUMED_SHAPE
4192 real(r8), intent(out) :: ad_state(Mstr:)
4193# else
4194 real(r8), intent(out) :: ad_state(Mstr:Mend)
4195# endif
4196!
4197! Local variable declarations.
4198!
4199 character (len=*), parameter :: MyFile = &
4200 & __FILE__//", ad_pack"
4201!
4202# include "tile.h"
4203!
4204# ifdef PROFILE
4205 CALL wclock_on (ng, iadm, 2, __line__, myfile)
4206# endif
4207
4208 CALL ad_pack_tile (ng, tile, &
4209 & lbi, ubi, lbj, ubj, &
4210 & imins, imaxs, jmins, jmaxs, &
4211 & kstp(ng), &
4212# ifdef SOLVE3D
4213 & nstp(ng), &
4214# endif
4215# ifdef DISTRIBUTE
4216 & 1, mstate(ng), swork, &
4217# else
4218 & mstr, mend, ad_state, &
4219# endif
4220# ifdef MASKING
4221 & grid(ng) % IJwaterR, &
4222 & grid(ng) % IJwaterU, &
4223 & grid(ng) % IJwaterV, &
4224 & grid(ng) % rmask, &
4225 & grid(ng) % umask, &
4226 & grid(ng) % vmask, &
4227# endif
4228 & grid(ng) % h, &
4229# ifdef SOLVE3D
4230 & grid(ng) % Hz, &
4231 & ocean(ng) % ad_t, &
4232 & ocean(ng) % ad_u, &
4233 & ocean(ng) % ad_v, &
4234# else
4235 & ocean(ng) % ad_ubar, &
4236 & ocean(ng) % ad_vbar, &
4237# endif
4238 & ocean(ng) % ad_zeta)
4239
4240# ifdef PROFILE
4241 CALL wclock_off (ng, iadm, 2, __line__, myfile)
4242# endif
4243
4244# ifdef DISTRIBUTE
4245!
4246! Scatter (global to threaded) adjoint state solution to all
4247! distributed nodes.
4248!
4249 CALL mp_scatter_state (ng, iadm, mstr, mend, mstate(ng), &
4250 & swork, ad_state)
4251# endif
4252!
4253 RETURN
4254 END SUBROUTINE ad_pack
4255!
4256!***********************************************************************
4257 SUBROUTINE ad_pack_tile (ng, tile, &
4258 & LBi, UBi, LBj, UBj, &
4259 & IminS, ImaxS, JminS, JmaxS, &
4260 & kstp, &
4261# ifdef SOLVE3D
4262 & nstp, &
4263# endif
4264 & Mstr, Mend, ad_state, &
4265# ifdef MASKING
4266 & IJwaterR, IJwaterU, IJwaterV, &
4267 & rmask, umask, vmask, &
4268# endif
4269 & h, &
4270# ifdef SOLVE3D
4271 & Hz, &
4272 & ad_t, ad_u, ad_v, &
4273# else
4274 & ad_ubar, ad_vbar, &
4275# endif
4276 & ad_zeta)
4277!***********************************************************************
4278!
4279 USE mod_param
4280 USE mod_parallel
4281 USE mod_ncparam
4282 USE mod_scalars
4283!
4284! Imported variable declarations.
4285!
4286 integer, intent(in) :: ng, tile
4287 integer, intent(in) :: LBi, UBi, LBj, UBj
4288 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
4289 integer, intent(in) :: Mstr, Mend
4290 integer, intent(in) :: kstp
4291# ifdef SOLVE3D
4292 integer, intent(in) :: nstp
4293# endif
4294!
4295# ifdef ASSUMED_SHAPE
4296# ifdef MASKING
4297 integer, intent(in) :: IJwaterR(LBi:,LBj:)
4298 integer, intent(in) :: IJwaterU(LBi:,LBj:)
4299 integer, intent(in) :: IJwaterV(LBi:,LBj:)
4300
4301 real(r8), intent(in) :: rmask(LBi:,LBj:)
4302 real(r8), intent(in) :: umask(LBi:,LBj:)
4303 real(r8), intent(in) :: vmask(LBi:,LBj:)
4304# endif
4305 real(r8), intent(in) :: h(LBi:,LBj:)
4306# ifdef SOLVE3D
4307 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
4308
4309 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
4310 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
4311 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
4312# else
4313 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
4314 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
4315# endif
4316 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
4317 real(r8), intent(out) :: ad_state(Mstr:)
4318# else
4319# ifdef MASKING
4320 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
4321 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
4322 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
4323
4324 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
4325 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
4326 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
4327# endif
4328 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
4329# ifdef SOLVE3D
4330 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
4331
4332 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
4333 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
4334 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
4335# else
4336 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
4337 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
4338# endif
4339 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
4340 real(r8), intent(out) :: ad_state(Mstr:Mend)
4341# endif
4342!
4343! Local variable declarations.
4344!
4345# ifndef MASKING
4346 integer :: Imax, Ioff, Jmax, Joff
4347# endif
4348 integer :: Uoff, Voff
4349 integer :: i, iadd, is, itrc, j, k
4350
4351 integer, dimension(5+NT(ng)) :: offset
4352
4353 real(r8), parameter :: Aspv = 0.0_r8
4354
4355 real(r8) :: cff, scale
4356
4357# include "set_bounds.h"
4358
4359# ifdef DISTRIBUTE
4360!
4361!-----------------------------------------------------------------------
4362! Initialize adjoint state vector with special value (zero) to
4363! facilitate gathering/scattering communications between all nodes.
4364! This is achieved by summing all the buffers.
4365!-----------------------------------------------------------------------
4366!
4367 DO is=mstr,mend
4368 ad_state(is)=aspv
4369 END DO
4370# endif
4371!
4372!-----------------------------------------------------------------------
4373! Load adjoint STATE variables into full 1D state vector.
4374!-----------------------------------------------------------------------
4375!
4376! Set offsets for momentum variables due to periodic boundary
4377! conditions. Recall that in East-West periodic boundary conditions
4378! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
4379! applications IstrV=1 or else IstrV=2.
4380!
4381 IF (ewperiodic(ng)) THEN
4382 uoff=0
4383 ELSE
4384 uoff=1
4385 END IF
4386!
4387 IF (nsperiodic(ng)) THEN
4388 voff=0
4389 ELSE
4390 voff=1
4391 END IF
4392!
4393! Determine the index offset for each variable in the state vector.
4394# ifdef MASKING
4395! Notice that in Land/Sea masking application the state vector only
4396! contains water points to avoid large null space.
4397# endif
4398!
4399# ifdef SOLVE3D
4400# ifdef MASKING
4401 offset(isfsur)=0
4402 offset(isuvel)=offset(isfsur)+nwaterr(ng)
4403 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
4404 iadd=nwaterv(ng)*n(ng)
4405 DO itrc=1,nt(ng)
4406 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
4407 iadd=nwaterr(ng)*n(ng)
4408 END DO
4409# else
4410# ifdef FULL_GRID
4411 offset(isfsur)=0
4412 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
4413 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
4414 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
4415 DO itrc=1,nt(ng)
4416 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
4417 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
4418 END DO
4419# else
4420 offset(isfsur)=0
4421 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
4422 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
4423 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
4424 DO itrc=1,nt(ng)
4425 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
4426 iadd=lm(ng)*mm(ng)*n(ng)
4427 END DO
4428# endif
4429# endif
4430# else
4431# ifdef MASKING
4432 offset(isfsur)=0
4433 offset(isubar)=offset(isfsur)+nwaterr(ng)
4434 offset(isvbar)=offset(isubar)+nwateru(ng)
4435# else
4436# ifdef FULL_GRID
4437 offset(isfsur)=0
4438 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
4439 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
4440# else
4441 offset(isfsur)=0
4442 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
4443 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
4444# endif
4445# endif
4446# endif
4447!
4448! Load adjoint free-surface.
4449!
4450# ifndef MASKING
4451# ifdef FULL_GRID
4452 imax=lm(ng)+2
4453 ioff=1
4454 joff=0
4455# else
4456 imax=lm(ng)
4457 ioff=0
4458 joff=1
4459# endif
4460# endif
4461# ifdef ENERGYNORM_SCALE
4462 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
4463# else
4464 scale=1.0_r8
4465# endif
4466 DO j=jr_range
4467 DO i=ir_range
4468# ifdef MASKING
4469 IF (rmask(i,j).gt.0.0_r8) THEN
4470 is=ijwaterr(i,j)+offset(isfsur)
4471 ad_state(is)=scale*ad_zeta(i,j,kstp)
4472 END IF
4473# else
4474 is=(i+ioff)+(j-joff)*imax+offset(isfsur)
4475 ad_state(is)=scale*ad_zeta(i,j,kstp)
4476# endif
4477 END DO
4478 END DO
4479
4480# ifndef SOLVE3D
4481!
4482! Load adjoint 2D U-velocity.
4483!
4484# ifndef MASKING
4485# ifdef FULL_GRID
4486 imax=lm(ng)+1
4487 ioff=0
4488 joff=0
4489# else
4490 imax=lm(ng)-uoff
4491 ioff=uoff
4492 joff=1
4493# endif
4494# endif
4495# ifdef ENERGYNORM_SCALE
4496 cff=0.25_r8*rho0
4497# else
4498 scale=1.0_r8
4499# endif
4500 DO j=jr_range
4501 DO i=iu_range
4502# ifdef ENERGYNORM_SCALE
4503 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
4504# endif
4505# ifdef MASKING
4506 IF (umask(i,j).gt.0.0_r8) THEN
4507 is=ijwateru(i,j)+offset(isubar)
4508 ad_state(is)=scale*ad_ubar(i,j,kstp)
4509 END IF
4510# else
4511 is=(i-ioff)+(j-joff)*imax+offset(isubar)
4512 ad_state(is)=scale*ad_ubar(i,j,kstp)
4513# endif
4514 END DO
4515 END DO
4516!
4517! Load adjoint 2D V-velocity.
4518!
4519# ifndef MASKING
4520# ifdef FULL_GRID
4521 imax=lm(ng)+2
4522 ioff=1
4523 joff=1
4524# else
4525 imax=lm(ng)
4526 ioff=0
4527 joff=1+voff
4528# endif
4529# endif
4530# ifdef ENERGYNORM_SCALE
4531 cff=0.25_r8*rho0
4532# else
4533 scale=1.0_r8
4534# endif
4535 DO j=jv_range
4536 DO i=ir_range
4537# ifdef ENERGYNORM_SCALE
4538 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
4539# endif
4540# ifdef MASKING
4541 IF (vmask(i,j).gt.0.0_r8) THEN
4542 is=ijwaterv(i,j)+offset(isvbar)
4543 ad_state(is)=scale*ad_vbar(i,j,kstp)
4544 END IF
4545# else
4546 is=(i+ioff)+(j-joff)*imax+offset(isvbar)
4547 ad_state(is)=scale*ad_vbar(i,j,kstp)
4548# endif
4549 END DO
4550 END DO
4551# else
4552!
4553! Load adjoint 3D U-velocity.
4554!
4555# ifndef MASKING
4556# ifdef FULL_GRID
4557 imax=lm(ng)+1
4558 jmax=mm(ng)+2
4559 ioff=0
4560 joff=0
4561# else
4562 imax=lm(ng)-uoff
4563 jmax=mm(ng)
4564 ioff=uoff
4565 joff=1
4566# endif
4567# endif
4568# ifdef ENERGYNORM_SCALE
4569 cff=0.25_r8*rho0
4570# else
4571 scale=1.0_r8
4572# endif
4573 DO k=1,n(ng)
4574# ifdef MASKING
4575 iadd=(k-1)*nwateru(ng)+offset(isuvel)
4576# else
4577 iadd=(k-1)*imax*jmax+offset(isuvel)
4578# endif
4579 DO j=jr_range
4580 DO i=iu_range
4581# ifdef MASKING
4582 IF (umask(i,j).gt.0.0_r8) THEN
4583# ifdef ENERGYNORM_SCALE
4584 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
4585# endif
4586 is=ijwateru(i,j)+iadd
4587 ad_state(is)=scale*ad_u(i,j,k,nstp)
4588 END IF
4589# else
4590# ifdef ENERGYNORM_SCALE
4591 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
4592# endif
4593 is=(i-ioff)+(j-joff)*imax+iadd
4594 ad_state(is)=scale*ad_u(i,j,k,nstp)
4595# endif
4596 END DO
4597 END DO
4598 END DO
4599!
4600! Load adjoint 3D V-velocity.
4601!
4602# ifndef MASKING
4603# ifdef FULL_GRID
4604 imax=lm(ng)+2
4605 jmax=mm(ng)+1
4606 ioff=1
4607 joff=1
4608# else
4609 imax=lm(ng)
4610 jmax=mm(ng)-voff
4611 ioff=0
4612 joff=1+voff
4613# endif
4614# endif
4615# ifdef ENERGYNORM_SCALE
4616 cff=0.25_r8*rho0
4617# else
4618 scale=1.0_r8
4619# endif
4620 DO k=1,n(ng)
4621# ifdef MASKING
4622 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
4623# else
4624 iadd=(k-1)*imax*jmax+offset(isvvel)
4625# endif
4626 DO j=jv_range
4627 DO i=ir_range
4628# ifdef MASKING
4629 IF (vmask(i,j).gt.0.0_r8) THEN
4630# ifdef ENERGYNORM_SCALE
4631 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
4632# endif
4633 is=ijwaterv(i,j)+iadd
4634 ad_state(is)=scale*ad_v(i,j,k,nstp)
4635 END IF
4636# else
4637# ifdef ENERGYNORM_SCALE
4638 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
4639# endif
4640 is=(i+ioff)+(j-joff)*imax+iadd
4641 ad_state(is)=scale*ad_v(i,j,k,nstp)
4642# endif
4643 END DO
4644 END DO
4645 END DO
4646!
4647! Load adjoint tracers variables. For now, use salinity scale for
4648! passive tracers.
4649!
4650# ifndef MASKING
4651# ifdef FULL_GRID
4652 imax=lm(ng)+2
4653 jmax=mm(ng)+2
4654 ioff=1
4655 joff=0
4656# else
4657 imax=lm(ng)
4658 jmax=mm(ng)
4659 ioff=0
4660 joff=1
4661# endif
4662# endif
4663 DO itrc=1,nt(ng)
4664# ifdef ENERGYNORM_SCALE
4665 IF (itrc.eq.itemp) THEN
4666 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
4667 ELSE IF (itrc.eq.isalt) THEN
4668 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
4669 ELSE
4670 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
4671 END IF
4672# else
4673 scale=1.0_r8
4674# endif
4675 DO k=1,n(ng)
4676# ifdef MASKING
4677 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
4678# else
4679 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
4680# endif
4681 DO j=jr_range
4682 DO i=ir_range
4683# ifdef MASKING
4684 IF (rmask(i,j).gt.0.0_r8) THEN
4685# ifdef ENERGYNORM_SCALE
4686 scale=1.0_r8/sqrt(cff*hz(i,j,k))
4687# endif
4688 is=ijwaterr(i,j)+iadd
4689 ad_state(is)=scale*ad_t(i,j,k,nstp,itrc)
4690 END IF
4691# else
4692# ifdef ENERGYNORM_SCALE
4693 scale=1.0_r8/sqrt(cff*hz(i,j,k))
4694# endif
4695 is=(i+ioff)+(j-joff)*imax+iadd
4696 ad_state(is)=scale*ad_t(i,j,k,nstp,itrc)
4697# endif
4698 END DO
4699 END DO
4700 END DO
4701 END DO
4702# endif
4703!
4704 RETURN
4705 END SUBROUTINE ad_pack_tile
4706
4707# endif
4708
4709# if defined ADJOINT && (defined SO_SEMI || defined STOCHASTIC_OPT)
4710!
4711 SUBROUTINE ad_unpack (ng, tile, Mstr, Mend, state)
4712!
4713!=======================================================================
4714! !
4715! This routine unpacks the requested adjoint state and/or surface !
4716! forcing variables used in stochastic optimals. The state vector !
4717! contains only interior water points. !
4718! !
4719!=======================================================================
4720!
4721 USE mod_param
4722 USE mod_grid
4723 USE mod_forces
4724 USE mod_stepping
4725# ifdef DISTRIBUTE
4726 USE mod_storage
4727# endif
4728# ifdef DISTRIBUTE
4729!
4730 USE distribute_mod, ONLY : mp_gather_state
4731# endif
4732!
4733! Imported variable declarations.
4734!
4735 integer, intent(in) :: ng, tile
4736 integer, intent(in) :: Mstr, Mend
4737# ifdef ASSUMED_SHAPE
4738 real(r8), intent(in) :: state(Mstr:)
4739# else
4740 real(r8), intent(in) :: state(Mstr:Mend)
4741# endif
4742!
4743! Local variable declarations.
4744!
4745 character (len=*), parameter :: MyFile = &
4746 & __FILE__//", ad_unpak"
4747!
4748# include "tile.h"
4749!
4750# ifdef DISTRIBUTE
4751!
4752! Gather (threaded to global) adjoint state solution from all
4753! distributed nodes.
4754!
4755 CALL mp_gather_state (ng, inlm, mstr, mend, mstate(ng), &
4756 & state, swork)
4757!
4758# endif
4759
4760# ifdef PROFILE
4761 CALL wclock_on (ng, iadm, 2, __line__, myfile)
4762# endif
4763
4764 CALL ad_unpack_tile (ng, tile, &
4765 & lbi, ubi, lbj, ubj, &
4766 & imins, imaxs, jmins, jmaxs, &
4767# ifdef STOCHASTIC_OPT
4768 & knew(ng), &
4769# else
4770 & kstp(ng), &
4771# endif
4772# ifdef SOLVE3D
4773 & nstp(ng), &
4774# endif
4775# ifdef MASKING
4776 & grid(ng) % IJwaterR, &
4777 & grid(ng) % IJwaterU, &
4778 & grid(ng) % IJwaterV, &
4779 & grid(ng) % rmask, &
4780 & grid(ng) % umask, &
4781 & grid(ng) % vmask, &
4782# endif
4783# ifdef ENERGYNORM_SCALE
4784 & grid(ng) % h, &
4785# ifdef SOLVE3D
4786 & grid(ng) % Hz, &
4787# endif
4788# endif
4789# ifdef DISTRIBUTE
4790 & 1, mstate(ng), swork)
4791# else
4792 & mstr, mend, state)
4793# endif
4794
4795# ifdef PROFILE
4796 CALL wclock_off (ng, iadm, 2, __line__, myfile)
4797# endif
4798!
4799 RETURN
4800 END SUBROUTINE ad_unpack
4801!
4802!***********************************************************************
4803 SUBROUTINE ad_unpack_tile (ng, tile, &
4804 & LBi, UBi, LBj, UBj, &
4805 & IminS, ImaxS, JminS, JmaxS, &
4806 & kout, &
4807# ifdef SOLVE3D
4808 & nout, &
4809# endif
4810# ifdef MASKING
4811 & IJwaterR, IJwaterU, IJwaterV, &
4812 & rmask, umask, vmask, &
4813# endif
4814# ifdef ENERGYNORM_SCALE
4815 & h, &
4816# ifdef SOLVE3D
4817 & Hz, &
4818# endif
4819# endif
4820 & Mstr, Mend, state)
4821!***********************************************************************
4822!
4823 USE mod_param
4824 USE mod_parallel
4825 USE mod_forces
4826 USE mod_ncparam
4827 USE mod_ocean
4828 USE mod_scalars
4829!
4830! Imported variable declarations.
4831!
4832 integer, intent(in) :: ng, tile
4833 integer, intent(in) :: LBi, UBi, LBj, UBj
4834 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
4835 integer, intent(in) :: kout
4836# ifdef SOLVE3D
4837 integer, intent(in) :: nout
4838# endif
4839 integer, intent(in) :: Mstr, Mend
4840!
4841# ifdef ASSUMED_SHAPE
4842# ifdef MASKING
4843 integer, intent(in) :: IJwaterR(LBi:,LBj:)
4844 integer, intent(in) :: IJwaterU(LBi:,LBj:)
4845 integer, intent(in) :: IJwaterV(LBi:,LBj:)
4846
4847 real(r8), intent(in) :: rmask(LBi:,LBj:)
4848 real(r8), intent(in) :: umask(LBi:,LBj:)
4849 real(r8), intent(in) :: vmask(LBi:,LBj:)
4850# endif
4851# ifdef ENERGYNORM_SCALE
4852 real(r8), intent(in) :: h(LBi:,LBj:)
4853# ifdef SOLVE3D
4854 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
4855# endif
4856# endif
4857 real(r8), intent(in) :: state(Mstr:)
4858# else
4859# ifdef MASKING
4860 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
4861 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
4862 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
4863
4864 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
4865 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
4866 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
4867# endif
4868# ifdef ENERGYNORM_SCALE
4869 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
4870# ifdef SOLVE3D
4871 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
4872# endif
4873# endif
4874 real(r8), intent(in) :: state(Mstr:Mend)
4875# endif
4876!
4877! Local variable declarations.
4878!
4879# ifndef MASKING
4880 integer :: Imax, Ioff, Jmax, Joff
4881# endif
4882 integer :: Uoff, Voff
4883 integer :: i, iadd, icount, is, itrc, j, k
4884
4885# ifdef SOLVE3D
4886# ifdef SALINITY
4887 integer, dimension(7+2*NT(ng)) :: offset
4888# else
4889 integer, dimension(7+2*(NT(ng)+1)) :: offset
4890# endif
4891# else
4892 integer, dimension(5) :: offset
4893# endif
4894
4895 real(r8) :: cff, scale
4896
4897# include "set_bounds.h"
4898!
4899!-----------------------------------------------------------------------
4900! Extract adjoint FORCING variables from full 1D state vector.
4901!-----------------------------------------------------------------------
4902!
4903! Set offsets for momentum variables due to periodic boundary
4904! conditions. Recall that in East-West periodic boundary conditions
4905! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
4906! applications IstrV=1 or else IstrV=2.
4907!
4908 IF (ewperiodic(ng)) THEN
4909 uoff=0
4910 ELSE
4911 uoff=1
4912 END IF
4913!
4914 IF (nsperiodic(ng)) THEN
4915 voff=0
4916 ELSE
4917 voff=1
4918 END IF
4919!
4920! Determine the index offset for each variable in the state vector.
4921# ifdef MASKING
4922! Notice that in Land/Sea masking application the state vector only
4923! contains water points to avoid large null space.
4924# endif
4925!
4926! First clear the "offset" array.
4927!
4928 offset=0
4929!
4930# ifdef SOLVE3D
4931# ifdef MASKING
4932 IF (scalars(ng)%Fstate(isfsur)) THEN
4933 offset(isfsur)=0
4934 END IF
4935 IF (scalars(ng)%Fstate(isuvel)) THEN
4936 offset(isuvel)=offset(isfsur)+nwaterr(ng)
4937 END IF
4938 IF (scalars(ng)%Fstate(isvvel)) THEN
4939 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
4940 END IF
4941 iadd=nwaterv(ng)*n(ng)
4942 DO itrc=1,nt(ng)
4943 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
4944 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
4945 iadd=nwaterr(ng)*n(ng)
4946 END IF
4947 END DO
4948 IF (scalars(ng)%Fstate(isustr)) THEN
4949 offset(isustr)=0
4950 END IF
4951 IF (scalars(ng)%Fstate(isvstr)) THEN
4952 offset(isvstr)=offset(isustr)+nwateru(ng)
4953 END IF
4954 DO itrc=1,nt(ng)
4955 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
4956 IF (itrc.eq.1) THEN
4957 offset(istsur(itrc))=offset(isvstr)+nwaterv(ng)
4958 ELSE
4959 offset(istsur(itrc))=offset(istsur(itrc-1))+nwaterr(ng)
4960 END IF
4961 END IF
4962 END DO
4963# else
4964# ifdef FULL_GRID
4965 IF (scalars(ng)%Fstate(isfsur)) THEN
4966 offset(isfsur)=0
4967 END IF
4968 IF (scalars(ng)%Fstate(isuvel)) THEN
4969 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
4970 END IF
4971 IF (scalars(ng)%Fstate(isvvel)) THEN
4972 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
4973 END IF
4974 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
4975 DO itrc=1,nt(ng)
4976 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
4977 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
4978 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
4979 END IF
4980 END DO
4981 IF (scalars(ng)%Fstate(isustr)) THEN
4982 offset(isustr)=0
4983 END IF
4984 IF (scalars(ng)%Fstate(isvstr)) THEN
4985 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
4986 END IF
4987 DO itrc=1,nt(ng)
4988 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
4989 IF (itrc.eq.1) THEN
4990 offset(istsur(itrc))=offset(isvstr)+ &
4991 & (lm(ng)+2)*(mm(ng)+1)
4992 ELSE
4993 offset(istsur(itrc))=offset(istsur(itrc-1))+ &
4994 & (lm(ng)+2)*(mm(ng)+2)
4995 END IF
4996 END IF
4997 END DO
4998# else
4999 IF (scalars(ng)%Fstate(isfsur)) THEN
5000 offset(isfsur)=0
5001 END IF
5002 IF (scalars(ng)%Fstate(isuvel)) THEN
5003 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
5004 END IF
5005 IF (scalars(ng)%Fstate(isvvel)) THEN
5006 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
5007 END IF
5008 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
5009 DO itrc=1,nt(ng)
5010 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
5011 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
5012 iadd=lm(ng)*mm(ng)*n(ng)
5013 END IF
5014 END DO
5015 IF (scalars(ng)%Fstate(isustr)) THEN
5016 offset(isustr)=0
5017 END IF
5018 IF (scalars(ng)%Fstate(isvstr)) THEN
5019 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
5020 END IF
5021 DO itrc=1,nt(ng)
5022 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
5023 IF (itrc.eq.1) THEN
5024 offset(istsur(itrc))=offset(isvstr)+lm(ng)*(mm(ng)-voff)
5025 ELSE
5026 offset(istsur(itrc))=offset(istsur(itrc-1))+lm(ng)*mm(ng)
5027 END IF
5028 END IF
5029 END DO
5030# endif
5031# endif
5032# else
5033# ifdef MASKING
5034 IF (scalars(ng)%Fstate(isfsur)) THEN
5035 offset(isfsur)=0
5036 END IF
5037 IF (scalars(ng)%Fstate(isubar)) THEN
5038 offset(isubar)=offset(isfsur)+nwaterr(ng)
5039 END IF
5040 IF (scalars(ng)%Fstate(isvbar)) THEN
5041 offset(isvbar)=offset(isubar)+nwateru(ng)
5042 END IF
5043 IF (scalars(ng)%Fstate(isustr)) THEN
5044 offset(isustr)=0
5045 END IF
5046 IF (scalars(ng)%Fstate(isvstr)) THEN
5047 offset(isvstr)=offset(isustr)+nwateru(ng)
5048 END IF
5049# else
5050# ifdef FULL_GRID
5051 IF (scalars(ng)%Fstate(isfsur)) THEN
5052 offset(isfsur)=0
5053 END IF
5054 IF (scalars(ng)%Fstate(isubar)) THEN
5055 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
5056 END IF
5057 IF (scalars(ng)%Fstate(isvbar) THEN
5058 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
5059 END IF
5060 IF (scalars(ng)%Fstate(isustr)) THEN
5061 offset(isustr)=0
5062 END IF
5063 IF (scalars(ng)%Fstate(isvstr)) THEN
5064 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
5065 END IF
5066# else
5067 IF (scalars(ng)%Fstate(isfsur)) THEN
5068 offset(isfsur)=0
5069 END IF
5070 IF (scalars(ng)%Fstate(isubar)) THEN
5071 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
5072 END IF
5073 IF (scalars(ng)%Fstate(isvbar) THEN
5074 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
5075 END IF
5076 IF (scalars(ng)%Fstate(isustr)) THEN
5077 offset(isustr)=0
5078 END IF
5079 IF (scalars(ng)%Fstate(isustr)) THEN
5080 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
5081 END IF
5082# endif
5083# endif
5084# endif
5085!
5086! Extract adjoint free-surface.
5087!
5088 IF (scalars(ng)%Fstate(isfsur)) THEN
5089# ifndef MASKING
5090# ifdef FULL_GRID
5091 imax=lm(ng)+2
5092 ioff=1
5093 joff=0
5094# else
5095 imax=lm(ng)
5096 ioff=0
5097 joff=1
5098# endif
5099# endif
5100# ifdef ENERGYNORM_SCALE
5101 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
5102# else
5103 scale=1.0_r8
5104# endif
5105 DO j=jr_range
5106 DO i=ir_range
5107# ifdef MASKING
5108 IF (rmask(i,j).gt.0.0_r8) THEN
5109 is=ijwaterr(i,j)+offset(isfsur)
5110 ocean(ng)%ad_zeta(i,j,kout)=scale*state(is)
5111 ELSE
5112 ocean(ng)%ad_zeta(i,j,kout)=0.0_r8
5113 END IF
5114# else
5115 is=(i-ioff)+(j-joff)*imax+offset(isfsur)
5116 ocean(ng)%ad_zeta(i,j,kout)=scale*state(is)
5117# endif
5118 END DO
5119 END DO
5120 END IF
5121
5122# ifndef SOLVE3D
5123!
5124! Extract adjoint 2D U-velocity.
5125!
5126 IF (scalars(ng)%Fstate(isubar)) THEN
5127# ifndef MASKING
5128# ifdef FULL_GRID
5129 imax=lm(ng)+1
5130 ioff=0
5131 joff=0
5132# else
5133 imax=lm(ng)-uoff
5134 ioff=uoff
5135 joff=1
5136# endif
5137# endif
5138# ifdef ENERGYNORM_SCALE
5139 cff=0.25_r8*rho0
5140# else
5141 scale=1.0_r8
5142# endif
5143 DO j=jr_range
5144 DO i=iu_range
5145# ifdef ENERGYNORM_SCALE
5146 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
5147# endif
5148# ifdef MASKING
5149 IF (umask(i,j).gt.0.0_r8) THEN
5150 is=ijwateru(i,j)+offset(isubar)
5151 ocean(ng)%ad_ubar(i,j,kout)=scale*state(is)
5152 ELSE
5153 ocean(ng)%ubar(i,j,kout)=0.0_r8
5154 END IF
5155# else
5156 is=(i-ioff)+(j-joff)*imax+offset(isubar)
5157 ocean(ng)%ad_ubar(i,j,kout)=scale*state(is)
5158# endif
5159 END DO
5160 END DO
5161 END IF
5162!
5163! Extract adjoint 2D V-velocity.
5164!
5165 IF (scalars(ng)%Fstate(isvbar)) THEN
5166# ifndef MASKING
5167# ifdef FULL_GRID
5168 imax=lm(ng)+2
5169 ioff=1
5170 joff=1
5171# else
5172 imax=lm(ng)
5173 ioff=0
5174 joff=1+voff
5175# endif
5176# endif
5177# ifdef ENERGYNORM_SCALE
5178 cff=0.25_r8*rho0
5179# else
5180 scale=1.0_r8
5181# endif
5182 DO j=jv_range
5183 DO i=ir_range
5184# ifdef ENERGYNORM_SCALE
5185 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
5186# endif
5187# ifdef MASKING
5188 IF (vmask(i,j).gt.0.0_r8) THEN
5189 is=ijwaterv(i,j)+offset(isvbar)
5190 ocean(ng)%ad_vbar(i,j,kout)=scale*state(is)
5191 ELSE
5192 ocean(ng)%ad_vbar(i,j,kout)=0.0_r8
5193 END IF
5194# else
5195 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
5196 ocean(ng)%ad_vbar(i,j,kout)=scale*state(is)
5197# endif
5198 END DO
5199 END DO
5200 END IF
5201
5202# else
5203!
5204! Extract adjoint 3D U-velocity.
5205!
5206 IF (scalars(ng)%Fstate(isuvel)) THEN
5207# ifndef MASKING
5208# ifdef FULL_GRID
5209 imax=lm(ng)+1
5210 jmax=mm(ng)+2
5211 ioff=0
5212 joff=0
5213# else
5214 imax=lm(ng)-uoff
5215 jmax=mm(ng)
5216 ioff=uoff
5217 joff=1
5218# endif
5219# endif
5220# ifdef ENERGYNORM_SCALE
5221 cff=0.25_r8*rho0
5222# else
5223 scale=1.0_r8
5224# endif
5225 DO k=1,n(ng)
5226# ifdef MASKING
5227 iadd=(k-1)*nwateru(ng)+offset(isuvel)
5228# else
5229 iadd=(k-1)*imax*jmax+offset(isuvel)
5230# endif
5231 DO j=jr_range
5232 DO i=iu_range
5233# ifdef MASKING
5234 IF (umask(i,j).gt.0.0_r8) THEN
5235# ifdef ENERGYNORM_SCALE
5236 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
5237# endif
5238 is=ijwateru(i,j)+iadd
5239 ocean(ng)%ad_u(i,j,k,nout)=scale*state(is)
5240 ELSE
5241 ocean(ng)%ad_u(i,j,k,nout)=0.0_r8
5242 END IF
5243# else
5244# ifdef ENERGYNORM_SCALE
5245 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
5246# endif
5247 is=(i-ioff)+(j-joff)*imax+iadd
5248 ocean(ng)%ad_u(i,j,k,nout)=scale*state(is)
5249# endif
5250 END DO
5251 END DO
5252 END DO
5253 END IF
5254!
5255! Extract adjoint 3D V-velocity.
5256!
5257 IF (scalars(ng)%Fstate(isvvel)) THEN
5258# ifndef MASKING
5259# ifdef FULL_GRID
5260 imax=lm(ng)+2
5261 jmax=mm(ng)+1
5262 ioff=1
5263 joff=1
5264# else
5265 imax=lm(ng)
5266 jmax=mm(ng)-voff
5267 ioff=0
5268 joff=1+voff
5269# endif
5270# endif
5271# ifdef ENERGYNORM_SCALE
5272 cff=0.25_r8*rho0
5273# else
5274 scale=1.0_r8
5275# endif
5276 DO k=1,n(ng)
5277# ifdef MASKING
5278 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
5279# else
5280 iadd=(k-1)*imax*jmax+offset(isvvel)
5281# endif
5282 DO j=jv_range
5283 DO i=ir_range
5284# ifdef MASKING
5285 IF (vmask(i,j).gt.0.0_r8) THEN
5286# ifdef ENERGYNORM_SCALE
5287 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
5288# endif
5289 is=ijwaterv(i,j)+iadd
5290 ocean(ng)%ad_v(i,j,k,nout)=scale*state(is)
5291 ELSE
5292 ocean(ng)%ad_v(i,j,k,nout)=0.0_r8
5293 END IF
5294# else
5295# ifdef ENERGYNORM_SCALE
5296 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
5297# endif
5298 is=(i+ioff)+(j-joff)*imax+iadd
5299 ocean(ng)%ad_v(i,j,k,nout)=scale*state(is)
5300# endif
5301 END DO
5302 END DO
5303 END DO
5304 END IF
5305!
5306! Extract adjoint tracers variables.
5307!
5308 DO itrc=1,nt(ng)
5309 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
5310# ifndef MASKING
5311# ifdef FULL_GRID
5312 imax=lm(ng)+2
5313 jmax=mm(ng)+2
5314 ioff=1
5315 joff=0
5316# else
5317 imax=lm(ng)
5318 jmax=mm(ng)
5319 ioff=0
5320 joff=1
5321# endif
5322# endif
5323# ifdef ENERGYNORM_SCALE
5324 IF (itrc.eq.itemp) THEN
5325 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
5326 ELSE IF (itrc.eq.isalt) THEN
5327 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
5328 ELSE
5329 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
5330 END IF
5331# else
5332 scale=1.0_r8
5333# endif
5334 DO k=1,n(ng)
5335# ifdef MASKING
5336 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
5337# else
5338 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
5339# endif
5340 DO j=jr_range
5341 DO i=ir_range
5342# ifdef MASKING
5343 IF (rmask(i,j).gt.0.0_r8) THEN
5344# ifdef ENERGYNORM_SCALE
5345 scale=1.0_r8/sqrt(cff*hz(i,j,k))
5346# endif
5347 is=ijwaterr(i,j)+iadd
5348 ocean(ng)%ad_t(i,j,k,nout,itrc)=scale*state(is)
5349 ELSE
5350 ocean(ng)%ad_t(i,j,k,nout,itrc)=0.0_r8
5351 END IF
5352# else
5353# ifdef ENERGYNORM_SCALE
5354 scale=1.0_r8/sqrt(cff*hz(i,j,k))
5355# endif
5356 is=(i+ioff)+(j-joff)*imax+iadd
5357 ocean(ng)%ad_t(i,j,k,nout,itrc)=scale*state(is)
5358# endif
5359 END DO
5360 END DO
5361 END DO
5362 END IF
5363 END DO
5364# endif
5365!
5366! Extract adjoint surface U-momentum stress.
5367!
5368 IF (scalars(ng)%Fstate(isustr)) THEN
5369# ifndef MASKING
5370# ifdef FULL_GRID
5371 imax=lm(ng)+1
5372 ioff=0
5373 joff=0
5374# else
5375 imax=lm(ng)-uoff
5376 ioff=uoff
5377 joff=1
5378# endif
5379# endif
5380 scale=1.0_r8
5381 DO j=jr_range
5382 DO i=iu_range
5383# ifdef MASKING
5384 IF (umask(i,j).gt.0.0_r8) THEN
5385 is=ijwateru(i,j)+offset(isustr)
5386 forces(ng)%ad_sustr(i,j)=scale*state(is)
5387 ELSE
5388 forces(ng)%ad_sustr(i,j)=0.0_r8
5389 END IF
5390# else
5391 is=(i-ioff)+(j-joff)*imax+offset(isustr)
5392 forces(ng)%ad_sustr(i,j)=scale*state(is)
5393# endif
5394 END DO
5395 END DO
5396 END IF
5397!
5398! Extract adjoint surface V-momentum stress.
5399!
5400 IF (scalars(ng)%Fstate(isvstr)) THEN
5401# ifndef MASKING
5402# ifdef FULL_GRID
5403 imax=lm(ng)+2
5404 ioff=1
5405 joff=1
5406# else
5407 imax=lm(ng)
5408 ioff=0
5409 joff=1+voff
5410# endif
5411# endif
5412 scale=1.0_r8
5413 DO j=jv_range
5414 DO i=ir_range
5415# ifdef MASKING
5416 IF (vmask(i,j).gt.0.0_r8) THEN
5417 is=ijwaterv(i,j)+offset(isvstr)
5418 forces(ng)%ad_svstr(i,j)=scale*state(is)
5419 ELSE
5420 forces(ng)%ad_svstr(i,j)=0.0_r8
5421 END IF
5422# else
5423 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
5424 forces(ng)%ad_svstr(i,j)=scale*state(is)
5425# endif
5426 END DO
5427 END DO
5428 END IF
5429
5430# ifdef SOLVE3D
5431!
5432! Extract adjoint surface tracer flux variables.
5433!
5434 DO itrc=1,nt(ng)
5435 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
5436# ifndef MASKING
5437# ifdef FULL_GRID
5438 imax=lm(ng)+2
5439 jmax=mm(ng)+2
5440 ioff=1
5441 joff=0
5442# else
5443 imax=lm(ng)
5444 jmax=mm(ng)
5445 ioff=0
5446 joff=1
5447# endif
5448# endif
5449 scale=1.0_r8
5450 DO j=jr_range
5451 DO i=ir_range
5452# ifdef MASKING
5453 IF (rmask(i,j).gt.0.0_r8) THEN
5454 is=ijwaterr(i,j)+offset(istvar(itrc))
5455 forces(ng)%ad_stflx(i,j,itrc)=scale*state(is)
5456 ELSE
5457 forces(ng)%ad_stflx(i,j,itrc)=0.0_r8
5458 END IF
5459# else
5460 is=(i+ioff)+(j-joff)*imax+offset(istvar(itrc))
5461 forces(ng)%ad_stflx(i,j,itrc)=scale*state(is)
5462# endif
5463 END DO
5464 END DO
5465 END IF
5466 END DO
5467# endif
5468!
5469 RETURN
5470 END SUBROUTINE ad_unpack_tile
5471
5472# elif defined ADJOINT
5473!
5474 SUBROUTINE ad_unpack (ng, tile, Mstr, Mend, state)
5475!
5476!=======================================================================
5477! !
5478! This routine unpacks the adjoint model variables from the state !
5479! vector. If applicable, the state vector includes only unmasked !
5480! water points. !
5481! !
5482!=======================================================================
5483!
5484 USE mod_param
5485 USE mod_grid
5486 USE mod_ocean
5487 USE mod_stepping
5488# ifdef DISTRIBUTE
5489 USE mod_storage
5490# endif
5491# ifdef DISTRIBUTE
5492!
5493 USE distribute_mod, ONLY : mp_gather_state
5494# endif
5495!
5496! Imported variable declarations.
5497!
5498 integer, intent(in) :: ng, tile
5499 integer, intent(in) :: Mstr, Mend
5500# ifdef ASSUMED_SHAPE
5501 real(r8), intent(in) :: state(Mstr:)
5502# else
5503 real(r8), intent(in) :: state(Mstr:Mend)
5504# endif
5505!
5506! Local variable declarations.
5507!
5508 character (len=*), parameter :: MyFile = &
5509 & __FILE__//", ad_unpack"
5510!
5511# include "tile.h"
5512!
5513# ifdef PROFILE
5514 CALL wclock_on (ng, iadm, 2, __line__, myfile)
5515# endif
5516
5517# ifdef DISTRIBUTE
5518!
5519! Gather (threaded to global) adjoint state solution from all
5520! distributed nodes.
5521!
5522 CALL mp_gather_state (ng, itlm, mstr, mend, mstate(ng), &
5523 & state, swork)
5524!
5525# endif
5526 CALL ad_unpack_tile (ng, tile, &
5527 & lbi, ubi, lbj, ubj, &
5528 & imins, imaxs, jmins, jmaxs, &
5529 & knew(ng), &
5530# ifdef SOLVE3D
5531 & nstp(ng), &
5532# endif
5533# ifdef DISTRIBUTE
5534 & 1, mstate(ng), swork, &
5535# else
5536 & mstr, mend, state, &
5537# endif
5538# ifdef MASKING
5539 & grid(ng) % IJwaterR, &
5540 & grid(ng) % IJwaterU, &
5541 & grid(ng) % IJwaterV, &
5542 & grid(ng) % rmask, &
5543 & grid(ng) % umask, &
5544 & grid(ng) % vmask, &
5545# endif
5546 & grid(ng) % h, &
5547# ifdef SOLVE3D
5548 & grid(ng) % Hz, &
5549 & ocean(ng) % ad_t, &
5550 & ocean(ng) % ad_u, &
5551 & ocean(ng) % ad_v, &
5552# else
5553 & ocean(ng) % ad_ubar, &
5554 & ocean(ng) % ad_vbar, &
5555# endif
5556 & ocean(ng) % ad_zeta)
5557# ifdef PROFILE
5558 CALL wclock_off (ng, iadm, 2, __line__, myfile)
5559# endif
5560!
5561 RETURN
5562 END SUBROUTINE ad_unpack
5563!
5564!***********************************************************************
5565 SUBROUTINE ad_unpack_tile (ng, tile, &
5566 & LBi, UBi, LBj, UBj, &
5567 & IminS, ImaxS, JminS, JmaxS, &
5568 & knew, &
5569# ifdef SOLVE3D
5570 & nstp, &
5571# endif
5572 & Mstr, Mend, state, &
5573# ifdef MASKING
5574 & IJwaterR, IJwaterU, IJwaterV, &
5575 & rmask, umask, vmask, &
5576# endif
5577 & h, &
5578# ifdef SOLVE3D
5579 & Hz, &
5580 & ad_t, ad_u, ad_v, &
5581# else
5582 & ad_ubar, ad_vbar, &
5583# endif
5584 & ad_zeta)
5585!***********************************************************************
5586!
5587 USE mod_param
5588 USE mod_parallel
5589 USE mod_ncparam
5590 USE mod_scalars
5591!
5592! Imported variable declarations.
5593!
5594 integer, intent(in) :: ng, tile
5595 integer, intent(in) :: LBi, UBi, LBj, UBj
5596 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
5597 integer, intent(in) :: Mstr, Mend
5598 integer, intent(in) :: knew
5599# ifdef SOLVE3D
5600 integer, intent(in) :: nstp
5601# endif
5602!
5603# ifdef ASSUMED_SHAPE
5604# ifdef MASKING
5605 integer, intent(in) :: IJwaterR(LBi:,LBj:)
5606 integer, intent(in) :: IJwaterU(LBi:,LBj:)
5607 integer, intent(in) :: IJwaterV(LBi:,LBj:)
5608
5609 real(r8), intent(in) :: rmask(LBi:,LBj:)
5610 real(r8), intent(in) :: umask(LBi:,LBj:)
5611 real(r8), intent(in) :: vmask(LBi:,LBj:)
5612# endif
5613 real(r8), intent(in) :: state(Mstr:)
5614 real(r8), intent(in) :: h(LBi:,LBj:)
5615# ifdef SOLVE3D
5616 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
5617
5618 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
5619 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
5620 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
5621# else
5622 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
5623 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
5624# endif
5625 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
5626# else
5627# ifdef MASKING
5628 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
5629 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
5630 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
5631
5632 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
5633 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
5634 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
5635# endif
5636 real(r8), intent(in) :: state(Mstr:Mend)
5637 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
5638# ifdef SOLVE3D
5639 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
5640
5641 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
5642 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
5643 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
5644# else
5645 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
5646 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
5647# endif
5648 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
5649# endif
5650!
5651! Local variable declarations.
5652!
5653# ifndef MASKING
5654 integer :: Imax, Ioff, Jmax, Joff
5655# endif
5656 integer :: Uoff, Voff
5657 integer :: i, iadd, is, itrc, j, k
5658
5659 integer, dimension(5+NT(ng)) :: offset
5660
5661 real(r8) :: cff, scale
5662
5663# include "set_bounds.h"
5664!
5665!-----------------------------------------------------------------------
5666! Extract adjoint state variables from full 1D state vector.
5667!-----------------------------------------------------------------------
5668!
5669! Set offsets for momentum variables due to periodic boundary
5670! conditions. Recall that in East-West periodic boundary conditions
5671! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
5672! applications IstrV=1 or else IstrV=2.
5673!
5674 IF (ewperiodic(ng)) THEN
5675 uoff=0
5676 ELSE
5677 uoff=1
5678 END IF
5679!
5680 IF (nsperiodic(ng)) THEN
5681 voff=0
5682 ELSE
5683 voff=1
5684 END IF
5685!
5686! Determine the index offset for each variable in the state vector.
5687# ifdef MASKING
5688! Notice that in Land/Sea masking application the state vector only
5689! contains water points to avoid large null space.
5690# endif
5691!
5692# ifdef SOLVE3D
5693# ifdef MASKING
5694 offset(isfsur)=0
5695 offset(isuvel)=offset(isfsur)+nwaterr(ng)
5696 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
5697 iadd=nwaterv(ng)*n(ng)
5698 DO itrc=1,nt(ng)
5699 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
5700 iadd=nwaterr(ng)*n(ng)
5701 END DO
5702# else
5703# ifdef FULL_GRID
5704 offset(isfsur)=0
5705 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
5706 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
5707 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
5708 DO itrc=1,nt(ng)
5709 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
5710 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
5711 END DO
5712# else
5713 offset(isfsur)=0
5714 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
5715 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
5716 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
5717 DO itrc=1,nt(ng)
5718 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
5719 iadd=lm(ng)*mm(ng)*n(ng)
5720 END DO
5721# endif
5722# endif
5723# else
5724# ifdef MASKING
5725 offset(isfsur)=0
5726 offset(isubar)=offset(isfsur)+nwaterr(ng)
5727 offset(isvbar)=offset(isubar)+nwateru(ng)
5728# else
5729# ifdef FULL_GRID
5730 offset(isfsur)=0
5731 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
5732 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
5733# else
5734 offset(isfsur)=0
5735 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
5736 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
5737# endif
5738# endif
5739# endif
5740!
5741! Extract adjoint free-surface.
5742!
5743# ifndef MASKING
5744# ifdef FULL_GRID
5745 imax=lm(ng)+2
5746 ioff=1
5747 joff=0
5748# else
5749 imax=lm(ng)
5750 ioff=0
5751 joff=1
5752# endif
5753# endif
5754# if defined ENERGYNORM_SCALE
5755 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
5756# else
5757 scale=1.0_r8
5758# endif
5759 DO j=jr_range
5760 DO i=ir_range
5761# ifdef MASKING
5762 IF (rmask(i,j).gt.0.0_r8) THEN
5763 is=ijwaterr(i,j)+offset(isfsur)
5764 ad_zeta(i,j,knew)=scale*state(is)
5765 ELSE
5766 ad_zeta(i,j,knew)=0.0_r8
5767 END IF
5768# else
5769 is=(i+ioff)+(j-joff)*imax+offset(isfsur)
5770 ad_zeta(i,j,knew)=scale*state(is)
5771# endif
5772 END DO
5773 END DO
5774# ifndef SOLVE3D
5775!
5776! Extract adjoint 2D U-velocity.
5777!
5778# ifndef MASKING
5779# ifdef FULL_GRID
5780 imax=lm(ng)+1
5781 ioff=0
5782 joff=0
5783# else
5784 imax=lm(ng)-uoff
5785 ioff=uoff
5786 joff=1
5787# endif
5788# endif
5789# if defined ENERGYNORM_SCALE
5790 cff=0.25_r8*rho0
5791# else
5792 scale=1.0_r8
5793# endif
5794 DO j=jr_range
5795 DO i=iu_range
5796# if define ENERGYNORM_SCALE
5797 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
5798# endif
5799# ifdef MASKING
5800 IF (umask(i,j).gt.0.0_r8) THEN
5801 is=ijwateru(i,j)+offset(isubar)
5802 ad_ubar(i,j,knew)=scale*state(is)
5803 ELSE
5804 ad_ubar(i,j,knew)=0.0_r8
5805 END IF
5806# else
5807 is=(i-ioff)+(j-joff)*imax+offset(isubar)
5808 ad_ubar(i,j,knew)=scale*state(is)
5809# endif
5810 END DO
5811 END DO
5812!
5813! Extract adjoint 2D V-velocity.
5814!
5815# ifndef MASKING
5816# ifdef FULL_GRID
5817 imax=lm(ng)+2
5818 ioff=1
5819 joff=1
5820# else
5821 imax=lm(ng)
5822 ioff=0
5823 joff=1+voff
5824# endif
5825# endif
5826# if defined ENERGYNORM_SCALE
5827 cff=0.25_r8*rho0
5828# else
5829 scale=1.0_r8
5830# endif
5831 DO j=jv_range
5832 DO i=ir_range
5833# if defined ENERGYNORM_SCALE
5834 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
5835# endif
5836# ifdef MASKING
5837 IF (vmask(i,j).gt.0.0_r8) THEN
5838 is=ijwaterv(i,j)+offset(isvbar)
5839 ad_vbar(i,j,knew)=scale*state(is)
5840 ELSE
5841 ad_vbar(i,j,knew)=0.0_r8
5842 END IF
5843# else
5844 is=(i+ioff)+(j-joff)*imax+offset(isvbar)
5845 ad_vbar(i,j,knew)=scale*state(is)
5846# endif
5847 END DO
5848 END DO
5849# else
5850!
5851! Extract adjoint 3D U-velocity.
5852!
5853# ifndef MASKING
5854# ifdef FULL_GRID
5855 imax=lm(ng)+1
5856 jmax=mm(ng)+2
5857 ioff=0
5858 joff=0
5859# else
5860 imax=lm(ng)-uoff
5861 jmax=mm(ng)
5862 ioff=uoff
5863 joff=1
5864# endif
5865# endif
5866# if defined ENERGYNORM_SCALE
5867 cff=0.25_r8*rho0
5868# else
5869 scale=1.0_r8
5870# endif
5871 DO k=1,n(ng)
5872# ifdef MASKING
5873 iadd=(k-1)*nwateru(ng)+offset(isuvel)
5874# else
5875 iadd=(k-1)*imax*jmax+offset(isuvel)
5876# endif
5877 DO j=jr_range
5878 DO i=iu_range
5879# ifdef MASKING
5880 IF (umask(i,j).gt.0.0_r8) THEN
5881# if defined ENERGYNORM_SCALE
5882 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
5883# endif
5884 is=ijwateru(i,j)+iadd
5885 ad_u(i,j,k,nstp)=scale*state(is)
5886 ELSE
5887 ad_u(i,j,k,nstp)=0.0_r8
5888 END IF
5889# else
5890# if defined ENERGYNORM_SCALE
5891 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
5892# endif
5893 is=(i-ioff)+(j-joff)*imax+iadd
5894 ad_u(i,j,k,nstp)=scale*state(is)
5895# endif
5896 END DO
5897 END DO
5898 END DO
5899!
5900! Extract adjoint 3D V-velocity.
5901!
5902# ifndef MASKING
5903# ifdef FULL_GRID
5904 imax=lm(ng)+2
5905 jmax=mm(ng)+1
5906 ioff=1
5907 joff=1
5908# else
5909 imax=lm(ng)
5910 jmax=mm(ng)-voff
5911 ioff=0
5912 joff=1+voff
5913# endif
5914# endif
5915# if defined ENERGYNORM_SCALE
5916 cff=0.25_r8*rho0
5917# else
5918 scale=1.0_r8
5919# endif
5920 DO k=1,n(ng)
5921# ifdef MASKING
5922 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
5923# else
5924 iadd=(k-1)*imax*jmax+offset(isvvel)
5925# endif
5926 DO j=jv_range
5927 DO i=ir_range
5928# ifdef MASKING
5929 IF (vmask(i,j).gt.0.0_r8) THEN
5930# if defined ENERGYNORM_SCALE
5931 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
5932# endif
5933 is=ijwaterv(i,j)+iadd
5934 ad_v(i,j,k,nstp)=scale*state(is)
5935 ELSE
5936 ad_v(i,j,k,nstp)=0.0_r8
5937 END IF
5938# else
5939# if defined ENERGYNORM_SCALE
5940 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
5941# endif
5942 is=(i+ioff)+(j-joff)*imax+iadd
5943 ad_v(i,j,k,nstp)=scale*state(is)
5944# endif
5945 END DO
5946 END DO
5947 END DO
5948!
5949! Extract tangent linear tracers variables. For now, use salinity scale
5950! for passive tracers.
5951!
5952# ifndef MASKING
5953# ifdef FULL_GRID
5954 imax=lm(ng)+2
5955 jmax=mm(ng)+2
5956 ioff=1
5957 joff=0
5958# else
5959 imax=lm(ng)
5960 jmax=mm(ng)
5961 ioff=0
5962 joff=1
5963# endif
5964# endif
5965 DO itrc=1,nt(ng)
5966# if defined ENERGYNORM_SCALE
5967 IF (itrc.eq.itemp) THEN
5968 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
5969 ELSE IF (itrc.eq.isalt) THEN
5970 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
5971 ELSE
5972 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
5973 END IF
5974# else
5975 scale=1.0_r8
5976# endif
5977 DO k=1,n(ng)
5978# ifdef MASKING
5979 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
5980# else
5981 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
5982# endif
5983 DO j=jr_range
5984 DO i=ir_range
5985# ifdef MASKING
5986 IF (rmask(i,j).gt.0.0_r8) THEN
5987# if defined ENERGYNORM_SCALE
5988 scale=1.0_r8/sqrt(cff*hz(i,j,k))
5989# endif
5990 is=ijwaterr(i,j)+iadd
5991 ad_t(i,j,k,nstp,itrc)=scale*state(is)
5992 ELSE
5993 ad_t(i,j,k,nstp,itrc)=0.0_r8
5994 END IF
5995# else
5996# if defined ENERGYNORM_SCALE
5997 scale=1.0_r8/sqrt(cff*hz(i,j,k))
5998# endif
5999 is=(i+ioff)+(j-joff)*imax+iadd
6000 ad_t(i,j,k,nstp,itrc)=scale*state(is)
6001# endif
6002 END DO
6003 END DO
6004 END DO
6005 END DO
6006# endif
6007!
6008 RETURN
6009 END SUBROUTINE ad_unpack_tile
6010# endif
6011
6012# ifdef TANGENT
6013!
6014 SUBROUTINE tl_pack (ng, tile, Mstr, Mend, tl_state)
6015!
6016!=======================================================================
6017! !
6018! This routine packs the tangent linear variables into the state !
6019! vetor. The state vector contains only interior water points. !
6020! !
6021!=======================================================================
6022!
6023 USE mod_param
6024 USE mod_grid
6025 USE mod_ocean
6026 USE mod_stepping
6027# ifdef DISTRIBUTE
6028 USE mod_storage
6029# endif
6030# ifdef DISTRIBUTE
6031!
6032 USE distribute_mod, ONLY : mp_scatter_state
6033# endif
6034!
6035! Imported variable declarations.
6036!
6037 integer, intent(in) :: ng, tile
6038 integer, intent(in) :: Mstr, Mend
6039# ifdef ASSUMED_SHAPE
6040 real(r8), intent(out) :: tl_state(Mstr:)
6041# else
6042 real(r8), intent(out) :: tl_state(Mstr:Mend)
6043# endif
6044!
6045! Local variable declarations.
6046!
6047 character (len=*), parameter :: MyFile = &
6048 & __FILE__//", tl_pack"
6049
6050# include "tile.h"
6051!
6052# ifdef PROFILE
6053 CALL wclock_on (ng, itlm, 2, __line__, myfile)
6054# endif
6055 CALL tl_pack_tile (ng, tile, &
6056 & lbi, ubi, lbj, ubj, &
6057 & imins, imaxs, jmins, jmaxs, &
6058 & krhs(ng), kstp(ng), knew(ng), &
6059# ifdef SOLVE3D
6060 & nstp(ng), &
6061# endif
6062# ifdef DISTRIBUTE
6063 & 1, mstate(ng), swork, &
6064# else
6065 & mstr, mend, tl_state, &
6066# endif
6067# ifdef MASKING
6068 & grid(ng) % IJwaterR, &
6069 & grid(ng) % IJwaterU, &
6070 & grid(ng) % IJwaterV, &
6071 & grid(ng) % rmask, &
6072 & grid(ng) % umask, &
6073 & grid(ng) % vmask, &
6074# endif
6075 & grid(ng) % h, &
6076# ifdef SOLVE3D
6077 & grid(ng) % Hz, &
6078 & ocean(ng) % tl_t, &
6079 & ocean(ng) % tl_u, &
6080 & ocean(ng) % tl_v, &
6081# else
6082 & ocean(ng) % tl_ubar, &
6083 & ocean(ng) % tl_vbar, &
6084# endif
6085 & ocean(ng) % tl_zeta)
6086
6087# ifdef DISTRIBUTE
6088!
6089! Scatter (global to threaded) tangent linear state solution to all
6090! distributed nodes.
6091!
6092 CALL mp_scatter_state (ng, itlm, mstr, mend, mstate(ng), &
6093 & swork, tl_state)
6094# endif
6095
6096# ifdef PROFILE
6097 CALL wclock_off (ng, itlm, 2, __line__, myfile)
6098# endif
6099!
6100 RETURN
6101 END SUBROUTINE tl_pack
6102!
6103!***********************************************************************
6104 SUBROUTINE tl_pack_tile (ng, tile, &
6105 & LBi, UBi, LBj, UBj, &
6106 & IminS, ImaxS, JminS, JmaxS, &
6107 & krhs, kstp, knew, &
6108# ifdef SOLVE3D
6109 & nstp, &
6110# endif
6111 & Mstr, Mend, tl_state, &
6112# ifdef MASKING
6113 & IJwaterR, IJwaterU, IJwaterV, &
6114 & rmask, umask, vmask, &
6115# endif
6116 & h, &
6117# ifdef SOLVE3D
6118 & Hz, &
6119 & tl_t, tl_u, tl_v, &
6120# else
6121 & tl_ubar, tl_vbar, &
6122# endif
6123 & tl_zeta)
6124!***********************************************************************
6125!
6126 USE mod_param
6127 USE mod_parallel
6128 USE mod_ncparam
6129 USE mod_scalars
6130!
6131! Imported variable declarations.
6132!
6133 integer, intent(in) :: ng, tile
6134 integer, intent(in) :: LBi, UBi, LBj, UBj
6135 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
6136 integer, intent(in) :: Mstr, Mend
6137 integer, intent(in) :: krhs, kstp, knew
6138# ifdef SOLVE3D
6139 integer, intent(in) :: nstp
6140# endif
6141!
6142# ifdef ASSUMED_SHAPE
6143# ifdef MASKING
6144 integer, intent(in) :: IJwaterR(LBi:,LBj:)
6145 integer, intent(in) :: IJwaterU(LBi:,LBj:)
6146 integer, intent(in) :: IJwaterV(LBi:,LBj:)
6147
6148 real(r8), intent(in) :: rmask(LBi:,LBj:)
6149 real(r8), intent(in) :: umask(LBi:,LBj:)
6150 real(r8), intent(in) :: vmask(LBi:,LBj:)
6151# endif
6152 real(r8), intent(in) :: h(LBi:,LBj:)
6153# ifdef SOLVE3D
6154 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
6155
6156 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
6157 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
6158 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
6159# else
6160 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
6161 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
6162# endif
6163 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
6164
6165 real(r8), intent(out) :: tl_state(Mstr:)
6166# else
6167# ifdef MASKING
6168 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
6169 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
6170 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
6171
6172 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
6173 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
6174 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
6175# endif
6176 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
6177# ifdef SOLVE3D
6178 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
6179
6180 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
6181 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
6182 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
6183# else
6184 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
6185 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
6186# endif
6187 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
6188
6189 real(r8), intent(out) :: tl_state(Mstr:Mend)
6190# endif
6191!
6192! Local variable declarations.
6193!
6194# ifndef MASKING
6195 integer :: Imax, Ioff, Jmax, Joff
6196# endif
6197 integer :: Uoff, Voff
6198 integer :: i, iadd, is, itrc, j, k
6199
6200 integer, dimension(5+NT(ng)) :: offset
6201
6202 real(r8), parameter :: Aspv = 0.0_r8
6203
6204 real(r8) :: cff, scale
6205
6206# include "set_bounds.h"
6207
6208# ifdef DISTRIBUTE
6209!
6210!-----------------------------------------------------------------------
6211! Initialize tangent linear state vector with special value (zero) to
6212! facilitate gathering/scattering communications between all nodes.
6213! This is achieved by summing all the buffers.
6214!-----------------------------------------------------------------------
6215!
6216 DO is=mstr,mend
6217 tl_state(is)=aspv
6218 END DO
6219# endif
6220!
6221!-----------------------------------------------------------------------
6222! Load tangent linear state variables into full 1D state vector.
6223!-----------------------------------------------------------------------
6224!
6225! Set offsets for momentum variables due to periodic boundary
6226! conditions. Recall that in East-West periodic boundary conditions
6227! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
6228! applications IstrV=1 or else IstrV=2.
6229!
6230 IF (ewperiodic(ng)) THEN
6231 uoff=0
6232 ELSE
6233 uoff=1
6234 END IF
6235!
6236 IF (nsperiodic(ng)) THEN
6237 voff=0
6238 ELSE
6239 voff=1
6240 END IF
6241!
6242! Determine the index offset for each variable in the state vector.
6243# ifdef MASKING
6244! Notice that in Land/Sea masking application the state vector only
6245! contains water points to avoid large null space.
6246# endif
6247!
6248# ifdef SOLVE3D
6249# ifdef MASKING
6250 offset(isfsur)=0
6251 offset(isuvel)=offset(isfsur)+nwaterr(ng)
6252 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
6253 iadd=nwaterv(ng)*n(ng)
6254 DO itrc=1,nt(ng)
6255 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6256 iadd=nwaterr(ng)*n(ng)
6257 END DO
6258# else
6259# ifdef FULL_GRID
6260 offset(isfsur)=0
6261 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
6262 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
6263 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
6264 DO itrc=1,nt(ng)
6265 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6266 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
6267 END DO
6268# else
6269 offset(isfsur)=0
6270 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
6271
6272 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
6273 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
6274 DO itrc=1,nt(ng)
6275 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6276 iadd=lm(ng)*mm(ng)*n(ng)
6277 END DO
6278# endif
6279# endif
6280# else
6281# ifdef MASKING
6282 offset(isfsur)=0
6283 offset(isubar)=offset(isfsur)+nwaterr(ng)
6284 offset(isvbar)=offset(isubar)+nwateru(ng)
6285# else
6286# ifdef FULL_GRID
6287 offset(isfsur)=0
6288 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
6289 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
6290# else
6291 offset(isfsur)=0
6292 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
6293 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
6294# endif
6295# endif
6296# endif
6297!
6298! Load tangent linear free-surface.
6299!
6300# ifndef MASKING
6301# ifdef FULL_GRID
6302 imax=lm(ng)+2
6303 ioff=1
6304 joff=0
6305# else
6306 imax=lm(ng)
6307 ioff=0
6308 joff=1
6309# endif
6310# endif
6311# ifdef ENERGYNORM_SCALE
6312 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
6313# else
6314 scale=1.0_r8
6315# endif
6316 DO j=jr_range
6317 DO i=ir_range
6318# ifdef MASKING
6319 IF (rmask(i,j).gt.0.0_r8) THEN
6320 is=ijwaterr(i,j)+offset(isfsur)
6321 tl_state(is)=scale*tl_zeta(i,j,knew)
6322 END IF
6323# else
6324 is=(i+ioff)+(j-joff)*imax+offset(isfsur)
6325 tl_state(is)=scale*tl_zeta(i,j,knew)
6326# endif
6327 END DO
6328 END DO
6329# ifndef SOLVE3D
6330!
6331! Load tangent linear 2D U-velocity.
6332!
6333# ifndef MASKING
6334# ifdef FULL_GRID
6335 imax=lm(ng)+1
6336 ioff=0
6337 joff=0
6338# else
6339 imax=lm(ng)-uoff
6340 ioff=uoff
6341 joff=1
6342# endif
6343# endif
6344# ifdef ENERGYNORM_SCALE
6345 cff=0.25_r8*rho0
6346# else
6347 scale=1.0_r8
6348# endif
6349 DO j=jr_range
6350 DO i=iu_range
6351# ifdef ENERGYNORM_SCALE
6352 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
6353# endif
6354# ifdef MASKING
6355 IF (umask(i,j).gt.0.0_r8) THEN
6356 is=ijwateru(i,j)+offset(isubar)
6357 tl_state(is)=scale*tl_ubar(i,j,knew)
6358 END IF
6359# else
6360 is=(i-ioff)+(j-joff)*imax+offset(isubar)
6361 tl_state(is)=scale*tl_ubar(i,j,knew)
6362# endif
6363 END DO
6364 END DO
6365!
6366! Load tangent linear 2D V-velocity.
6367!
6368# ifndef MASKING
6369# ifdef FULL_GRID
6370 imax=lm(ng)+2
6371 ioff=1
6372 joff=1
6373# else
6374 imax=lm(ng)
6375 ioff=0
6376 joff=1+voff
6377# endif
6378# endif
6379# ifdef ENERGYNORM_SCALE
6380 cff=0.25_r8*rho0
6381# else
6382 scale=1.0_r8
6383# endif
6384 DO j=jv_range
6385 DO i=ir_range
6386# ifdef ENERGYNORM_SCALE
6387 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
6388# endif
6389# ifdef MASKING
6390 IF (vmask(i,j).gt.0.0_r8) THEN
6391 is=ijwaterv(i,j)+offset(isvbar)
6392 tl_state(is)=scale*tl_vbar(i,j,knew)
6393 END IF
6394# else
6395 is=(i+ioff)+(j-joff)*imax+offset(isvbar)
6396 tl_state(is)=scale*tl_vbar(i,j,knew)
6397# endif
6398 END DO
6399 END DO
6400# else
6401!
6402! Load tangent linear 3D U-velocity.
6403!
6404# ifndef MASKING
6405# ifdef FULL_GRID
6406 imax=lm(ng)+1
6407 jmax=mm(ng)+2
6408 ioff=0
6409 joff=0
6410# else
6411 imax=lm(ng)-uoff
6412 jmax=mm(ng)
6413 ioff=uoff
6414 joff=1
6415# endif
6416# endif
6417# ifdef ENERGYNORM_SCALE
6418 cff=0.25_r8*rho0
6419# else
6420 scale=1.0_r8
6421# endif
6422 DO k=1,n(ng)
6423# ifdef MASKING
6424 iadd=(k-1)*nwateru(ng)+offset(isuvel)
6425# else
6426 iadd=(k-1)*imax*jmax+offset(isuvel)
6427# endif
6428 DO j=jr_range
6429 DO i=iu_range
6430# ifdef MASKING
6431 IF (umask(i,j).gt.0.0_r8) THEN
6432# ifdef ENERGYNORM_SCALE
6433 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
6434# endif
6435 is=ijwateru(i,j)+iadd
6436 tl_state(is)=scale*tl_u(i,j,k,nstp)
6437 END IF
6438# else
6439# ifdef ENERGYNORM_SCALE
6440 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
6441# endif
6442 is=(i-ioff)+(j-joff)*imax+iadd
6443 tl_state(is)=scale*tl_u(i,j,k,nstp)
6444# endif
6445 END DO
6446 END DO
6447 END DO
6448!
6449! Load tangent linear 3D V-velocity.
6450!
6451# ifndef MASKING
6452# ifdef FULL_GRID
6453 imax=lm(ng)+2
6454 jmax=mm(ng)+1
6455 ioff=1
6456 joff=1
6457# else
6458 imax=lm(ng)
6459 jmax=mm(ng)-voff
6460 ioff=0
6461 joff=1+voff
6462# endif
6463# endif
6464# ifdef ENERGYNORM_SCALE
6465 cff=0.25_r8*rho0
6466# else
6467 scale=1.0_r8
6468# endif
6469 DO k=1,n(ng)
6470# ifdef MASKING
6471 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
6472# else
6473 iadd=(k-1)*imax*jmax+offset(isvvel)
6474# endif
6475 DO j=jv_range
6476 DO i=ir_range
6477# ifdef MASKING
6478 IF (vmask(i,j).gt.0.0_r8) THEN
6479# ifdef ENERGYNORM_SCALE
6480 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
6481# endif
6482 is=ijwaterv(i,j)+iadd
6483 tl_state(is)=scale*tl_v(i,j,k,nstp)
6484 END IF
6485# else
6486# ifdef ENERGYNORM_SCALE
6487 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
6488# endif
6489 is=(i+ioff)+(j-joff)*imax+iadd
6490 tl_state(is)=scale*tl_v(i,j,k,nstp)
6491# endif
6492 END DO
6493 END DO
6494 END DO
6495!
6496! Load tangent linear tracers variables. For now, use salinity scale
6497! for passive tracers.
6498!
6499# ifndef MASKING
6500# ifdef FULL_GRID
6501 imax=lm(ng)+2
6502 jmax=mm(ng)+2
6503 ioff=1
6504 joff=0
6505# else
6506 imax=lm(ng)
6507 jmax=mm(ng)
6508 ioff=0
6509 joff=1
6510# endif
6511# endif
6512 DO itrc=1,nt(ng)
6513# ifdef ENERGYNORM_SCALE
6514 IF (itrc.eq.itemp) THEN
6515 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
6516 ELSE IF (itrc.eq.isalt) THEN
6517 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
6518 ELSE
6519 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
6520 END IF
6521# else
6522 scale=1.0_r8
6523# endif
6524 DO k=1,n(ng)
6525# ifdef MASKING
6526 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
6527# else
6528 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
6529# endif
6530 DO j=jr_range
6531 DO i=ir_range
6532# ifdef MASKING
6533 IF (rmask(i,j).gt.0.0_r8) THEN
6534# ifdef ENERGYNORM_SCALE
6535 scale=1.0_r8/sqrt(cff*hz(i,j,k))
6536# endif
6537 is=ijwaterr(i,j)+iadd
6538 tl_state(is)=scale*tl_t(i,j,k,nstp,itrc)
6539 END IF
6540# else
6541# ifdef ENERGYNORM_SCALE
6542 scale=1.0_r8/sqrt(cff*hz(i,j,k))
6543# endif
6544 is=(i+ioff)+(j-joff)*imax+iadd
6545 tl_state(is)=scale*tl_t(i,j,k,nstp,itrc)
6546# endif
6547 END DO
6548 END DO
6549 END DO
6550 END DO
6551# endif
6552!
6553 RETURN
6554 END SUBROUTINE tl_pack_tile
6555# endif
6556
6557# if defined TANGENT && (defined STOCHASTIC_OPT || \
6558 defined hessian_sv )
6559!
6560 SUBROUTINE tl_unpack (ng, tile, Mstr, Mend, state)
6561!
6562!=======================================================================
6563! !
6564! This routine unpacks the tangent linear variables from the state !
6565! vector. If applicable, the state vector includes only unmasked !
6566! water points. !
6567! !
6568!=======================================================================
6569!
6570 USE mod_param
6571 USE mod_grid
6572 USE mod_ocean
6573 USE mod_forces
6574 USE mod_stepping
6575# ifdef DISTRIBUTE
6576 USE mod_storage
6577# endif
6578# ifdef DISTRIBUTE
6579!
6580 USE distribute_mod, ONLY : mp_gather_state
6581# endif
6582!
6583! Imported variable declarations.
6584!
6585 integer, intent(in) :: ng, tile
6586 integer, intent(in) :: Mstr, Mend
6587# ifdef ASSUMED_SHAPE
6588 real(r8), intent(in) :: state(Mstr:)
6589# else
6590 real(r8), intent(in) :: state(Mstr:Mend)
6591# endif
6592!
6593! Local variable declarations.
6594!
6595 character (len=*), parameter :: MyFile = &
6596 & __FILE__//", tl_unpack"
6597!
6598# include "tile.h"
6599!
6600# ifdef PROFILE
6601 CALL wclock_on (ng, itlm, 2, __line__, myfile)
6602# endif
6603
6604# ifdef DISTRIBUTE
6605!
6606! Gather (threaded to global) tangent linear state solution from all
6607! distributed nodes.
6608!
6609 CALL mp_gather_state (ng, itlm, mstr, mend, mstate(ng), &
6610 & state, swork)
6611!
6612# endif
6613 CALL tl_unpack_tile (ng, tile, &
6614 & lbi, ubi, lbj, ubj, &
6615 & imins, imaxs, jmins, jmaxs, &
6616 & kstp(ng), &
6617# ifdef SOLVE3D
6618 & nstp(ng), &
6619# endif
6620# ifdef DISTRIBUTE
6621 & 1, mstate(ng), swork, &
6622# else
6623 & mstr, mend, state, &
6624# endif
6625# ifdef MASKING
6626 & grid(ng) % IJwaterR, &
6627 & grid(ng) % IJwaterU, &
6628 & grid(ng) % IJwaterV, &
6629 & grid(ng) % rmask, &
6630 & grid(ng) % umask, &
6631 & grid(ng) % vmask, &
6632# endif
6633 & grid(ng) % h, &
6634# ifdef SOLVE3D
6635 & grid(ng) % Hz, &
6636 & ocean(ng) % tl_t, &
6637 & ocean(ng) % tl_u, &
6638 & ocean(ng) % tl_v, &
6639# else
6640 & ocean(ng) % tl_ubar, &
6641 & ocean(ng) % tl_vbar, &
6642# endif
6643 & ocean(ng) % tl_zeta, &
6644# ifdef SOLVE3D
6645 & forces(ng) % tl_stflx, &
6646# endif
6647 & forces(ng) % tl_sustr, &
6648 & forces(ng) % tl_svstr)
6649
6650# ifdef PROFILE
6651 CALL wclock_off (ng, itlm, 2, __line__, myfile)
6652# endif
6653!
6654 RETURN
6655 END SUBROUTINE tl_unpack
6656!
6657!***********************************************************************
6658 SUBROUTINE tl_unpack_tile (ng, tile, &
6659 & LBi, UBi, LBj, UBj, &
6660 & IminS, ImaxS, JminS, JmaxS, &
6661 & kstp, &
6662# ifdef SOLVE3D
6663 & nstp, &
6664# endif
6665 & Mstr, Mend, state, &
6666# ifdef MASKING
6667 & IJwaterR, IJwaterU, IJwaterV, &
6668 & rmask, umask, vmask, &
6669# endif
6670 & h, &
6671# ifdef SOLVE3D
6672 & Hz, &
6673 & tl_t, tl_u, tl_v, &
6674# else
6675 & tl_ubar, tl_vbar, &
6676# endif
6677 & tl_zeta, &
6678# ifdef SOLVE3D
6679 & tl_stflx, &
6680# endif
6681 & tl_sustr, tl_svstr)
6682!***********************************************************************
6683!
6684 USE mod_param
6685 USE mod_parallel
6686 USE mod_forces
6687 USE mod_ncparam
6688 USE mod_ocean
6689 USE mod_scalars
6690!
6691! Imported variable declarations.
6692!
6693 integer, intent(in) :: ng, tile
6694 integer, intent(in) :: LBi, UBi, LBj, UBj
6695 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
6696 integer, intent(in) :: Mstr, Mend
6697 integer, intent(in) :: kstp
6698# ifdef SOLVE3D
6699 integer, intent(in) :: nstp
6700# endif
6701!
6702# ifdef ASSUMED_SHAPE
6703# ifdef MASKING
6704 integer, intent(in) :: IJwaterR(LBi:,LBj:)
6705 integer, intent(in) :: IJwaterU(LBi:,LBj:)
6706 integer, intent(in) :: IJwaterV(LBi:,LBj:)
6707
6708 real(r8), intent(in) :: rmask(LBi:,LBj:)
6709 real(r8), intent(in) :: umask(LBi:,LBj:)
6710 real(r8), intent(in) :: vmask(LBi:,LBj:)
6711# endif
6712 real(r8), intent(in) :: state(Mstr:)
6713 real(r8), intent(in) :: h(LBi:,LBj:)
6714# ifdef SOLVE3D
6715 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
6716
6717 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
6718 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
6719 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
6720 real(r8), intent(inout) :: tl_stflx(LBi:,LBj:,:)
6721# else
6722 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
6723 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
6724# endif
6725 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
6726 real(r8), intent(inout) :: tl_sustr(LBi:,LBj:)
6727 real(r8), intent(inout) :: tl_svstr(LBi:,LBj:)
6728# else
6729# ifdef MASKING
6730 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
6731 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
6732 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
6733
6734 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
6735 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
6736 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
6737# endif
6738 real(r8), intent(in) :: state(Mstr:Mend)
6739 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
6740# ifdef SOLVE3D
6741 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
6742
6743 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
6744 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
6745 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
6746 real(r8), intent(inout) :: tl_stflx(LBi:UBi,LBj:UBj,NT(ng))
6747# else
6748 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
6749 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
6750# endif
6751 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
6752 real(r8), intent(inout) :: tl_sustr(LBi:UBi,LBj:UBj)
6753 real(r8), intent(inout) :: tl_svstr(LBi:UBi,LBj:UBj)
6754# endif
6755!
6756! Local variable declarations.
6757!
6758# ifndef MASKING
6759 integer :: Imax, Ioff, Jmax, Joff
6760# endif
6761 integer :: Uoff, Voff
6762 integer :: i, iadd, icount, is, itrc, j, k
6763
6764# ifdef SALINITY
6765 integer, dimension(7+2*NT(ng)) :: offset
6766# else
6767 integer, dimension(7+2*(NT(ng)+1)) :: offset
6768# endif
6769
6770 real(r8) :: cff, scale
6771
6772# include "set_bounds.h"
6773!
6774!-----------------------------------------------------------------------
6775! Extract tangent linear FORCING variables from full 1D state vector.
6776!-----------------------------------------------------------------------
6777!
6778! Set offsets for momentum variables due to periodic boundary
6779! conditions. Recall that in East-West periodic boundary conditions
6780! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
6781! applications IstrV=1 or else IstrV=2.
6782!
6783 IF (ewperiodic(ng)) THEN
6784 uoff=0
6785 ELSE
6786 uoff=1
6787 END IF
6788!
6789 IF (nsperiodic(ng)) THEN
6790 voff=0
6791 ELSE
6792 voff=1
6793 END IF
6794!
6795! Determine the index offset for each variable in the state vector.
6796# ifdef MASKING
6797! Notice that in Land/Sea masking application the state vector only
6798! contains water points to avoid large null space.
6799# endif
6800!
6801! First clear the "offset" array.
6802!
6803 offset=0
6804!
6805# ifdef SOLVE3D
6806# ifdef MASKING
6807 IF (scalars(ng)%Fstate(isfsur)) THEN
6808 offset(isfsur)=0
6809 END IF
6810 IF (scalars(ng)%Fstate(isuvel)) THEN
6811 offset(isuvel)=offset(isfsur)+nwaterr(ng)
6812 END IF
6813 IF (scalars(ng)%Fstate(isvvel)) THEN
6814 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
6815 END IF
6816 iadd=nwaterv(ng)*n(ng)
6817 DO itrc=1,nt(ng)
6818 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
6819 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6820 iadd=nwaterr(ng)*n(ng)
6821 END IF
6822 END DO
6823 IF (scalars(ng)%Fstate(isustr)) THEN
6824 offset(isustr)=0
6825 END IF
6826 IF (scalars(ng)%Fstate(isvstr)) THEN
6827 offset(isvstr)=offset(isustr)+nwateru(ng)
6828 END IF
6829 DO itrc=1,nt(ng)
6830 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
6831 IF (itrc.eq.1) THEN
6832 offset(istsur(itrc))=offset(isvstr)+nwaterv(ng)
6833 ELSE
6834 offset(istsur(itrc))=offset(istsur(itrc-1))+nwaterr(ng)
6835 END IF
6836 END IF
6837 END DO
6838# else
6839# ifdef FULL_GRID
6840 IF (scalars(ng)%Fstate(isfsur)) THEN
6841 offset(isfsur)=0
6842 END IF
6843 IF (scalars(ng)%Fstate(isuvel)) THEN
6844 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
6845 END IF
6846 IF (scalars(ng)%Fstate(isvvel)) THEN
6847 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
6848 END IF
6849 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
6850 DO itrc=1,nt(ng)
6851 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
6852 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6853 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
6854 END IF
6855 END DO
6856 IF (scalars(ng)%Fstate(isustr)) THEN
6857 offset(isustr)=0
6858 END IF
6859 IF (scalars(ng)%Fstate(isvstr)) THEN
6860 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
6861 END IF
6862 DO itrc=1,nt(ng)
6863 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
6864 IF (itrc.eq.1) THEN
6865 offset(istsur(itrc))=offset(isvstr)+ &
6866 & (lm(ng)+2)*(mm(ng)+1)
6867 ELSE
6868 offset(istsur(itrc))=offset(istsur(itrc-1))+ &
6869 & (lm(ng)+2)*(mm(ng)+2)
6870 END IF
6871 END IF
6872 END DO
6873# else
6874 IF (scalars(ng)%Fstate(isfsur)) THEN
6875 offset(isfsur)=0
6876 END IF
6877 IF (scalars(ng)%Fstate(isuvel)) THEN
6878 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
6879 END IF
6880 IF (scalars(ng)%Fstate(isvvel)) THEN
6881 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
6882 END IF
6883 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
6884 DO itrc=1,nt(ng)
6885 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
6886 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
6887 iadd=lm(ng)*mm(ng)*n(ng)
6888 END IF
6889 END DO
6890 IF (scalars(ng)%Fstate(isustr)) THEN
6891 offset(isustr)=0
6892 END IF
6893 IF (scalars(ng)%Fstate(isvstr)) THEN
6894 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
6895 END IF
6896 DO itrc=1,nt(ng)
6897 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
6898 IF (itrc.eq.1) THEN
6899 offset(istsur(itrc))=offset(isvstr)+lm(ng)*(mm(ng)-voff)
6900 ELSE
6901 offset(istsur(itrc))=offset(istsur(itrc-1))+lm(ng)*mm(ng)
6902 END IF
6903 END IF
6904 END DO
6905# endif
6906# endif
6907# else
6908# ifdef MASKING
6909 IF (scalars(ng)%Fstate(isfsur)) THEN
6910 offset(isfsur)=0
6911 END IF
6912 IF (scalars(ng)%Fstate(isubar)) THEN
6913 offset(isubar)=offset(isfsur)+nwaterr(ng)
6914 END IF
6915 IF (scalars(ng)%Fstate(isvbar)) THEN
6916 offset(isvbar)=offset(isubar)+nwateru(ng)
6917 END IF
6918 IF (scalars(ng)%Fstate(isustr)) THEN
6919 offset(isustr)=0
6920 END IF
6921 IF (scalars(ng)%Fstate(isvstr)) THEN
6922 offset(isvstr)=offset(isustr)+nwateru(ng)
6923 END IF
6924# else
6925# ifdef FULL_GRID
6926 IF (scalars(ng)%Fstate(isfsur)) THEN
6927 offset(isfsur)=0
6928 END IF
6929 IF (scalars(ng)%Fstate(isubar)) THEN
6930 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
6931 END IF
6932 IF (scalars(ng)%Fstate(isvbar) THEN
6933 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
6934 END IF
6935 IF (scalars(ng)%Fstate(isustr)) THEN
6936 offset(isustr)=0
6937 END IF
6938 IF (scalars(ng)%Fstate(isvstr)) THEN
6939 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
6940 END IF
6941# else
6942 IF (scalars(ng)%Fstate(isfsur)) THEN
6943 offset(isfsur)=0
6944 END IF
6945 IF (scalars(ng)%Fstate(isubar)) THEN
6946 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
6947 END IF
6948 IF (scalars(ng)%Fstate(isvbar) THEN
6949 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
6950 END IF
6951 IF (scalars(ng)%Fstate(isustr)) THEN
6952 offset(isustr)=0
6953 END IF
6954 IF (scalars(ng)%Fstate(isustr)) THEN
6955 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
6956 END IF
6957# endif
6958# endif
6959# endif
6960!
6961! Extract tangent linear free-surface.
6962!
6963 IF (scalars(ng)%Fstate(isfsur)) THEN
6964# ifndef MASKING
6965# ifdef FULL_GRID
6966 imax=lm(ng)+2
6967 ioff=1
6968 joff=0
6969# else
6970 imax=lm(ng)
6971 ioff=0
6972 joff=1
6973# endif
6974# endif
6975# ifdef ENERGYNORM_SCALE
6976 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
6977# else
6978 scale=1.0_r8
6979# endif
6980 DO j=jr_range
6981 DO i=ir_range
6982# ifdef MASKING
6983 IF (rmask(i,j).gt.0.0_r8) THEN
6984 is=ijwaterr(i,j)+offset(isfsur)
6985 tl_zeta(i,j,kstp)=scale*state(is)
6986 ELSE
6987 tl_zeta(i,j,kstp)=0.0_r8
6988 END IF
6989# else
6990 is=(i-ioff)+(j-joff)*imax+offset(isfsur)
6991 tl_zeta(i,j,kstp)=scale*state(is)
6992# endif
6993 END DO
6994 END DO
6995 END IF
6996
6997# ifndef SOLVE3D
6998!
6999! Extract tangent linear 2D U-velocity.
7000!
7001 IF (scalars(ng)%Fstate(isubar)) THEN
7002# ifndef MASKING
7003# ifdef FULL_GRID
7004 imax=lm(ng)+1
7005 ioff=0
7006 joff=0
7007# else
7008 imax=lm(ng)-uoff
7009 ioff=uoff
7010 joff=1
7011# endif
7012# endif
7013# ifdef ENERGYNORM_SCALE
7014 cff=0.25_r8*rho0
7015# else
7016 scale=1.0_r8
7017# endif
7018 DO j=jr_range
7019 DO i=iu_range
7020# ifdef ENERGYNORM_SCALE
7021 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
7022# endif
7023# ifdef MASKING
7024 IF (umask(i,j).gt.0.0_r8) THEN
7025 is=ijwateru(i,j)+offset(isubar)
7026 tl_ubar(i,j,kstp)=scale*state(is)
7027 ELSE
7028 tl_ubar(i,j,kstp)=0.0_r8
7029 END IF
7030# else
7031 is=(i-ioff)+(j-joff)*imax+offset(isubar)
7032 tl_ubar(i,j,kstp)=scale*state(is)
7033# endif
7034 END DO
7035 END DO
7036 END IF
7037!
7038! Extract tangent linear 2D V-velocity.
7039!
7040 IF (scalars(ng)%Fstate(isvbar)) THEN
7041# ifndef MASKING
7042# ifdef FULL_GRID
7043 imax=lm(ng)+2
7044 ioff=1
7045 joff=1
7046# else
7047 imax=lm(ng)
7048 ioff=0
7049 joff=1+voff
7050# endif
7051# endif
7052# ifdef ENERGYNORM_SCALE
7053 cff=0.25_r8*rho0
7054# else
7055 scale=1.0_r8
7056# endif
7057 DO j=jv_range
7058 DO i=ir_range
7059# ifdef ENERGYNORM_SCALE
7060 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
7061# endif
7062# ifdef MASKING
7063 IF (vmask(i,j).gt.0.0_r8) THEN
7064 is=ijwaterv(i,j)+offset(isvbar)
7065 tl_vbar(i,j,kstp)=scale*state(is)
7066 ELSE
7067 tl_vbar(i,j,kstp)=0.0_r8
7068 END IF
7069# else
7070 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
7071 tl_vbar(i,j,kstp)=scale*state(is)
7072# endif
7073 END DO
7074 END DO
7075 END IF
7076
7077# else
7078!
7079! Extract tangent linear 3D U-velocity.
7080!
7081 IF (scalars(ng)%Fstate(isuvel)) THEN
7082# ifndef MASKING
7083# ifdef FULL_GRID
7084 imax=lm(ng)+1
7085 jmax=mm(ng)+2
7086 ioff=0
7087 joff=0
7088# else
7089 imax=lm(ng)-uoff
7090 jmax=mm(ng)
7091 ioff=uoff
7092 joff=1
7093# endif
7094# endif
7095# ifdef ENERGYNORM_SCALE
7096 cff=0.25_r8*rho0
7097# else
7098 scale=1.0_r8
7099# endif
7100 DO k=1,n(ng)
7101# ifdef MASKING
7102 iadd=(k-1)*nwateru(ng)+offset(isuvel)
7103# else
7104 iadd=(k-1)*imax*jmax+offset(isuvel)
7105# endif
7106 DO j=jr_range
7107 DO i=iu_range
7108# ifdef MASKING
7109 IF (umask(i,j).gt.0.0_r8) THEN
7110# ifdef ENERGYNORM_SCALE
7111 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
7112# endif
7113 is=ijwateru(i,j)+iadd
7114 tl_u(i,j,k,nstp)=scale*state(is)
7115 ELSE
7116 tl_u(i,j,k,nstp)=0.0_r8
7117 END IF
7118# else
7119# ifdef ENERGYNORM_SCALE
7120 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
7121# endif
7122 is=(i-ioff)+(j-joff)*imax+iadd
7123 tl_u(i,j,k,nstp)=scale*state(is)
7124# endif
7125 END DO
7126 END DO
7127 END DO
7128 END IF
7129!
7130! Extract tangent linear 3D V-velocity.
7131!
7132 IF (scalars(ng)%Fstate(isvvel)) THEN
7133# ifndef MASKING
7134# ifdef FULL_GRID
7135 imax=lm(ng)+2
7136 jmax=mm(ng)+1
7137 ioff=1
7138 joff=1
7139# else
7140 imax=lm(ng)
7141 jmax=mm(ng)-voff
7142 ioff=0
7143 joff=1+voff
7144# endif
7145# endif
7146# ifdef ENERGYNORM_SCALE
7147 cff=0.25_r8*rho0
7148# else
7149 scale=1.0_r8
7150# endif
7151 DO k=1,n(ng)
7152# ifdef MASKING
7153 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
7154# else
7155 iadd=(k-1)*imax*jmax+offset(isvvel)
7156# endif
7157 DO j=jv_range
7158 DO i=ir_range
7159# ifdef MASKING
7160 IF (vmask(i,j).gt.0.0_r8) THEN
7161# ifdef ENERGYNORM_SCALE
7162 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
7163# endif
7164 is=ijwaterv(i,j)+iadd
7165 tl_v(i,j,k,nstp)=scale*state(is)
7166 ELSE
7167 tl_v(i,j,k,nstp)=0.0_r8
7168 END IF
7169# else
7170# ifdef ENERGYNORM_SCALE
7171 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
7172# endif
7173 is=(i+ioff)+(j-joff)*imax+iadd
7174 tl_v(i,j,k,nstp)=scale*state(is)
7175# endif
7176 END DO
7177 END DO
7178 END DO
7179 END IF
7180!
7181! Extract tangent linear tracers variables.
7182!
7183 DO itrc=1,nt(ng)
7184 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
7185# ifndef MASKING
7186# ifdef FULL_GRID
7187 imax=lm(ng)+2
7188 jmax=mm(ng)+2
7189 ioff=1
7190 joff=0
7191# else
7192 imax=lm(ng)
7193 jmax=mm(ng)
7194 ioff=0
7195 joff=1
7196# endif
7197# endif
7198# ifdef ENERGYNORM_SCALE
7199 IF (itrc.eq.itemp) THEN
7200 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
7201 ELSE IF (itrc.eq.isalt) THEN
7202 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
7203 ELSE
7204 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
7205 END IF
7206# else
7207 scale=1.0_r8
7208# endif
7209 DO k=1,n(ng)
7210# ifdef MASKING
7211 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
7212# else
7213 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
7214# endif
7215 DO j=jr_range
7216 DO i=ir_range
7217# ifdef MASKING
7218 IF (rmask(i,j).gt.0.0_r8) THEN
7219# ifdef ENERGYNORM_SCALE
7220 scale=1.0_r8/sqrt(cff*hz(i,j,k))
7221# endif
7222 is=ijwaterr(i,j)+iadd
7223 tl_t(i,j,k,nstp,itrc)=scale*state(is)
7224 ELSE
7225 tl_t(i,j,k,nstp,itrc)=0.0_r8
7226 END IF
7227# else
7228# ifdef ENERGYNORM_SCALE
7229 scale=1.0_r8/sqrt(cff*hz(i,j,k))
7230# endif
7231 is=(i+ioff)+(j-joff)*imax+iadd
7232 tl_t(i,j,k,nstp,itrc)=scale*state(is)
7233# endif
7234 END DO
7235 END DO
7236 END DO
7237 END IF
7238 END DO
7239# endif
7240!
7241! Extract tangent linear surface U-momentum stress.
7242!
7243 IF (scalars(ng)%Fstate(isustr)) THEN
7244# ifndef MASKING
7245# ifdef FULL_GRID
7246 imax=lm(ng)+1
7247 ioff=0
7248 joff=0
7249# else
7250 imax=lm(ng)-uoff
7251 ioff=uoff
7252 joff=1
7253# endif
7254# endif
7255 scale=1.0_r8
7256 DO j=jr_range
7257 DO i=iu_range
7258# ifdef MASKING
7259 IF (umask(i,j).gt.0.0_r8) THEN
7260 is=ijwateru(i,j)+offset(isustr)
7261 tl_sustr(i,j)=scale*state(is)
7262 ELSE
7263 tl_sustr(i,j)=0.0_r8
7264 END IF
7265# else
7266 is=(i-ioff)+(j-joff)*imax+offset(isustr)
7267 tl_sustr(i,j)=scale*state(is)
7268# endif
7269 END DO
7270 END DO
7271 END IF
7272!
7273! Extract tangent linear surface V-momentum stress.
7274!
7275 IF (scalars(ng)%Fstate(isvstr)) THEN
7276# ifndef MASKING
7277# ifdef FULL_GRID
7278 imax=lm(ng)+2
7279 ioff=1
7280 joff=1
7281# else
7282 imax=lm(ng)
7283 ioff=0
7284 joff=1+voff
7285# endif
7286# endif
7287 scale=1.0_r8
7288 DO j=jv_range
7289 DO i=ir_range
7290# ifdef MASKING
7291 IF (vmask(i,j).gt.0.0_r8) THEN
7292 is=ijwaterv(i,j)+offset(isvstr)
7293 tl_svstr(i,j)=scale*state(is)
7294 ELSE
7295 tl_svstr(i,j)=0.0_r8
7296 END IF
7297# else
7298 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
7299 tl_svstr(i,j)=scale*state(is)
7300# endif
7301 END DO
7302 END DO
7303 END IF
7304
7305# ifdef SOLVE3D
7306!
7307! Extract tangent linear surface tracer flux variables.
7308!
7309 DO itrc=1,nt(ng)
7310 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
7311# ifndef MASKING
7312# ifdef FULL_GRID
7313 imax=lm(ng)+2
7314 jmax=mm(ng)+2
7315 ioff=1
7316 joff=0
7317# else
7318 imax=lm(ng)
7319 jmax=mm(ng)
7320 ioff=0
7321 joff=1
7322# endif
7323# endif
7324 scale=1.0_r8
7325 DO j=jr_range
7326 DO i=ir_range
7327# ifdef MASKING
7328 IF (rmask(i,j).gt.0.0_r8) THEN
7329 is=ijwaterr(i,j)+offset(istsur(itrc))
7330 tl_stflx(i,j,itrc)=scale*state(is)
7331 ELSE
7332 tl_stflx(i,j,itrc)=0.0_r8
7333 END IF
7334# else
7335 is=(i+ioff)+(j-joff)*imax+offset(istsur(itrc))
7336 tl_stflx(i,j,itrc)=scale*state(is)
7337# endif
7338 END DO
7339 END DO
7340 END IF
7341 END DO
7342# endif
7343!
7344 RETURN
7345 END SUBROUTINE tl_unpack_tile
7346
7347# elif defined TANGENT && defined FORCING_SV
7348!
7349 SUBROUTINE tl_unpack (ng, tile, Mstr, Mend, state)
7350!
7351!=======================================================================
7352! !
7353! This routine unpacks the tangent linear variables from the state !
7354! vector. If applicable, the state vector includes only unmasked !
7355! water points. !
7356! !
7357!=======================================================================
7358!
7359 USE mod_param
7360 USE mod_grid
7361 USE mod_ocean
7362 USE mod_forces
7363 USE mod_stepping
7364# ifdef DISTRIBUTE
7365 USE mod_storage
7366# endif
7367# ifdef DISTRIBUTE
7368!
7369 USE distribute_mod, ONLY : mp_gather_state
7370# endif
7371!
7372! Imported variable declarations.
7373!
7374 integer, intent(in) :: ng, tile
7375 integer, intent(in) :: Mstr, Mend
7376# ifdef ASSUMED_SHAPE
7377 real(r8), intent(in) :: state(Mstr:)
7378# else
7379 real(r8), intent(in) :: state(Mstr:Mend)
7380# endif
7381!
7382! Local variable declarations.
7383!
7384 character (len=*), parameter :: MyFile = &
7385 & __FILE__//", tl_unpack"
7386!
7387# include "tile.h"
7388!
7389# ifdef PROFILE
7390 CALL wclock_on (ng, itlm, 2, __line__, myfile)
7391# endif
7392
7393# ifdef DISTRIBUTE
7394!
7395! Gather (threaded to global) tangent linear state solution from all
7396! distributed nodes.
7397!
7398 CALL mp_gather_state (ng, itlm, mstr, mend, mstate(ng), &
7399 & state, swork)
7400!
7401# endif
7402 CALL tl_unpack_tile (ng, tile, &
7403 & lbi, ubi, lbj, ubj, &
7404 & imins, imaxs, jmins, jmaxs, &
7405 & kstp(ng), &
7406# ifdef SOLVE3D
7407 & nstp(ng), &
7408# endif
7409# ifdef DISTRIBUTE
7410 & 1, mstate(ng), swork, &
7411# else
7412 & mstr, mend, state, &
7413# endif
7414# ifdef MASKING
7415 & grid(ng) % IJwaterR, &
7416 & grid(ng) % IJwaterU, &
7417 & grid(ng) % IJwaterV, &
7418 & grid(ng) % rmask, &
7419 & grid(ng) % umask, &
7420 & grid(ng) % vmask, &
7421# endif
7422 & grid(ng) % h, &
7423# ifdef SOLVE3D
7424 & grid(ng) % Hz, &
7425 & ocean(ng) % f_t, &
7426 & ocean(ng) % f_u, &
7427 & ocean(ng) % f_v, &
7428# endif
7429 & ocean(ng) % f_ubar, &
7430 & ocean(ng) % f_vbar, &
7431 & ocean(ng) % f_zeta, &
7432# ifdef SOLVE3D
7433 & forces(ng) % tl_stflx, &
7434# endif
7435 & forces(ng) % tl_sustr, &
7436 & forces(ng) % tl_svstr)
7437
7438# ifdef PROFILE
7439 CALL wclock_off (ng, itlm, 2, __line__, myfile)
7440# endif
7441!
7442 RETURN
7443 END SUBROUTINE tl_unpack
7444!
7445!***********************************************************************
7446 SUBROUTINE tl_unpack_tile (ng, tile, &
7447 & LBi, UBi, LBj, UBj, &
7448 & IminS, ImaxS, JminS, JmaxS, &
7449 & kstp, &
7450# ifdef SOLVE3D
7451 & nstp, &
7452# endif
7453 & Mstr, Mend, state, &
7454# ifdef MASKING
7455 & IJwaterR, IJwaterU, IJwaterV, &
7456 & rmask, umask, vmask, &
7457# endif
7458 & h, &
7459# ifdef SOLVE3D
7460 & Hz, &
7461 & f_t, f_u, f_v, &
7462# endif
7463 & f_ubar, f_vbar, &
7464 & f_zeta, &
7465# ifdef SOLVE3D
7466 & tl_stflx, &
7467# endif
7468 & tl_sustr, tl_svstr)
7469!***********************************************************************
7470!
7471 USE mod_param
7472 USE mod_parallel
7473 USE mod_forces
7474 USE mod_ncparam
7475 USE mod_ocean
7476 USE mod_scalars
7477!
7478# ifdef FORCING_SV
7479 USE exchange_2d_mod
7480# ifdef SOLVE3D
7481 USE exchange_3d_mod
7482# endif
7483# ifdef DISTRIBUTE
7484 USE mp_exchange_mod, ONLY : mp_exchange2d
7485# ifdef SOLVE3D
7486 USE mp_exchange_mod, ONLY : mp_exchange3d, mp_exchange4d
7487# endif
7488# endif
7489# endif
7490!
7491! Imported variable declarations.
7492!
7493 integer, intent(in) :: ng, tile
7494 integer, intent(in) :: LBi, UBi, LBj, UBj
7495 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
7496 integer, intent(in) :: Mstr, Mend
7497 integer, intent(in) :: kstp
7498# ifdef SOLVE3D
7499 integer, intent(in) :: nstp
7500# endif
7501!
7502# ifdef ASSUMED_SHAPE
7503# ifdef MASKING
7504 integer, intent(in) :: IJwaterR(LBi:,LBj:)
7505 integer, intent(in) :: IJwaterU(LBi:,LBj:)
7506 integer, intent(in) :: IJwaterV(LBi:,LBj:)
7507
7508 real(r8), intent(in) :: rmask(LBi:,LBj:)
7509 real(r8), intent(in) :: umask(LBi:,LBj:)
7510 real(r8), intent(in) :: vmask(LBi:,LBj:)
7511# endif
7512 real(r8), intent(in) :: state(Mstr:)
7513 real(r8), intent(in) :: h(LBi:,LBj:)
7514# ifdef SOLVE3D
7515 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
7516
7517 real(r8), intent(inout) :: f_t(LBi:,LBj:,:,:)
7518 real(r8), intent(inout) :: f_u(LBi:,LBj:,:)
7519 real(r8), intent(inout) :: f_v(LBi:,LBj:,:)
7520 real(r8), intent(inout) :: tl_stflx(LBi:,LBj:,:)
7521# endif
7522 real(r8), intent(inout) :: f_ubar(LBi:,LBj:)
7523 real(r8), intent(inout) :: f_vbar(LBi:,LBj:)
7524 real(r8), intent(inout) :: f_zeta(LBi:,LBj:)
7525 real(r8), intent(inout) :: tl_sustr(LBi:,LBj:)
7526 real(r8), intent(inout) :: tl_svstr(LBi:,LBj:)
7527# else
7528# ifdef MASKING
7529 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
7530 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
7531 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
7532
7533 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
7534 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
7535 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
7536# endif
7537 real(r8), intent(in) :: state(Mstr:Mend)
7538 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
7539# ifdef SOLVE3D
7540 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
7541
7542 real(r8), intent(inout) :: f_t(LBi:UBi,LBj:UBj,N(ng),NT(ng))
7543 real(r8), intent(inout) :: f_u(LBi:UBi,LBj:UBj,N(ng))
7544 real(r8), intent(inout) :: f_v(LBi:UBi,LBj:UBj,N(ng))
7545 real(r8), intent(inout) :: tl_stflx(LBi:UBi,LBj:UBj,NT(ng))
7546# endif
7547 real(r8), intent(inout) :: f_ubar(LBi:UBi,LBj:UBj)
7548 real(r8), intent(inout) :: f_vbar(LBi:UBi,LBj:UBj)
7549 real(r8), intent(inout) :: f_zeta(LBi:UBi,LBj:UBj)
7550 real(r8), intent(inout) :: tl_sustr(LBi:UBi,LBj:UBj)
7551 real(r8), intent(inout) :: tl_svstr(LBi:UBi,LBj:UBj)
7552# endif
7553!
7554! Local variable declarations.
7555!
7556# ifndef MASKING
7557 integer :: Imax, Ioff, Jmax, Joff
7558# endif
7559 integer :: Uoff, Voff
7560 integer :: i, iadd, icount, is, itrc, j, k
7561
7562# ifdef SALINITY
7563 integer, dimension(7+2*NT(ng)) :: offset
7564# else
7565 integer, dimension(7+2*(NT(ng)+1)) :: offset
7566# endif
7567
7568 real(r8) :: cff, scale
7569
7570# ifdef SOLVE3D
7571 real(r8) :: cff1, cff2
7572 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: CF
7573 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DC
7574# endif
7575
7576# include "set_bounds.h"
7577!
7578!-----------------------------------------------------------------------
7579! Extract tangent linear FORCING variables from full 1D state vector.
7580!-----------------------------------------------------------------------
7581!
7582! Set offsets for momentum variables due to periodic boundary
7583! conditions. Recall that in East-West periodic boundary conditions
7584! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
7585! applications IstrV=1 or else IstrV=2.
7586!
7587 IF (ewperiodic(ng)) THEN
7588 uoff=0
7589 ELSE
7590 uoff=1
7591 END IF
7592!
7593 IF (nsperiodic(ng)) THEN
7594 voff=0
7595 ELSE
7596 voff=1
7597 END IF
7598!
7599! Determine the index offset for each variable in the state vector.
7600# ifdef MASKING
7601! Notice that in Land/Sea masking application the state vector only
7602! contains water points to avoid large null space.
7603# endif
7604!
7605! First clear the "offset" array.
7606!
7607 offset=0
7608!
7609# ifdef SOLVE3D
7610# ifdef MASKING
7611 IF (scalars(ng)%Fstate(isfsur)) THEN
7612 offset(isfsur)=0
7613 END IF
7614 IF (scalars(ng)%Fstate(isuvel)) THEN
7615 offset(isuvel)=offset(isfsur)+nwaterr(ng)
7616 END IF
7617 IF (scalars(ng)%Fstate(isvvel)) THEN
7618 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
7619 END IF
7620 iadd=nwaterv(ng)*n(ng)
7621 DO itrc=1,nt(ng)
7622 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
7623 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
7624 iadd=nwaterr(ng)*n(ng)
7625 END IF
7626 END DO
7627 IF (scalars(ng)%Fstate(isustr)) THEN
7628 offset(isustr)=0
7629 END IF
7630 IF (scalars(ng)%Fstate(isvstr)) THEN
7631 offset(isvstr)=offset(isustr)+nwateru(ng)
7632 END IF
7633 DO itrc=1,nt(ng)
7634 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
7635 IF (itrc.eq.1) THEN
7636 offset(istsur(itrc))=offset(isvstr)+nwaterv(ng)
7637 ELSE
7638 offset(istsur(itrc))=offset(istsur(itrc-1))+nwaterr(ng)
7639 END IF
7640 END IF
7641 END DO
7642# else
7643# ifdef FULL_GRID
7644 IF (scalars(ng)%Fstate(isfsur)) THEN
7645 offset(isfsur)=0
7646 END IF
7647 IF (scalars(ng)%Fstate(isuvel)) THEN
7648 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
7649 END IF
7650 IF (scalars(ng)%Fstate(isvvel)) THEN
7651 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
7652 END IF
7653 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
7654 DO itrc=1,nt(ng)
7655 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
7656 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
7657 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
7658 END IF
7659 END DO
7660 IF (scalars(ng)%Fstate(isustr)) THEN
7661 offset(isustr)=0
7662 END IF
7663 IF (scalars(ng)%Fstate(isvstr)) THEN
7664 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
7665 END IF
7666 DO itrc=1,nt(ng)
7667 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
7668 IF (itrc.eq.1) THEN
7669 offset(istsur(itrc))=offset(isvstr)+ &
7670 & (lm(ng)+2)*(mm(ng)+1)
7671 ELSE
7672 offset(istsur(itrc))=offset(istsur(itrc-1))+ &
7673 & (lm(ng)+2)*(mm(ng)+2)
7674 END IF
7675 END IF
7676 END DO
7677# else
7678 IF (scalars(ng)%Fstate(isfsur)) THEN
7679 offset(isfsur)=0
7680 END IF
7681 IF (scalars(ng)%Fstate(isuvel)) THEN
7682 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
7683 END IF
7684 IF (scalars(ng)%Fstate(isvvel)) THEN
7685 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
7686 END IF
7687 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
7688 DO itrc=1,nt(ng)
7689 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
7690 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
7691 iadd=lm(ng)*mm(ng)*n(ng)
7692 END IF
7693 END DO
7694 IF (scalars(ng)%Fstate(isustr)) THEN
7695 offset(isustr)=0
7696 END IF
7697 IF (scalars(ng)%Fstate(isvstr)) THEN
7698 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
7699 END IF
7700 DO itrc=1,nt(ng)
7701 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
7702 IF (itrc.eq.1) THEN
7703 offset(istsur(itrc))=offset(isvstr)+lm(ng)*(mm(ng)-voff)
7704 ELSE
7705 offset(istsur(itrc))=offset(istsur(itrc-1))+lm(ng)*mm(ng)
7706 END IF
7707 END IF
7708 END DO
7709# endif
7710# endif
7711# else
7712# ifdef MASKING
7713 IF (scalars(ng)%Fstate(isfsur)) THEN
7714 offset(isfsur)=0
7715 END IF
7716 IF (scalars(ng)%Fstate(isubar)) THEN
7717 offset(isubar)=offset(isfsur)+nwaterr(ng)
7718 END IF
7719 IF (scalars(ng)%Fstate(isvbar)) THEN
7720 offset(isvbar)=offset(isubar)+nwateru(ng)
7721 END IF
7722 IF (scalars(ng)%Fstate(isustr)) THEN
7723 offset(isustr)=0
7724 END IF
7725 IF (scalars(ng)%Fstate(isvstr)) THEN
7726 offset(isvstr)=offset(isustr)+nwateru(ng)
7727 END IF
7728# else
7729# ifdef FULL_GRID
7730 IF (scalars(ng)%Fstate(isfsur)) THEN
7731 offset(isfsur)=0
7732 END IF
7733 IF (scalars(ng)%Fstate(isubar)) THEN
7734 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
7735 END IF
7736 IF (scalars(ng)%Fstate(isvbar) THEN
7737 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
7738 END IF
7739 IF (scalars(ng)%Fstate(isustr)) THEN
7740 offset(isustr)=0
7741 END IF
7742 IF (scalars(ng)%Fstate(isvstr)) THEN
7743 offset(isvstr)=offset(isustr)+(lm(ng)+1)*(mm(ng)+2)
7744 END IF
7745# else
7746 IF (scalars(ng)%Fstate(isfsur)) THEN
7747 offset(isfsur)=0
7748 END IF
7749 IF (scalars(ng)%Fstate(isubar)) THEN
7750 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
7751 END IF
7752 IF (scalars(ng)%Fstate(isvbar) THEN
7753 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
7754 END IF
7755 IF (scalars(ng)%Fstate(isustr)) THEN
7756 offset(isustr)=0
7757 END IF
7758 IF (scalars(ng)%Fstate(isustr)) THEN
7759 offset(isvstr)=offset(isustr)+(lm(ng)-uoff)*mm(ng)
7760 END IF
7761# endif
7762# endif
7763# endif
7764!
7765! Extract tangent linear free-surface.
7766!
7767 IF (scalars(ng)%Fstate(isfsur)) THEN
7768# ifndef MASKING
7769# ifdef FULL_GRID
7770 imax=lm(ng)+2
7771 ioff=1
7772 joff=0
7773# else
7774 imax=lm(ng)
7775 ioff=0
7776 joff=1
7777# endif
7778# endif
7779# ifdef ENERGYNORM_SCALE
7780 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
7781# else
7782 scale=1.0_r8
7783# endif
7784 DO j=jr_range
7785 DO i=ir_range
7786# ifdef MASKING
7787 IF (rmask(i,j).gt.0.0_r8) THEN
7788 is=ijwaterr(i,j)+offset(isfsur)
7789 f_zeta(i,j)=scale*state(is)
7790 ELSE
7791 f_zeta(i,j)=0.0_r8
7792 END IF
7793# else
7794 is=(i-ioff)+(j-joff)*imax+offset(isfsur)
7795 f_zeta(i,j)=scale*state(is)
7796# endif
7797 END DO
7798 END DO
7799 END IF
7800
7801# ifndef SOLVE3D
7802!
7803! Extract tangent linear 2D U-velocity.
7804!
7805 IF (scalars(ng)%Fstate(isubar)) THEN
7806# ifndef MASKING
7807# ifdef FULL_GRID
7808 imax=lm(ng)+1
7809 ioff=0
7810 joff=0
7811# else
7812 imax=lm(ng)-uoff
7813 ioff=uoff
7814 joff=1
7815# endif
7816# endif
7817# ifdef ENERGYNORM_SCALE
7818 cff=0.25_r8*rho0
7819# else
7820 scale=1.0_r8
7821# endif
7822 DO j=jr_range
7823 DO i=iu_range
7824# ifdef ENERGYNORM_SCALE
7825 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
7826# endif
7827# ifdef MASKING
7828 IF (umask(i,j).gt.0.0_r8) THEN
7829 is=ijwateru(i,j)+offset(isubar)
7830 f_ubar(i,j)=scale*state(is)
7831 ELSE
7832 f_ubar(i,j)=0.0_r8
7833 END IF
7834# else
7835 is=(i-ioff)+(j-joff)*imax+offset(isubar)
7836 f_ubar(i,j)=scale*state(is)
7837# endif
7838 END DO
7839 END DO
7840 END IF
7841!
7842! Extract tangent linear 2D V-velocity.
7843!
7844 IF (scalars(ng)%Fstate(isvbar)) THEN
7845# ifndef MASKING
7846# ifdef FULL_GRID
7847 imax=lm(ng)+2
7848 ioff=1
7849 joff=1
7850# else
7851 imax=lm(ng)
7852 ioff=0
7853 joff=1+voff
7854# endif
7855# endif
7856# ifdef ENERGYNORM_SCALE
7857 cff=0.25_r8*rho0
7858# else
7859 scale=1.0_r8
7860# endif
7861 DO j=jv_range
7862 DO i=ir_range
7863# ifdef ENERGYNORM_SCALE
7864 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
7865# endif
7866# ifdef MASKING
7867 IF (vmask(i,j).gt.0.0_r8) THEN
7868 is=ijwaterv(i,j)+offset(isvbar)
7869 f_vbar(i,j)=scale*state(is)
7870 ELSE
7871 f_vbar(i,j)=0.0_r8
7872 END IF
7873# else
7874 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
7875 f_vbar(i,j)=scale*state(is)
7876# endif
7877 END DO
7878 END DO
7879 END IF
7880
7881# else
7882!
7883! Extract tangent linear 3D U-velocity.
7884!
7885 IF (scalars(ng)%Fstate(isuvel)) THEN
7886# ifndef MASKING
7887# ifdef FULL_GRID
7888 imax=lm(ng)+1
7889 jmax=mm(ng)+2
7890 ioff=0
7891 joff=0
7892# else
7893 imax=lm(ng)-uoff
7894 jmax=mm(ng)
7895 ioff=uoff
7896 joff=1
7897# endif
7898# endif
7899# ifdef ENERGYNORM_SCALE
7900 cff=0.25_r8*rho0
7901# else
7902 scale=1.0_r8
7903# endif
7904 DO k=1,n(ng)
7905# ifdef MASKING
7906 iadd=(k-1)*nwateru(ng)+offset(isuvel)
7907# else
7908 iadd=(k-1)*imax*jmax+offset(isuvel)
7909# endif
7910 DO j=jr_range
7911 DO i=iu_range
7912# ifdef ENERGYNORM_SCALE
7913 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
7914# endif
7915# ifdef MASKING
7916 IF (umask(i,j).gt.0.0_r8) THEN
7917 is=ijwateru(i,j)+iadd
7918 f_u(i,j,k)=scale*state(is)
7919 ELSE
7920 f_u(i,j,k)=0.0_r8
7921 END IF
7922# else
7923 is=(i-ioff)+(j-joff)*imax+iadd
7924 f_u(i,j,k)=scale*state(is)
7925# endif
7926 END DO
7927 END DO
7928 END DO
7929!
7930! Compute the forcing forcing for tl_ubar based on f_u.
7931!
7932 DO j=jr_range
7933 DO i=iu_range
7934 dc(i,0)=0.0_r8
7935 cf(i,0)=0.0_r8
7936 END DO
7937 DO k=1,n(ng)
7938 DO i=iu_range
7939 dc(i,k)=0.5_r8*(hz(i,j,k)+hz(i-1,j,k))
7940 dc(i,0)=dc(i,0)+dc(i,k)
7941 cf(i,0)=cf(i,0)+dc(i,k)*f_u(i,j,k)
7942 END DO
7943 END DO
7944 DO i=iu_range
7945 cff1=1.0_r8/dc(i,0)
7946 cff2=cf(i,0)*cff1
7947# ifdef MASKING
7948 cff2=cff2*umask(i,j)
7949# endif
7950 f_ubar(i,j)=cff2
7951 END DO
7952 END DO
7953 END IF
7954!
7955! Extract tangent linear 3D V-velocity.
7956!
7957 IF (scalars(ng)%Fstate(isvvel)) THEN
7958# ifndef MASKING
7959# ifdef FULL_GRID
7960 imax=lm(ng)+2
7961 jmax=mm(ng)+1
7962 ioff=1
7963 joff=1
7964# else
7965 imax=lm(ng)
7966 jmax=mm(ng)-voff
7967 ioff=0
7968 joff=1+voff
7969# endif
7970# endif
7971# ifdef ENERGYNORM_SCALE
7972 cff=0.25_r8*rho0
7973# else
7974 scale=1.0_r8
7975# endif
7976 DO k=1,n(ng)
7977# ifdef MASKING
7978 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
7979# else
7980 iadd=(k-1)*imax*jmax+offset(isvvel)
7981# endif
7982 DO j=jv_range
7983 DO i=ir_range
7984# ifdef ENERGYNORM_SCALE
7985 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
7986# endif
7987# ifdef MASKING
7988 IF (vmask(i,j).gt.0.0_r8) THEN
7989 is=ijwaterv(i,j)+iadd
7990 f_v(i,j,k)=scale*state(is)
7991 ELSE
7992 f_v(i,j,k)=0.0_r8
7993 END IF
7994# else
7995 is=(i+ioff)+(j-joff)*imax+iadd
7996 f_v(i,j,k)=scale*state(is)
7997# endif
7998 END DO
7999 END DO
8000 END DO
8001!
8002! Compute the forcing forcing for tl_vbar based on f_v.
8003!
8004 DO j=jv_range
8005 IF (j.ge.jstrm) THEN
8006 DO i=ir_range
8007 dc(i,0)=0.0_r8
8008 cf(i,0)=0.0_r8
8009 END DO
8010 DO k=1,n(ng)
8011 DO i=ir_range
8012 dc(i,k)=0.5_r8*(hz(i,j,k)+hz(i,j-1,k))
8013 dc(i,0)=dc(i,0)+dc(i,k)
8014 cf(i,0)=cf(i,0)+dc(i,k)*f_v(i,j,k)
8015 END DO
8016 END DO
8017 DO i=ir_range
8018 cff1=1.0_r8/dc(i,0)
8019 cff2=cf(i,0)*cff1
8020# ifdef MASKING
8021 cff2=cff2*vmask(i,j)
8022# endif
8023 f_vbar(i,j)=cff2
8024 END DO
8025 END IF
8026 END DO
8027 END IF
8028!
8029! Extract tangent linear tracers variables.
8030!
8031 DO itrc=1,nt(ng)
8032 IF (scalars(ng)%Fstate(istvar(itrc))) THEN
8033# ifndef MASKING
8034# ifdef FULL_GRID
8035 imax=lm(ng)+2
8036 jmax=mm(ng)+2
8037 ioff=1
8038 joff=0
8039# else
8040 imax=lm(ng)
8041 jmax=mm(ng)
8042 ioff=0
8043 joff=1
8044# endif
8045# endif
8046# ifdef ENERGYNORM_SCALE
8047 IF (itrc.eq.itemp) THEN
8048 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
8049 ELSE IF (itrc.eq.isalt) THEN
8050 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
8051 ELSE
8052 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
8053 END IF
8054# else
8055 scale=1.0_r8
8056# endif
8057 DO k=1,n(ng)
8058# ifdef MASKING
8059 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
8060# else
8061 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
8062# endif
8063 DO j=jr_range
8064 DO i=ir_range
8065# ifdef ENERGYNORM_SCALE
8066 scale=1.0_r8/sqrt(cff*hz(i,j,k))
8067# endif
8068# ifdef MASKING
8069 IF (rmask(i,j).gt.0.0_r8) THEN
8070 is=ijwaterr(i,j)+iadd
8071 f_t(i,j,k,itrc)=scale*state(is)
8072 ELSE
8073 f_t(i,j,k,itrc)=0.0_r8
8074 END IF
8075# else
8076 is=(i+ioff)+(j-joff)*imax+iadd
8077 f_t(i,j,k,itrc)=scale*state(is)
8078# endif
8079 END DO
8080 END DO
8081 END DO
8082 END IF
8083 END DO
8084# endif
8085
8086# ifdef FORCING_SV
8087!
8088! Impose periodic boundary conditions as appropriate.
8089!
8090 IF (ewperiodic(ng).or.nsperiodic(ng)) THEN
8091 CALL exchange_r2d_tile (ng, tile, &
8092 & lbi, ubi, lbj, ubj, f_zeta)
8093# ifndef SOLVE3D
8094 CALL exchange_u2d_tile (ng, tile, &
8095 & lbi, ubi, lbj, ubj, f_ubar)
8096 CALL exchange_v2d_tile (ng, tile, &
8097 & lbi, ubi, lbj, ubj, f_vbar)
8098# else
8099 CALL exchange_u3d_tile (ng, tile, &
8100 & lbi, ubi, lbj, ubj, 1, n(ng), f_u)
8101 CALL exchange_v3d_tile (ng, tile, &
8102 & lbi, ubi, lbj, ubj, 1, n(ng), f_v)
8103 DO itrc=1,nt(ng)
8104 CALL exchange_r3d_tile (ng, tile, &
8105 & lbi, ubi, lbj, ubj, 1, n(ng), &
8106 & f_t(:,:,:,itrc))
8107 END DO
8108# endif
8109 END IF
8110
8111# ifdef DISTRIBUTE
8112 CALL mp_exchange2d (ng, tile, itlm, 1, &
8113 & lbi, ubi, lbj, ubj, &
8114 & nghostpoints, &
8115 & ewperiodic(ng), nsperiodic(ng), &
8116 & f_zeta)
8117# ifndef SOLVE3D
8118 CALL mp_exchange2d (ng, tile, itlm, 2, &
8119 & lbi, ubi, lbj, ubj, &
8120 & nghostpoints, &
8121 & ewperiodic(ng), nsperiodic(ng), &
8122 & f_ubar, f_vbar)
8123# else
8124 CALL mp_exchange3d (ng, tile, itlm, 2, &
8125 & lbi, ubi, lbj, ubj, 1, n(ng), &
8126 & nghostpoints, &
8127 & ewperiodic(ng), nsperiodic(ng), f_u, f_v)
8128 CALL mp_exchange4d (ng, tile, itlm, 1, &
8129 & lbi, ubi, lbj, ubj, 1, n(ng), 1, nt(ng), &
8130 & nghostpoints, &
8131 & ewperiodic(ng), nsperiodic(ng), f_t)
8132# endif
8133# endif
8134# endif
8135!
8136! Extract tangent linear surface U-momentum stress.
8137!
8138 IF (scalars(ng)%Fstate(isustr)) THEN
8139# ifndef MASKING
8140# ifdef FULL_GRID
8141 imax=lm(ng)+1
8142 ioff=0
8143 joff=0
8144# else
8145 imax=lm(ng)-uoff
8146 ioff=uoff
8147 joff=1
8148# endif
8149# endif
8150 scale=1.0_r8
8151 DO j=jr_range
8152 DO i=iu_range
8153# ifdef MASKING
8154 IF (umask(i,j).gt.0.0_r8) THEN
8155 is=ijwateru(i,j)+offset(isustr)
8156 tl_sustr(i,j)=scale*state(is)
8157 ELSE
8158 tl_sustr(i,j)=0.0_r8
8159 END IF
8160# else
8161 is=(i-ioff)+(j-joff)*imax+offset(isustr)
8162 tl_sustr(i,j)=scale*state(is)
8163# endif
8164 END DO
8165 END DO
8166 END IF
8167!
8168! Extract tangent linear surface V-momentum stress.
8169!
8170 IF (scalars(ng)%Fstate(isvstr)) THEN
8171# ifndef MASKING
8172# ifdef FULL_GRID
8173 imax=lm(ng)+2
8174 ioff=1
8175 joff=1
8176# else
8177 imax=lm(ng)
8178 ioff=0
8179 joff=1+voff
8180# endif
8181# endif
8182 scale=1.0_r8
8183 DO j=jv_range
8184 DO i=ir_range
8185# ifdef MASKING
8186 IF (vmask(i,j).gt.0.0_r8) THEN
8187 is=ijwaterv(i,j)+offset(isvstr)
8188 tl_svstr(i,j)=scale*state(is)
8189 ELSE
8190 tl_svstr(i,j)=0.0_r8
8191 END IF
8192# else
8193 is=(i+ioff)+(j-joff)*imax+offset(isvstr)
8194 tl_svstr(i,j)=scale*state(is)
8195# endif
8196 END DO
8197 END DO
8198 END IF
8199
8200# ifdef SOLVE3D
8201!
8202! Extract tangent linear surface tracer flux variables.
8203!
8204 DO itrc=1,nt(ng)
8205 IF (scalars(ng)%Fstate(istsur(itrc))) THEN
8206# ifndef MASKING
8207# ifdef FULL_GRID
8208 imax=lm(ng)+2
8209 jmax=mm(ng)+2
8210 ioff=1
8211 joff=0
8212# else
8213 imax=lm(ng)
8214 jmax=mm(ng)
8215 ioff=0
8216 joff=1
8217# endif
8218# endif
8219 scale=1.0_r8
8220 DO j=jr_range
8221 DO i=ir_range
8222# ifdef MASKING
8223 IF (rmask(i,j).gt.0.0_r8) THEN
8224 is=ijwaterr(i,j)+offset(istsur(itrc))
8225 tl_stflx(i,j,itrc)=scale*state(is)
8226 ELSE
8227 tl_stflx(i,j,itrc)=0.0_r8
8228 END IF
8229# else
8230 is=(i+ioff)+(j-joff)*imax+offset(istsur(itrc))
8231 tl_stflx(i,j,itrc)=scale*state(is)
8232# endif
8233 END DO
8234 END DO
8235 END IF
8236 END DO
8237# endif
8238!
8239 RETURN
8240 END SUBROUTINE tl_unpack_tile
8241
8242# elif defined TANGENT
8243!
8244 SUBROUTINE tl_unpack (ng, tile, Mstr, Mend, state)
8245!
8246!=======================================================================
8247! !
8248! This routine unpacks the tangent linear variables from the state !
8249! vector. If applicable, the state vector includes only unmasked !
8250! water points. !
8251! !
8252!=======================================================================
8253!
8254 USE mod_param
8255 USE mod_grid
8256 USE mod_ocean
8257 USE mod_stepping
8258# ifdef DISTRIBUTE
8259 USE mod_storage
8260# endif
8261# ifdef DISTRIBUTE
8262!
8263 USE distribute_mod, ONLY : mp_gather_state
8264# endif
8265!
8266! Imported variable declarations.
8267!
8268 integer, intent(in) :: ng, tile
8269 integer, intent(in) :: Mstr, Mend
8270# ifdef ASSUMED_SHAPE
8271 real(r8), intent(in) :: state(Mstr:)
8272# else
8273 real(r8), intent(in) :: state(Mstr:Mend)
8274# endif
8275!
8276! Local variable declarations.
8277!
8278 character (len=*), parameter :: MyFile = &
8279 & __FILE__//", tl_unpack"
8280!
8281# include "tile.h"
8282!
8283# ifdef PROFILE
8284 CALL wclock_on (ng, itlm, 2, __line__, myfile)
8285# endif
8286
8287# ifdef DISTRIBUTE
8288!
8289! Gather (threaded to global) tangent linear state solution from all
8290! distributed nodes.
8291!
8292 CALL mp_gather_state (ng, itlm, mstr, mend, mstate(ng), &
8293 & state, swork)
8294!
8295# endif
8296 CALL tl_unpack_tile (ng, tile, &
8297 & lbi, ubi, lbj, ubj, &
8298 & imins, imaxs, jmins, jmaxs, &
8299 & kstp(ng), &
8300# ifdef SOLVE3D
8301 & nstp(ng), &
8302# endif
8303# ifdef DISTRIBUTE
8304 & 1, mstate(ng), swork, &
8305# else
8306 & mstr, mend, state, &
8307# endif
8308# ifdef MASKING
8309 & grid(ng) % IJwaterR, &
8310 & grid(ng) % IJwaterU, &
8311 & grid(ng) % IJwaterV, &
8312 & grid(ng) % rmask, &
8313 & grid(ng) % umask, &
8314 & grid(ng) % vmask, &
8315# endif
8316 & grid(ng) % h, &
8317# ifdef SOLVE3D
8318 & grid(ng) % Hz, &
8319 & ocean(ng) % tl_t, &
8320 & ocean(ng) % tl_u, &
8321 & ocean(ng) % tl_v, &
8322# else
8323 & ocean(ng) % tl_ubar, &
8324 & ocean(ng) % tl_vbar, &
8325# endif
8326 & ocean(ng) % tl_zeta)
8327# ifdef PROFILE
8328 CALL wclock_off (ng, itlm, 2, __line__, myfile)
8329# endif
8330!
8331 RETURN
8332 END SUBROUTINE tl_unpack
8333!
8334!***********************************************************************
8335 SUBROUTINE tl_unpack_tile (ng, tile, &
8336 & LBi, UBi, LBj, UBj, &
8337 & IminS, ImaxS, JminS, JmaxS, &
8338 & kstp, &
8339# ifdef SOLVE3D
8340 & nstp, &
8341# endif
8342 & Mstr, Mend, state, &
8343# ifdef MASKING
8344 & IJwaterR, IJwaterU, IJwaterV, &
8345 & rmask, umask, vmask, &
8346# endif
8347 & h, &
8348# ifdef SOLVE3D
8349 & Hz, &
8350 & tl_t, tl_u, tl_v, &
8351# else
8352 & tl_ubar, tl_vbar, &
8353# endif
8354 & tl_zeta)
8355!***********************************************************************
8356!
8357 USE mod_param
8358 USE mod_parallel
8359 USE mod_ncparam
8360 USE mod_scalars
8361!
8362! Imported variable declarations.
8363!
8364 integer, intent(in) :: ng, tile
8365 integer, intent(in) :: LBi, UBi, LBj, UBj
8366 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
8367 integer, intent(in) :: Mstr, Mend
8368 integer, intent(in) :: kstp
8369# ifdef SOLVE3D
8370 integer, intent(in) :: nstp
8371# endif
8372!
8373# ifdef ASSUMED_SHAPE
8374# ifdef MASKING
8375 integer, intent(in) :: IJwaterR(LBi:,LBj:)
8376 integer, intent(in) :: IJwaterU(LBi:,LBj:)
8377 integer, intent(in) :: IJwaterV(LBi:,LBj:)
8378
8379 real(r8), intent(in) :: rmask(LBi:,LBj:)
8380 real(r8), intent(in) :: umask(LBi:,LBj:)
8381 real(r8), intent(in) :: vmask(LBi:,LBj:)
8382# endif
8383 real(r8), intent(in) :: state(Mstr:)
8384 real(r8), intent(in) :: h(LBi:,LBj:)
8385# ifdef SOLVE3D
8386 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
8387
8388 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
8389 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
8390 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
8391# else
8392 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
8393 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
8394# endif
8395 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
8396# else
8397# ifdef MASKING
8398 integer, intent(in) :: IJwaterR(LBi:UBi,LBj:UBj)
8399 integer, intent(in) :: IJwaterU(LBi:UBi,LBj:UBj)
8400 integer, intent(in) :: IJwaterV(LBi:UBi,LBj:UBj)
8401
8402 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
8403 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
8404 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
8405# endif
8406 real(r8), intent(in) :: state(Mstr:Mend)
8407 real(r8), intent(in) :: h(LBi:UBi,LBj:UBj)
8408# ifdef SOLVE3D
8409 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
8410
8411 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
8412 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
8413 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
8414# else
8415 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
8416 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
8417# endif
8418 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
8419# endif
8420!
8421! Local variable declarations.
8422!
8423# ifndef MASKING
8424 integer :: Imax, Ioff, Jmax, Joff
8425# endif
8426 integer :: Uoff, Voff
8427 integer :: i, iadd, is, itrc, j, k
8428
8429 integer, dimension(5+NT(ng)) :: offset
8430
8431 real(r8) :: cff, scale
8432
8433# include "set_bounds.h"
8434!
8435!-----------------------------------------------------------------------
8436! Extract tangent linear STATE variables from full 1D state vector.
8437!-----------------------------------------------------------------------
8438!
8439! Set offsets for momentum variables due to periodic boundary
8440! conditions. Recall that in East-West periodic boundary conditions
8441! IstrU=1. Otherwise, IstrU=2. Similarly, in North-South periodic
8442! applications IstrV=1 or else IstrV=2.
8443!
8444 IF (ewperiodic(ng)) THEN
8445 uoff=0
8446 ELSE
8447 uoff=1
8448 END IF
8449!
8450 IF (nsperiodic(ng)) THEN
8451 voff=0
8452 ELSE
8453 voff=1
8454 END IF
8455!
8456! Determine the index offset for each variable in the state vector.
8457# ifdef MASKING
8458! Notice that in Land/Sea masking application the state vector only
8459! contains water points to avoid large null space.
8460# endif
8461!
8462# ifdef SOLVE3D
8463# ifdef MASKING
8464 offset(isfsur)=0
8465 offset(isuvel)=offset(isfsur)+nwaterr(ng)
8466 offset(isvvel)=offset(isuvel)+nwateru(ng)*n(ng)
8467 iadd=nwaterv(ng)*n(ng)
8468 DO itrc=1,nt(ng)
8469 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
8470 iadd=nwaterr(ng)*n(ng)
8471 END DO
8472# else
8473# ifdef FULL_GRID
8474 offset(isfsur)=0
8475 offset(isuvel)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
8476 offset(isvvel)=offset(isuvel)+(lm(ng)+1)*(mm(ng)+2)*n(ng)
8477 iadd=(lm(ng)+2)*(mm(ng)+1)*n(ng)
8478 DO itrc=1,nt(ng)
8479 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
8480 iadd=(lm(ng)+2)*(mm(ng)+2)*n(ng)
8481 END DO
8482# else
8483 offset(isfsur)=0
8484 offset(isuvel)=offset(isfsur)+lm(ng)*mm(ng)
8485 offset(isvvel)=offset(isuvel)+(lm(ng)-uoff)*mm(ng)*n(ng)
8486 iadd=lm(ng)*(mm(ng)-voff)*n(ng)
8487 DO itrc=1,nt(ng)
8488 offset(istvar(itrc))=offset(istvar(itrc)-1)+iadd
8489 iadd=lm(ng)*mm(ng)*n(ng)
8490 END DO
8491# endif
8492# endif
8493# else
8494# ifdef MASKING
8495 offset(isfsur)=0
8496 offset(isubar)=offset(isfsur)+nwaterr(ng)
8497 offset(isvbar)=offset(isubar)+nwateru(ng)
8498# else
8499# ifdef FULL_GRID
8500 offset(isfsur)=0
8501 offset(isubar)=offset(isfsur)+(lm(ng)+2)*(mm(ng)+2)
8502 offset(isvbar)=offset(isubar)+(lm(ng)+1)*(mm(ng)+2)
8503# else
8504 offset(isfsur)=0
8505 offset(isubar)=offset(isfsur)+lm(ng)*mm(ng)
8506 offset(isvbar)=offset(isubar)+(lm(ng)-uoff)*mm(ng)
8507# endif
8508# endif
8509# endif
8510!
8511! Extract tangent linear free-surface.
8512!
8513# ifndef MASKING
8514# ifdef FULL_GRID
8515 imax=lm(ng)+2
8516 ioff=1
8517 joff=0
8518# else
8519 imax=lm(ng)
8520 ioff=0
8521 joff=1
8522# endif
8523# endif
8524# ifdef ENERGYNORM_SCALE
8525 scale=1.0_r8/sqrt(0.5_r8*g*rho0)
8526# else
8527 scale=1.0_r8
8528# endif
8529 DO j=jr_range
8530 DO i=ir_range
8531# ifdef MASKING
8532 IF (rmask(i,j).gt.0.0_r8) THEN
8533 is=ijwaterr(i,j)+offset(isfsur)
8534 tl_zeta(i,j,kstp)=scale*state(is)
8535 ELSE
8536 tl_zeta(i,j,kstp)=0.0_r8
8537 END IF
8538# else
8539 is=(i+ioff)+(j-joff)*imax+offset(isfsur)
8540 tl_zeta(i,j,kstp)=scale*state(is)
8541# endif
8542 END DO
8543 END DO
8544
8545# ifndef SOLVE3D
8546!
8547! Extract tangent linear 2D U-velocity.
8548!
8549# ifndef MASKING
8550# ifdef FULL_GRID
8551 imax=lm(ng)+1
8552 ioff=0
8553 joff=0
8554# else
8555 imax=lm(ng)-uoff
8556 ioff=uoff
8557 joff=1
8558# endif
8559# endif
8560# ifdef ENERGYNORM_SCALE
8561 cff=0.25_r8*rho0
8562# else
8563 scale=1.0_r8
8564# endif
8565 DO j=jr_range
8566 DO i=iu_range
8567# ifdef ENERGYNORM_SCALE
8568 scale=1.0_r8/sqrt(cff*(h(i-1,j)+h(i,j)))
8569# endif
8570# ifdef MASKING
8571 IF (umask(i,j).gt.0.0_r8) THEN
8572 is=ijwateru(i,j)+offset(isubar)
8573 tl_ubar(i,j,kstp)=scale*state(is)
8574 ELSE
8575 tl_ubar(i,j,kstp)=0.0_r8
8576 END IF
8577# else
8578 is=(i-ioff)+(j-joff)*imax+offset(isubar)
8579 tl_ubar(i,j,kstp)=scale*state(is)
8580# endif
8581 END DO
8582 END DO
8583!
8584! Extract tangent linear 2D V-velocity.
8585!
8586# ifndef MASKING
8587# ifdef FULL_GRID
8588 imax=lm(ng)+2
8589 ioff=1
8590 joff=1
8591# else
8592 imax=lm(ng)
8593 ioff=0
8594 joff=1+voff
8595# endif
8596# endif
8597# ifdef ENERGYNORM_SCALE
8598 cff=0.25_r8*rho0
8599# else
8600 scale=1.0_r8
8601# endif
8602 DO j=jv_range
8603 DO i=ir_range
8604# ifdef ENERGYNORM_SCALE
8605 scale=1.0_r8/sqrt(cff*(h(i,j-1)+h(i,j)))
8606# endif
8607# ifdef MASKING
8608 IF (vmask(i,j).gt.0.0_r8) THEN
8609 is=ijwaterv(i,j)+offset(isvbar)
8610 tl_vbar(i,j,kstp)=scale*state(is)
8611 ELSE
8612 tl_vbar(i,j,kstp)=0.0_r8
8613 END IF
8614# else
8615 is=(i+ioff)+(j-joff)*imax+offset(isvbar)
8616 tl_vbar(i,j,kstp)=scale*state(is)
8617# endif
8618 END DO
8619 END DO
8620
8621# else
8622!
8623! Extract tangent linear 3D U-velocity.
8624!
8625# ifndef MASKING
8626# ifdef FULL_GRID
8627 imax=lm(ng)+1
8628 jmax=mm(ng)+2
8629 ioff=0
8630 joff=0
8631# else
8632 imax=lm(ng)-uoff
8633 jmax=mm(ng)
8634 ioff=uoff
8635 joff=1
8636# endif
8637# endif
8638# ifdef ENERGYNORM_SCALE
8639 cff=0.25_r8*rho0
8640# else
8641 scale=1.0_r8
8642# endif
8643 DO k=1,n(ng)
8644# ifdef MASKING
8645 iadd=(k-1)*nwateru(ng)+offset(isuvel)
8646# else
8647 iadd=(k-1)*imax*jmax+offset(isuvel)
8648# endif
8649 DO j=jr_range
8650 DO i=iu_range
8651# ifdef MASKING
8652 IF (umask(i,j).gt.0.0_r8) THEN
8653# ifdef ENERGYNORM_SCALE
8654 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
8655# endif
8656 is=ijwateru(i,j)+iadd
8657 tl_u(i,j,k,nstp)=scale*state(is)
8658 ELSE
8659 tl_u(i,j,k,nstp)=0.0_r8
8660 END IF
8661# else
8662# ifdef ENERGYNORM_SCALE
8663 scale=1.0_r8/sqrt(cff*(hz(i-1,j,k)+hz(i,j,k)))
8664# endif
8665 is=(i-ioff)+(j-joff)*imax+iadd
8666 tl_u(i,j,k,nstp)=scale*state(is)
8667# endif
8668 END DO
8669 END DO
8670 END DO
8671!
8672! Extract tangent linear 3D V-velocity.
8673!
8674# ifndef MASKING
8675# ifdef FULL_GRID
8676 imax=lm(ng)+2
8677 jmax=mm(ng)+1
8678 ioff=1
8679 joff=1
8680# else
8681 imax=lm(ng)
8682 jmax=mm(ng)-voff
8683 ioff=0
8684 joff=1+voff
8685# endif
8686# endif
8687# ifdef ENERGYNORM_SCALE
8688 cff=0.25_r8*rho0
8689# else
8690 scale=1.0_r8
8691# endif
8692 DO k=1,n(ng)
8693# ifdef MASKING
8694 iadd=(k-1)*nwaterv(ng)+offset(isvvel)
8695# else
8696 iadd=(k-1)*imax*jmax+offset(isvvel)
8697# endif
8698 DO j=jv_range
8699 DO i=ir_range
8700# ifdef MASKING
8701 IF (vmask(i,j).gt.0.0_r8) THEN
8702# ifdef ENERGYNORM_SCALE
8703 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
8704# endif
8705 is=ijwaterv(i,j)+iadd
8706 tl_v(i,j,k,nstp)=scale*state(is)
8707 ELSE
8708 tl_v(i,j,k,nstp)=0.0_r8
8709 END IF
8710# else
8711# ifdef ENERGYNORM_SCALE
8712 scale=1.0_r8/sqrt(cff*(hz(i,j-1,k)+hz(i,j,k)))
8713# endif
8714 is=(i+ioff)+(j-joff)*imax+iadd
8715 tl_v(i,j,k,nstp)=scale*state(is)
8716# endif
8717 END DO
8718 END DO
8719 END DO
8720!
8721! Extract tangent linear tracers variables. For now, use salinity scale
8722! for passive tracers.
8723!
8724# ifndef MASKING
8725# ifdef FULL_GRID
8726 imax=lm(ng)+2
8727 jmax=mm(ng)+2
8728 ioff=1
8729 joff=0
8730# else
8731 imax=lm(ng)
8732 jmax=mm(ng)
8733 ioff=0
8734 joff=1
8735# endif
8736# endif
8737 DO itrc=1,nt(ng)
8738# ifdef ENERGYNORM_SCALE
8739 IF (itrc.eq.itemp) THEN
8740 cff=0.5_r8*rho0*tcoef(ng)*tcoef(ng)*g*g/bvf_bak
8741 ELSE IF (itrc.eq.isalt) THEN
8742 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
8743 ELSE
8744 cff=0.5_r8*rho0*scoef(ng)*scoef(ng)*g*g/bvf_bak
8745 END IF
8746# else
8747 scale=1.0_r8
8748# endif
8749 DO k=1,n(ng)
8750# ifdef MASKING
8751 iadd=(k-1)*nwaterr(ng)+offset(istvar(itrc))
8752# else
8753 iadd=(k-1)*imax*jmax+offset(istvar(itrc))
8754# endif
8755 DO j=jr_range
8756 DO i=ir_range
8757# ifdef MASKING
8758 IF (rmask(i,j).gt.0.0_r8) THEN
8759# ifdef ENERGYNORM_SCALE
8760 scale=1.0_r8/sqrt(cff*hz(i,j,k))
8761# endif
8762 is=ijwaterr(i,j)+iadd
8763 tl_t(i,j,k,nstp,itrc)=scale*state(is)
8764 ELSE
8765 tl_t(i,j,k,nstp,itrc)=0.0_r8
8766 END IF
8767# else
8768# ifdef ENERGYNORM_SCALE
8769 scale=1.0_r8/sqrt(cff*hz(i,j,k))
8770# endif
8771 is=(i+ioff)+(j-joff)*imax+iadd
8772 tl_t(i,j,k,nstp,itrc)=scale*state(is)
8773# endif
8774 END DO
8775 END DO
8776 END DO
8777 END DO
8778# endif
8779!
8780 RETURN
8781 END SUBROUTINE tl_unpack_tile
8782# endif
8783
8784# ifdef SO_SEMI
8785# ifdef SO_SEMI_WHITE
8786!
8787 SUBROUTINE so_semi_white (ng, tile, Mstr, Mend, state, ad_state)
8788!
8789!=======================================================================
8790! !
8791! This routine computes a new stochastic optimals perturbation vector !
8792! (seminorm estimation) assuming white noise forcing using ARPACK. !
8793! !
8794!=======================================================================
8795!
8796 USE mod_param
8797 USE mod_parallel
8798 USE mod_scalars
8799 USE mod_storage
8800# ifdef DISTRIBUTE
8801!
8802 USE distribute_mod, ONLY : mp_reduce
8803# endif
8804!
8805! Imported variable declarations.
8806!
8807 integer, intent(in) :: ng, tile
8808 integer, intent(in) :: Mstr, Mend
8809# ifdef ASSUMED_SHAPE
8810 real(r8), intent(in) :: state(Mstr:)
8811 real(r8), intent(out) :: ad_state(Mstr:)
8812# else
8813 real(r8), intent(in) :: state(Mstr:Mend)
8814 real(r8), intent(out) :: ad_state(Mstr:Mend)
8815# endif
8816!
8817! Local variable declarations.
8818!
8819 integer :: NSUB, is, rec
8820
8821 real(r8) :: SOnorm, my_SOnorm, my_TRnorm
8822 real(r8) :: SOnorm1, my_SOnorm1
8823 real(r8) :: cff, cff1, cff2
8824
8825# ifdef DISTRIBUTE
8826 real(r8), dimension(3) :: rbuffer
8827
8828 character (len=3), dimension(3) :: op_handle
8829# endif
8830
8831# include "tile.h"
8832!
8833!-----------------------------------------------------------------------
8834! Compute seminorm, stochastic optimals adjoint perturbation vector.
8835!-----------------------------------------------------------------------
8836!
8837! Initialize adjoint state vector.
8838!
8839 DO is=mstr,mend
8840 ad_state(is)=0.0_r8
8841 END DO
8842!
8843! Sum over all adjoint surface forcing records available in "so_state'.
8844!
8845 IF (master) THEN
8846 WRITE (stdout,'(/)')
8847 END IF
8848 my_trnorm=0.0_r8
8849!
8850 DO rec=1,nsemi(ng)
8851!
8852! Compute normalization factor.
8853!
8854 cff=real((nadj(ng)-1)*(2*nadj(ng)-1),r8)/real(6*nadj(ng),r8)
8855 cff1=1.0_r8+cff
8856 cff2=0.5_r8*real((nadj(ng)-1))-cff
8857!
8858 my_sonorm=0.0_r8
8859 my_sonorm1=0.0_r8
8860 DO is=mstr,mend
8861 my_sonorm=my_sonorm+ &
8862 & storage(ng)%so_state(is,rec)*state(is)
8863 END DO
8864!
8865 IF (rec.ne.nsemi(ng)) THEN
8866 DO is=mstr,mend
8867 my_sonorm1=my_sonorm1+ &
8868 & storage(ng)%so_state(is,rec+1)*state(is)
8869 my_trnorm=my_trnorm+ &
8870 & cff1*storage(ng)%so_state(is,rec)* &
8871 & storage(ng)%so_state(is,rec)+ &
8872 & 2.0_r8*cff2*storage(ng)%so_state(is,rec )* &
8873 & storage(ng)%so_state(is,rec+1)+ &
8874 & cff*storage(ng)%so_state(is,rec+1)* &
8875 & storage(ng)%so_state(is,rec+1)
8876 END DO
8877 ELSE
8878 DO is=mstr,mend
8879 my_trnorm=my_trnorm+ &
8880 & storage(ng)%so_state(is,rec)* &
8881 & storage(ng)%so_state(is,rec)
8882 END DO
8883 END IF
8884!
8885! Global reduction of normalization factor.
8886!
8887# ifdef DISTRIBUTE
8888 nsub=1 ! distributed-memory
8889# else
8890 IF (domain(ng)%SouthWest_Corner(tile).and. &
8891 & domain(ng)%NorthEast_Corner(tile)) THEN
8892 nsub=1 ! non-tiled application
8893 ELSE
8894 nsub=ntilex(ng)*ntilee(ng) ! tiled application
8895 END IF
8896# endif
8897!$OMP CRITICAL (SO_NORM)
8898 IF (tile_count.eq.0) THEN
8899 sonorm=0.0_r8
8900 sonorm1=0.0_r8
8901 IF (rec.eq.1) THEN
8902 trnorm(ng)=0.0_r8
8903 END IF
8904 END IF
8905 sonorm=sonorm+my_sonorm
8906 sonorm1=sonorm1+my_sonorm1
8907 tile_count=tile_count+1
8908 IF (tile_count.eq.nsub) THEN
8909 tile_count=0
8910# ifdef DISTRIBUTE
8911 rbuffer(1)=sonorm
8912 rbuffer(2)=sonorm1
8913 op_handle(1)='SUM'
8914 op_handle(2)='SUM'
8915 CALL mp_reduce (ng, iadm, 2, rbuffer, op_handle)
8916 sonorm=rbuffer(1)
8917 sonorm1=rbuffer(2)
8918# endif
8919 END IF
8920!$OMP END CRITICAL (SO_NORM)
8921!
8922! Report normalization factors.
8923!
8924 IF (master) THEN
8925 WRITE (stdout,10) rec, sonorm, sonorm1
8926 10 FORMAT (3x,'Rec = ',i2.2,2x,'SOnorm = ',1p,e15.8,0p, &
8927 & 2x,'SOnorm1 = ',1p,e15.8)
8928 END IF
8929!
8930! Compute new perturbation vector.
8931!
8932 IF (rec.ne.nsemi(ng)) THEN
8933 DO is=mstr,mend
8934 ad_state(is)=ad_state(is)+ &
8935 & cff1*sonorm *storage(ng)%so_state(is,rec )+ &
8936 & cff2*sonorm1*storage(ng)%so_state(is,rec )+ &
8937 & cff2*sonorm *storage(ng)%so_state(is,rec+1)+ &
8938 & cff *sonorm1*storage(ng)%so_state(is,rec+1)
8939 END DO
8940 ELSE
8941 DO is=mstr,mend
8942 ad_state(is)=ad_state(is)+ &
8943 & sonorm*storage(ng)%so_state(is,rec)
8944 END DO
8945 END IF
8946 END DO
8947!
8948! Global reduction of normalization factor, TRnorm.
8949!
8950# ifdef DISTRIBUTE
8951 nsub=1 ! distributed-memory
8952# else
8953 IF (domain(ng)%SouthWest_Corner(tile).and. &
8954 & domain(ng)%NorthEast_Corner(tile)) THEN
8955 nsub=1 ! non-tiled application
8956 ELSE
8957 nsub=ntilex(ng)*ntilee(ng) ! tiled application
8958 END IF
8959# endif
8960!$OMP CRITICAL (TR_NORM)
8961 IF (tile_count.eq.0) THEN
8962 trnorm(ng)=0.0_r8
8963 END IF
8964 trnorm(ng)=trnorm(ng)+my_trnorm
8965 tile_count=tile_count+1
8966 IF (tile_count.eq.nsub) THEN
8967 tile_count=0
8968# ifdef DISTRIBUTE
8969 op_handle(1)='SUM'
8970 CALL mp_reduce (ng, iadm, 1, trnorm(ng), op_handle(1))
8971# endif
8972 END IF
8973!$OMP END CRITICAL (TR_NORM)
8974!
8975 RETURN
8976 END SUBROUTINE so_semi_white
8977
8978# else
8979!
8980 SUBROUTINE so_semi_red (ng, tile, Mstr, Mend, state, ad_state)
8981!
8982!=======================================================================
8983! !
8984! This routine computes a new stochastic optimals perturbation vector !
8985! (seminorm estimation) assuming red noise forcing using ARPACK. !
8986! !
8987!=======================================================================
8988!
8989 USE mod_param
8990 USE mod_parallel
8991 USE mod_iounits
8992 USE mod_storage
8993 USE mod_scalars
8994# ifdef DISTRIBUTE
8995!
8996 USE distribute_mod, ONLY : mp_reduce
8997# endif
8998!
8999! Imported variable declarations.
9000!
9001 integer, intent(in) :: ng, tile
9002 integer, intent(in) :: Mstr, Mend
9003# ifdef ASSUMED_SHAPE
9004 real(r8), intent(in) :: state(Mstr:)
9005 real(r8), intent(out) :: ad_state(Mstr:)
9006# else
9007 real(r8), intent(in) :: state(Mstr:Mend)
9008 real(r8), intent(out) :: ad_state(Mstr:Mend)
9009# endif
9010!
9011! Local variable declarations.
9012!
9013 integer :: NSUB, is, ntAD, ntTL, rec, rec1
9014
9015 real(r8) :: SOnorm, my_TRnorm
9016
9017 real(r8), dimension(Nsemi(ng)) :: Bcoef
9018 real(r8), dimension(Nsemi(ng)) :: SOdotprod
9019 real(r8), dimension(Nsemi(ng)) :: my_dotprod
9020
9021# ifdef DISTRIBUTE
9022 character (len=3), dimension(Nsemi(ng)) :: op_handle
9023# endif
9024
9025# include "tile.h"
9026!
9027!-----------------------------------------------------------------------
9028! Compute seminorm, stochastic optimals adjoint perturbation vector.
9029!-----------------------------------------------------------------------
9030!
9031! Initialize adjoint state vector.
9032!
9033 DO is=mstr,mend
9034 ad_state(is)=0.0_r8
9035 END DO
9036!
9037! First compute the dot-products.
9038!
9039 DO rec=1,nsemi(ng)
9040 my_dotprod(rec)=0.0_r8
9041 DO is=mstr,mend
9042 my_dotprod(rec)=my_dotprod(rec)+ &
9043 & storage(ng)%so_state(is,rec)*state(is)
9044 END DO
9045 END DO
9046!
9047! Global reduction of dot products.
9048!
9049# ifdef DISTRIBUTE
9050 nsub=1 ! distributed-memory
9051# else
9052 IF (domain(ng)%SouthWest_Corner(tile).and. &
9053 & domain(ng)%NorthEast_Corner(tile)) THEN
9054 nsub=1 ! non-tiled application
9055 ELSE
9056 nsub=ntilex(ng)*ntilee(ng) ! tiled application
9057 END IF
9058# endif
9059!$OMP CRITICAL (SO_DOT)
9060 IF (tile_count.eq.0) THEN
9061 DO rec=1,nsemi(ng)
9062 sodotprod(rec)=0.0_r8
9063 END DO
9064 END IF
9065 DO rec=1,nsemi(ng)
9066 sodotprod(rec)=sodotprod(rec)+my_dotprod(rec)
9067 END DO
9068 tile_count=tile_count+1
9069 IF (tile_count.eq.nsub) THEN
9070 tile_count=0
9071# ifdef DISTRIBUTE
9072 DO rec=1,nsemi(ng)
9073 op_handle(rec)='SUM'
9074 END DO
9075 CALL mp_reduce (ng, iadm, nsemi(ng), sodotprod, op_handle)
9076# endif
9077 END IF
9078!$OMP END CRITICAL (SO_DOT)
9079!
9080! Second, loop over time twice allowing for the decorrelation due to the
9081! red noise AR(1) process with assumed decorrelation time SOdecay.
9082!
9083 IF (master) THEN
9084 WRITE (stdout,'(/)')
9085 END IF
9086 my_trnorm=0.0_r8
9087!
9088 DO rec=1,nsemi(ng)
9089 ntad=(rec-1)*nadj(ng)+1
9090 sonorm=0.0_r8
9091 DO rec1=1,nsemi(ng)
9092 nttl=(rec1-1)*nadj(ng)+1
9093 CALL sp_bcoef (ng, ntad, nttl, bcoef(rec1))
9094 sonorm=sonorm+bcoef(rec1)*sodotprod(rec1)
9095 DO is=mstr,mend
9096 my_trnorm=my_trnorm+ &
9097 & storage(ng)%so_state(is,rec )*bcoef(rec1)* &
9098 & storage(ng)%so_state(is,rec1)
9099 END DO
9100 END DO
9101!
9102! Report normalization factors.
9103!
9104 IF (master) THEN
9105 WRITE (stdout,10) rec, sodotprod(rec), bcoef(rec), sonorm
9106 10 FORMAT (1x,'Rec = ',i2.2,1x,'SOdotprod = ',1p,e13.6,0p, &
9107 & 1x,'Bcoef = ',1p,e13.6,0p,1x,'SOnorm = ',1p,e13.6)
9108 END IF
9109!
9110! Compute new perturbation vector.
9111!
9112 DO is=mstr,mend
9113 ad_state(is)=ad_state(is)+ &
9114 & sonorm*storage(ng)%so_state(is,rec)
9115 END DO
9116 END DO
9117!
9118! Global reduction of normalization factor, TRnorm.
9119!
9120# ifdef DISTRIBUTE
9121 nsub=1 ! distributed-memory
9122# else
9123 IF (domain(ng)%SouthWest_Corner(tile).and. &
9124 & domain(ng)%NorthEast_Corner(tile)) THEN
9125 nsub=1 ! non-tiled application
9126 ELSE
9127 nsub=ntilex(ng)*ntilee(ng) ! tiled application
9128 END IF
9129# endif
9130!$OMP CRITICAL (TR_NORM)
9131 IF (tile_count.eq.0) THEN
9132 trnorm(ng)=0.0_r8
9133 END IF
9134 trnorm(ng)=trnorm(ng)+my_trnorm
9135 tile_count=tile_count+1
9136 IF (tile_count.eq.nsub) THEN
9137 tile_count=0
9138# ifdef DISTRIBUTE
9139 op_handle(1)='SUM'
9140 CALL mp_reduce (ng, iadm, 1, trnorm(ng), op_handle(1))
9141# endif
9142 END IF
9143!$OMP END CRITICAL (TR_NORM)
9144!
9145 RETURN
9146 END SUBROUTINE so_semi_red
9147# endif
9148# endif
9149
9150# if defined SO_SEMI || !defined STOCH_OPT_WHITE
9151!
9152 SUBROUTINE sp_bcoef (ng, ntAD, ntTL, Bcoef)
9153!
9154!=======================================================================
9155! !
9156! This routine is used to compute red noise stochastic processes !
9157! time-lagged coefficient, Bcoef, used to evaluate discrete !
9158! double-time integrals. Currently, a discrete-time Markov chain !
9159! model is assumed with autoregressive order-one processes, AR(1). !
9160! Notice that the routine SP_ACOEF is called to compute the inner !
9161! integral. !
9162! !
9163!=======================================================================
9164!
9165 USE mod_scalars
9166!
9167! Imported variable declarations.
9168!
9169 integer, intent(in) :: ng, ntAD, ntTL
9170
9171 real(r8), intent(out):: Bcoef
9172!
9173! Local variable declarations.
9174!
9175 integer :: i, it1, it2
9176
9177 real(r8) :: Acoef, Acoef1, Acoef2, df1, rov
9178
9179!
9180!-----------------------------------------------------------------------
9181! Compute red noise stochastic process time-lagged coefficient to
9182! evaluate discrete double time-integrals. Currently, only Markov
9183! processes, AR(1), are considered.
9184!-----------------------------------------------------------------------
9185!
9186! Here, ntAD is the current model timestep and ntTL is the timestep
9187! associated with forcing.
9188!
9189 rov=1.0_r8/real(nadj(ng),r8)
9190!
9191 IF ((ntad.gt.1).and.(ntad.lt.ntimes(ng)+1)) THEN
9192 it1=ntad
9193 it2=ntad-nadj(ng)
9194 CALL sp_acoef (ng, it1, nttl, acoef)
9195 bcoef=acoef
9196 DO i=1,nadj(ng)-1
9197 CALL sp_acoef (ng, it1+i, nttl, acoef1)
9198 CALL sp_acoef (ng, it2+i, nttl, acoef2)
9199 df1=real(i,r8)*rov
9200 bcoef=bcoef+(1.0_r8-df1)*acoef1+df1*acoef2
9201 END DO
9202 ELSE IF (ntad.eq.1) THEN
9203 CALL sp_acoef (ng, 1, nttl, acoef)
9204 bcoef=acoef
9205 DO i=1,nadj(ng)-1
9206 CALL sp_acoef (ng, 1+i, nttl, acoef1)
9207 df1=real(i,r8)*rov
9208 bcoef=bcoef+(1.0_r8-df1)*acoef1
9209 END DO
9210 ELSE IF (ntad.eq.ntimes(ng)+1) THEN
9211 CALL sp_acoef (ng, ntimes(ng)+1, nttl, acoef)
9212 bcoef=acoef
9213 DO i=1,nadj(ng)-1
9214 CALL sp_acoef (ng, ntimes(ng)+1-nadj(ng)+i, nttl, acoef1)
9215 df1=real(i,r8)*rov
9216 bcoef=bcoef+df1*acoef1
9217 END DO
9218 END IF
9219!
9220 RETURN
9221 END SUBROUTINE sp_bcoef
9222!
9223 SUBROUTINE sp_acoef (ng, ntAD, ntTL, Acoef)
9224!
9225!=======================================================================
9226! !
9227! This routine is used to compute red noise stochastic processes !
9228! time-lagged coefficient, Acoef, used to evaluate inner time !
9229! integral. Currently, a discrete-time Markov chain model is !
9230! assumed with autoregressive order-one processes, AR(1). Notice !
9231! that function SP_AUTOC is used to set autocorrelation model. !
9232! !
9233!=======================================================================
9234!
9235 USE mod_scalars
9236!
9237! Imported variable declarations.
9238!
9239 integer, intent(in) :: ng, ntAD, ntTL
9240
9241 real(r8), intent(out):: Acoef
9242!
9243! Local variable declarations.
9244!
9245 integer :: i, idf1, idf2, idf4
9246
9247 real(r8) :: df3, rov
9248!
9249!-----------------------------------------------------------------------
9250! Compute red noise stochastic process time-lagged coefficients to
9251! evaluate discrete inner time-integral. Currently, only Markov
9252! processes, AR(1), are considered.
9253!-----------------------------------------------------------------------
9254!
9255! Here, ntAD is the current timestep corresponding to time when
9256! solution is saved.
9257!
9258 rov=1.0_r8/real(nadj(ng),r8)
9259 IF ((nttl.gt.1).and.(nttl.lt.ntimes(ng)+1)) THEN
9260 acoef=0.0_r8
9261 DO i=1,nadj(ng)-1
9262 idf1=iabs(ntad-nttl-i)+1
9263 idf2=iabs(ntad-(nttl-nadj(ng))-i)+1
9264 df3=real(i,r8)*rov
9265 acoef=acoef+sp_autoc(ng,idf1)*(1.0_r8-df3)+ &
9266 & sp_autoc(ng,idf2)*df3
9267 END DO
9268 idf4=iabs(ntad-nttl)+1
9269 acoef=acoef+sp_autoc(ng,idf4)
9270 ELSE IF (nttl.eq.1) THEN
9271 acoef=0.0_r8
9272 DO i=1,nadj(ng)-1
9273 idf1=iabs(ntad-1-i)+1
9274 df3=real(i,r8)*rov
9275 acoef=acoef+sp_autoc(ng,idf1)*(1.0_r8-df3)
9276 END DO
9277 idf4=iabs(ntad-1)+1
9278 acoef=acoef+sp_autoc(ng,idf4)
9279 ELSE IF (nttl.eq.ntimes(ng)+1) THEN
9280 acoef=0.0_r8
9281 DO i=1,nadj(ng)-1
9282 idf2=iabs(ntad-ntimes(ng)-1+nadj(ng)-i)+1
9283 df3=real(i,r8)*rov
9284 acoef=acoef+sp_autoc(ng,idf2)*df3
9285 END DO
9286 idf4=iabs(ntad-ntimes(ng)-1)+1
9287 acoef=acoef+sp_autoc(ng,idf4)
9288 END IF
9289!
9290 RETURN
9291 END SUBROUTINE sp_acoef
9292!
9293 FUNCTION sp_autoc (ng, idf)
9294!
9295!=======================================================================
9296! !
9297! This routine is used to compute red noise stochastic processes !
9298! autocorrelation model. Notice that only AR(1) processes are !
9299! considered. However, other models can be easily implemented in !
9300! terms of look tables. !
9301!
9302!=======================================================================
9303!
9304 USE mod_scalars
9305!
9306! Imported variable declarations.
9307!
9308 integer, intent(in) :: ng, idf
9309!
9310! Function result.
9311!
9312 real(r8) :: sp_autoc
9313!
9314!-----------------------------------------------------------------------
9315! Set autocorrelation model.
9316!-----------------------------------------------------------------------
9317# ifdef SO_NON_AR1
9318!
9319! Use a user-defined temporal decorrelation function such as in the
9320! form of a look-up table computed from actual data.
9321!
9322 sp_autoc=0.0_r8
9323# else
9324!
9325! Assume an AR(1) process with decorrelation time SO_decay.
9326!
9327 sp_autoc=exp(-abs(real(idf-1,r8))*dt(ng)/so_decay(ng))
9328# endif
9329!
9330 RETURN
9331 END FUNCTION sp_autoc
9332# endif
9333#endif
9334
9335#undef IR_RANGE
9336#undef IU_RANGE
9337#undef JR_RANGE
9338#undef JV_RANGE
9339
9340 END MODULE packing_mod
distribute_mod::mp_bcastf
Definition distribute.F:75
distribute_mod::mp_reduce
Definition distribute.F:113
nf_fread2d_mod::nf_fread2d
Definition nf_fread2d.F:69
nf_fread3d_mod::nf_fread3d
Definition nf_fread3d.F:69
ad_exchange_2d_mod
Definition ad_exchange_2d.F:2
ad_exchange_2d_mod::ad_exchange_u2d_tile
subroutine ad_exchange_u2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:816
ad_exchange_2d_mod::ad_exchange_v2d_tile
subroutine ad_exchange_v2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:1201
ad_exchange_2d_mod::ad_exchange_r2d_tile
subroutine ad_exchange_r2d_tile(ng, tile, lbi, ubi, lbj, ubj, ad_a)
Definition ad_exchange_2d.F:431
ad_exchange_3d_mod
Definition ad_exchange_3d.F:2
ad_exchange_3d_mod::ad_exchange_v3d_tile
subroutine ad_exchange_v3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
Definition ad_exchange_3d.F:1283
ad_exchange_3d_mod::ad_exchange_r3d_tile
subroutine ad_exchange_r3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
Definition ad_exchange_3d.F:461
ad_exchange_3d_mod::ad_exchange_u3d_tile
subroutine ad_exchange_u3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, ad_a)
Definition ad_exchange_3d.F:872
distribute_mod
Definition distribute.F:3
distribute_mod::mp_gather_state
subroutine mp_gather_state(ng, model, mstr, mend, asize, a, awrk)
Definition distribute.F:5143
distribute_mod::mp_scatter_state
subroutine mp_scatter_state(ng, model, mstr, mend, asize, a, awrk)
Definition distribute.F:8502
exchange_2d_mod
Definition exchange_2d.F:2
exchange_2d_mod::exchange_r2d_tile
subroutine exchange_r2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition exchange_2d.F:253
exchange_2d_mod::exchange_u2d_tile
subroutine exchange_u2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition exchange_2d.F:440
exchange_2d_mod::exchange_v2d_tile
subroutine exchange_v2d_tile(ng, tile, lbi, ubi, lbj, ubj, a)
Definition exchange_2d.F:627
exchange_3d_mod
Definition exchange_3d.F:2
exchange_3d_mod::exchange_u3d_tile
subroutine exchange_u3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition exchange_3d.F:495
exchange_3d_mod::exchange_r3d_tile
subroutine exchange_r3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition exchange_3d.F:283
exchange_3d_mod::exchange_v3d_tile
subroutine exchange_v3d_tile(ng, tile, lbi, ubi, lbj, ubj, lbk, ubk, a)
Definition exchange_3d.F:707
mod_forces
Definition mod_forces.F:2
mod_forces::forces
type(t_forces), dimension(:), allocatable forces
Definition mod_forces.F:554
mod_grid
Definition mod_grid.F:2
mod_grid::grid
type(t_grid), dimension(:), allocatable grid
Definition mod_grid.F:365
mod_iounits
Definition mod_iounits.F:2
mod_iounits::ioerror
integer ioerror
Definition mod_iounits.F:313
mod_iounits::adm
type(t_io), dimension(:), allocatable adm
Definition mod_iounits.F:200
mod_iounits::stdout
integer stdout
Definition mod_iounits.F:195
mod_ncparam
Definition mod_ncparam.F:2
mod_ncparam::io_nf90
integer, parameter io_nf90
Definition mod_ncparam.F:95
mod_ncparam::idubar
integer idubar
Definition mod_ncparam.F:325
mod_ncparam::idvvel
integer idvvel
Definition mod_ncparam.F:381
mod_ncparam::idvsms
integer idvsms
Definition mod_ncparam.F:377
mod_ncparam::isvvel
integer isvvel
Definition mod_ncparam.F:507
mod_ncparam::io_pio
integer, parameter io_pio
Definition mod_ncparam.F:96
mod_ncparam::isvbar
integer isvbar
Definition mod_ncparam.F:505
mod_ncparam::nwaterv
integer, dimension(:), allocatable nwaterv
Definition mod_ncparam.F:123
mod_ncparam::isvstr
integer isvstr
Definition mod_ncparam.F:511
mod_ncparam::idtsur
integer, dimension(:), allocatable idtsur
Definition mod_ncparam.F:453
mod_ncparam::idfsur
integer idfsur
Definition mod_ncparam.F:206
mod_ncparam::nwateru
integer, dimension(:), allocatable nwateru
Definition mod_ncparam.F:122
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::iduvel
integer iduvel
Definition mod_ncparam.F:343
mod_ncparam::isustr
integer isustr
Definition mod_ncparam.F:510
mod_ncparam::vname
character(len=maxlen), dimension(6, 0:nv) vname
Definition mod_ncparam.F:591
mod_ncparam::isubar
integer isubar
Definition mod_ncparam.F:504
mod_ncparam::idusms
integer idusms
Definition mod_ncparam.F:339
mod_ncparam::istsur
integer, dimension(:), allocatable istsur
Definition mod_ncparam.F:519
mod_ncparam::nwaterr
integer, dimension(:), allocatable nwaterr
Definition mod_ncparam.F:121
mod_ncparam::idvbar
integer idvbar
Definition mod_ncparam.F:360
mod_netcdf
Definition mod_netcdf.F:2
mod_ocean
Definition mod_ocean.F:2
mod_ocean::ocean
type(t_ocean), dimension(:), allocatable ocean
Definition mod_ocean.F:351
mod_parallel
Definition mod_parallel.F:2
mod_parallel::master
logical master
Definition mod_parallel.F:40
mod_parallel::tile_count
integer tile_count
Definition mod_parallel.F:89
mod_param
Definition mod_param.F:2
mod_param::inlm
integer, parameter inlm
Definition mod_param.F:662
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::mstate
integer, dimension(:), allocatable mstate
Definition mod_param.F:644
mod_param::ntilex
integer, dimension(:), allocatable ntilex
Definition mod_param.F:685
mod_param::r3dvar
integer, parameter r3dvar
Definition mod_param.F:721
mod_param::nghostpoints
integer nghostpoints
Definition mod_param.F:710
mod_param::iadm
integer, parameter iadm
Definition mod_param.F:665
mod_param::u3dvar
integer, parameter u3dvar
Definition mod_param.F:722
mod_param::domain
type(t_domain), dimension(:), allocatable domain
Definition mod_param.F:329
mod_param::lm
integer, dimension(:), allocatable lm
Definition mod_param.F:455
mod_param::u2dvar
integer, parameter u2dvar
Definition mod_param.F:718
mod_param::nsemi
integer, dimension(:), allocatable nsemi
Definition mod_param.F:655
mod_param::ntilee
integer, dimension(:), allocatable ntilee
Definition mod_param.F:686
mod_param::itlm
integer, parameter itlm
Definition mod_param.F:663
mod_param::nt
integer, dimension(:), allocatable nt
Definition mod_param.F:489
mod_param::mm
integer, dimension(:), allocatable mm
Definition mod_param.F:456
mod_param::r2dvar
integer, parameter r2dvar
Definition mod_param.F:717
mod_param::v2dvar
integer, parameter v2dvar
Definition mod_param.F:719
mod_param::v3dvar
integer, parameter v3dvar
Definition mod_param.F:723
mod_pio_netcdf
Definition mod_pio_netcdf.F:2
mod_pio_netcdf::iodesc_dp_r3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_r3dvar
Definition mod_pio_netcdf.F:248
mod_pio_netcdf::iodesc_sp_u3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_u3dvar
Definition mod_pio_netcdf.F:210
mod_pio_netcdf::iodesc_sp_u2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_u2dvar
Definition mod_pio_netcdf.F:195
mod_pio_netcdf::iodesc_dp_u3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_u3dvar
Definition mod_pio_netcdf.F:249
mod_pio_netcdf::iodesc_sp_r2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_r2dvar
Definition mod_pio_netcdf.F:194
mod_pio_netcdf::iodesc_dp_u2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_u2dvar
Definition mod_pio_netcdf.F:234
mod_pio_netcdf::iodesc_dp_v3dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_v3dvar
Definition mod_pio_netcdf.F:250
mod_pio_netcdf::iodesc_dp_v2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_v2dvar
Definition mod_pio_netcdf.F:235
mod_pio_netcdf::iodesc_sp_v3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_v3dvar
Definition mod_pio_netcdf.F:211
mod_pio_netcdf::iodesc_sp_r3dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_r3dvar
Definition mod_pio_netcdf.F:209
mod_pio_netcdf::iodesc_dp_r2dvar
type(io_desc_t), dimension(:), pointer iodesc_dp_r2dvar
Definition mod_pio_netcdf.F:233
mod_pio_netcdf::iodesc_sp_v2dvar
type(io_desc_t), dimension(:), pointer iodesc_sp_v2dvar
Definition mod_pio_netcdf.F:196
mod_scalars
Definition mod_scalars.F:2
mod_scalars::ntimes
integer, dimension(:), allocatable ntimes
Definition mod_scalars.F:336
mod_scalars::dt
real(dp), dimension(:), allocatable dt
Definition mod_scalars.F:269
mod_scalars::ewperiodic
logical, dimension(:), allocatable ewperiodic
Definition mod_scalars.F:510
mod_scalars::nsperiodic
logical, dimension(:), allocatable nsperiodic
Definition mod_scalars.F:511
mod_scalars::bvf_bak
real(dp) bvf_bak
Definition mod_scalars.F:791
mod_scalars::tcoef
real(r8), dimension(:), allocatable tcoef
Definition mod_scalars.F:732
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
mod_scalars::isalt
integer isalt
Definition mod_scalars.F:127
mod_scalars::itemp
integer itemp
Definition mod_scalars.F:126
mod_scalars::nintervals
integer nintervals
Definition mod_scalars.F:347
mod_scalars::scalars
type(t_scalars), dimension(:), allocatable scalars
Definition mod_scalars.F:65
mod_scalars::g
real(dp) g
Definition mod_scalars.F:464
mod_scalars::rho0
real(dp) rho0
Definition mod_scalars.F:787
mod_scalars::trnorm
real(r8), dimension(:), allocatable trnorm
Definition mod_scalars.F:1235
mod_scalars::nadj
integer, dimension(:), allocatable nadj
Definition mod_scalars.F:1072
mod_scalars::so_decay
real(r8), dimension(:), allocatable so_decay
Definition mod_scalars.F:1240
mod_scalars::scoef
real(r8), dimension(:), allocatable scoef
Definition mod_scalars.F:733
mod_stepping
Definition mod_stepping.F:2
mod_stepping::kstp
integer, dimension(:), allocatable kstp
Definition mod_stepping.F:66
mod_stepping::knew
integer, dimension(:), allocatable knew
Definition mod_stepping.F:64
mod_stepping::krhs
integer, dimension(:), allocatable krhs
Definition mod_stepping.F:65
mod_stepping::nstp
integer, dimension(:), allocatable nstp
Definition mod_stepping.F:71
mod_storage
Definition mod_storage.F:2
mod_storage::storage
type(t_storage), dimension(:), allocatable storage
Definition mod_storage.F:91
mod_storage::swork
real(r8), dimension(:), allocatable swork
Definition mod_storage.F:132
mp_exchange_mod
Definition mp_exchange.F:2
mp_exchange_mod::ad_mp_exchange3d
subroutine ad_mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
Definition mp_exchange.F:5451
mp_exchange_mod::ad_mp_exchange4d
subroutine ad_mp_exchange4d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c)
Definition mp_exchange.F:7058
mp_exchange_mod::mp_exchange4d
subroutine mp_exchange4d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, lbt, ubt, nghost, ew_periodic, ns_periodic, a, b, c)
Definition mp_exchange.F:3377
mp_exchange_mod::ad_mp_exchange2d
subroutine ad_mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, ad_a, ad_b, ad_c, ad_d)
Definition mp_exchange.F:4058
mp_exchange_mod::mp_exchange2d
subroutine mp_exchange2d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:294
mp_exchange_mod::mp_exchange3d
subroutine mp_exchange3d(ng, tile, model, nvar, lbi, ubi, lbj, ubj, lbk, ubk, nghost, ew_periodic, ns_periodic, a, b, c, d)
Definition mp_exchange.F:2037
nf_fread2d_mod
Definition nf_fread2d.F:2
nf_fread3d_mod
Definition nf_fread3d.F:2
strings_mod
Definition strings.F:2
strings_mod::founderror
logical function, public founderror(flag, noerr, line, routine)
Definition strings.F:52
so_semi_white
subroutine so_semi_white(ng, tile, mstr, mend, state, ad_state)
Definition packing.F:8788
sp_bcoef
subroutine sp_bcoef(ng, ntad, nttl, bcoef)
Definition packing.F:9153
ad_unpack
subroutine ad_unpack(ng, tile, mstr, mend, state)
Definition packing.F:4712
tl_pack_tile
subroutine tl_pack_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, krhs, kstp, knew, nstp, mstr, mend, tl_state, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, tl_t, tl_u, tl_v, tl_zeta)
Definition packing.F:6124
sp_acoef
subroutine sp_acoef(ng, ntad, nttl, acoef)
Definition packing.F:9224
ad_unpack_tile
subroutine ad_unpack_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kout, nout, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, mstr, mend, state)
Definition packing.F:4821
so_semi_red
subroutine so_semi_red(ng, tile, mstr, mend, state, ad_state)
Definition packing.F:8981
tl_pack
subroutine tl_pack(ng, tile, mstr, mend, tl_state)
Definition packing.F:6015
tl_unpack
subroutine tl_unpack(ng, tile, mstr, mend, state)
Definition packing.F:6561
sp_autoc
real(r8) function sp_autoc(ng, idf)
Definition packing.F:9294
ad_pack
subroutine ad_pack(ng, tile, mstr, mend, ad_state)
Definition packing.F:341
c_norm2
subroutine c_norm2(ng, model, mstr, mend, evaluer, evaluei, evectorr, evectori, state, norm2)
Definition packing.F:75
tl_unpack_tile
subroutine tl_unpack_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kstp, nstp, mstr, mend, state, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, tl_t, tl_u, tl_v, tl_zeta, tl_stflx, tl_sustr, tl_svstr)
Definition packing.F:6682
r_norm2
subroutine r_norm2(ng, model, mstr, mend, evalue, evector, state, norm2)
Definition packing.F:175
ad_pack_tile
subroutine ad_pack_tile(ng, tile, lbi, ubi, lbj, ubj, imins, imaxs, jmins, jmaxs, kstp, nstp, mstr, mend, ad_state, ijwaterr, ijwateru, ijwaterv, rmask, umask, vmask, h, hz, f_t, f_u, f_v, ad_stflx, f_ubar, f_vbar, f_zeta, ad_sustr, ad_svstr)
Definition packing.F:453
wclock_off
recursive subroutine wclock_off(ng, model, region, line, routine)
Definition timers.F:148
wclock_on
recursive subroutine wclock_on(ng, model, region, line, routine)
Definition timers.F:3