ROMS
Loading...
Searching...
No Matches
hessian_so_roms.h
Go to the documentation of this file.
1 MODULE roms_kernel_mod
2!
3!git $Id$
4!================================================== Hernan G. Arango ===
5! Copyright (c) 2002-2025 The ROMS Group Andrew M. Moore !
6! Licensed under a MIT/X style license !
7! See License_ROMS.md !
8!=======================================================================
9! !
10! ROMS Stochastic Optimal Driver: !
11! !
12! These routines control the initialization, time-stepping, and !
13! finalization of ROMS model following ESMF conventions: !
14! !
15! ROMS_initialize !
16! ROMS_run !
17! ROMS_finalize !
18! !
19! Reference: !
20! !
21! Moore, A.M. et al., 2004: A comprehensive ocean prediction and !
22! analysis system based on the tangent linear and adjoint of a !
23! regional ocean model, Ocean Modelling, 7, 227-258. !
24! !
25!=======================================================================
26!
27 USE mod_param
28 USE mod_parallel
29 USE mod_arrays
30 USE mod_iounits
31 USE mod_ncparam
32 USE mod_netcdf
33#if defined PIO_LIB && defined DISTRIBUTE
35#endif
36 USE mod_scalars
37 USE mod_stepping
38 USE mod_storage
39 USE mod_fourdvar
40 USE mod_netcdf
41!
43!
45#ifdef CHECKPOINTING
46 USE def_gst_mod, ONLY : def_gst
47 USE get_gst_mod, ONLY : get_gst
48#endif
49#ifdef DISTRIBUTE
51#endif
52 USE inp_par_mod, ONLY : inp_par
53#ifdef MCT_LIB
54# ifdef ATM_COUPLING
55 USE mct_coupler_mod, ONLY : initialize_ocn2atm_coupling
56# endif
57# ifdef WAV_COUPLING
58 USE mct_coupler_mod, ONLY : initialize_ocn2wav_coupling
59# endif
60#endif
61 USE packing_mod, ONLY : r_norm2
63 USE strings_mod, ONLY : founderror
64#ifdef CHECKPOINTING
65 USE wrt_gst_mod, ONLY : wrt_gst
66#endif
67 USE wrt_rst_mod, ONLY : wrt_rst
68!
69 implicit none
70!
71 PRIVATE :: iram_error
72 PUBLIC :: roms_initialize
73 PUBLIC :: roms_run
74 PUBLIC :: roms_finalize
75!
76 CONTAINS
77!
78 SUBROUTINE roms_initialize (first, mpiCOMM)
79!
80!=======================================================================
81! !
82! This routine allocates and initializes ROMS state variables !
83! and internal and external parameters. !
84! !
85!=======================================================================
86!
87! Imported variable declarations.
88!
89 logical, intent(inout) :: first
90!
91 integer, intent(in), optional :: mpiCOMM
92!
93! Local variable declarations.
94!
95 logical :: allocate_vars = .true.
96!
97#ifdef DISTRIBUTE
98 integer :: MyError, MySize
99#endif
100 integer :: chunk_size, ng, thread
101#ifdef _OPENMP
102 integer :: my_threadnum
103#endif
104!
105 character (len=*), parameter :: MyFile = &
106 & __FILE__//", ROMS_initialize"
107
108#ifdef DISTRIBUTE
109!
110!-----------------------------------------------------------------------
111! Set distribute-memory (mpi) world communictor.
112!-----------------------------------------------------------------------
113!
114 IF (PRESENT(mpicomm)) THEN
115 ocn_comm_world=mpicomm
116 ELSE
117 ocn_comm_world=mpi_comm_world
118 END IF
119 CALL mpi_comm_rank (ocn_comm_world, myrank, myerror)
120 CALL mpi_comm_size (ocn_comm_world, mysize, myerror)
121#endif
122!
123!-----------------------------------------------------------------------
124! On first pass, initialize model parameters a variables for all
125! nested/composed grids. Notice that the logical switch "first"
126! is used to allow multiple calls to this routine during ensemble
127! configurations.
128!-----------------------------------------------------------------------
129!
130 IF (first) THEN
131 first=.false.
132!
133! Initialize parallel control switches. These scalars switches are
134! independent from standard input parameters.
135!
137!
138! Set the ROMS standard output unit to write verbose execution info.
139! Notice that the default standard out unit in Fortran is 6.
140!
141! In some applications like coupling or disjointed mpi-communications,
142! it is advantageous to write standard output to a specific filename
143! instead of the default Fortran standard output unit 6. If that is
144! the case, it opens such formatted file for writing.
145!
146 IF (set_stdoutunit) THEN
148 set_stdoutunit=.false.
149 END IF
150!
151! Read in model tunable parameters from standard input. Allocate and
152! initialize variables in several modules after the number of nested
153! grids and dimension parameters are known.
154!
155 CALL inp_par (itlm)
156 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
157!
158! Set domain decomposition tile partition range. This range is
159! computed only once since the "first_tile" and "last_tile" values
160! are private for each parallel thread/node.
161!
162#if defined _OPENMP
163 mythread=my_threadnum()
164#elif defined DISTRIBUTE
166#else
167 mythread=0
168#endif
169 DO ng=1,ngrids
170 chunk_size=(ntilex(ng)*ntilee(ng)+numthreads-1)/numthreads
171 first_tile(ng)=mythread*chunk_size
172 last_tile(ng)=first_tile(ng)+chunk_size-1
173 END DO
174!
175! Initialize internal wall clocks. Notice that the timings does not
176! includes processing standard input because several parameters are
177! needed to allocate clock variables.
178!
179 IF (master) THEN
180 WRITE (stdout,10)
181 10 FORMAT (/,' Process Information:',/)
182 END IF
183!
184 DO ng=1,ngrids
185 DO thread=thread_range
186 CALL wclock_on (ng, itlm, 0, __line__, myfile)
187 END DO
188 END DO
189!
190! Allocate and initialize modules variables.
191!
192 CALL roms_allocate_arrays (allocate_vars)
194 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
195
196 END IF
197
198#if defined MCT_LIB && (defined ATM_COUPLING || defined WAV_COUPLING)
199!
200!-----------------------------------------------------------------------
201! Initialize coupling streams between model(s).
202!-----------------------------------------------------------------------
203!
204 DO ng=1,ngrids
205# ifdef ATM_COUPLING
206 CALL initialize_ocn2atm_coupling (ng, myrank)
207# endif
208# ifdef WAV_COUPLING
209 CALL initialize_ocn2wav_coupling (ng, myrank)
210# endif
211 END DO
212#endif
213!
214!-----------------------------------------------------------------------
215! Initialize tangent linear for all grids first in order to compute
216! the size of the state vector, Nstate. This size is computed in
217! routine "wpoints".
218!-----------------------------------------------------------------------
219
220#ifdef FORWARD_FLUXES
221!
222! Set the BLK structure to contain the nonlinear model surface fluxes
223! needed by the tangent linear and adjoint models. Also, set switches
224! to process that structure in routine "check_multifile". Notice that
225! it is possible to split the solution into multiple NetCDF files to
226! reduce their size.
227!
228! The switch LreadFRC is deactivated because all the atmospheric
229! forcing, including shortwave radiation, is read from the NLM
230! surface fluxes or is assigned during ESM coupling. Such fluxes
231! are available from the QCK structure. There is no need for reading
232! and processing from the FRC structure input forcing-files.
233!
234 CALL edit_multifile ('QCK2BLK')
235 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
236 DO ng=1,ngrids
237 lreadblk(ng)=.true.
238 lreadfrc(ng)=.false.
239 END DO
240#endif
241!
242! Initialize perturbation tangent linear model.
243!
244 DO ng=1,ngrids
245 lreadfwd(ng)=.true.
246 CALL tl_initial (ng)
247 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
248 END DO
249!
250!-----------------------------------------------------------------------
251! Read in Lanczos algorithm coefficients ("cg_beta", "cg_delta") from
252! file LCZ(ng)%name NetCDF (I4D-Var adjoint file), as computed in the
253! I4D-Var Lanczos data assimilation algorithm for the first outer
254! loop. They are needed here, in routine "tl_inner2state", to compute
255! the tangent linear model initial conditions as the weighted sum
256! of the Lanczos vectors. The weighting coefficient are computed
257! by solving a tri-diagonal system that uses "cg_beta" and "cg_gamma".
258!-----------------------------------------------------------------------
259!
260 sourcefile=myfile
261 DO ng=1,ngrids
262 SELECT CASE (lcz(ng)%IOtype)
263 CASE (io_nf90)
264 CALL netcdf_get_fvar (ng, iadm, lcz(ng)%name, &
265 & 'cg_beta', cg_beta)
266 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
267!
268 CALL netcdf_get_fvar (ng, iadm, lcz(ng)%name, &
269 & 'cg_delta', cg_delta)
270 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
271
272#if defined PIO_LIB && defined DISTRIBUTE
273 CASE (io_pio)
274 CALL pio_netcdf_get_fvar (ng, iadm, lcz(ng)%name, &
275 & 'cg_beta', cg_beta)
276 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
277!
278 CALL pio_netcdf_get_fvar (ng, iadm, lcz(ng)%name, &
279 & 'cg_delta', cg_delta)
280 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
281#endif
282 END SELECT
283 END DO
284!
285! Allocate arrays associated with Generalized Stability Theory (GST)
286! analysis.
287!
289!
290! Initialize various IO flags.
291!
292 nrun=0
293 DO ng=1,ngrids
294 lwrtadj(ng)=.true.
295 lwrthis(ng)=.true.
296 lwrttlm(ng)=.true.
297 lwrtper(ng)=.false.
298 lcycletlm(ng)=.false.
299 lcycleadj(ng)=.false.
300 nadj(ng)=ntimes(ng)/nintervals
301 ntlm(ng)=ntimes(ng)
302 END DO
303!
304! Initialize ARPACK parameters.
305!
306 lrvec=.true. ! Compute Ritz vectors
307 bmat='I' ! standard eigenvalue problem
308 which='LM' ! compute NEV largest eigenvalues
309 howmany='A' ! compute NEV Ritz vectors
310 DO ng=1,ngrids
311 ido(ng)=0 ! reverse communication flag
312 info(ng)=0 ! random initial residual vector
313 iparam(1,ng)=1 ! exact shifts
314 iparam(3,ng)=maxitergst ! maximum number of Arnoldi iterations
315 iparam(4,ng)=1 ! block size in the recurrence
316 iparam(7,ng)=1 ! type of eigenproblem being solved
317 END DO
318!
319! ARPACK debugging parameters.
320!
321 logfil=stdout ! output logical unit
322 ndigit=-3 ! number of decimal digits
323 msaupd=1 ! iterations, timings, Ritz
324 msaup2=1 ! norms, Ritz values
325 msaitr=0
326 mseigt=0
327 msapps=0
328 msgets=0
329 mseupd=0
330!
331! Determine size of the eigenproblem (Nsize) and size of work space
332! array SworkL (LworkL).
333!
334 DO ng=1,ngrids
335 nconv(ng)=0
336 nsize(ng)=ninner
337 END DO
338
339#ifdef CHECKPOINTING
340!
341! If restart, read in checkpointing data GST restart NetCDF file.
342! Otherwise, create checkpointing restart NetCDF file.
343!
344 DO ng=1,ngrids
345 IF (lrstgst) THEN
346 CALL get_gst (ng, itlm)
347 ido(ng)=-2
348 laup2(1)=.false. ! cnorm
349 laup2(2)=.false. ! getv0
350 laup2(3)=.false. ! initv
351 laup2(4)=.false. ! update
352 laup2(5)=.true. ! ushift
353 ELSE
354 CALL def_gst (ng, itlm)
355 END IF
356 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
357 END DO
358#endif
359!
360 RETURN
361 END SUBROUTINE roms_initialize
362!
363 SUBROUTINE roms_run (RunInterval)
364!
365!=======================================================================
366! !
367! This routine computes the singular vectors of R(0,t) by a single !
368! integration of a perturbation "u" forward in time with the !
369! tangent linear model over [0,t], multiplication of the result !
370! by "X", followed by an integration of the result backwards in !
371! time with the adjoint model over [t,0]. This is equivalmet to !
372! the matrix-vector operation: !
373! !
374! transpose[R(t,0)] X R(0,t) u !
375! !
376! The above operator is symmetric and the ARPACK library is used !
377! to select eigenvectors and eigenvalues: !
378! !
379! Lehoucq, R.B., D.C. Sorensen, and C. Yang, 1997: ARPACK user's !
380! guide: solution of large scale eigenvalue problems with !
381! implicit restarted Arnoldi Methods, Rice University, 140p. !
382! !
383!=======================================================================
384!
385! Imported variable declarations
386!
387 real(dp), intent(in) :: RunInterval ! seconds
388!
389! Local variable declarations.
390!
391 logical :: ITERATE
392#ifdef CHECKPOINTING
393 logical :: LwrtGST
394#endif
395!
396 integer :: Is, Ie
397 integer :: i, iter, ng, tile
398 integer :: NconvRitz(Ngrids)
399!
400 real(r8) :: Enorm
401!
402 TYPE (T_GST), allocatable :: ad_state(:)
403 TYPE (T_GST), allocatable :: state(:)
404!
405 character (len=55) :: string
406
407 character (len=*), parameter :: MyFile = &
408 & __FILE__//", ROMS_run"
409!
410!-----------------------------------------------------------------------
411! Implicit Restarted Arnoldi Method (IRAM) for the computation of
412! optimal perturbation Ritz eigenfunctions.
413!-----------------------------------------------------------------------
414!
415! Allocate nested grid pointers for state vectors.
416!
417 IF (.not.allocated(ad_state)) THEN
418 allocate ( ad_state(ngrids) )
419 END IF
420 IF (.not.allocated(state)) THEN
421 allocate ( state(ngrids) )
422 END IF
423!
424! Iterate until either convergence or maximum iterations has been
425! exceeded.
426!
427 iter=0
428 iterate=.true.
429#ifdef CHECKPOINTING
430 lwrtgst=.true.
431#endif
432!
433 iter_loop : DO WHILE (iterate)
434 iter=iter+1
435!
436! Reverse communication interface.
437!
438 DO ng=1,ngrids
439#ifdef PROFILE
440 CALL wclock_on (ng, itlm, 38, __line__, myfile)
441#endif
442 IF (master) THEN
443 CALL dsaupd (ido(ng), bmat, nsize(ng), which, nev, &
444 & ritz_tol, &
445 & storage(ng)%resid, ncv, &
446 & storage(ng)%Bvec, nsize(ng), &
447 & iparam(1,ng), ipntr(1,ng), &
448 & storage(ng)%SworkD, &
449 & sworkl(1,ng), lworkl, info(ng))
450 nconv(ng)=iaup2(4)
451 END IF
452#ifdef PROFILE
453 CALL wclock_off (ng, itlm, 38, __line__, myfile)
454#endif
455#ifdef DISTRIBUTE
456!
457! Broadcast various Arnoldi iteration variables to all member in the
458! group. The Arnoldi problem solved here is very small so the ARPACK
459! library is run by the master node and all relevant variables are
460! broadcasted to all nodes.
461!
462 CALL mp_bcasti (ng, itlm, nconv(ng))
463 CALL mp_bcasti (ng, itlm, ido(ng))
464 CALL mp_bcasti (ng, itlm, info(ng))
465 CALL mp_bcasti (ng, itlm, iparam(:,ng))
466 CALL mp_bcasti (ng, itlm, ipntr(:,ng))
467 CALL mp_bcastf (ng, itlm, storage(ng)%SworkD)
468#endif
469#ifdef CHECKPOINTING
470!
471! If appropriate, write out check point data into GST restart NetCDF
472! file. Notice that the restart data is always saved if MaxIterGST
473! is reached without convergence. It is also saved when convergence
474! is achieved (ido=99).
475!
476 IF ((mod(iter,ngst).eq.0).or.(iter.ge.maxitergst).or. &
477 & (any(ido.eq.99))) THEN
478 CALL wrt_gst (ng, itlm)
479 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
480 END IF
481#endif
482 END DO
483!
484! Terminate computations if maximum number of iterations is reached.
485! This will faciliate splitting the analysis in several computational
486! cycles using the restart option.
487!
488 IF ((iter.ge.maxitergst).and.any(ido.ne.99)) THEN
489 iterate=.false.
490 EXIT iter_loop
491 END IF
492!
493! Perform matrix-vector operation: R`(t,0)XR(0,t)u
494!
495 IF (any(abs(ido).eq.1)) THEN
496!
497! Set state vectors to process by the propagator via pointer
498! equivalence.
499!
500 DO ng=1,ngrids
501 IF (ASSOCIATED(state(ng)%vector)) THEN
502 nullify (state(ng)%vector)
503 END IF
504 is=ipntr(1,ng)
505 ie=is+nsize(ng)-1
506 state(ng)%vector => storage(ng)%SworkD(is:ie)
507
508 IF (ASSOCIATED(ad_state(ng)%vector)) THEN
509 nullify (ad_state(ng)%vector)
510 END IF
511 is=ipntr(2,ng)
512 ie=is+nsize(ng)-1
513 ad_state(ng)%vector => storage(ng)%SworkD(is:ie)
514 END DO
515!
516 CALL propagator_hso (runinterval, iter, state, ad_state)
517 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
518 ELSE
519 IF (any(info.ne.0)) THEN
520 DO ng=1,ngrids
521 IF (info(ng).ne.0) THEN
522 IF (master) THEN
523 CALL iram_error (info(ng), string)
524 WRITE (stdout,10) 'DSAUPD', trim(string), &
525 & ', info = ', info(ng)
526 END IF
527 RETURN
528 END IF
529 END DO
530 ELSE
531!
532! Compute Ritz vectors (the only choice left is IDO=99). They are
533! generated in ARPACK in decreasing magnitude of its eigenvalue.
534! The most significant is first.
535!
536 DO ng=1,ngrids
537 nconvritz(ng)=iparam(5,ng)
538 IF (master) THEN
539 WRITE (stdout,20) 'Number of converged Ritz values:', &
540 & iparam(5,ng)
541 WRITE (stdout,20) 'Number of Arnoldi iterations:', &
542 & iparam(3,ng)
543 END IF
544#ifdef PROFILE
545 CALL wclock_on (ng, itlm, 38, __line__, myfile)
546#endif
547 IF (master) THEN
548 CALL dseupd (lrvec, howmany, pick(1,ng), &
549 & rvaluer(1,ng), &
550 & storage(ng)%Rvector, nsize(ng), &
552 & storage(ng)%resid, ncv, &
553 & storage(ng)%Bvec, nsize(ng), &
554 & iparam(1,ng), ipntr(1,ng), &
555 & storage(ng)%SworkD, &
556 & sworkl(1,ng), lworkl, info(ng))
557 END IF
558#ifdef DISTRIBUTE
559!
560! Broadcast various Arnoldi iteration variables to all member in the
561! group.
562!
563 CALL mp_bcasti (ng, itlm, info(ng))
564 CALL mp_bcasti (ng, itlm, iparam(:,ng))
565 CALL mp_bcasti (ng, itlm, ipntr(:,ng))
566 CALL mp_bcastf (ng, itlm, rvaluer(:,ng))
567 CALL mp_bcastf (ng, itlm, storage(ng)%Rvector)
568#endif
569#ifdef PROFILE
570 CALL wclock_off (ng, itlm, 38, __line__, myfile)
571#endif
572 END DO
573
574 IF (any(info.ne.0)) THEN
575 DO ng=1,ngrids
576 IF (info(ng).ne.0) THEN
577 IF (master) THEN
578 CALL iram_error (info(ng), string)
579 WRITE (stdout,10) 'DSEUPD', trim(string), &
580 & ', info = ', info(ng)
581 END IF
582 RETURN
583 END IF
584 END DO
585 ELSE
586!
587! Activate writing of each eigenvector into single or multiple tangent
588! linear history NetCDF files.
589!
590 nrun=0
591
592 DO i=1,maxval(nconvritz)
593 DO ng=1,ngrids
594 IF (lmultigst) THEN
595 WRITE (tlm(ng)%name,30) trim(tlm(ng)%base), i
596 END IF
597 END DO
598!
599! Compute and write Ritz eigenvectors.
600!
601 DO ng=1,ngrids
602 is=1
603 ie=ninner
604 IF (ASSOCIATED(state(ng)%vector)) THEN
605 nullify (state(ng)%vector)
606 END IF
607
608 IF (ASSOCIATED(ad_state(ng)%vector)) THEN
609 nullify (ad_state(ng)%vector)
610 END IF
611 state(ng)%vector => storage(ng)%Rvector(is:ie,i)
612 ad_state(ng)%vector => sworkr(is:ie)
613 END DO
614!
615 CALL propagator_hso (runinterval, -i, state, ad_state)
617 & __line__, myfile)) RETURN
618!
619 DO ng=1,ngrids
620 CALL r_norm2 (ng, itlm, 1, ninner, &
621 & -rvaluer(i,ng), &
622 & state(ng)%vector, &
623 & ad_state(ng)%vector, enorm)
624 norm(i,ng)=enorm
625 IF (master) THEN
626 WRITE (stdout,40) i, norm(i,ng), rvaluer(i,ng), i
627 END IF
628 END DO
629!
630! Write out Ritz eigenvalues and Ritz eigenvector Euclidean norm
631! (residual) to NetCDF file(s). Notice that we write the same value
632! twice in the TLM file for the initial and final perturbation of
633! the eigenvector.
634!
635 sourcefile=myfile
636 DO ng=1,ngrids
637 SELECT CASE (tlm(ng)%IOtype)
638 CASE (io_nf90)
639 CALL netcdf_put_fvar (ng, itlm, &
640 & tlm(ng)%name, &
641 & 'Ritz_rvalue', &
642 & rvaluer(i:,ng), &
643 & start = (/tlm(ng)%Rindex/), &
644 & total = (/1/), &
645 & ncid = tlm(ng)%ncid)
646
648 & __line__, myfile)) RETURN
649!
650 CALL netcdf_put_fvar (ng, itlm, &
651 & tlm(ng)%name, &
652 & 'Ritz_norm', &
653 & norm(i:,ng), &
654 & start = (/tlm(ng)%Rindex/), &
655 & total = (/1/), &
656 & ncid = tlm(ng)%ncid)
657
659 & __line__, myfile)) RETURN
660
661#if defined PIO_LIB && defined DISTRIBUTE
662 CASE (io_pio)
663 CALL pio_netcdf_put_fvar (ng, itlm, &
664 & tlm(ng)%name, &
665 & 'Ritz_rvalue', &
666 & rvaluer(i:,ng), &
667 & start = (/tlm(ng)%Rindex/), &
668 & total = (/1/), &
669 & piofile = tlm(ng)%pioFile)
670
672 & __line__, myfile)) RETURN
673!
674 CALL pio_netcdf_put_fvar (ng, itlm, &
675 & tlm(ng)%name, &
676 & 'Ritz_norm', &
677 & norm(i:,ng), &
678 & start = (/tlm(ng)%Rindex/), &
679 & total = (/1/), &
680 & piofile = tlm(ng)%pioFile)
681
683 & __line__, myfile)) RETURN
684#endif
685 END SELECT
686!
687 IF (lmultigst) THEN
688 CALL close_file (ng, itlm, tlm(ng), tlm(ng)%name)
690 & __line__, myfile)) RETURN
691 END IF
692!
693 SELECT CASE (adm(ng)%IOtype)
694 CASE (io_nf90)
695 CALL netcdf_put_fvar (ng, iadm, &
696 & adm(ng)%name, &
697 & 'Ritz_rvalue', &
698 & rvaluer(i:,ng), &
699 & start = (/adm(ng)%Rindex/), &
700 & total = (/1/), &
701 & ncid = adm(ng)%ncid)
703 & __line__, myfile)) RETURN
704!
705 CALL netcdf_put_fvar (ng, iadm, &
706 & adm(ng)%name, &
707 & 'Ritz_norm', &
708 & norm(i:,ng), &
709 & start = (/adm(ng)%Rindex/), &
710 & total = (/1/), &
711 & ncid = adm(ng)%ncid)
712
714 & __line__, myfile)) RETURN
715
716#if defined PIO_LIB && defined DISTRIBUTE
717 CASE (io_pio)
718 CALL pio_netcdf_put_fvar (ng, iadm, &
719 & adm(ng)%name, &
720 & 'Ritz_rvalue', &
721 & rvaluer(i:,ng), &
722 & start = (/adm(ng)%Rindex/), &
723 & total = (/1/), &
724 & piofile = adm(ng)%pioFile)
726 & __line__, myfile)) RETURN
727!
728 CALL pio_netcdf_put_fvar (ng, iadm, &
729 & adm(ng)%name, &
730 & 'Ritz_norm', &
731 & norm(i:,ng), &
732 & start = (/adm(ng)%Rindex/), &
733 & total = (/1/), &
734 & piofile = adm(ng)%pioFile)
735
737 & __line__, myfile)) RETURN
738#endif
739 END SELECT
740 END DO
741 END DO
742 END IF
743 END IF
744 iterate=.false.
745 END IF
746
747 END DO iter_loop
748!
749 10 FORMAT (/,1x,'Error in ',a,1x,a,a,1x,i5,/)
750 20 FORMAT (/,a,1x,i2,/)
751 30 FORMAT (a,'_',i3.3,'.nc')
752 40 FORMAT (1x,i4.4,'-th residual',1p,e14.6,0p, &
753 & ' Ritz value',1pe14.6,0p,2x,i4.4)
754!
755 RETURN
756 END SUBROUTINE roms_run
757!
758 SUBROUTINE roms_finalize
759!
760!=======================================================================
761! !
762! This routine terminates ROMS nonlinear and adjoint models !
763! execution. !
764! !
765!=======================================================================
766!
767! Local variable declarations.
768!
769 integer :: Fcount, ng, thread
770!
771 character (len=*), parameter :: MyFile = &
772 & __FILE__//", ROMS_finalize"
773!
774!-----------------------------------------------------------------------
775! If blowing-up, save latest model state into RESTART NetCDF file.
776!-----------------------------------------------------------------------
777!
778! If cycling restart records, write solution into the next record.
779!
780 IF (exit_flag.eq.1) THEN
781 DO ng=1,ngrids
782 IF (lwrtrst(ng)) THEN
783 IF (master) WRITE (stdout,10)
784 10 FORMAT (/,' Blowing-up: Saving latest model state into ', &
785 & ' RESTART file',/)
786 fcount=rst(ng)%load
787 IF (lcyclerst(ng).and.(rst(ng)%Nrec(fcount).ge.2)) THEN
788 rst(ng)%Rindex=2
789 lcyclerst(ng)=.false.
790 END IF
793#ifdef DISTRIBUTE
794 CALL wrt_rst (ng, myrank)
795#else
796 CALL wrt_rst (ng, -1)
797#endif
798 END IF
799 END DO
800 END IF
801!
802!-----------------------------------------------------------------------
803! Stop model and time profiling clocks, report memory requirements, and
804! close output NetCDF files.
805!-----------------------------------------------------------------------
806!
807! Stop time clocks.
808!
809 IF (master) THEN
810 WRITE (stdout,20)
811 20 FORMAT (/,'Elapsed wall CPU time for each process (seconds):',/)
812 END IF
813!
814 DO ng=1,ngrids
815 DO thread=thread_range
816 CALL wclock_off (ng, itlm, 0, __line__, myfile)
817 END DO
818 END DO
819!
820! Report dynamic memory and automatic memory requirements.
821!
822 CALL memory
823!
824! Close IO files.
825!
826 DO ng=1,ngrids
827 CALL close_inp (ng, itlm)
828 END DO
829 CALL close_out
830!
831 RETURN
832 END SUBROUTINE roms_finalize
833!
834 SUBROUTINE iram_error (info, string)
835!
836!=======================================================================
837! !
838! This routine decodes internal error messages from the Implicit !
839! Restarted Arnoldi Method (IRAM) for the computation of optimal !
840! perturbation Ritz eigenfunctions. !
841! !
842!=======================================================================
843!
844! imported variable declarations.
845!
846 integer, intent(in) :: info
847!
848 character (len=*), intent(out) :: string
849!
850!-----------------------------------------------------------------------
851! Decode error message from IRAM.
852!-----------------------------------------------------------------------
853!
854 IF (info.eq.0) THEN
855 string='Normal exit '
856 ELSE IF (info.eq.1) THEN
857 string='Maximum number of iterations taken '
858 ELSE IF (info.eq.3) THEN
859 string='No shifts could be applied during an IRAM cycle '
860 ELSE IF (info.eq.-1) THEN
861 string='Nstate must be positive '
862 ELSE IF (info.eq.-2) THEN
863 string='NEV must be positive '
864 ELSE IF (info.eq.-3) THEN
865 string='NCV must be greater NEV and less than or equal Nstate '
866 ELSE IF (info.eq.-4) THEN
867 string='Maximum number of iterations must be greater than zero '
868 ELSE IF (info.eq.-5) THEN
869 string='WHICH must be one of LM, SM, LA, SA or BE '
870 ELSE IF (info.eq.-6) THEN
871 string='BMAT must be one of I or G '
872 ELSE IF (info.eq.-7) THEN
873 string='Length of private work array SworkL is not sufficient '
874 ELSE IF (info.eq.-8) THEN
875 string='Error in DSTEQR in the eigenvalue calculation '
876 ELSE IF (info.eq.-9) THEN
877 string='Starting vector is zero '
878 ELSE IF (info.eq.-10) THEN
879 string='IPARAM(7) must be 1, 2, 3, 4, 5 '
880 ELSE IF (info.eq.-11) THEN
881 string='IPARAM(7) = 1 and BMAT = G are incompatable '
882 ELSE IF (info.eq.-12) THEN
883 string='IPARAM(1) must be equal to 0 or 1 '
884 ELSE IF (info.eq.-13) THEN
885 string='NEV and WHICH = BE are incompatable '
886 ELSE IF (info.eq.-14) THEN
887 string='Did not find any eigenvalues to sufficient accuaracy '
888 ELSE IF (info.eq.-15) THEN
889 string='HOWMANY must be one of A or S if RVEC = .TRUE. '
890 ELSE IF (info.eq.-16) THEN
891 string='HOWMANY = S not yet implemented '
892 ELSE IF (info.eq.-17) THEN
893 string='Different count of converge Ritz values in DSEUPD '
894 ELSE IF (info.eq.-9999) THEN
895 string='Could not build and Arnoldi factorization '
896 END IF
897!
898 RETURN
899 END SUBROUTINE iram_error
900
901 END MODULE roms_kernel_mod
subroutine edit_multifile(task)
subroutine memory
Definition memory.F:3
subroutine, public close_out
Definition close_io.F:175
subroutine, public close_file(ng, model, s, ncname, lupdate)
Definition close_io.F:43
subroutine, public close_inp(ng, model)
Definition close_io.F:92
subroutine, public def_gst(ng, model)
Definition def_gst.F:45
subroutine, public get_gst(ng, model)
Definition get_gst.F:38
subroutine, public inp_par(model)
Definition inp_par.F:56
subroutine, public roms_initialize_arrays
Definition mod_arrays.F:351
subroutine, public roms_allocate_arrays(allocate_vars)
Definition mod_arrays.F:114
real(dp), dimension(:,:), allocatable cg_beta
real(dp), dimension(:,:), allocatable cg_delta
type(t_io), dimension(:), allocatable lcz
type(t_io), dimension(:), allocatable adm
type(t_io), dimension(:), allocatable tlm
type(t_io), dimension(:), allocatable rst
integer stdout
character(len=256) sourcefile
integer, parameter io_nf90
Definition mod_ncparam.F:95
integer, parameter io_pio
Definition mod_ncparam.F:96
subroutine, public initialize_parallel
integer numthreads
integer, dimension(:), allocatable first_tile
integer mythread
logical master
integer, dimension(:), allocatable last_tile
integer ocn_comm_world
integer, dimension(:), allocatable ntilex
Definition mod_param.F:685
integer, parameter iadm
Definition mod_param.F:665
integer, dimension(:), allocatable nsize
Definition mod_param.F:648
integer ngrids
Definition mod_param.F:113
integer, dimension(:), allocatable ntilee
Definition mod_param.F:686
integer, parameter itlm
Definition mod_param.F:663
integer ninner
integer, dimension(:), allocatable ntimes
integer, dimension(:), allocatable ntlm
logical lmultigst
integer, dimension(:), allocatable nconv
integer blowup
logical, dimension(:), allocatable lreadfrc
logical, dimension(:), allocatable lcycleadj
logical, dimension(:), allocatable lwrtadj
logical lrstgst
logical, dimension(:), allocatable lcycletlm
integer exit_flag
real(dp) ritz_tol
logical, dimension(:), allocatable lwrtper
integer nintervals
integer maxitergst
logical, dimension(:), allocatable lwrthis
logical, dimension(:), allocatable lwrttlm
logical, dimension(:), allocatable lwrtrst
integer nrun
integer, dimension(:), allocatable nadj
logical, dimension(:), allocatable lreadfwd
integer noerror
logical, dimension(:), allocatable lcyclerst
logical, dimension(:), allocatable lreadblk
integer msaup2
integer, dimension(8) iaup2
integer, dimension(:), allocatable ido
real(r8), dimension(:,:), allocatable sworkl
integer, dimension(:,:), allocatable ipntr
integer ncv
character(len=1) howmany
logical, dimension(5) laup2
logical lrvec
Definition mod_storage.F:95
integer msaupd
character(len=1) bmat
integer nev
type(t_storage), dimension(:), allocatable storage
Definition mod_storage.F:91
real(r8), dimension(:,:), allocatable norm
integer, dimension(:), allocatable info
subroutine, public allocate_storage
character(len=2) which
integer lworkl
integer, dimension(:,:), allocatable iparam
integer mseigt
integer msapps
integer ndigit
integer msgets
logical, dimension(:,:), allocatable pick
Definition mod_storage.F:96
real(r8) sigmar
integer logfil
real(r8), dimension(:), pointer sworkr
real(r8), dimension(:,:), allocatable rvaluer
integer msaitr
integer mseupd
subroutine, public propagator_hso(runinterval, iter, state, ad_state)
subroutine, public roms_finalize
Definition ad_roms.h:283
subroutine, public roms_run(runinterval)
Definition ad_roms.h:239
subroutine, private iram_error(info, icall, string)
Definition afte_roms.h:862
subroutine, public roms_initialize(first, mpicomm)
Definition ad_roms.h:52
integer function, public stdout_unit(mymaster)
Definition stdout_mod.F:48
logical, save set_stdoutunit
Definition stdout_mod.F:41
logical function, public founderror(flag, noerr, line, routine)
Definition strings.F:52
subroutine, public wrt_gst(ng, model)
Definition wrt_gst.F:39
subroutine, public wrt_rst(ng, tile)
Definition wrt_rst.F:63
subroutine r_norm2(ng, model, mstr, mend, evalue, evector, state, norm2)
Definition packing.F:175
recursive subroutine wclock_off(ng, model, region, line, routine)
Definition timers.F:148
recursive subroutine wclock_on(ng, model, region, line, routine)
Definition timers.F:3
subroutine tl_initial(ng)
Definition tl_initial.F:4