ROMS
Loading...
Searching...
No Matches
inner2state.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE inner2state_mod
3#if defined HESSIAN_FSV || defined HESSIAN_SO || defined HESSIAN_SV
4!
5!git $Id$
6!================================================== Hernan G. Arango ===
7! Copyright (c) 2002-2025 The ROMS Group Andrew M. Moore !
8! Licensed under a MIT/X style license !
9! See License_ROMS.md !
10!=======================================================================
11! !
12! This routine computes the tangent linear model initial conditions !
13! as the weighted sum of all Lanczos vectors computed from the first !
14! outer loop of the I4D-Var Lanczos algorithm. It converts from inner !
15! loop space span by assimilation to physical state space. !
16! !
17!=======================================================================
18!
19 USE mod_param
20 USE mod_parallel
21# ifdef ADJUST_BOUNDARY
22 USE mod_boundary
23# endif
24# if defined ADJUST_STFLUX || defined ADJUST_WSTRESS
25 USE mod_forces
26# endif
27 USE mod_fourdvar
28 USE mod_grid
29 USE mod_iounits
30 USE mod_ncparam
31 USE mod_netcdf
32 USE mod_ocean
33# if defined PIO_LIB && defined DISTRIBUTE
34 USE mod_pio_netcdf
35# endif
36 USE mod_scalars
37 USE mod_stepping
38!
39# ifdef DISTRIBUTE
40 USE distribute_mod, ONLY : mp_bcastf
41 USE distribute_mod, ONLY : mp_bcasti
42# endif
43 USE state_addition_mod, ONLY : state_addition
44 USE state_copy_mod, ONLY : state_copy
45 USE state_dotprod_mod, ONLY : state_dotprod
46 USE state_initialize_mod, ONLY : state_initialize
47 USE state_read_mod, ONLY : state_read
48 USE state_scale_mod, ONLY : state_scale
49 USE strings_mod, ONLY : founderror
50!
51 implicit none
52!
53 PRIVATE
54!
55 PUBLIC :: ad_inner2state
56 PUBLIC :: tl_inner2state
57 PUBLIC :: ini_c_norm
58!
59 CONTAINS
60!
61!***********************************************************************
62 SUBROUTINE tl_inner2state (ng, tile, Lini, state)
63!***********************************************************************
64!
65! Imported variable declarations.
66!
67 integer, intent(in) :: ng, tile, lini
68!
69 real(r8), intent(in) :: state(ninner)
70!
71! Local variable declarations.
72!
73 character (len=*), parameter :: myfile = &
74 & __FILE__//", tl_inner2state"
75!
76# include "tile.h"
77!
78# ifdef PROFILE
79 CALL wclock_on (ng, itlm, 2, __line__, myfile)
80# endif
81 CALL tl_inner2state_tile (ng, tile, &
82 & lbi, ubi, lbj, ubj, lbij, ubij, &
83 & imins, imaxs, jmins, jmaxs, &
84 & lini, state, &
85# ifdef MASKING
86 & grid(ng) % rmask, &
87 & grid(ng) % umask, &
88 & grid(ng) % vmask, &
89# endif
90# ifdef ADJUST_BOUNDARY
91# ifdef SOLVE3D
92 & boundary(ng) % tl_t_obc, &
93 & boundary(ng) % tl_u_obc, &
94 & boundary(ng) % tl_v_obc, &
95# ifdef LCZ_FINAL
96 & boundary(ng) % ad_t_obc, &
97 & boundary(ng) % ad_u_obc, &
98 & boundary(ng) % ad_v_obc, &
99# endif
100# endif
101 & boundary(ng) % tl_ubar_obc, &
102 & boundary(ng) % tl_vbar_obc, &
103 & boundary(ng) % tl_zeta_obc, &
104# ifdef LCZ_FINAL
105 & boundary(ng) % ad_ubar_obc, &
106 & boundary(ng) % ad_vbar_obc, &
107 & boundary(ng) % ad_zeta_obc, &
108# endif
109# endif
110# ifdef ADJUST_WSTRESS
111 & forces(ng) % tl_ustr, &
112 & forces(ng) % tl_vstr, &
113# ifdef LCZ_FINAL
114 & forces(ng) % ad_ustr, &
115 & forces(ng) % ad_vstr, &
116# endif
117# endif
118# if defined ADJUST_STFLUX && defined SOLVE3D
119 & forces(ng) % tl_tflux, &
120# ifdef LCZ_FINAL
121 & forces(ng) % ad_tflux, &
122# endif
123# endif
124# ifdef SOLVE3D
125 & ocean(ng) % tl_t, &
126 & ocean(ng) % tl_u, &
127 & ocean(ng) % tl_v, &
128# if defined WEAK_CONSTRAINT && defined TIME_CONV
129 & ocean(ng) % tl_ubar, &
130 & ocean(ng) % tl_vbar, &
131# endif
132# ifdef LCZ_FINAL
133 & ocean(ng) % ad_t, &
134 & ocean(ng) % ad_u, &
135 & ocean(ng) % ad_v, &
136# if defined WEAK_CONSTRAINT && defined TIME_CONV
137 & ocean(ng) % ad_ubar, &
138 & ocean(ng) % ad_vbar, &
139# endif
140# endif
141# else
142 & ocean(ng) % tl_ubar, &
143 & ocean(ng) % tl_vbar, &
144# ifdef LCZ_FINAL
145 & ocean(ng) % ad_ubar, &
146 & ocean(ng) % ad_vbar, &
147# endif
148# endif
149 & ocean(ng) % tl_zeta &
150# ifdef LCZ_FINAL
151 & ,ocean(ng) % ad_zeta &
152# endif
153# ifdef HESSIAN_FSV
154# ifdef SOLVE3D
155 & ,grid(ng) % Hz, &
156 & ocean(ng) % f_t, &
157 & ocean(ng) % f_u, &
158 & ocean(ng) % f_v, &
159 & ocean(ng) % f_ubar, &
160 & ocean(ng) % f_vbar, &
161# else
162 & ocean(ng) % f_ubar, &
163 & ocean(ng) % f_vbar, &
164# endif
165 & ocean(ng) % f_zeta &
166# endif
167 & )
168# ifdef PROFILE
169 CALL wclock_off (ng, itlm, 2, __line__, myfile)
170# endif
171!
172 RETURN
173 END SUBROUTINE tl_inner2state
174!
175!***********************************************************************
176 SUBROUTINE tl_inner2state_tile (ng, tile, &
177 & LBi, UBi, LBj, UBj, LBij, UBij, &
178 & IminS, ImaxS, JminS, JmaxS, &
179 & Lini, state, &
180# ifdef MASKING
181 & rmask, umask, vmask, &
182# endif
183# ifdef ADJUST_BOUNDARY
184# ifdef SOLVE3D
185 & tl_t_obc, tl_u_obc, tl_v_obc, &
186# ifdef LCZ_FINAL
187 & ad_t_obc, ad_u_obc, ad_v_obc, &
188# endif
189# endif
190 & tl_ubar_obc, tl_vbar_obc, &
191 & tl_zeta_obc, &
192# ifdef LCZ_FINAL
193 & ad_ubar_obc, ad_vbar_obc, &
194 & ad_zeta_obc, &
195# endif
196# endif
197# ifdef ADJUST_WSTRESS
198 & tl_ustr, tl_vstr, &
199# ifdef LCZ_FINAL
200 & ad_ustr, ad_vstr, &
201# endif
202# endif
203# if defined ADJUST_STFLUX && defined SOLVE3D
204 & tl_tflux, &
205# ifdef LCZ_FINAL
206 & ad_tflux, &
207# endif
208# endif
209# ifdef SOLVE3D
210 & tl_t, tl_u, tl_v, &
211# if defined WEAK_CONSTRAINT && defined TIME_CONV
212 & tl_ubar, tl_vbar, &
213# endif
214# ifdef LCZ_FINAL
215 & ad_t, ad_u, ad_v, &
216# if defined WEAK_CONSTRAINT && defined TIME_CONV
217 & ad_ubar, ad_vbar, &
218# endif
219# endif
220# else
221 & tl_ubar, tl_vbar, &
222# ifdef LCZ_FINAL
223 & ad_ubar, ad_vbar, &
224# endif
225# endif
226 & tl_zeta &
227# ifdef LCZ_FINAL
228 & ,ad_zeta &
229# endif
230# ifdef HESSIAN_FSV
231# ifdef SOLVE3D
232 & , Hz, f_t, f_u, f_v, &
233 & f_ubar, f_vbar , &
234# else
235 & f_ubar, f_vbar , &
236# endif
237 & f_zeta &
238# endif
239 & )
240!***********************************************************************
241!
242! Imported variable declarations.
243!
244 integer, intent(in) :: ng, tile
245 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
246 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
247 integer, intent(in) :: Lini
248!
249 real(r8), intent(in) :: state(Ninner)
250!
251# ifdef ASSUMED_SHAPE
252# ifdef MASKING
253 real(r8), intent(in) :: rmask(LBi:,LBj:)
254 real(r8), intent(in) :: umask(LBi:,LBj:)
255 real(r8), intent(in) :: vmask(LBi:,LBj:)
256# endif
257# ifdef ADJUST_BOUNDARY
258# ifdef SOLVE3D
259 real(r8), intent(inout) :: tl_t_obc(LBij:,:,:,:,:,:)
260 real(r8), intent(inout) :: tl_u_obc(LBij:,:,:,:,:)
261 real(r8), intent(inout) :: tl_v_obc(LBij:,:,:,:,:)
262# ifdef LCZ_FINAL
263 real(r8), intent(inout) :: ad_t_obc(LBij:,:,:,:,:,:)
264 real(r8), intent(inout) :: ad_u_obc(LBij:,:,:,:,:)
265 real(r8), intent(inout) :: ad_v_obc(LBij:,:,:,:,:)
266# endif
267# endif
268 real(r8), intent(inout) :: tl_ubar_obc(LBij:,:,:,:)
269 real(r8), intent(inout) :: tl_vbar_obc(LBij:,:,:,:)
270 real(r8), intent(inout) :: tl_zeta_obc(LBij:,:,:,:)
271# ifdef LCZ_FINAL
272 real(r8), intent(inout) :: ad_ubar_obc(LBij:,:,:,:)
273 real(r8), intent(inout) :: ad_vbar_obc(LBij:,:,:,:)
274 real(r8), intent(inout) :: ad_zeta_obc(LBij:,:,:,:)
275# endif
276# endif
277# ifdef ADJUST_WSTRESS
278 real(r8), intent(inout) :: tl_ustr(LBi:,LBj:,:,:)
279 real(r8), intent(inout) :: tl_vstr(LBi:,LBj:,:,:)
280# ifdef LCZ_FINAL
281 real(r8), intent(inout) :: ad_ustr(LBi:,LBj:,:,:)
282 real(r8), intent(inout) :: ad_vstr(LBi:,LBj:,:,:)
283# endif
284# endif
285# if defined ADJUST_STFLUX && defined SOLVE3D
286 real(r8), intent(inout) :: tl_tflux(LBi:,LBj:,:,:,:)
287# ifdef LCZ_FINAL
288 real(r8), intent(inout) :: ad_tflux(LBi:,LBj:,:,:,:)
289# endif
290# endif
291# ifdef SOLVE3D
292 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
293 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
294 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
295# if defined WEAK_CONSTRAINT && defined TIME_CONV
296 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
297 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
298# endif
299# ifdef LCZ_FINAL
300 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
301 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
302 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
303# if defined WEAK_CONSTRAINT && defined TIME_CONV
304 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
305 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
306# endif
307# endif
308# ifdef HESSIAN_FSV
309 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
310 real(r8), intent(inout) :: f_t(LBi:,LBj:,:,:)
311 real(r8), intent(inout) :: f_u(LBi:,LBj:,:)
312 real(r8), intent(inout) :: f_v(LBi:,LBj:,:)
313 real(r8), intent(inout) :: f_ubar(LBi:,LBj:)
314 real(r8), intent(inout) :: f_vbar(LBi:,LBj:)
315# endif
316# else
317 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
318 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
319# ifdef HESSIAN_FSV
320 real(r8), intent(inout) :: f_ubar(LBi:,LBj:)
321 real(r8), intent(inout) :: f_vbar(LBi:,LBj:)
322# endif
323# ifdef LCZ_FINAL
324 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
325 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
326# endif
327# endif
328 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
329# ifdef HESSIAN_FSV
330 real(r8), intent(inout) :: f_zeta(LBi:,LBj:)
331# endif
332# ifdef LCZ_FINAL
333 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
334# endif
335# else
336# ifdef MASKING
337 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
338 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
339 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
340# endif
341# ifdef ADJUST_BOUNDARY
342# ifdef SOLVE3D
343 real(r8), intent(inout) :: tl_t_obc(LBij:UBij,N(ng),4, &
344 & Nbrec(ng),2,NT(ng))
345 real(r8), intent(inout) :: tl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
346 real(r8), intent(inout) :: tl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
347# ifdef LCZ_FINAL
348 real(r8), intent(inout) :: ad_t_obc(LBij:UBij,N(ng),4, &
349 & Nbrec(ng),2,NT(ng))
350 real(r8), intent(inout) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
351 real(r8), intent(inout) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
352# endif
353# endif
354 real(r8), intent(inout) :: tl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
355 real(r8), intent(inout) :: tl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
356 real(r8), intent(inout) :: tl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
357# ifdef LCZ_FINAL
358 real(r8), intent(inout) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
359 real(r8), intent(inout) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
360 real(r8), intent(inout) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
361# endif
362# endif
363# ifdef ADJUST_WSTRESS
364 real(r8), intent(inout) :: tl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
365 real(r8), intent(inout) :: tl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
366# ifdef LCZ_FINAL
367 real(r8), intent(inout) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
368 real(r8), intent(inout) :: ad_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
369# endif
370# endif
371# if defined ADJUST_STFLUX && defined SOLVE3D
372 real(r8), intent(inout) :: tl_tflux(LBi:UBi,LBj:UBj, &
373 & Nfrec(ng),2,NT(ng))
374# ifdef LCZ_FINAL
375 real(r8), intent(inout) :: ad_tflux(LBi:UBi,LBj:UBj, &
376 & Nfrec(ng),2,NT(ng))
377# endif
378# endif
379# ifdef SOLVE3D
380 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
381 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
382 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
383# if defined WEAK_CONSTRAINT && defined TIME_CONV
384 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
385 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
386# endif
387# ifdef HESSIAN_FSV
388 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
389 real(r8), intent(inout) :: f_t(LBi:UBi,LBj:UBj,N(ng),NT(ng))
390 real(r8), intent(inout) :: f_u(LBi:UBi,LBj:UBj,N(ng))
391 real(r8), intent(inout) :: f_v(LBi:UBi,LBj:UBj,N(ng))
392 real(r8), intent(inout) :: f_ubar(LBi:UBi,LBj:UBj)
393 real(r8), intent(inout) :: f_vbar(LBi:UBi,LBj:UBj)
394# endif
395# ifdef LCZ_FINAL
396 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
397 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
398 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
399# if defined WEAK_CONSTRAINT && defined TIME_CONV
400 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
401 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
402# endif
403# endif
404# else
405 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
406 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
407# ifdef HESSIAN_FSV
408 real(r8), intent(inout) :: f_ubar(LBi:UBi,LBj:UBj)
409 real(r8), intent(inout) :: f_vbar(LBi:UBi,LBj:UBj)
410# endif
411# ifdef LCZ_FINAL
412 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
413 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
414# endif
415# endif
416 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
417# ifdef HESSIAN_FSV
418 real(r8), intent(inout) :: f_zeta(LBi:UBi,LBj:UBj)
419# endif
420# ifdef LCZ_FINAL
421 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
422# endif
423# endif
424!
425! Local variable declarations.
426!
427 integer :: Lwrk, i, j, lstr, outLoop, rec, info
428
429 integer :: ndefLCZ = 1
430# ifdef LCZ_FINAL
431 integer :: ndefLZE = 1
432 integer :: ncidsav
433# endif
434# ifdef SOLVE3D
435 integer :: itrc, k
436# ifdef HESSIAN_FSV
437 real(r8) :: cff1, cff2
438 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: CF
439 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DC
440# endif
441# endif
442 real(r8) :: fac, fac1, fac2
443 real(r8) :: zbeta
444
445 real(r8), dimension(0:NstateVar(ng)) :: dot
446 real(r8), dimension(Ninner) :: DotProd
447 real(r8), dimension(Ninner) :: bvector
448 real(r8), dimension(Ninner) :: work
449# ifdef LCZ_FINAL
450 real(r8), dimension(Ninner,Ninner) :: GStemp
451 real(r8), dimension(Ninner,Ninner) :: GSsub
452 real(r8), dimension(Ninner) :: work1
453# endif
454
455# ifdef LCZ_FINAL
456 real :: sum
457 logical, save :: first = .true.
458 logical, save :: first1 = .true.
459# endif
460!
461 character (len=256) :: ncname
462
463 character (len=*), parameter :: MyFile = &
464 & __FILE__//", tl_inner2state_tile"
465
466# include "set_bounds.h"
467!
468 calledfrom=myfile
469 sourcefile=myfile
470!
471! Compute a Cholesky factorization of the tridiagonal matrix
472! of inner-loop Lanczos vector coefficients of the form
473! L*D*L' where L is a lower unit lower bidiagonal matrix,
474! and D is a diagonal matrix.
475!
476 outloop=nouter
477 IF (master) THEN
478 DO i=1,ninner
479 zlanczos_diag(i)=cg_delta(i,outloop)
480 END DO
481 DO i=2,ninner
482 zlanczos_offdiag(i-1)=cg_beta(i,outloop)
483 END DO
484!
485 CALL dpttrf (ninner, zlanczos_diag, zlanczos_offdiag, info)
486!
487! Overwrite zLanczos_diag with its square root.
488!
489 DO i=1,ninner
490 zlanczos_diag(i)=sqrt(zlanczos_diag(i))
491 END DO
492 END IF
493# ifdef DISTRIBUTE
494 CALL mp_bcasti (ng, itlm, info)
495 CALL mp_bcastf (ng, itlm, zlanczos_diag)
496 CALL mp_bcastf (ng, itlm, zlanczos_offdiag)
497# endif
498 IF (info.ne.0) THEN
499 IF (master) WRITE (stdout,*) ' Error in DPTTRF: info = ', info
500 exit_flag=8
501 RETURN
502 END IF
503!
504! Compute inv(L')*inv(sqrt(D))*state.
505! Since L is lower unit bidiagonal, then L'=U, a unit
506! upper bidiagonal. The following loops solve for the inverse of U.
507!
508 DO i=1,ninner
509 work(i)=state(i)/zlanczos_diag(i)
510 END DO
511 DO i=ninner-1,1,-1
512 work(i)=work(i)-zlanczos_offdiag(i)*work(i+1)
513 END DO
514
515# ifdef LCZ_FINAL
516!
517! If using the evolved Lanczos vectors, then we need to perform a
518! Gramm-Schmidt orthogonalization to compute a new set of orthonormal
519! basis functions since the evolved Lanczos vectors are no longer
520! orthonormal. The evolved Lanczos vectors from I4D-Var are computed
521! using the EVOLVED_LCZ cpp option in 4D-Var.
522!
523! Determine if single or multiple Lanczos vector NetCDF files.
524!
525 SELECT CASE (lcz(ng)%IOtype)
526 CASE (io_nf90)
527 CALL netcdf_get_ivar (ng, itlm, trim(lcz(ng)%name), &
528 & 'ndefADJ', ndeflcz)
529
530# if defined PIO_LIB && defined DISTRIBUTE
531 CASE (io_pio)
532 CALL pio_netcdf_get_ivar (ng, itlm, trim(lcz(ng)%name), &
533 & 'ndefADJ', ndeflcz)
534# endif
535 END SELECT
536 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
537!
538 IF (first) THEN
539 first=.false.
540!
541! Determine Lanczos vector file to read. The Lanczos vectors are
542! written into the adjoint NetCDF in the I4D-Var Lanczos algorithm.
543! The Lanczos vector for each inner loop is accumulated in the
544! unlimited dimension. The name of this file is provided here in
545! the LCZ(ng)%name variable since the ADM(ng)%name value will be
546! use in the adjoint sensitivity part.
547!
548 IF (ndeflcz.gt.0) THEN
549 lstr=len_trim(lcz(ng)%name)
550 WRITE (ncname,10) lcz(ng)%name(1:lstr-8), nouter
551 ELSE
552 ncname=lcz(ng)%name
553 END IF
554 lwrk=2
555!
556! Initialize the Gramm-Schmidt matrix.
557!
558 DO j=1,ninner
559 DO i=1,ninner
560 gsmatrix(i,j)=0.0_r8
561 END DO
562 END do3
563 DO j=1,ninner
564 gsmatrix(j,j)=1.0_r8
565 END DO
566!
567 DO inner=1,ninner
568!
569! Initialize the Gramm-Schmidt sub-matrices.
570!
571 DO j=1,ninner
572 DO i=1,ninner
573 gstemp(i,j)=0.0_r8
574 END DO
575 END DO
576 DO j=1,ninner
577 gstemp(j,j)=1.0_r8
578 END DO
579!
580 ncname=lcz(ng)%name
581 CALL state_read (ng, tile, itlm, lcz(ng)%IOtype, &
582 & lbi, ubi, lbj, ubj, lbij, ubij, &
583 & lwrk, inner, &
584 & ndeflcz, lcz(ng)%ncid, &
585# if defined PIO_LIB && defined DISTRIBUTE
586 & lcz(ng)%pioFile, &
587# endif
588 & trim(ncname), &
589# ifdef MASKING
590 & rmask, umask, vmask, &
591# endif
592# ifdef ADJUST_BOUNDARY
593# ifdef SOLVE3D
594 & tl_t_obc, tl_u_obc, tl_v_obc, &
595# endif
596 & tl_ubar_obc, tl_vbar_obc, &
597 & tl_zeta_obc, &
598# endif
599# ifdef ADJUST_WSTRESS
600 & tl_ustr, tl_vstr, &
601# endif
602# if defined ADJUST_STFLUX && defined SOLVE3D
603 & tl_tflux, &
604# endif
605# ifdef SOLVE3D
606 & tl_t, tl_u, tl_v, &
607# else
608 & tl_ubar, tl_vbar, &
609# endif
610 & tl_zeta)
611!
612! Copy tl_var(Lwrk) into tl_var(Lini).
613!
614!
615! NOTE: In the case of WEAK_CONSTRAINT and TIME_CONV, tl_ubar, tl_vbar
616! ad_ubar and ad_vbar are only passed as required but are not
617! used in subsequent calculations.
618!
619 CALL state_copy (ng, tile, &
620 & lbi, ubi, lbj, ubj, lbij, ubij, &
621 & lwrk, lini, &
622# ifdef ADJUST_BOUNDARY
623# ifdef SOLVE3D
624 & tl_t_obc, tl_t_obc, &
625 & tl_u_obc, tl_u_obc, &
626 & tl_v_obc, tl_v_obc, &
627# endif
628 & tl_ubar_obc, tl_ubar_obc, &
629 & tl_vbar_obc, tl_vbar_obc, &
630 & tl_zeta_obc, tl_zeta_obc, &
631# endif
632# ifdef ADJUST_WSTRESS
633 & tl_ustr, tl_ustr, &
634 & tl_vstr, tl_vstr, &
635# endif
636# ifdef SOLVE3D
637# ifdef ADJUST_STFLUX
638 & tl_tflux, tl_tflux, &
639# endif
640 & tl_t, tl_t, &
641 & tl_u, tl_u, &
642 & tl_v, tl_v, &
643# if defined WEAK_CONSTRAINT && defined TIME_CONV
644 & tl_ubar, tl_ubar, &
645 & tl_vbar, tl_vbar, &
646# endif
647# else
648 & tl_ubar, tl_ubar, &
649 & tl_vbar, tl_vbar, &
650# endif
651 & tl_zeta, tl_zeta)
652!
653! Orthonormalize Lanczos vectors.
654!
655 DO rec=1,inner-1
656!
657! Read in gradient just computed Hessian eigenvectors into tangent
658! linear state array index Lwrk.
659!
660 ncname=lze(ng)%name
661 CALL state_read (ng, tile, itlm, lze(ng)%IOtype, &
662 & lbi, ubi, lbj, ubj, lbij, ubij, &
663 & lwrk, rec, &
664 & ndeflze, lze(ng)%ncid, &
665# if defined PIO_LIB && defined DISTRIBUTE
666 & lze(ng)%pioFile, &
667# endif
668 & trim(ncname), &
669# ifdef MASKING
670 & rmask, umask, vmask, &
671# endif
672# ifdef ADJUST_BOUNDARY
673# ifdef SOLVE3D
674 & ad_t_obc, ad_u_obc, ad_v_obc, &
675# endif
676 & ad_ubar_obc, ad_vbar_obc, &
677 & ad_zeta_obc, &
678# endif
679# ifdef ADJUST_WSTRESS
680 & ad_ustr, ad_vstr, &
681# endif
682# if defined ADJUST_STFLUX && defined SOLVE3D
683 & ad_tflux, &
684# endif
685# ifdef SOLVE3D
686 & ad_t, ad_u, ad_v, &
687# else
688 & ad_ubar, ad_vbar, &
689# endif
690 & ad_zeta)
691 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
692!
693! Compute dot product.
694!
695 CALL state_dotprod (ng, tile, itlm, &
696 & lbi, ubi, lbj, ubj, lbij, ubij, &
697 & nstatevar(ng), dot(0:), &
698# ifdef MASKING
699 & rmask, umask, vmask, &
700# endif
701# ifdef ADJUST_BOUNDARY
702# ifdef SOLVE3D
703 & tl_t_obc(:,:,:,:,lini,:), &
704 & ad_t_obc(:,:,:,:,lwrk,:), &
705 & tl_u_obc(:,:,:,:,lini), &
706 & ad_u_obc(:,:,:,:,lwrk), &
707 & tl_v_obc(:,:,:,:,lini), &
708 & ad_v_obc(:,:,:,:,lwrk), &
709# endif
710 & tl_ubar_obc(:,:,:,lini), &
711 & ad_ubar_obc(:,:,:,lwrk), &
712 & tl_vbar_obc(:,:,:,lini), &
713 & ad_vbar_obc(:,:,:,lwrk), &
714 & tl_zeta_obc(:,:,:,lini), &
715 & ad_zeta_obc(:,:,:,lwrk), &
716# endif
717# ifdef ADJUST_WSTRESS
718 & tl_ustr(:,:,:,lini), ad_ustr(:,:,:,lwrk), &
719 & tl_vstr(:,:,:,lini), ad_vstr(:,:,:,lwrk), &
720# endif
721# ifdef SOLVE3D
722# ifdef ADJUST_STFLUX
723 & tl_tflux(:,:,:,lini,:), &
724 & ad_tflux(:,:,:,lwrk,:), &
725# endif
726 & tl_t(:,:,:,lini,:), ad_t(:,:,:,lwrk,:), &
727 & tl_u(:,:,:,lini), ad_u(:,:,:,lwrk), &
728 & tl_v(:,:,:,lini), ad_v(:,:,:,lwrk), &
729# else
730 & tl_ubar(:,:,lini), ad_ubar(:,:,lwrk), &
731 & tl_vbar(:,:,lini), ad_vbar(:,:,lwrk), &
732# endif
733 & tl_zeta(:,:,lini), ad_zeta(:,:,lwrk))
734!
735 gstemp(rec,inner)=-dot(0)
736!
737! tl_var(Lini) = fac1 * tl_var(Lini) + fac2 * ad_var(Lwrk)
738!
739 fac1=1.0_r8
740 fac2=-dot(0)
741
742!
743! NOTE: In the case of WEAK_CONSTRAINT and TIME_CONV, tl_ubar, tl_vbar
744! ad_ubar and ad_vbar are only passed as required but are not
745! used in subsequent calculations.
746!
747 CALL state_addition (ng, tile, &
748 & lbi, ubi, lbj, ubj, lbij, ubij, &
749 & lini, lwrk, lini, fac1, fac2, &
750# ifdef MASKING
751 & rmask, umask, vmask, &
752# endif
753# ifdef ADJUST_BOUNDARY
754# ifdef SOLVE3D
755 & tl_t_obc, ad_t_obc, &
756 & tl_u_obc, ad_u_obc, &
757 & tl_v_obc, ad_v_obc, &
758# endif
759 & tl_ubar_obc, ad_ubar_obc, &
760 & tl_vbar_obc, ad_vbar_obc, &
761 & tl_zeta_obc, ad_zeta_obc, &
762# endif
763# ifdef ADJUST_WSTRESS
764 & tl_ustr, ad_ustr, &
765 & tl_vstr, ad_vstr, &
766# endif
767# ifdef SOLVE3D
768# ifdef ADJUST_STFLUX
769 & tl_tflux, ad_tflux, &
770# endif
771 & tl_t, ad_t, &
772 & tl_u, ad_u, &
773 & tl_v, ad_v, &
774# if defined WEAK_CONSTRAINT && defined TIME_CONV
775 & tl_ubar, ad_ubar, &
776 & tl_vbar, ad_vbar, &
777# endif
778# else
779 & tl_ubar, ad_ubar, &
780 & tl_vbar, ad_vbar, &
781# endif
782 & tl_zeta, ad_zeta)
783 END DO
784!
785! Compute normalization factor.
786!
787 CALL state_dotprod (ng, tile, itlm, &
788 & lbi, ubi, lbj, ubj, lbij, ubij, &
789 & nstatevar(ng), dot(0:), &
790# ifdef MASKING
791 & rmask, umask, vmask, &
792# endif
793# ifdef ADJUST_BOUNDARY
794# ifdef SOLVE3D
795 & tl_t_obc(:,:,:,:,lini,:), &
796 & tl_t_obc(:,:,:,:,lini,:), &
797 & tl_u_obc(:,:,:,:,lini), &
798 & tl_u_obc(:,:,:,:,lini), &
799 & tl_v_obc(:,:,:,:,lini), &
800 & tl_v_obc(:,:,:,:,lini), &
801# endif
802 & tl_ubar_obc(:,:,:,lini), &
803 & tl_ubar_obc(:,:,:,lini), &
804 & tl_vbar_obc(:,:,:,lini), &
805 & tl_vbar_obc(:,:,:,lini), &
806 & tl_zeta_obc(:,:,:,lini), &
807 & tl_zeta_obc(:,:,:,lini), &
808# endif
809# ifdef ADJUST_WSTRESS
810 & tl_ustr(:,:,:,lini), tl_ustr(:,:,:,lini), &
811 & tl_vstr(:,:,:,lini), tl_vstr(:,:,:,lini), &
812# endif
813# ifdef SOLVE3D
814# ifdef ADJUST_STFLUX
815 & tl_tflux(:,:,:,lini,:), &
816 & tl_tflux(:,:,:,lini,:), &
817# endif
818 & tl_t(:,:,:,lini,:), tl_t(:,:,:,lini,:), &
819 & tl_u(:,:,:,lini), tl_u(:,:,:,lini), &
820 & tl_v(:,:,:,lini), tl_v(:,:,:,lini), &
821# else
822 & tl_ubar(:,:,lini), tl_ubar(:,:,lini), &
823 & tl_vbar(:,:,lini), tl_vbar(:,:,lini), &
824# endif
825 & tl_zeta(:,:,lini), tl_zeta(:,:,lini))
826!
827 DO i=1,inner
828 gstemp(i,inner)=gstemp(i,inner)/sqrt(dot(0))
829 END DO
830!
831! Normalize the evolved Lanczos vectors:
832!
833! tl_var(Lini) = fac * tl_var(Lini)
834!
835 fac=1.0_r8/sqrt(dot(0))
836
837 CALL state_scale (ng, tile, &
838 & lbi, ubi, lbj, ubj, lbij, ubij, &
839 & lini, lini, fac, &
840# ifdef MASKING
841 & rmask, umask, vmask, &
842# endif
843# ifdef ADJUST_BOUNDARY
844# ifdef SOLVE3D
845 & tl_t_obc, tl_u_obc, tl_v_obc, &
846# endif
847 & tl_ubar_obc, tl_vbar_obc, &
848 & tl_zeta_obc, &
849# endif
850# ifdef ADJUST_WSTRESS
851 & tl_ustr, tl_vstr, &
852# endif
853# ifdef SOLVE3D
854# ifdef ADJUST_STFLUX
855 & tl_tflux, &
856# endif
857 & tl_t, tl_u, tl_v, &
858# else
859 & tl_ubar, tl_vbar, &
860# endif
861 & tl_zeta)
862!
863! Copy tl_var(Lini) into ad_var(Lini) and write into the Hessian
864! netcdf file.
865!
866!
867! NOTE: In the case of WEAK_CONSTRAINT and TIME_CONV, tl_ubar, tl_vbar
868! ad_ubar and ad_vbar are only passed as required but are not
869! used in subsequent calculations.
870!
871 CALL state_copy (ng, tile, &
872 & lbi, ubi, lbj, ubj, lbij, ubij, &
873 & lini, lini, &
874# ifdef ADJUST_BOUNDARY
875# ifdef SOLVE3D
876 & ad_t_obc, tl_t_obc, &
877 & ad_u_obc, tl_u_obc, &
878 & ad_v_obc, tl_v_obc, &
879# endif
880 & ad_ubar_obc, tl_ubar_obc, &
881 & ad_vbar_obc, tl_vbar_obc, &
882 & ad_zeta_obc, tl_zeta_obc, &
883# endif
884# ifdef ADJUST_WSTRESS
885 & ad_ustr, tl_ustr, &
886 & ad_vstr, tl_vstr, &
887# endif
888# ifdef SOLVE3D
889# ifdef ADJUST_STFLUX
890 & ad_tflux, tl_tflux, &
891# endif
892 & ad_t, tl_t, &
893 & ad_u, tl_u, &
894 & ad_v, tl_v, &
895# if defined WEAK_CONSTRAINT && defined TIME_CONV
896 & ad_ubar, tl_ubar, &
897 & ad_vbar, tl_vbar, &
898# endif
899# else
900 & ad_ubar, tl_ubar, &
901 & ad_vbar, tl_vbar, &
902# endif
903 & ad_zeta, tl_zeta)
904!
905! AMM: Had to add this temporary save of LZEncid otherwise the write
906! of ocean_time to the LZE netcdf file fails.
907!
908 IF (inner.gt.1) THEN
909 lze(ng)%ncid=ncidsav
910 ELSE
911 ncidsav=lze(ng)%ncid
912 END IF
913 lze(ng)%Rindex=inner-1
914 CALL wrt_evolved (ng, lini, lini)
915 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
916!
917! Build the full Gramm-Schmidt matrix from as the product of each
918! sub-matrix.
919!
920 DO j=1,ninner
921 DO i=1,ninner
922 sum=0.0_r8
923 DO k=1,ninner
924 sum=sum+gsmatrix(i,k)*gstemp(k,j)
925 END DO
926 gssub(i,j)=sum
927 END DO
928 END DO
929 DO j=1,ninner
930 DO i=1,ninner
931 gsmatrix(i,j)=gssub(i,j)
932 END DO
933 END DO
934
935 END DO
936!
937! Test the orthonormalization of the evolved Lanczos vectors.
938!
939!
940 IF (master) THEN
941 WRITE (stdout,*) ' Test of orthonormalization'
942 END IF
943!
944 DO inner=1,ninner
945!
946 ncname=lze(ng)%name
947 CALL state_read (ng, tile, itlm, lze(ng)%IOtype, &
948 & lbi, ubi, lbj, ubj, lbij, ubij, &
949 & lwrk, inner, &
950 & ndeflze, lze(ng)%ncid, &
951# if defined PIO_LIB && defined DISTRIBUTE
952 & lze(ng)%pioFile, &
953# endif
954 & trim(ncname), &
955# ifdef MASKING
956 & rmask, umask, vmask, &
957# endif
958# ifdef ADJUST_BOUNDARY
959# ifdef SOLVE3D
960 & tl_t_obc, tl_u_obc, tl_v_obc, &
961# endif
962 & tl_ubar_obc, tl_vbar_obc, &
963 & tl_zeta_obc, &
964# endif
965# ifdef ADJUST_WSTRESS
966 & tl_ustr, tl_vstr, &
967# endif
968# if defined ADJUST_STFLUX && defined SOLVE3D
969 & tl_tflux, &
970# endif
971# ifdef SOLVE3D
972 & tl_t, tl_u, tl_v, &
973# else
974 & tl_ubar, tl_vbar, &
975# endif
976 & tl_zeta)
977 DO rec=1,ninner
978!
979 ncname=lze(ng)%name
980 CALL state_read (ng, tile, itlm, lze(ng)%IOtype, &
981 & lbi, ubi, lbj, ubj, lbij, ubij, &
982 & lwrk, rec, &
983 & ndeflze, lze(ng)%ncid, &
984# if defined PIO_LIB && defined DISTRIBUTE
985 & lze(ng)%pioFile, &
986# endif
987 & trim(ncname), &
988# ifdef MASKING
989 & rmask, umask, vmask, &
990# endif
991# ifdef ADJUST_BOUNDARY
992# ifdef SOLVE3D
993 & ad_t_obc, ad_u_obc, ad_v_obc, &
994# endif
995 & ad_ubar_obc, ad_vbar_obc, &
996 & ad_zeta_obc, &
997# endif
998# ifdef ADJUST_WSTRESS
999 & ad_ustr, ad_vstr, &
1000# endif
1001# if defined ADJUST_STFLUX && defined SOLVE3D
1002 & ad_tflux, &
1003# endif
1004# ifdef SOLVE3D
1005 & ad_t, ad_u, ad_v, &
1006# else
1007 & ad_ubar, ad_vbar, &
1008# endif
1009 & ad_zeta)
1010 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1011!
1012! Compute dot product.
1013!
1014 CALL state_dotprod (ng, tile, itlm, &
1015 & lbi, ubi, lbj, ubj, lbij, ubij, &
1016 & nstatevar(ng), dot(0:), &
1017# ifdef MASKING
1018 & rmask, umask, vmask, &
1019# endif
1020# ifdef ADJUST_BOUNDARY
1021# ifdef SOLVE3D
1022 & tl_t_obc(:,:,:,:,lwrk,:), &
1023 & ad_t_obc(:,:,:,:,lwrk,:), &
1024 & tl_u_obc(:,:,:,:,lwrk), &
1025 & ad_u_obc(:,:,:,:,lwrk), &
1026 & tl_v_obc(:,:,:,:,lwrk), &
1027 & ad_v_obc(:,:,:,:,lwrk), &
1028# endif
1029 & tl_ubar_obc(:,:,:,lwrk), &
1030 & ad_ubar_obc(:,:,:,lwrk), &
1031 & tl_vbar_obc(:,:,:,lwrk), &
1032 & ad_vbar_obc(:,:,:,lwrk), &
1033 & tl_zeta_obc(:,:,:,lwrk), &
1034 & ad_zeta_obc(:,:,:,lwrk), &
1035# endif
1036# ifdef ADJUST_WSTRESS
1037 & tl_ustr(:,:,:,lwrk), ad_ustr(:,:,:,lwrk), &
1038 & tl_vstr(:,:,:,lwrk), ad_vstr(:,:,:,lwrk), &
1039# endif
1040# ifdef SOLVE3D
1041# ifdef ADJUST_STFLUX
1042 & tl_tflux(:,:,:,lwrk,:), &
1043 & ad_tflux(:,:,:,lwrk,:), &
1044# endif
1045 & tl_t(:,:,:,lwrk,:), ad_t(:,:,:,lwrk,:), &
1046 & tl_u(:,:,:,lwrk), ad_u(:,:,:,lwrk), &
1047 & tl_v(:,:,:,lwrk), ad_v(:,:,:,lwrk), &
1048# else
1049 & tl_ubar(:,:,lwrk), ad_ubar(:,:,lwrk), &
1050 & tl_vbar(:,:,lwrk), ad_vbar(:,:,lwrk), &
1051# endif
1052 & tl_zeta(:,:,lwrk), ad_zeta(:,:,lwrk))
1053!
1054 IF (master) THEN
1055 WRITE (stdout,*) 'inner = ', inner, ' rec = ', rec, &
1056 & ' dot-product = ', dot(0)
1057 END IF
1058!
1059 END DO
1060 END DO
1061!
1062! Compute the inverse of GSmatrix.
1063!
1064 IF (master) THEN
1065 DO j=1,ninner
1066 DO i=1,ninner
1067 gsmatinv(i,j)=gsmatrix(i,j)
1068 END DO
1069 END DO
1070 CALL dtrtri ('U','N',ninner,gsmatinv,ninner,info)
1071 END IF
1072# ifdef DISTRIBUTE
1073 CALL mp_bcasti (ng, itlm, info)
1074 CALL mp_bcastf (ng, itlm, gsmatrix)
1075 CALL mp_bcastf (ng, itlm, gsmatinv)
1076# endif
1077 IF (info.ne.0) THEN
1078 IF (master) WRITE (stdout,*) ' Error in DPTTRF: info = ', info
1079 exit_flag=8
1080 RETURN
1081 END IF
1082!
1083 END IF
1084!
1085! Now multiply by GSmatinv.
1086!
1087 DO i=1,ninner
1088 sum=0.0_r8
1089 DO j=1,ninner
1090 sum=sum+gsmatinv(i,j)*work(j)
1091 END DO
1092 work1(i)=sum
1093 END DO
1094 DO i=1,ninner
1095 work(i)=work1(i)
1096 END DO
1097
1098# endif
1099!
1100!-----------------------------------------------------------------------
1101! Compute tangent linear model initial conditions from the weighted
1102! sum of the Lanczos vectors.
1103!-----------------------------------------------------------------------
1104!
1105# ifdef LCZ_FINAL
1106! Determine if single or multiple Lanczos vector NetCDF files.
1107!
1108 SELECT CASE (lze(ng)%IOtype)
1109 CASE (io_nf90)
1110 CALL netcdf_get_ivar (ng, itlm, trim(lze(ng)%name), &
1111 & 'ndefADJ', ndeflze)
1112
1113# if defined PIO_LIB && defined DISTRIBUTE
1114 CASE (io_pio)
1115 CALL pio_netcdf_get_ivar (ng, itlm, trim(lze(ng)%name), &
1116 & 'ndefADJ', ndeflze)
1117# endif
1118 END SELECT
1119 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1120# else
1121! Determine if single or multiple Lanczos vector NetCDF files.
1122!
1123 SELECT CASE (lcz(ng)%IOtype)
1124 CASE (io_nf90)
1125 CALL netcdf_get_ivar (ng, itlm, trim(lcz(ng)%name), &
1126 & 'ndefADJ', ndeflcz)
1127
1128# if defined PIO_LIB && defined DISTRIBUTE
1129 CASE (io_pio)
1130 CALL pio_netcdf_get_ivar (ng, itlm, trim(lcz(ng)%name), &
1131 & 'ndefADJ', ndeflcz)
1132# endif
1133 END SELECT
1134 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1135# endif
1136!
1137# ifdef LCZ_FINAL
1138! Determine Lanczos vector file to read. The reorthonormalized
1139! Lanczos vectors are written in the Hessian netcdf file.
1140!
1141 IF (ndeflze.gt.0) THEN
1142 lstr=len_trim(lze(ng)%name)
1143 WRITE (ncname,10) lze(ng)%name(1:lstr-8), nouter
1144 10 FORMAT (a,'_',i4.4,'.nc')
1145 ELSE
1146 ncname=lze(ng)%name
1147 END IF
1148# else
1149! Determine Lanczos vector file to read. The Lanczos vectors are
1150! written into the adjoint NetCDF in the I4D-Var Lanczos algorithm.
1151! The Lanczos vector for each inner loop is accumulated in the
1152! unlimited dimension. The name of this file is provided here in
1153! the LCZ(ng)%name variable since the ADM(ng)%name value will be
1154! use in the adjoint sensitivity part.
1155!
1156 IF (ndeflcz.gt.0) THEN
1157 lstr=len_trim(lcz(ng)%name)
1158 WRITE (ncname,10) lcz(ng)%name(1:lstr-8), nouter
1159 10 FORMAT (a,'_',i4.4,'.nc')
1160 ELSE
1161 ncname=lcz(ng)%name
1162 END IF
1163# endif
1164!
1165 lwrk=2
1166# ifdef LCZ_FINAL
1167!
1168! AMM: Had to add this temporary save of LZEncid otherwise the write
1169! of ocean_time to the LZE netcdf file fails.
1170!
1171 IF (first1) THEN
1172 first1=.false.
1173 lze(ng)%ncid=ncidsav
1174 END IF
1175!
1176# endif
1177 DO inner=1,ninner
1178!
1179! Read in the Lanczos vectors (q_i, where i=1,2,...k) computed from
1180! k inner-loops of the I4D-Var algorithm first outer loop. Load
1181! Lanczos vectors into TANGENT LINEAR STATE ARRAYS at index Lwrk.
1182!
1183 CALL state_read (ng, tile, itlm, &
1184# ifdef LCZ_FINAL
1185 & lze(ng)%IOtype, &
1186# else
1187 & lcz(ng)%IOtype, &
1188# endif
1189 & lbi, ubi, lbj, ubj, lbij, ubij, &
1190 & lwrk, inner, &
1191# ifdef LCZ_FINAL
1192 & ndeflze, lze(ng)%ncid, &
1193# if defined PIO_LIB && defined DISTRIBUTE
1194 & lze(ng)%pioFile, &
1195# endif
1196# else
1197 & ndeflcz, lcz(ng)%ncid, &
1198# if defined PIO_LIB && defined DISTRIBUTE
1199 & lcz(ng)%pioFile, &
1200# endif
1201# endif
1202 & trim(ncname), &
1203# ifdef MASKING
1204 & rmask, umask, vmask, &
1205# endif
1206# ifdef ADJUST_BOUNDARY
1207# ifdef SOLVE3D
1208 & tl_t_obc, tl_u_obc, tl_v_obc, &
1209# endif
1210 & tl_ubar_obc, tl_vbar_obc, &
1211 & tl_zeta_obc, &
1212# endif
1213# ifdef ADJUST_WSTRESS
1214 & tl_ustr, tl_vstr, &
1215# endif
1216# if defined ADJUST_STFLUX && defined SOLVE3D
1217 & tl_tflux, &
1218# endif
1219# ifdef SOLVE3D
1220 & tl_t, tl_u, tl_v, &
1221# else
1222 & tl_ubar, tl_vbar, &
1223# endif
1224 & tl_zeta)
1225 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1226
1227 IF (inner.eq.1) THEN
1228 fac=0.0_r8
1229 CALL state_initialize (ng, tile, &
1230 & lbi, ubi, lbj, ubj, lbij, ubij, &
1231 & lini, fac, &
1232# ifdef MASKING
1233 & rmask, umask, vmask, &
1234# endif
1235# ifdef ADJUST_BOUNDARY
1236# ifdef SOLVE3D
1237 & tl_t_obc, tl_u_obc, tl_v_obc, &
1238# endif
1239 & tl_ubar_obc, tl_vbar_obc, &
1240 & tl_zeta_obc, &
1241# endif
1242# ifdef ADJUST_WSTRESS
1243 & tl_ustr, tl_vstr, &
1244# endif
1245# if defined ADJUST_STFLUX && defined SOLVE3D
1246 & tl_tflux, &
1247# endif
1248# ifdef SOLVE3D
1249 & tl_t, tl_u, tl_v, &
1250# else
1251 & tl_ubar, tl_vbar, &
1252# endif
1253 & tl_zeta)
1254 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1255 END IF
1256!
1257! NOTE: In the case of WEAK_CONSTRAINT and TIME_CONV, tl_ubar, tl_vbar
1258! ad_ubar and ad_vbar are only passed as required but are not
1259! used in subsequent calculations.
1260!
1261 fac1=1.0_r8
1262 fac2=work(inner)
1263 CALL state_addition (ng, tile, &
1264 & lbi, ubi, lbj, ubj, lbij, ubij, &
1265 & lini, lwrk, lini, &
1266 & fac1, fac2, &
1267# ifdef MASKING
1268 & rmask, umask, vmask, &
1269# endif
1270# ifdef ADJUST_BOUNDARY
1271# ifdef SOLVE3D
1272 & tl_t_obc, tl_t_obc, &
1273 & tl_u_obc, tl_u_obc, &
1274 & tl_v_obc, tl_v_obc, &
1275# endif
1276 & tl_ubar_obc, tl_ubar_obc, &
1277 & tl_vbar_obc, tl_vbar_obc, &
1278 & tl_zeta_obc, tl_zeta_obc, &
1279# endif
1280# ifdef ADJUST_WSTRESS
1281 & tl_ustr, tl_ustr, &
1282 & tl_vstr, tl_vstr, &
1283# endif
1284# if defined ADJUST_STFLUX && defined SOLVE3D
1285 & tl_tflux, tl_tflux, &
1286# endif
1287# ifdef SOLVE3D
1288 & tl_t, tl_t, &
1289 & tl_u, tl_u, &
1290 & tl_v, tl_v, &
1291# if defined WEAK_CONSTRAINT && defined TIME_CONV
1292 & tl_ubar, tl_ubar, &
1293 & tl_vbar, tl_vbar, &
1294# endif
1295# else
1296 & tl_ubar, tl_ubar, &
1297 & tl_vbar, tl_vbar, &
1298# endif
1299 & tl_zeta, tl_zeta)
1300 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1301
1302 END DO
1303# ifdef HESSIAN_FSV
1304!
1305! Copy tl_var into f_var arrays then clear the tl_var arrays.
1306!
1307!
1308 DO j=jstrr,jendr
1309 DO i=istrr,iendr
1310 f_zeta(i,j)=tl_zeta(i,j,lini)
1311 END DO
1312 END DO
1313# ifndef SOLVE3D
1314!
1315! Tangent linear 2D momentum.
1316
1317 DO j=jstrr,jendr
1318 DO i=istr,iendr
1319 f_ubar(i,j)=tl_ubar(i,j,lini)
1320 END DO
1321 END DO
1322!
1323 DO j=jstr,jendr
1324 DO i=istrr,iendr
1325 f_vbar(i,j)=tl_vbar(i,j,lini)
1326 END DO
1327 END DO
1328
1329# else
1330!
1331! Tangent linear 3D momentum.
1332!
1333 DO k=1,n(ng)
1334 DO j=jstrr,jendr
1335 DO i=istr,iendr
1336 f_u(i,j,k)=tl_u(i,j,k,lini)
1337 END DO
1338 END DO
1339 DO j=jstr,jendr
1340 DO i=istrr,iendr
1341 f_v(i,j,k)=tl_v(i,j,k,lini)
1342 END DO
1343 END DO
1344 END DO
1345!
1346! Compute the forcing for tl_ubar based on f_u.
1347!
1348 DO j=jstr,jend
1349 DO i=istru,iend
1350 dc(i,0)=0.0_r8
1351 cf(i,0)=0.0_r8
1352 END DO
1353 DO k=1,n(ng)
1354 DO i=istru,iend
1355 dc(i,k)=0.5_r8*(hz(i,j,k)+hz(i-1,j,k))
1356 dc(i,0)=dc(i,0)+dc(i,k)
1357 cf(i,0)=cf(i,0)+dc(i,k)*f_u(i,j,k)
1358 END DO
1359 END DO
1360 DO i=istru,iend
1361 cff1=1.0_r8/dc(i,0)
1362 cff2=cf(i,0)*cff1
1363# ifdef MASKING
1364 cff2=cff2*umask(i,j)
1365# endif
1366 f_ubar(i,j)=cff2
1367 END DO
1368 END DO
1369!
1370! Compute the forcing for tl_vbar based on f_v.
1371!
1372 DO j=jstrv,jend
1373 IF (j.ge.jstrm) THEN
1374 DO i=istr,iend
1375 dc(i,0)=0.0_r8
1376 cf(i,0)=0.0_r8
1377 END DO
1378 DO k=1,n(ng)
1379 DO i=istr,iend
1380 dc(i,k)=0.5_r8*(hz(i,j,k)+hz(i,j-1,k))
1381 dc(i,0)=dc(i,0)+dc(i,k)
1382 cf(i,0)=cf(i,0)+dc(i,k)*f_v(i,j,k)
1383 END DO
1384 END DO
1385 DO i=istr,iend
1386 cff1=1.0_r8/dc(i,0)
1387 cff2=cf(i,0)*cff1
1388# ifdef MASKING
1389 cff2=cff2*vmask(i,j)
1390# endif
1391 f_vbar(i,j)=cff2
1392 END DO
1393 END IF
1394 END DO
1395!
1396! Tangent linear tracers.
1397!
1398 DO itrc=1,nt(ng)
1399 DO k=1,n(ng)
1400 DO j=jstrr,jendr
1401 DO i=istrr,iendr
1402 f_t(i,j,k,itrc)=tl_t(i,j,k,lini,itrc)
1403 END DO
1404 END DO
1405 END DO
1406 END DO
1407# endif
1408 fac=0.0_r8
1409 CALL state_initialize (ng, tile, &
1410 & lbi, ubi, lbj, ubj, lbij, ubij, &
1411 & lini, fac, &
1412# ifdef MASKING
1413 & rmask, umask, vmask, &
1414# endif
1415# ifdef ADJUST_BOUNDARY
1416# ifdef SOLVE3D
1417 & tl_t_obc, tl_u_obc, tl_v_obc, &
1418# endif
1419 & tl_ubar_obc, tl_vbar_obc, &
1420 & tl_zeta_obc, &
1421# endif
1422# ifdef ADJUST_WSTRESS
1423 & tl_ustr, tl_vstr, &
1424# endif
1425# if defined ADJUST_STFLUX && defined SOLVE3D
1426 & tl_tflux, &
1427# endif
1428# ifdef SOLVE3D
1429 & tl_t, tl_u, tl_v, &
1430# else
1431 & tl_ubar, tl_vbar, &
1432# endif
1433 & tl_zeta)
1434
1435# endif
1436!
1437 RETURN
1438 END SUBROUTINE tl_inner2state_tile
1439!
1440!***********************************************************************
1441 SUBROUTINE ad_inner2state (ng, tile, Lini, ad_state)
1442!***********************************************************************
1443!
1444! Imported variable declarations.
1445!
1446 integer, intent(in) :: ng, tile, lini
1447!
1448 real(r8), intent(inout) :: ad_state(ninner)
1449!
1450! Local variable declarations.
1451!
1452 character (len=*), parameter :: myfile = &
1453 & __FILE__//", ad_inner2state"
1454!
1455# include "tile.h"
1456!
1457# ifdef PROFILE
1458 CALL wclock_on (ng, itlm, 2, __line__, myfile)
1459# endif
1460 CALL ad_inner2state_tile (ng, tile, &
1461 & lbi, ubi, lbj, ubj, lbij, ubij, &
1462 & imins, imaxs, jmins, jmaxs, &
1463 & lini, ad_state, &
1464# ifdef MASKING
1465 & grid(ng) % rmask, &
1466 & grid(ng) % umask, &
1467 & grid(ng) % vmask, &
1468# endif
1469# ifdef ADJUST_BOUNDARY
1470# ifdef SOLVE3D
1471 & boundary(ng) % ad_t_obc, &
1472 & boundary(ng) % ad_u_obc, &
1473 & boundary(ng) % ad_v_obc, &
1474# endif
1475 & boundary(ng) % ad_ubar_obc, &
1476 & boundary(ng) % ad_vbar_obc, &
1477 & boundary(ng) % ad_zeta_obc, &
1478# endif
1479# ifdef ADJUST_WSTRESS
1480 & forces(ng) % ad_ustr, &
1481 & forces(ng) % ad_vstr, &
1482# endif
1483# if defined ADJUST_STFLUX && defined SOLVE3D
1484 & forces(ng) % ad_tflux, &
1485# endif
1486# ifdef SOLVE3D
1487 & ocean(ng) % ad_t, &
1488 & ocean(ng) % ad_u, &
1489 & ocean(ng) % ad_v, &
1490# if defined WEAK_CONSTRAINT && defined TIME_CONV
1491 & ocean(ng) % ad_ubar, &
1492 & ocean(ng) % ad_vbar, &
1493# endif
1494# else
1495 & ocean(ng) % ad_ubar, &
1496 & ocean(ng) % ad_vbar, &
1497# endif
1498 & ocean(ng) % ad_zeta, &
1499# ifdef ADJUST_BOUNDARY
1500# ifdef SOLVE3D
1501 & boundary(ng) % tl_t_obc, &
1502 & boundary(ng) % tl_u_obc, &
1503 & boundary(ng) % tl_v_obc, &
1504# endif
1505 & boundary(ng) % tl_ubar_obc, &
1506 & boundary(ng) % tl_vbar_obc, &
1507 & boundary(ng) % tl_zeta_obc, &
1508# endif
1509# ifdef ADJUST_WSTRESS
1510 & forces(ng) % tl_ustr, &
1511 & forces(ng) % tl_vstr, &
1512# endif
1513# if defined ADJUST_STFLUX && defined SOLVE3D
1514 & forces(ng) % tl_tflux, &
1515# endif
1516# ifdef SOLVE3D
1517 & ocean(ng) % tl_t, &
1518 & ocean(ng) % tl_u, &
1519 & ocean(ng) % tl_v, &
1520# if defined WEAK_CONSTRAINT && defined TIME_CONV
1521 & ocean(ng) % tl_ubar, &
1522 & ocean(ng) % tl_vbar, &
1523# endif
1524# else
1525 & ocean(ng) % tl_ubar, &
1526 & ocean(ng) % tl_vbar, &
1527# endif
1528 & ocean(ng) % tl_zeta &
1529# ifdef HESSIAN_FSV
1530# ifdef SOLVE3D
1531 & ,grid(ng) % Hz, &
1532 & ocean(ng) % f_t, &
1533 & ocean(ng) % f_u, &
1534 & ocean(ng) % f_v, &
1535 & ocean(ng) % f_ubar, &
1536 & ocean(ng) % f_vbar, &
1537# else
1538 & ocean(ng) % f_ubar, &
1539 & ocean(ng) % f_vbar, &
1540# endif
1541 & ocean(ng) % f_zeta &
1542# endif
1543 & )
1544# ifdef PROFILE
1545 CALL wclock_off (ng, itlm, 2, __line__, myfile)
1546# endif
1547!
1548 RETURN
1549 END SUBROUTINE ad_inner2state
1550!
1551!***********************************************************************
1552 SUBROUTINE ad_inner2state_tile (ng, tile, &
1553 & LBi, UBi, LBj, UBj, LBij, UBij, &
1554 & IminS, ImaxS, JminS, JmaxS, &
1555 & Lini, ad_state, &
1556# ifdef MASKING
1557 & rmask, umask, vmask, &
1558# endif
1559# ifdef ADJUST_BOUNDARY
1560# ifdef SOLVE3D
1561 & ad_t_obc, ad_u_obc, ad_v_obc, &
1562# endif
1563 & ad_ubar_obc, ad_vbar_obc, &
1564 & ad_zeta_obc, &
1565# endif
1566# ifdef ADJUST_WSTRESS
1567 & ad_ustr, ad_vstr, &
1568# endif
1569# if defined ADJUST_STFLUX && defined SOLVE3D
1570 & ad_tflux, &
1571# endif
1572# ifdef SOLVE3D
1573 & ad_t, ad_u, ad_v, &
1574# if defined WEAK_CONSTRAINT && defined TIME_CONV
1575 & ad_ubar, ad_vbar, &
1576# endif
1577# else
1578 & ad_ubar, ad_vbar, &
1579# endif
1580 & ad_zeta, &
1581# ifdef ADJUST_BOUNDARY
1582# ifdef SOLVE3D
1583 & tl_t_obc, tl_u_obc, tl_v_obc, &
1584# endif
1585 & tl_ubar_obc, tl_vbar_obc, &
1586 & tl_zeta_obc, &
1587# endif
1588# ifdef ADJUST_WSTRESS
1589 & tl_ustr, tl_vstr, &
1590# endif
1591# if defined ADJUST_STFLUX && defined SOLVE3D
1592 & tl_tflux, &
1593# endif
1594# ifdef SOLVE3D
1595 & tl_t, tl_u, tl_v, &
1596# if defined WEAK_CONSTRAINT && defined TIME_CONV
1597 & tl_ubar, tl_vbar, &
1598# endif
1599# else
1600 & tl_ubar, tl_vbar, &
1601# endif
1602 & tl_zeta &
1603# ifdef HESSIAN_FSV
1604# ifdef SOLVE3D
1605 & ,Hz, f_t, f_u, f_v, &
1606 & f_ubar, f_vbar , &
1607# else
1608 & f_ubar, f_vbar , &
1609# endif
1610 & f_zeta &
1611# endif
1612 & )
1613!***********************************************************************
1614!
1615! Imported variable declarations.
1616!
1617 integer, intent(in) :: ng, tile
1618 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
1619 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
1620 integer, intent(in) :: Lini
1621!
1622 real(r8), intent(inout) :: ad_state(Ninner)
1623!
1624# ifdef ASSUMED_SHAPE
1625# ifdef MASKING
1626 real(r8), intent(in) :: rmask(LBi:,LBj:)
1627 real(r8), intent(in) :: umask(LBi:,LBj:)
1628 real(r8), intent(in) :: vmask(LBi:,LBj:)
1629# endif
1630# ifdef ADJUST_BOUNDARY
1631# ifdef SOLVE3D
1632 real(r8), intent(inout) :: ad_t_obc(LBij:,:,:,:,:,:)
1633 real(r8), intent(inout) :: ad_u_obc(LBij:,:,:,:,:)
1634 real(r8), intent(inout) :: ad_v_obc(LBij:,:,:,:,:)
1635# endif
1636 real(r8), intent(inout) :: ad_ubar_obc(LBij:,:,:,:)
1637 real(r8), intent(inout) :: ad_vbar_obc(LBij:,:,:,:)
1638 real(r8), intent(inout) :: ad_zeta_obc(LBij:,:,:,:)
1639# endif
1640# ifdef ADJUST_WSTRESS
1641 real(r8), intent(inout) :: ad_ustr(LBi:,LBj:,:,:)
1642 real(r8), intent(inout) :: ad_vstr(LBi:,LBj:,:,:)
1643# endif
1644# if defined ADJUST_STFLUX && defined SOLVE3D
1645 real(r8), intent(inout) :: ad_tflux(LBi:,LBj:,:,:,:)
1646# endif
1647# ifdef SOLVE3D
1648 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
1649 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
1650 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
1651# if defined WEAK_CONSTRAINT && defined TIME_CONV
1652 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
1653 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
1654# endif
1655# ifdef HESSIAN_FSV
1656 real(r8), intent(in) :: Hz(LBi:,LBj:,:)
1657 real(r8), intent(inout) :: f_t(LBi:,LBj:,:,:)
1658 real(r8), intent(inout) :: f_u(LBi:,LBj:,:)
1659 real(r8), intent(inout) :: f_v(LBi:,LBj:,:)
1660 real(r8), intent(inout) :: f_ubar(LBi:,LBj:)
1661 real(r8), intent(inout) :: f_vbar(LBi:,LBj:)
1662# endif
1663# else
1664 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
1665 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
1666# ifdef HESSIAN_FSV
1667 real(r8), intent(inout) :: f_ubar(LBi:,LBj:)
1668 real(r8), intent(inout) :: f_vbar(LBi:,LBj:)
1669# endif
1670# endif
1671 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
1672# ifdef HESSIAN_FSV
1673 real(r8), intent(inout) :: f_zeta(LBi:,LBj:)
1674# endif
1675# ifdef ADJUST_BOUNDARY
1676# ifdef SOLVE3D
1677 real(r8), intent(inout) :: tl_t_obc(LBij:,:,:,:,:,:)
1678 real(r8), intent(inout) :: tl_u_obc(LBij:,:,:,:,:)
1679 real(r8), intent(inout) :: tl_v_obc(LBij:,:,:,:,:)
1680# endif
1681 real(r8), intent(inout) :: tl_ubar_obc(LBij:,:,:,:)
1682 real(r8), intent(inout) :: tl_vbar_obc(LBij:,:,:,:)
1683 real(r8), intent(inout) :: tl_zeta_obc(LBij:,:,:,:)
1684# endif
1685# ifdef ADJUST_WSTRESS
1686 real(r8), intent(inout) :: tl_ustr(LBi:,LBj:,:,:)
1687 real(r8), intent(inout) :: tl_vstr(LBi:,LBj:,:,:)
1688# endif
1689# if defined ADJUST_STFLUX && defined SOLVE3D
1690 real(r8), intent(inout) :: tl_tflux(LBi:,LBj:,:,:,:)
1691# endif
1692# ifdef SOLVE3D
1693 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
1694 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
1695 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
1696# if defined WEAK_CONSTRAINT && defined TIME_CONV
1697 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
1698 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
1699# endif
1700# else
1701 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
1702 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
1703# endif
1704 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
1705# else
1706# ifdef MASKING
1707 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
1708 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
1709 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
1710# endif
1711# ifdef ADJUST_BOUNDARY
1712# ifdef SOLVE3D
1713 real(r8), intent(inout) :: ad_t_obc(LBij:UBij,N(ng),4, &
1714 & Nbrec(ng),2,NT(ng))
1715 real(r8), intent(inout) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
1716 real(r8), intent(inout) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
1717# endif
1718 real(r8), intent(inout) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
1719 real(r8), intent(inout) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
1720 real(r8), intent(inout) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
1721# endif
1722# ifdef ADJUST_WSTRESS
1723 real(r8), intent(inout) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
1724 real(r8), intent(inout) :: ad_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
1725# endif
1726# if defined ADJUST_STFLUX && defined SOLVE3D
1727 real(r8), intent(inout) :: ad_tflux(LBi:UBi,LBj:UBj, &
1728 & Nfrec(ng),2,NT(ng))
1729# endif
1730# ifdef SOLVE3D
1731 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
1732 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
1733 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
1734# if defined WEAK_CONSTRAINT && defined TIME_CONV
1735 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
1736 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
1737# endif
1738# ifdef HESSIAN_FSV
1739 real(r8), intent(in) :: Hz(LBi:UBi,LBj:UBj,N(ng))
1740 real(r8), intent(inout) :: f_t(LBi:UBi,LBj:UBj,N(ng),NT(ng))
1741 real(r8), intent(inout) :: f_u(LBi:UBi,LBj:UBj,N(ng))
1742 real(r8), intent(inout) :: f_v(LBi:UBi,LBj:UBj,N(ng))
1743 real(r8), intent(inout) :: f_ubar(LBi:UBi,LBj:UBj)
1744 real(r8), intent(inout) :: f_vbar(LBi:UBi,LBj:UBj)
1745# endif
1746# else
1747 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
1748 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
1749# ifdef HESSIAN_FSV
1750 real(r8), intent(inout) :: f_ubar(LBi:UBi,LBj:UBj)
1751 real(r8), intent(inout) :: f_vbar(LBi:UBi,LBj:UBj)
1752# endif
1753# endif
1754 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
1755# ifdef HESSIAN_FSV
1756 real(r8), intent(inout) :: f_zeta(LBi:UBi,LBj:UBj)
1757# endif
1758# ifdef ADJUST_BOUNDARY
1759# ifdef SOLVE3D
1760 real(r8), intent(inout) :: tl_t_obc(LBij:,:,:,:,:,:)
1761 real(r8), intent(inout) :: tl_u_obc(LBij:,:,:,:,:)
1762 real(r8), intent(inout) :: tl_v_obc(LBij:,:,:,:,:)
1763# endif
1764 real(r8), intent(inout) :: tl_ubar_obc(LBij:,:,:,:)
1765 real(r8), intent(inout) :: tl_vbar_obc(LBij:,:,:,:)
1766 real(r8), intent(inout) :: tl_zeta_obc(LBij:,:,:,:)
1767# endif
1768# ifdef ADJUST_WSTRESS
1769 real(r8), intent(inout) :: tl_ustr(LBi:,LBj:,:,:)
1770 real(r8), intent(inout) :: tl_vstr(LBi:,LBj:,:,:)
1771# endif
1772# if defined ADJUST_STFLUX && defined SOLVE3D
1773 real(r8), intent(inout) :: tl_tflux(LBi:,LBj:,:,:,:)
1774# endif
1775# ifdef SOLVE3D
1776 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
1777 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
1778 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
1779# if defined WEAK_CONSTRAINT && defined TIME_CONV
1780 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
1781 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
1782# endif
1783# else
1784 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
1785 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
1786# endif
1787 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
1788# endif
1789!
1790 real(r8) :: work(Ninner)
1791 real(r8) :: dot_sav(Ninner)
1792# ifdef LCZ_FINAL
1793 real(r8) :: work1(Ninner)
1794 real(r8) :: sum
1795# endif
1796!
1797! Local variable declarations.
1798!
1799 integer :: Lwrk, i, j, lstr, outLoop, rec, info
1800
1801 integer :: ndefLCZ = 1
1802# ifdef LCZ_FINAL
1803 integer :: ndefLZE = 1
1804# endif
1805 integer :: kin
1806# ifdef SOLVE3D
1807 integer :: itrc, k, nin
1808# ifdef HESSIAN_FSV
1809 real(r8) :: cff1, cff2
1810 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: CF
1811 real(r8), dimension(IminS:ImaxS,0:N(ng)) :: DC
1812# endif
1813# endif
1814 real(r8) :: fac, fac1, fac2
1815 real(r8) :: zbeta
1816
1817 real(r8), dimension(0:NstateVar(ng)) :: dot
1818 real(r8), dimension(Ninner) :: DotProd
1819 real(r8), dimension(Ninner) :: bvector
1820!
1821 character (len=256) :: ncname
1822
1823 character (len=*), parameter :: MyFile = &
1824 & __FILE__//", ad_inner2state_tile"
1825
1826# include "set_bounds.h"
1827!
1828 calledfrom=myfile
1829 sourcefile=myfile
1830!
1831! Clear ad_state array.
1832!
1833 DO i=1,ninner
1834 ad_state(i)=0.0_r8
1835 END DO
1836!
1837# ifdef SOLVE3D
1838 nin=nstp(ng)
1839# endif
1840# ifdef HESSIAN_SO
1841 kin=knew(ng)
1842# else
1843 kin=kstp(ng)
1844# endif
1845# ifdef HESSIAN_FSV
1846!
1847! Copy f_var into ad_var arrays then clear the f_var arrays.
1848!
1849 DO j=jstrr,jendr
1850 DO i=istrr,iendr
1851 ad_zeta(i,j,kin)=f_zeta(i,j)
1852 f_zeta(i,j)=0.0_r8
1853 END DO
1854 END DO
1855# ifndef SOLVE3D
1856!
1857! Tangent linear 2D momentum.
1858
1859 DO j=jstrr,jendr
1860 DO i=istr,iendr
1861 ad_ubar(i,j,kin)=f_ubar(i,j)
1862 f_ubar(i,j)=0.0_r8
1863 END DO
1864 END DO
1865!
1866 DO j=jstr,jendr
1867 DO i=istrr,iendr
1868 ad_vbar(i,j,kin)=f_vbar(i,j)
1869 f_vbar(i,j)=0.0_r8
1870 END DO
1871 END DO
1872
1873# else
1874!
1875! Compute the contribution of f_ubar to f_u.
1876!
1877 DO j=jstr,jend
1878 DO i=istru,iend
1879 dc(i,0)=0.0_r8
1880 cf(i,0)=0.0_r8
1881 END DO
1882 DO k=1,n(ng)
1883 DO i=istru,iend
1884 dc(i,k)=0.5_r8*(hz(i,j,k)+hz(i-1,j,k))
1885 dc(i,0)=dc(i,0)+dc(i,k)
1886 END DO
1887 END DO
1888 DO i=istru,iend
1889 cff2=f_ubar(i,j)
1890 f_ubar(i,j)=0.0_r8
1891# ifdef MASKING
1892 cff2=cff2*umask(i,j)
1893# endif
1894 cff1=1.0_r8/dc(i,0)
1895 cf(i,0)=cff2*cff1
1896 cff2=0.0_r8
1897 END DO
1898 DO k=1,n(ng)
1899 DO i=istru,iend
1900 f_u(i,j,k)=f_u(i,j,k)+dc(i,k)*cf(i,0)
1901 END DO
1902 END DO
1903 DO i=istru,iend
1904 cf(i,0)=0.0_r8
1905 END DO
1906 END DO
1907!
1908! Compute the contribution of f_vbar to f_v.
1909!
1910 DO j=jstrv,jend
1911 IF (j.ge.jstrm) THEN
1912 DO i=istr,iend
1913 dc(i,0)=0.0_r8
1914 cf(i,0)=0.0_r8
1915 END DO
1916 DO k=1,n(ng)
1917 DO i=istr,iend
1918 dc(i,k)=0.5_r8*(hz(i,j,k)+hz(i,j-1,k))
1919 dc(i,0)=dc(i,0)+dc(i,k)
1920 END DO
1921 END DO
1922 DO i=istr,iend
1923 cff2=f_vbar(i,j)
1924 f_vbar(i,j)=0.0_r8
1925# ifdef MASKING
1926 cff2=cff2*vmask(i,j)
1927# endif
1928 cff1=1.0_r8/dc(i,0)
1929 cf(i,0)=cff2*cff1
1930 cff2=0.0_r8
1931 END DO
1932 DO k=1,n(ng)
1933 DO i=istr,iend
1934 f_v(i,j,k)=f_v(i,j,k)+dc(i,k)*cf(i,0)
1935 END DO
1936 END DO
1937 DO i=istr,iend
1938 cf(i,0)=0.0_r8
1939 END DO
1940 END IF
1941 END DO
1942!
1943! Tangent linear 3D momentum.
1944!
1945 DO k=1,n(ng)
1946 DO j=jstrr,jendr
1947 DO i=istr,iendr
1948 ad_u(i,j,k,nin)=f_u(i,j,k)
1949 f_u(i,j,k)=0.0_r8
1950 END DO
1951 END DO
1952 DO j=jstr,jendr
1953 DO i=istrr,iendr
1954 ad_v(i,j,k,nin)=f_v(i,j,k)
1955 f_v(i,j,k)=0.0_r8
1956 END DO
1957 END DO
1958 END DO
1959!
1960! Tangent linear tracers.
1961!
1962 DO itrc=1,nt(ng)
1963 DO k=1,n(ng)
1964 DO j=jstrr,jendr
1965 DO i=istrr,iendr
1966 ad_t(i,j,k,nin,itrc)=f_t(i,j,k,itrc)
1967 f_t(i,j,k,itrc)=0.0_r8
1968 END DO
1969 END DO
1970 END DO
1971 END DO
1972# endif
1973# endif
1974!
1975!-----------------------------------------------------------------------
1976! Compute tangent linear model initial conditions from the weighted
1977! sum of the Lanczos vectors.
1978!-----------------------------------------------------------------------
1979!
1980! Determine if single or multiple Lanczos vector NetCDF files.
1981# ifdef LCZ_FINAL
1982!
1983 SELECT CASE (lze(ng)%IOtype)
1984 CASE (io_nf90)
1985 CALL netcdf_get_ivar (ng, iadm, trim(lze(ng)%name), &
1986 & 'ndefADJ', ndeflze)
1987
1988# if defined PIO_LIB && defined DISTRIBUTE
1989 CASE (io_pio)
1990 CALL pio_netcdf_get_ivar (ng, iadm, trim(lze(ng)%name), &
1991 & 'ndefADJ', ndeflze)
1992# endif
1993 END SELECT
1994 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1995# else
1996!
1997 SELECT CASE (lcz(ng)%IOtype)
1998 CASE (io_nf90)
1999 CALL netcdf_get_ivar (ng, iadm, trim(lcz(ng)%name), &
2000 & 'ndefADJ', ndeflcz)
2001
2002# if defined PIO_LIB && defined DISTRIBUTE
2003 CASE (io_pio)
2004 CALL pio_netcdf_get_ivar (ng, iadm, trim(lcz(ng)%name), &
2005 & 'ndefADJ', ndeflcz)
2006# endif
2007 END SELECT
2008 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2009# endif
2010!
2011 lwrk=2
2012 DO inner=1,ninner
2013# ifdef LCZ_FINAL
2014!
2015! Determine Lanczos vector file to read. The orthonormalized evolved
2016! Lanczos vectors are written into the Hessian.
2017!
2018 IF (ndeflze.gt.0) THEN
2019 lstr=len_trim(lze(ng)%name)
2020 WRITE (ncname,10) lze(ng)%name(1:lstr-8), inner
2021 10 FORMAT (a,'_',i4.4,'.nc')
2022 ELSE
2023 ncname=lze(ng)%name
2024 END IF
2025# else
2026!
2027! Determine Lanczos vector file to read. The Lanczos vectors are
2028! written into the adjoint NetCDF in the I4D-Var Lanczos algorithm.
2029! The Lanczos vector for each inner loop is accumulated in the
2030! unlimited dimension. The name of this file is provided here in
2031! the LCZ(ng)%name variable since the ADM(ng)%name value will be
2032! use in the adjoint sensitivity part.
2033!
2034 IF (ndeflcz.gt.0) THEN
2035 lstr=len_trim(lcz(ng)%name)
2036 WRITE (ncname,10) lcz(ng)%name(1:lstr-8), inner
2037 10 FORMAT (a,'_',i4.4,'.nc')
2038 ELSE
2039 ncname=lcz(ng)%name
2040 END IF
2041# endif
2042!
2043! Read in the Lanczos vectors (q_i, where i=1,2,...k) computed from
2044! k inner-loops of the I4D-Var algorithm first outer loop. Load
2045! Lanczos vectors into TANGENT LINEAR STATE ARRAYS at index Lwrk.
2046!
2047 CALL state_read (ng, tile, iadm, &
2048# ifdef LCZ_FINAL
2049 & lze(ng)%IOtype, &
2050# else
2051 & lcz(ng)%IOtype, &
2052# endif
2053 & lbi, ubi, lbj, ubj, lbij, ubij, &
2054 & lwrk, inner, &
2055# ifdef LCZ_FINAL
2056 & ndeflze, lze(ng)%ncid, &
2057# if defined PIO_LIB && defined DISTRIBUTE
2058 & lze(ng)%pioFile, &
2059# endif
2060# else
2061 & ndeflcz, lcz(ng)%ncid, &
2062# if defined PIO_LIB && defined DISTRIBUTE
2063 & lcz(ng)%pioFile, &
2064# endif
2065# endif
2066 & trim(ncname), &
2067# ifdef MASKING
2068 & rmask, umask, vmask, &
2069# endif
2070# ifdef ADJUST_BOUNDARY
2071# ifdef SOLVE3D
2072 & tl_t_obc, tl_u_obc, tl_v_obc, &
2073# endif
2074 & tl_ubar_obc, tl_vbar_obc, &
2075 & tl_zeta_obc, &
2076# endif
2077# ifdef ADJUST_WSTRESS
2078 & tl_ustr, tl_vstr, &
2079# endif
2080# if defined ADJUST_STFLUX && defined SOLVE3D
2081 & tl_tflux, &
2082# endif
2083# ifdef SOLVE3D
2084 & tl_t, tl_u, tl_v, &
2085# else
2086 & tl_ubar, tl_vbar, &
2087# endif
2088 & tl_zeta)
2089 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2090
2091 CALL state_dotprod (ng, tile, iadm, &
2092 & lbi, ubi, lbj, ubj, lbij, ubij, &
2093 & nstatevar(ng), dot(0:), &
2094# ifdef MASKING
2095 & rmask, umask, vmask, &
2096# endif
2097# ifdef ADJUST_BOUNDARY
2098# ifdef SOLVE3D
2099 & ad_t_obc(:,:,:,:,lnew,:), &
2100 & tl_t_obc(:,:,:,:,lwrk,:), &
2101 & ad_u_obc(:,:,:,:,lnew), &
2102 & tl_u_obc(:,:,:,:,lwrk), &
2103 & ad_v_obc(:,:,:,:,lnew), &
2104 & tl_v_obc(:,:,:,:,lwrk), &
2105# endif
2106 & ad_ubar_obc(:,:,:,lnew), &
2107 & tl_ubar_obc(:,:,:,lwrk), &
2108 & ad_vbar_obc(:,:,:,lnew), &
2109 & tl_vbar_obc(:,:,:,lwrk), &
2110 & ad_zeta_obc(:,:,:,lnew), &
2111 & tl_zeta_obc(:,:,:,lwrk), &
2112# endif
2113# ifdef ADJUST_WSTRESS
2114 & ad_ustr(:,:,:,lnew), tl_ustr(:,:,:,lwrk), &
2115 & ad_vstr(:,:,:,lnew), tl_vstr(:,:,:,lwrk), &
2116# endif
2117# ifdef SOLVE3D
2118# ifdef ADJUST_STFLUX
2119 & ad_tflux(:,:,:,lnew,:), &
2120 & tl_tflux(:,:,:,lwrk,:), &
2121# endif
2122 & ad_t(:,:,:,nin,:), tl_t(:,:,:,lwrk,:), &
2123 & ad_u(:,:,:,nin), tl_u(:,:,:,lwrk), &
2124 & ad_v(:,:,:,nin), tl_v(:,:,:,lwrk), &
2125# else
2126 & ad_ubar(:,:,kin), tl_ubar(:,:,lwrk), &
2127 & ad_vbar(:,:,kin), tl_vbar(:,:,lwrk), &
2128# endif
2129 & ad_zeta(:,:,kin), tl_zeta(:,:,lwrk))
2130
2131 dot_sav(inner)=dot(0)
2132 END DO
2133 DO i=1,ninner
2134 work(i)=dot_sav(i)
2135 END DO
2136# ifdef LCZ_FINAL
2137!
2138! Now multiply by Tranpose(GSmatinv).
2139!
2140 DO i=1,ninner
2141 sum=0.0_r8
2142 DO j=1,ninner
2143 sum=sum+gsmatinv(j,i)*work(j)
2144 END DO
2145 work1(i)=sum
2146 END DO
2147 DO i=1,ninner
2148 work(i)=work1(i)
2149 END DO
2150# endif
2151!
2152! Compute inv(sqrt(D))*inv(L).
2153!
2154 DO i=1,ninner-1
2155 work(i+1)=work(i+1)-zlanczos_offdiag(i)*work(i)
2156 END DO
2157 DO i=1,ninner
2158 ad_state(i)=work(i)/zlanczos_diag(i)
2159 work(i)=0.0_r8
2160 END DO
2161!
2162 RETURN
2163 END SUBROUTINE ad_inner2state_tile
2164!
2165!***********************************************************************
2166 SUBROUTINE ini_c_norm (ng, tile, Kinp, Ninp, StateNorm)
2167!***********************************************************************
2168!
2169! Imported variable declarations.
2170!
2171 integer, intent(in) :: ng, tile, kinp, ninp
2172
2173 real(r8), intent(out) :: statenorm
2174!
2175! Local variable declarations.
2176!
2177 character (len=*), parameter :: myfile = &
2178 & __FILE__//", ini_C_norm"
2179!
2180# include "tile.h"
2181!
2182# ifdef PROFILE
2183 CALL wclock_on (ng, itlm, 2, __line__, myfile)
2184# endif
2185 CALL ini_c_norm_tile (ng, tile, &
2186 & lbi, ubi, lbj, ubj, lbij, ubij, &
2187 & imins, imaxs, jmins, jmaxs, &
2188 & kinp, ninp, &
2189 & statenorm, &
2190# ifdef MASKING
2191 & grid(ng) % rmask, &
2192 & grid(ng) % umask, &
2193 & grid(ng) % vmask, &
2194# endif
2195# ifdef ADJUST_BOUNDARY
2196# ifdef SOLVE3D
2197 & boundary(ng) % ad_t_obc, &
2198 & boundary(ng) % ad_u_obc, &
2199 & boundary(ng) % ad_v_obc, &
2200# endif
2201 & boundary(ng) % ad_ubar_obc, &
2202 & boundary(ng) % ad_vbar_obc, &
2203 & boundary(ng) % ad_zeta_obc, &
2204# endif
2205# ifdef ADJUST_WSTRESS
2206 & forces(ng) % ad_ustr, &
2207 & forces(ng) % ad_vstr, &
2208# endif
2209# if defined ADJUST_STFLUX && defined SOLVE3D
2210 & forces(ng) % ad_tflux, &
2211# endif
2212# ifdef SOLVE3D
2213 & ocean(ng) % ad_t, &
2214 & ocean(ng) % ad_u, &
2215 & ocean(ng) % ad_v, &
2216# else
2217 & ocean(ng) % ad_ubar, &
2218 & ocean(ng) % ad_vbar, &
2219# endif
2220 & ocean(ng) % ad_zeta, &
2221# ifdef ADJUST_BOUNDARY
2222# ifdef SOLVE3D
2223 & boundary(ng) % tl_t_obc, &
2224 & boundary(ng) % tl_u_obc, &
2225 & boundary(ng) % tl_v_obc, &
2226# endif
2227 & boundary(ng) % tl_ubar_obc, &
2228 & boundary(ng) % tl_vbar_obc, &
2229 & boundary(ng) % tl_zeta_obc, &
2230# endif
2231# ifdef ADJUST_WSTRESS
2232 & forces(ng) % tl_ustr, &
2233 & forces(ng) % tl_vstr, &
2234# endif
2235# if defined ADJUST_STFLUX && defined SOLVE3D
2236 & forces(ng) % tl_tflux, &
2237# endif
2238# ifdef SOLVE3D
2239 & ocean(ng) % tl_t, &
2240 & ocean(ng) % tl_u, &
2241 & ocean(ng) % tl_v, &
2242# else
2243 & ocean(ng) % tl_ubar, &
2244 & ocean(ng) % tl_vbar, &
2245# endif
2246 & ocean(ng) % tl_zeta, &
2247# ifdef ADJUST_BOUNDARY
2248# ifdef SOLVE3D
2249 & boundary(ng) % t_obc, &
2250 & boundary(ng) % u_obc, &
2251 & boundary(ng) % v_obc, &
2252# endif
2253 & boundary(ng) % ubar_obc, &
2254 & boundary(ng) % vbar_obc, &
2255 & boundary(ng) % zeta_obc, &
2256# endif
2257# ifdef ADJUST_WSTRESS
2258 & forces(ng) % ustr, &
2259 & forces(ng) % vstr, &
2260# endif
2261# if defined ADJUST_STFLUX && defined SOLVE3D
2262 & forces(ng) % tflux, &
2263# endif
2264# ifdef SOLVE3D
2265 & ocean(ng) % t, &
2266 & ocean(ng) % u, &
2267 & ocean(ng) % v, &
2268# else
2269 & ocean(ng) % ubar, &
2270 & ocean(ng) % vbar, &
2271# endif
2272 & ocean(ng) % zeta)
2273# ifdef PROFILE
2274 CALL wclock_off (ng, itlm, 2, __line__, myfile)
2275# endif
2276!
2277 RETURN
2278 END SUBROUTINE ini_c_norm
2279!
2280!***********************************************************************
2281 SUBROUTINE ini_c_norm_tile (ng, tile , &
2282 & LBi, UBi, LBj, UBj, LBij, UBij, &
2283 & IminS, ImaxS, JminS, JmaxS, &
2284 & Kinp, Ninp, &
2285 & StateNorm, &
2286# ifdef MASKING
2287 & rmask, umask, vmask, &
2288# endif
2289# ifdef ADJUST_BOUNDARY
2290# ifdef SOLVE3D
2291 & ad_t_obc, ad_u_obc, ad_v_obc, &
2292# endif
2293 & ad_ubar_obc, ad_vbar_obc, &
2294 & ad_zeta_obc, &
2295# endif
2296# ifdef ADJUST_WSTRESS
2297 & ad_ustr, ad_vstr, &
2298# endif
2299# if defined ADJUST_STFLUX && defined SOLVE3D
2300 & ad_tflux, &
2301# endif
2302# ifdef SOLVE3D
2303 & ad_t, ad_u, ad_v, &
2304# else
2305 & ad_ubar, ad_vbar, &
2306# endif
2307 & ad_zeta, &
2308# ifdef ADJUST_BOUNDARY
2309# ifdef SOLVE3D
2310 & tl_t_obc, tl_u_obc, tl_v_obc, &
2311# endif
2312 & tl_ubar_obc, tl_vbar_obc, &
2313 & tl_zeta_obc, &
2314# endif
2315# ifdef ADJUST_WSTRESS
2316 & tl_ustr, tl_vstr, &
2317# endif
2318# if defined ADJUST_STFLUX && defined SOLVE3D
2319 & tl_tflux, &
2320# endif
2321# ifdef SOLVE3D
2322 & tl_t, tl_u, tl_v, &
2323# else
2324 & tl_ubar, tl_vbar, &
2325# endif
2326 & tl_zeta, &
2327# ifdef ADJUST_BOUNDARY
2328# ifdef SOLVE3D
2329 & t_obc, u_obc, v_obc, &
2330# endif
2331 & ubar_obc,_vbar_obc, &
2332 & zeta_obc, &
2333# endif
2334# ifdef ADJUST_WSTRESS
2335 & ustr, vstr, &
2336# endif
2337# if defined ADJUST_STFLUX && defined SOLVE3D
2338 & tflux, &
2339# endif
2340# ifdef SOLVE3D
2341 & t, u, v, &
2342# else
2343 & ubar, vbar, &
2344# endif
2345 & zeta)
2346!***********************************************************************
2347!
2348! Imported variable declarations.
2349!
2350 integer, intent(in) :: ng, tile
2351 integer, intent(in) :: LBi, UBi, LBj, UBj, LBij, UBij
2352 integer, intent(in) :: IminS, ImaxS, JminS, JmaxS
2353 integer, intent(in) :: Kinp, Ninp
2354
2355 real(r8), intent(out) :: StateNorm
2356!
2357# ifdef ASSUMED_SHAPE
2358# ifdef MASKING
2359 real(r8), intent(in) :: rmask(LBi:,LBj:)
2360 real(r8), intent(in) :: umask(LBi:,LBj:)
2361 real(r8), intent(in) :: vmask(LBi:,LBj:)
2362# endif
2363# ifdef ADJUST_BOUNDARY
2364# ifdef SOLVE3D
2365 real(r8), intent(inout) :: ad_t_obc(LBij:,:,:,:,:,:)
2366 real(r8), intent(inout) :: ad_u_obc(LBij:,:,:,:,:)
2367 real(r8), intent(inout) :: ad_v_obc(LBij:,:,:,:,:)
2368# endif
2369 real(r8), intent(inout) :: ad_ubar_obc(LBij:,:,:,:)
2370 real(r8), intent(inout) :: ad_vbar_obc(LBij:,:,:,:)
2371 real(r8), intent(inout) :: ad_zeta_obc(LBij:,:,:,:)
2372# endif
2373# ifdef ADJUST_WSTRESS
2374 real(r8), intent(inout) :: ad_ustr(LBi:,LBj:,:,:)
2375 real(r8), intent(inout) :: ad_vstr(LBi:,LBj:,:,:)
2376# endif
2377# if defined ADJUST_STFLUX && defined SOLVE3D
2378 real(r8), intent(inout) :: ad_tflux(LBi:,LBj:,:,:,:)
2379# endif
2380# ifdef SOLVE3D
2381 real(r8), intent(inout) :: ad_t(LBi:,LBj:,:,:,:)
2382 real(r8), intent(inout) :: ad_u(LBi:,LBj:,:,:)
2383 real(r8), intent(inout) :: ad_v(LBi:,LBj:,:,:)
2384# else
2385 real(r8), intent(inout) :: ad_ubar(LBi:,LBj:,:)
2386 real(r8), intent(inout) :: ad_vbar(LBi:,LBj:,:)
2387# endif
2388 real(r8), intent(inout) :: ad_zeta(LBi:,LBj:,:)
2389# ifdef ADJUST_BOUNDARY
2390# ifdef SOLVE3D
2391 real(r8), intent(inout) :: tl_t_obc(LBij:,:,:,:,:,:)
2392 real(r8), intent(inout) :: tl_u_obc(LBij:,:,:,:,:)
2393 real(r8), intent(inout) :: tl_v_obc(LBij:,:,:,:,:)
2394# endif
2395 real(r8), intent(inout) :: tl_ubar_obc(LBij:,:,:,:)
2396 real(r8), intent(inout) :: tl_vbar_obc(LBij:,:,:,:)
2397 real(r8), intent(inout) :: tl_zeta_obc(LBij:,:,:,:)
2398# endif
2399# ifdef ADJUST_WSTRESS
2400 real(r8), intent(inout) :: tl_ustr(LBi:,LBj:,:,:)
2401 real(r8), intent(inout) :: tl_vstr(LBi:,LBj:,:,:)
2402# endif
2403# if defined ADJUST_STFLUX && defined SOLVE3D
2404 real(r8), intent(inout) :: tl_tflux(LBi:,LBj:,:,:,:)
2405# endif
2406# ifdef SOLVE3D
2407 real(r8), intent(inout) :: tl_t(LBi:,LBj:,:,:,:)
2408 real(r8), intent(inout) :: tl_u(LBi:,LBj:,:,:)
2409 real(r8), intent(inout) :: tl_v(LBi:,LBj:,:,:)
2410# else
2411 real(r8), intent(inout) :: tl_ubar(LBi:,LBj:,:)
2412 real(r8), intent(inout) :: tl_vbar(LBi:,LBj:,:)
2413# endif
2414 real(r8), intent(inout) :: tl_zeta(LBi:,LBj:,:)
2415# ifdef ADJUST_BOUNDARY
2416# ifdef SOLVE3D
2417 real(r8), intent(inout) :: t_obc(LBij:,:,:,:,:,:)
2418 real(r8), intent(inout) :: u_obc(LBij:,:,:,:,:)
2419 real(r8), intent(inout) :: v_obc(LBij:,:,:,:,:)
2420# endif
2421 real(r8), intent(inout) :: ubar_obc(LBij:,:,:,:)
2422 real(r8), intent(inout) :: vbar_obc(LBij:,:,:,:)
2423 real(r8), intent(inout) :: zeta_obc(LBij:,:,:,:)
2424# endif
2425# ifdef ADJUST_WSTRESS
2426 real(r8), intent(inout) :: ustr(LBi:,LBj:,:,:)
2427 real(r8), intent(inout) :: vstr(LBi:,LBj:,:,:)
2428# endif
2429# if defined ADJUST_STFLUX && defined SOLVE3D
2430 real(r8), intent(inout) :: tflux(LBi:,LBj:,:,:,:)
2431# endif
2432# ifdef SOLVE3D
2433 real(r8), intent(inout) :: t(LBi:,LBj:,:,:,:)
2434 real(r8), intent(inout) :: u(LBi:,LBj:,:,:)
2435 real(r8), intent(inout) :: v(LBi:,LBj:,:,:)
2436# else
2437 real(r8), intent(inout) :: ubar(LBi:,LBj:,:)
2438 real(r8), intent(inout) :: vbar(LBi:,LBj:,:)
2439# endif
2440 real(r8), intent(inout) :: zeta(LBi:,LBj:,:)
2441# else
2442# ifdef MASKING
2443 real(r8), intent(in) :: rmask(LBi:UBi,LBj:UBj)
2444 real(r8), intent(in) :: umask(LBi:UBi,LBj:UBj)
2445 real(r8), intent(in) :: vmask(LBi:UBi,LBj:UBj)
2446# endif
2447# ifdef ADJUST_BOUNDARY
2448# ifdef SOLVE3D
2449 real(r8), intent(inout) :: ad_t_obc(LBij:UBij,N(ng),4, &
2450 & Nbrec(ng),2,NT(ng))
2451 real(r8), intent(inout) :: ad_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2452 real(r8), intent(inout) :: ad_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2453# endif
2454 real(r8), intent(inout) :: ad_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
2455 real(r8), intent(inout) :: ad_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
2456 real(r8), intent(inout) :: ad_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
2457# endif
2458# ifdef ADJUST_WSTRESS
2459 real(r8), intent(inout) :: ad_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2460 real(r8), intent(inout) :: ad_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2461# endif
2462# if defined ADJUST_STFLUX && defined SOLVE3D
2463 real(r8), intent(inout) :: ad_tflux(LBi:UBi,LBj:UBj, &
2464 & Nfrec(ng),2,NT(ng))
2465# endif
2466# ifdef SOLVE3D
2467 real(r8), intent(inout) :: ad_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
2468 real(r8), intent(inout) :: ad_u(LBi:UBi,LBj:UBj,N(ng),2)
2469 real(r8), intent(inout) :: ad_v(LBi:UBi,LBj:UBj,N(ng),2)
2470# else
2471 real(r8), intent(inout) :: ad_ubar(LBi:UBi,LBj:UBj,:)
2472 real(r8), intent(inout) :: ad_vbar(LBi:UBi,LBj:UBj,:)
2473# endif
2474 real(r8), intent(inout) :: ad_zeta(LBi:UBi,LBj:UBj,:)
2475# ifdef ADJUST_BOUNDARY
2476# ifdef SOLVE3D
2477 real(r8), intent(inout) :: tl_t_obc(LBij:UBij,N(ng),4, &
2478 & Nbrec(ng),2,NT(ng))
2479 real(r8), intent(inout) :: tl_u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2480 real(r8), intent(inout) :: tl_v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2481# endif
2482 real(r8), intent(inout) :: tl_ubar_obc(LBij:UBij,4,Nbrec(ng),2)
2483 real(r8), intent(inout) :: tl_vbar_obc(LBij:UBij,4,Nbrec(ng),2)
2484 real(r8), intent(inout) :: tl_zeta_obc(LBij:UBij,4,Nbrec(ng),2)
2485# endif
2486# ifdef ADJUST_WSTRESS
2487 real(r8), intent(inout) :: tl_ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2488 real(r8), intent(inout) :: tl_vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2489# endif
2490# if defined ADJUST_STFLUX && defined SOLVE3D
2491 real(r8), intent(inout) :: tl_tflux(LBi:UBi,LBj:UBj, &
2492 & Nfrec(ng),2,NT(ng))
2493# endif
2494# ifdef SOLVE3D
2495 real(r8), intent(inout) :: tl_t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
2496 real(r8), intent(inout) :: tl_u(LBi:UBi,LBj:UBj,N(ng),2)
2497 real(r8), intent(inout) :: tl_v(LBi:UBi,LBj:UBj,N(ng),2)
2498# else
2499 real(r8), intent(inout) :: tl_ubar(LBi:UBi,LBj:UBj,:)
2500 real(r8), intent(inout) :: tl_vbar(LBi:UBi,LBj:UBj,:)
2501# endif
2502 real(r8), intent(inout) :: tl_zeta(LBi:UBi,LBj:UBj,:)
2503# ifdef ADJUST_BOUNDARY
2504# ifdef SOLVE3D
2505 real(r8), intent(inout) :: t_obc(LBij:UBij,N(ng),4, &
2506 & Nbrec(ng),2,NT(ng))
2507 real(r8), intent(inout) :: u_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2508 real(r8), intent(inout) :: v_obc(LBij:UBij,N(ng),4,Nbrec(ng),2)
2509# endif
2510 real(r8), intent(inout) :: ubar_obc(LBij:UBij,4,Nbrec(ng),2)
2511 real(r8), intent(inout) :: vbar_obc(LBij:UBij,4,Nbrec(ng),2)
2512 real(r8), intent(inout) :: zeta_obc(LBij:UBij,4,Nbrec(ng),2)
2513# endif
2514# ifdef ADJUST_WSTRESS
2515 real(r8), intent(inout) :: ustr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2516 real(r8), intent(inout) :: vstr(LBi:UBi,LBj:UBj,Nfrec(ng),2)
2517# endif
2518# if defined ADJUST_STFLUX && defined SOLVE3D
2519 real(r8), intent(inout) :: tflux(LBi:UBi,LBj:UBj, &
2520 & Nfrec(ng),2,NT(ng))
2521# endif
2522# ifdef SOLVE3D
2523 real(r8), intent(inout) :: t(LBi:UBi,LBj:UBj,N(ng),3,NT(ng))
2524 real(r8), intent(inout) :: u(LBi:UBi,LBj:UBj,N(ng),2)
2525 real(r8), intent(inout) :: v(LBi:UBi,LBj:UBj,N(ng),2)
2526# else
2527 real(r8), intent(inout) :: ubar(LBi:UBi,LBj:UBj,:)
2528 real(r8), intent(inout) :: vbar(LBi:UBi,LBj:UBj,:)
2529# endif
2530 real(r8), intent(inout) :: zeta(LBi:UBi,LBj:UBj,:)
2531# endif
2532!
2533! Local variable declarations.
2534!
2535 integer :: Lwrk1, Lwrk2, i, j, lstr, outLoop, rec
2536
2537 integer :: ndefLCZ = 1
2538# ifdef LCZ_FINAL
2539 integer :: ndefLZE = 1
2540# endif
2541# ifdef SOLVE3D
2542 integer :: itrc, k
2543# endif
2544!
2545 real(r8) :: fac, fac1, fac2
2546 real(r8) :: zbeta
2547
2548 real(r8), dimension(0:NstateVar(ng)) :: dot
2549 real(r8), dimension(Ninner) :: DotProd
2550 real(r8), dimension(Ninner) :: bvector
2551# ifdef LCZ_FINAL
2552 real(r8) :: sum
2553 real(r8), dimension(Ninner) :: work1
2554# endif
2555!
2556 character (len=256) :: ncname
2557
2558 character (len=*), parameter :: MyFile = &
2559 & __FILE__//", ini_C_norm_tile"
2560
2561# include "set_bounds.h"
2562!
2563 calledfrom=myfile
2564 sourcefile=myfile
2565!
2566!-----------------------------------------------------------------------
2567! Compute tangent linear model initial conditions from the weighted
2568! sum of the Lanczos vectors.
2569!-----------------------------------------------------------------------
2570!
2571! Determine if single or multiple Lanczos vector NetCDF files.
2572!
2573# ifdef LCZ_FINAL
2574 SELECT CASE (lze(ng)%IOtype)
2575 CASE (io_nf90)
2576 CALL netcdf_get_ivar (ng, iadm, trim(lze(ng)%name), &
2577 & 'ndefADJ', ndeflze)
2578
2579# if defined PIO_LIB && defined DISTRIBUTE
2580 CASE (io_pio)
2581 CALL pio_netcdf_get_ivar (ng, iadm, trim(lze(ng)%name), &
2582 & 'ndefADJ', ndeflze)
2583# endif
2584 END SELECT
2585 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2586# else
2587 SELECT CASE (lcz(ng)%IOtype)
2588 CASE (io_nf90)
2589 CALL netcdf_get_ivar (ng, iadm, trim(lcz(ng)%name), &
2590 & 'ndefADJ', ndeflcz)
2591
2592# if defined PIO_LIB && defined DISTRIBUTE
2593 CASE (io_pio)
2594 CALL pio_netcdf_get_ivar (ng, iadm, trim(lcz(ng)%name), &
2595 & 'ndefADJ', ndeflcz)
2596# endif
2597 END SELECT
2598 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2599# endif
2600!
2601 lwrk1=1
2602 lwrk2=2
2603 DO inner=1,ninner
2604
2605# ifdef LCZ_FINAL
2606!
2607! Determine Lanczos vector file to read. The orthonormalized
2608! evolved Lanczos vectors are written into the hessian NetCDF.
2609!
2610 IF (ndeflze.gt.0) THEN
2611 lstr=len_trim(lze(ng)%name)
2612 WRITE (ncname,10) lze(ng)%name(1:lstr-8), outloop
2613 10 FORMAT (a,'_',i4.4,'.nc')
2614 ELSE
2615 ncname=lze(ng)%name
2616 END IF
2617# else
2618!
2619! Determine Lanczos vector file to read. The Lanczos vectors are
2620! written into the adjoint NetCDF in the I4D-Var Lanczos algorithm.
2621! The Lanczos vector for each inner loop is accumulated in the
2622! unlimited dimension. The name of this file is provided here in
2623! the LCZ(ng)%name variable since the ADM(ng)%name value will be
2624! use in the adjoint sensitivity part.
2625!
2626 IF (ndeflcz.gt.0) THEN
2627 lstr=len_trim(lcz(ng)%name)
2628 WRITE (ncname,10) lcz(ng)%name(1:lstr-8), outloop
2629 10 FORMAT (a,'_',i4.4,'.nc')
2630 ELSE
2631 ncname=lcz(ng)%name
2632 END IF
2633# endif
2634!
2635! Read in the Lanczos vectors (q_i, where i=1,2,...k) computed from
2636! k inner-loops of the I4D-Var algorithm first outer loop. Load
2637! Lanczos vectors into ADJOINT LINEAR STATE ARRAYS at index Lwrk1.
2638!
2639 CALL state_read (ng, tile, itlm, &
2640# ifdef LCZ_FINAL
2641 & lze(ng)%IOtype, &
2642# else
2643 & lcz(ng)%IOtype, &
2644# endif
2645 & lbi, ubi, lbj, ubj, lbij, ubij, &
2646 & lwrk1, inner, &
2647# ifdef LCZ_FINAL
2648 & ndeflze, lze(ng)%ncid, &
2649# if defined PIO_LIB && defined DISTRIBUTE
2650 & lze(ng)%pioFile, &
2651# endif
2652# else
2653 & ndeflcz, lcz(ng)%ncid, &
2654# if defined PIO_LIB && defined DISTRIBUTE
2655 & lcz(ng)%pioFile, &
2656# endif
2657# endif
2658 & trim(ncname), &
2659# ifdef MASKING
2660 & rmask, umask, vmask, &
2661# endif
2662# ifdef ADJUST_BOUNDARY
2663# ifdef SOLVE3D
2664 & ad_t_obc, ad_u_obc, ad_v_obc, &
2665# endif
2666 & ad_ubar_obc, ad_vbar_obc, &
2667 & ad_zeta_obc, &
2668# endif
2669# ifdef ADJUST_WSTRESS
2670 & ad_ustr, ad_vstr, &
2671# endif
2672# if defined ADJUST_STFLUX && defined SOLVE3D
2673 & ad_tflux, &
2674# endif
2675# ifdef SOLVE3D
2676 & ad_t, ad_u, ad_v, &
2677# else
2678 & ad_ubar, ad_vbar, &
2679# endif
2680 & ad_zeta)
2681 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2682!
2683! Compute dot product between the tangent linear solution, x(0),
2684! and Lanczos vectors, q_i.
2685!
2686! DotProd(inner) = a_i = < x(0), q_i) >
2687!
2688 CALL state_dotprod (ng, tile, itlm, &
2689 & lbi, ubi, lbj, ubj, lbij, ubij, &
2690 & nstatevar(ng), dot(0:), &
2691# ifdef MASKING
2692 & rmask, umask, vmask, &
2693# endif
2694# ifdef ADJUST_BOUNDARY
2695# ifdef SOLVE3D
2696 & tl_t_obc(:,:,:,:,ladj,:), &
2697 & ad_t_obc(:,:,:,:,lwrk1,:), &
2698 & tl_u_obc(:,:,:,:,ladj), &
2699 & ad_u_obc(:,:,:,:,lwrk1), &
2700 & tl_v_obc(:,:,:,:,ladj), &
2701 & ad_v_obc(:,:,:,:,lwrk1), &
2702# endif
2703 & tl_ubar_obc(:,:,:,ladj), &
2704 & ad_ubar_obc(:,:,:,lwrk1), &
2705 & tl_vbar_obc(:,:,:,ladj), &
2706 & ad_vbar_obc(:,:,:,lwrk1), &
2707 & tl_zeta_obc(:,:,:,ladj), &
2708 & ad_zeta_obc(:,:,:,lwrk1), &
2709# endif
2710# ifdef ADJUST_WSTRESS
2711 & tl_ustr(:,:,:,ladj), ad_ustr(:,:,:,lwrk1), &
2712 & tl_vstr(:,:,:,ladj), ad_vstr(:,:,:,lwrk1), &
2713# endif
2714# if defined ADJUST_STFLUX && defined SOLVE3D
2715 & tl_tflux(:,:,:,ladj,:), &
2716 & ad_tflux(:,:,:,lwrk1,:), &
2717# endif
2718# ifdef SOLVE3D
2719 & tl_t(:,:,:,ninp,:), ad_t(:,:,:,lwrk1,:), &
2720 & tl_u(:,:,:,ninp), ad_u(:,:,:,lwrk1), &
2721 & tl_v(:,:,:,ninp), ad_v(:,:,:,lwrk1), &
2722# else
2723 & tl_ubar(:,:,kinp), ad_ubar(:,:,lwrk1), &
2724 & tl_vbar(:,:,kinp), ad_vbar(:,:,lwrk1), &
2725# endif
2726 & tl_zeta(:,:,kinp), ad_zeta(:,:,lwrk1))
2727!
2728! Store dot product.
2729!
2730 dotprod(inner)=dot(0)
2731 END DO
2732# ifdef LCZ_FINAL
2733!
2734! Now multiply by GSmatrix.
2735!
2736 DO i=1,ninner
2737 sum=0.0_r8
2738 DO j=1,ninner
2739 sum=sum+gsmatrix(i,j)*dotprod(j)
2740 END DO
2741 work1(i)=sum
2742 END DO
2743 DO i=1,ninner
2744 dotprod(i)=work1(i)
2745 END DO
2746# endif
2747!
2748! Multiply by the tridiagonal matrix associated with the
2749! Lanczos recursion relation.
2750!
2751! For now, we can only use the first outer loop. A different scaling
2752! is required for additional outer loops.
2753!
2754 outloop=1
2755!
2756 bvector(1)=cg_delta(1,outloop)*dotprod(1)+ &
2757 & cg_beta(2,outloop)*dotprod(2)
2758 DO i=2,ninner-1
2759 bvector(i)=cg_delta(i,outloop)*dotprod(i)+ &
2760 & cg_beta(i+1,outloop)*dotprod(i+1)+ &
2761 & cg_beta(i,outloop)*dotprod(i-1)
2762 END DO
2763 bvector(ninner)=cg_delta(ninner,outloop)*dotprod(ninner)+ &
2764 & cg_beta(ninner,outloop)*dotprod(ninner-1)
2765# ifdef LCZ_FINAL
2766!
2767! Now multiply by Transpose(GSmatrix).
2768!
2769 DO i=1,ninner
2770 sum=0.0_r8
2771 DO j=1,ninner
2772 sum=sum+gsmatrix(j,i)*bvector(j)
2773 END DO
2774 work1(i)=sum
2775 END DO
2776 DO i=1,ninner
2777 bvector(i)=work1(i)
2778 END DO
2779# endif
2780!
2781!-----------------------------------------------------------------------
2782! Compute Lanczos vectors weigthed sum.
2783!-----------------------------------------------------------------------
2784!
2785! Initialize non-linear state arrays: var(Lwrk1) = fac
2786!
2787 fac=0.0_r8
2788
2789 CALL state_initialize (ng, tile, &
2790 & lbi, ubi, lbj, ubj, lbij, ubij, &
2791 & lwrk1, fac, &
2792# ifdef MASKING
2793 & rmask, umask, vmask, &
2794# endif
2795# ifdef ADJUST_BOUNDARY
2796# ifdef SOLVE3D
2797 & t_obc, u_obc, v_obc, &
2798# endif
2799 & ubar_obc, vbar_obc, &
2800 & zeta_obc, &
2801# endif
2802# ifdef ADJUST_WSTRESS
2803 & ustr, vstr, &
2804# endif
2805# if defined ADJUST_STFLUX && defined SOLVE3D
2806 & tflux, &
2807# endif
2808# ifdef SOLVE3D
2809 & t, u, v, &
2810# else
2811 & ubar, vbar, &
2812# endif
2813 & zeta)
2814!
2815! Read in the Lanczos vectors (q_i, where i=1,2,...k) computed from
2816! k inner-loops of the I4D-Var algorithm first outer loop. Load
2817! Lanczos vectors into ADJOINT STATE ARRAYS at index Lwrk1.
2818!
2819 DO inner=1,ninner
2820# ifdef LCZ_FINAL
2821 IF (ndeflze.gt.0) THEN
2822 lstr=len_trim(lze(ng)%name)
2823 WRITE (ncname,10) lze(ng)%name(1:lstr-8), inner
2824 ELSE
2825 ncname=lze(ng)%name
2826 END IF
2827# else
2828 IF (ndeflcz.gt.0) THEN
2829 lstr=len_trim(lcz(ng)%name)
2830 WRITE (ncname,10) lcz(ng)%name(1:lstr-8), inner
2831 ELSE
2832 ncname=lcz(ng)%name
2833 END IF
2834# endif
2835 CALL state_read (ng, tile, itlm, &
2836# ifdef LCZ_FINAL
2837 & lze(ng)%IOtype, &
2838# else
2839 & lcz(ng)%IOtype, &
2840# endif
2841 & lbi, ubi, lbj, ubj, lbij, ubij, &
2842 & lwrk1, inner, &
2843# ifdef LCZ_FINAL
2844 & ndeflze, lze(ng)%ncid, &
2845# if defined PIO_LIB && defined DISTRIBUTE
2846 & lze(ng)%pioFile, &
2847# endif
2848# else
2849 & ndeflcz, lcz(ng)%ncid, &
2850# if defined PIO_LIB && defined DISTRIBUTE
2851 & lcz(ng)%pioFile, &
2852# endif
2853# endif
2854 & ncname, &
2855# ifdef MASKING
2856 & rmask, umask, vmask, &
2857# endif
2858# ifdef ADJUST_BOUNDARY
2859# ifdef SOLVE3D
2860 & ad_t_obc, ad_u_obc, ad_v_obc, &
2861# endif
2862 & ad_ubar_obc, ad_vbar_obc, &
2863 & ad_zeta_obc, &
2864# endif
2865# ifdef ADJUST_WSTRESS
2866 & ad_ustr, ad_vstr, &
2867# endif
2868# if defined ADJUST_STFLUX && defined SOLVE3D
2869 & ad_tflux, &
2870# endif
2871# ifdef SOLVE3D
2872 & ad_t, ad_u, ad_v, &
2873# else
2874 & ad_ubar, ad_vbar, &
2875# endif
2876 & ad_zeta)
2877 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
2878!
2879! Sum over all Lanczos vectors:
2880!
2881! var(Lwrk2) = fac1 * var(Lwrk2) + fac2 * ad_var(Lwrk1)
2882!
2883! This will become the tangent linear model initial conditions at
2884! time index Lnew.
2885!
2886 fac1=1.0_r8
2887 fac2=bvector(inner)
2888
2889!
2890! NOTE: In the case of WEAK_CONSTRAINT and TIME_CONV, tl_ubar, tl_vbar
2891! ad_ubar and ad_vbar are only passed as required but are not
2892! used in subsequent calculations.
2893!
2894 CALL state_addition (ng, tile, &
2895 & lbi, ubi, lbj, ubj, lbij, ubij, &
2896 & lwrk2, lwrk1, lwrk2, fac1, fac2, &
2897# ifdef MASKING
2898 & rmask, umask, vmask, &
2899# endif
2900# ifdef ADJUST_BOUNDARY
2901# ifdef SOLVE3D
2902 & t_obc, ad_t_obc, &
2903 & u_obc, ad_u_obc, &
2904 & v_obc, ad_v_obc, &
2905# endif
2906 & ubar_obc, ad_ubar_obc, &
2907 & vbar_obc, ad_vbar_obc, &
2908 & zeta_obc, ad_zeta_obc, &
2909# endif
2910# ifdef ADJUST_WSTRESS
2911 & ustr, ad_ustr, &
2912 & vstr, ad_vstr, &
2913# endif
2914# if defined ADJUST_STFLUX && defined SOLVE3D
2915 & tflux, ad_tflux, &
2916# endif
2917# ifdef SOLVE3D
2918 & t, ad_t, &
2919 & u, ad_u, &
2920 & v, ad_v, &
2921# if defined WEAK_CONSTRAINT && defined TIME_CONV
2922 & ubar, ad_ubar, &
2923 & vbar, ad_vbar, &
2924# endif
2925# else
2926 & ubar, ad_ubar, &
2927 & vbar, ad_vbar, &
2928# endif
2929 & zeta, ad_zeta)
2930 END DO
2931!
2932! Finally compute the dot-product with the input tl vector.
2933!
2934 CALL state_dotprod (ng, tile, itlm, &
2935 & lbi, ubi, lbj, ubj, lbij, ubij, &
2936 & nstatevar(ng), dot(0:), &
2937# ifdef MASKING
2938 & rmask, umask, vmask, &
2939# endif
2940# ifdef ADJUST_BOUNDARY
2941# ifdef SOLVE3D
2942 & tl_t_obc(:,:,:,:,ladj,:), &
2943 & t_obc(:,:,:,:,lwrk2,:), &
2944 & tl_u_obc(:,:,:,:,ladj), &
2945 & u_obc(:,:,:,:,lwrk2), &
2946 & tl_v_obc(:,:,:,:,ladj), &
2947 & v_obc(:,:,:,:,lwrk2), &
2948# endif
2949 & tl_ubar_obc(:,:,:,ladj), &
2950 & ubar_obc(:,:,:,lwrk2), &
2951 & tl_vbar_obc(:,:,:,ladj), &
2952 & vbar_obc(:,:,:,lwrk2), &
2953 & tl_zeta_obc(:,:,:,ladj), &
2954 & zeta_obc(:,:,:,lwrk2), &
2955# endif
2956# ifdef ADJUST_WSTRESS
2957 & tl_ustr(:,:,:,ladj), ustr(:,:,:,lwrk2), &
2958 & tl_vstr(:,:,:,ladj), vstr(:,:,:,lwrk2), &
2959# endif
2960# if defined ADJUST_STFLUX && defined SOLVE3D
2961 & tl_tflux(:,:,:,ladj,:), &
2962 & tflux(:,:,:,lwrk2,:), &
2963# endif
2964# ifdef SOLVE3D
2965 & tl_t(:,:,:,ninp,:), t(:,:,:,lwrk2,:), &
2966 & tl_u(:,:,:,ninp), u(:,:,:,lwrk2), &
2967 & tl_v(:,:,:,ninp), v(:,:,:,lwrk2), &
2968# else
2969 & tl_ubar(:,:,kinp), ubar(:,:,lwrk2), &
2970 & tl_vbar(:,:,kinp), vbar(:,:,lwrk2), &
2971# endif
2972 & tl_zeta(:,:,kinp), zeta(:,:,lwrk2))
2973!
2974 statenorm=dot(0)
2975!
2976 RETURN
2977 END SUBROUTINE ini_c_norm_tile
2978#endif
2979 END MODULE inner2state_mod
2980
distribute_mod::mp_bcastf
Definition distribute.F:75
distribute_mod::mp_bcasti
Definition distribute.F:95
mod_netcdf::netcdf_get_ivar
Definition mod_netcdf.F:59
mod_pio_netcdf::pio_netcdf_get_ivar
Definition mod_pio_netcdf.F:66
distribute_mod
Definition distribute.F:3
inner2state_mod
Definition inner2state.F:2
inner2state_mod::tl_inner2state_tile
subroutine tl_inner2state_tile(ng, tile, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, lini, state, rmask, umask, vmask, tl_t_obc, tl_u_obc, tl_v_obc, ad_t_obc, ad_u_obc, ad_v_obc, tl_ubar_obc, tl_vbar_obc, tl_zeta_obc, ad_ubar_obc, ad_vbar_obc, ad_zeta_obc, tl_ustr, tl_vstr, ad_ustr, ad_vstr, tl_tflux, ad_tflux, tl_t, tl_u, tl_v, tl_ubar, tl_vbar, ad_t, ad_u, ad_v, ad_ubar, ad_vbar, tl_zeta, ad_zeta, hz, f_t, f_u, f_v, f_ubar, f_vbar, f_zeta)
Definition inner2state.F:240
inner2state_mod::ad_inner2state_tile
subroutine ad_inner2state_tile(ng, tile, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, lini, ad_state, ifdef masking
Definition inner2state.F:1557
inner2state_mod::tl_inner2state
subroutine, public tl_inner2state(ng, tile, lini, state)
Definition inner2state.F:63
inner2state_mod::ini_c_norm_tile
subroutine ini_c_norm_tile(ng, tile, lbi, ubi, lbj, ubj, lbij, ubij, imins, imaxs, jmins, jmaxs, kinp, ninp, statenorm, ifdef masking
Definition inner2state.F:2287
inner2state_mod::ad_inner2state
subroutine, public ad_inner2state(ng, tile, lini, ad_state)
Definition inner2state.F:1442
inner2state_mod::ini_c_norm
subroutine, public ini_c_norm(ng, tile, kinp, ninp, statenorm)
Definition inner2state.F:2167
mod_boundary
Definition mod_boundary.F:2
mod_boundary::boundary
type(t_boundary), dimension(:), allocatable boundary
Definition mod_boundary.F:746
mod_forces
Definition mod_forces.F:2
mod_forces::forces
type(t_forces), dimension(:), allocatable forces
Definition mod_forces.F:554
mod_fourdvar
Definition mod_fourdvar.F:2
mod_fourdvar::cg_beta
real(dp), dimension(:,:), allocatable cg_beta
Definition mod_fourdvar.F:654
mod_fourdvar::zlanczos_diag
real(r8), dimension(:), allocatable zlanczos_diag
Definition mod_fourdvar.F:769
mod_fourdvar::gsmatrix
real(r8), dimension(:,:), allocatable gsmatrix
Definition mod_fourdvar.F:772
mod_fourdvar::gsmatinv
real(r8), dimension(:,:), allocatable gsmatinv
Definition mod_fourdvar.F:773
mod_fourdvar::cg_delta
real(dp), dimension(:,:), allocatable cg_delta
Definition mod_fourdvar.F:691
mod_fourdvar::zlanczos_offdiag
real(r8), dimension(:), allocatable zlanczos_offdiag
Definition mod_fourdvar.F:770
mod_fourdvar::nstatevar
integer, dimension(:), allocatable nstatevar
Definition mod_fourdvar.F:362
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::lcz
type(t_io), dimension(:), allocatable lcz
Definition mod_iounits.F:228
mod_iounits::calledfrom
character(len=256) calledfrom
Definition mod_iounits.F:315
mod_iounits::lze
type(t_io), dimension(:), allocatable lze
Definition mod_iounits.F:229
mod_iounits::stdout
integer stdout
Definition mod_iounits.F:195
mod_iounits::sourcefile
character(len=256) sourcefile
Definition mod_iounits.F:317
mod_ncparam
Definition mod_ncparam.F:2
mod_ncparam::io_nf90
integer, parameter io_nf90
Definition mod_ncparam.F:95
mod_ncparam::io_pio
integer, parameter io_pio
Definition mod_ncparam.F:96
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_param
Definition mod_param.F:2
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::itlm
integer, parameter itlm
Definition mod_param.F:663
mod_param::nt
integer, dimension(:), allocatable nt
Definition mod_param.F:489
mod_pio_netcdf
Definition mod_pio_netcdf.F:2
mod_scalars
Definition mod_scalars.F:2
mod_scalars::ninner
integer ninner
Definition mod_scalars.F:353
mod_scalars::nouter
integer nouter
Definition mod_scalars.F:354
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
mod_scalars::inner
integer inner
Definition mod_scalars.F:360
mod_scalars::noerror
integer noerror
Definition mod_scalars.F:561
mod_stepping
Definition mod_stepping.F:2
state_addition_mod
Definition state_addition.F:2
state_addition_mod::state_addition
subroutine, public state_addition(ng, tile, lbi, ubi, lbj, ubj, lbij, ubij, lin1, lin2, lout, fac1, fac2, rmask, umask, vmask, s1_t_obc, s2_t_obc, s1_u_obc, s2_u_obc, s1_v_obc, s2_v_obc, s1_ubar_obc, s2_ubar_obc, s1_vbar_obc, s2_vbar_obc, s1_zeta_obc, s2_zeta_obc, s1_sustr, s2_sustr, s1_svstr, s2_svstr, s1_tflux, s2_tflux, s1_t, s2_t, s1_u, s2_u, s1_v, s2_v, s1_ubar, s2_ubar, s1_vbar, s2_vbar, s1_zeta, s2_zeta)
Definition state_addition.F:64
state_copy_mod
Definition state_copy.F:2
state_copy_mod::state_copy
subroutine, public state_copy(ng, tile, lbi, ubi, lbj, ubj, lbij, ubij, linp, lout, s1_t_obc, s2_t_obc, s1_u_obc, s2_u_obc, s1_v_obc, s2_v_obc, s1_ubar_obc, s2_ubar_obc, s1_vbar_obc, s2_vbar_obc, s1_zeta_obc, s2_zeta_obc, s1_sustr, s2_sustr, s1_svstr, s2_svstr, s1_tflux, s2_tflux, s1_t, s2_t, s1_u, s2_u, s1_v, s2_v, s1_ubar, s2_ubar, s1_vbar, s2_vbar, s1_zeta, s2_zeta)
Definition state_copy.F:57
state_dotprod_mod
Definition state_dotprod.F:2
state_dotprod_mod::state_dotprod
subroutine, public state_dotprod(ng, tile, model, lbi, ubi, lbj, ubj, lbij, ubij, nstatevars, dotprod, rmask, umask, vmask, s1_t_obc, s2_t_obc, s1_u_obc, s2_u_obc, s1_v_obc, s2_v_obc, s1_ubar_obc, s2_ubar_obc, s1_vbar_obc, s2_vbar_obc, s1_zeta_obc, s2_zeta_obc, s1_sustr, s2_sustr, s1_svstr, s2_svstr, s1_tflux, s2_tflux, s1_t, s2_t, s1_u, s2_u, s1_v, s2_v, s1_zeta, s2_zeta)
Definition state_dotprod.F:85
state_initialize_mod
Definition state_initialize.F:2
state_initialize_mod::state_initialize
subroutine, public state_initialize(ng, tile, lbi, ubi, lbj, ubj, lbij, ubij, lout, fac, rmask, umask, vmask, s_t_obc, s_u_obc, s_v_obc, s_ubar_obc, s_vbar_obc, s_zeta_obc, s_sustr, s_svstr, s_tflux, s_t, s_u, s_v, s_zeta)
Definition state_initialize.F:52
state_read_mod
Definition state_read.F:2
state_read_mod::state_read
subroutine, public state_read(ng, tile, model, iotype, lbi, ubi, lbj, ubj, lbij, ubij, lout, rec, nopen, ncid, piofile, ncname, rmask, umask, vmask, s_t_obc, s_u_obc, s_v_obc, s_ubar_obc, s_vbar_obc, s_zeta_obc, s_ustr, s_vstr, s_tflux, s_t, s_u, s_v, s_zeta)
Definition state_read.F:137
state_scale_mod
Definition state_scale.F:2
state_scale_mod::state_scale
subroutine, public state_scale(ng, tile, lbi, ubi, lbj, ubj, lbij, ubij, linp, lout, fac, rmask, umask, vmask, s_t_obc, s_u_obc, s_v_obc, s_ubar_obc, s_vbar_obc, s_zeta_obc, s_sustr, s_svstr, s_tflux, s_t, s_u, s_v, s_zeta)
Definition state_scale.F:50
strings_mod
Definition strings.F:2
strings_mod::founderror
logical function, public founderror(flag, noerr, line, routine)
Definition strings.F:52
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