ROMS
Loading...
Searching...
No Matches
def_impulse.F
Go to the documentation of this file.
1#include "cppdefs.h"
2 MODULE def_impulse_mod
3#ifdef WEAK_CONSTRAINT
4!
5!git $Id$
6!================================================== Hernan G. Arango ===
7! Copyright (c) 2002-2025 The ROMS Group !
8! Licensed under a MIT/X style license !
9! See License_ROMS.md !
10!=======================================================================
11! !
12! This routine creates tangent linear and representer models impulse !
13! forcing NetCDF file used for weak constraint 4DVAR. It defines its !
14! dimensions, attributes, and variables. !
15! !
16!=======================================================================
17!
18 USE mod_param
19 USE mod_parallel
20# ifdef BIOLOGY
21 USE mod_biology
22# endif
23 USE mod_fourdvar
24 USE mod_iounits
25 USE mod_ncparam
26 USE mod_scalars
27# if defined SEDIMENT || defined BBL_MODEL
28 USE mod_sediment
29# endif
30!
31 USE def_dim_mod, ONLY : def_dim
32 USE def_info_mod, ONLY : def_info
33 USE def_var_mod, ONLY : def_var
34 USE strings_mod, ONLY : founderror
35 USE wrt_info_mod, ONLY : wrt_info
36!
37 implicit none
38!
39 PUBLIC :: def_impulse
40 PRIVATE :: def_impulse_nf90
41# if defined PIO_LIB && defined DISTRIBUTE
42 PRIVATE :: def_impulse_pio
43# endif
44!
45 CONTAINS
46!
47!***********************************************************************
48 SUBROUTINE def_impulse (ng)
49!***********************************************************************
50!
51! Imported variable declarations.
52!
53 integer, intent(in) :: ng
54!
55! Local variable declarations.
56!
57 character (len=*), parameter :: myfile = &
58 & __FILE__
59!
60!-----------------------------------------------------------------------
61! Create a new history file according to IO type.
62!-----------------------------------------------------------------------
63!
64 SELECT CASE (tlf(ng)%IOtype)
65 CASE (io_nf90)
66 CALL def_impulse_nf90 (ng)
67
68# if defined PIO_LIB && defined DISTRIBUTE
69 CASE (io_pio)
70 CALL def_impulse_pio (ng)
71# endif
72 CASE DEFAULT
73 IF (master) WRITE (stdout,10) tlf(ng)%IOtype
74 exit_flag=3
75 END SELECT
76 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
77!
78 10 FORMAT (' DEF_IMPULSE - Illegal output file type, io_type = ',i0, &
79 & /,15x,'Check KeyWord ''OUT_LIB'' in ''roms.in''.')
80!
81 RETURN
82 END SUBROUTINE def_impulse
83!
84!***********************************************************************
85 SUBROUTINE def_impulse_nf90 (ng)
86!***********************************************************************
87!
88 USE mod_netcdf
89!
90! Imported variable declarations.
91!
92 integer, intent(in) :: ng
93!
94! Local variable declarations.
95!
96 logical :: ldefine, got_var(nv)
97!
98 integer, parameter :: natt = 25
99
100 integer :: i, j, nvd3, nvd4
101 integer :: recdim, status, varid
102 integer :: fcount
103
104 integer :: dimids(ndimid)
105 integer :: t2dgrd(3), u2dgrd(3), v2dgrd(3)
106
107# ifdef SOLVE3D
108 integer :: itrc
109
110 integer :: t3dgrd(4), u3dgrd(4), v3dgrd(4)
111# endif
112!
113 real(r8) :: aval(6)
114!
115 character (len=256) :: ncname
116 character (len=MaxLen) :: vinfo(natt)
117
118 character (len=*), parameter :: myfile = &
119 & __FILE__//", def_impulse_nf90"
120!
121 sourcefile=myfile
122!
123!=======================================================================
124! Create a new impulse forcing file.
125!=======================================================================
126!
127 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
128 ncname=tlf(ng)%name
129!
130 IF (master) THEN
131 IF (ldeftlf(ng)) THEN
132 WRITE (stdout,10) ng, trim(ncname)
133 ELSE
134 WRITE (stdout,20) ng, trim(ncname)
135 END IF
136 END IF
137!
138 define : IF (ldeftlf(ng)) THEN
139 CALL netcdf_create (ng, itlm, trim(ncname), tlf(ng)%ncid)
140 IF (founderror(exit_flag, noerror, __line__, myfile)) THEN
141 IF (master) WRITE (stdout,30) trim(ncname)
142 RETURN
143 END IF
144!
145!-----------------------------------------------------------------------
146! Define file dimensions.
147!-----------------------------------------------------------------------
148!
149 dimids=0
150!
151 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xi_rho', &
152 & iobounds(ng)%xi_rho, dimids( 1))
153 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
154
155 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xi_u', &
156 & iobounds(ng)%xi_u, dimids( 2))
157 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
158
159 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xi_v', &
160 & iobounds(ng)%xi_v, dimids( 3))
161 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
162
163 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xi_psi', &
164 & iobounds(ng)%xi_psi, dimids( 4))
165 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
166
167 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'eta_rho', &
168 & iobounds(ng)%eta_rho, dimids( 5))
169 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
170
171 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'eta_u', &
172 & iobounds(ng)%eta_u, dimids( 6))
173 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
174
175 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'eta_v', &
176 & iobounds(ng)%eta_v, dimids( 7))
177 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
178
179 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'eta_psi', &
180 & iobounds(ng)%eta_psi, dimids( 8))
181 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
182
183# if defined WRITE_WATER && defined MASKING
184 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xy_rho', &
185 & iobounds(ng)%xy_rho, dimids(17))
186 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
187
188 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xy_u', &
189 & iobounds(ng)%xy_u, dimids(18))
190 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
191
192 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xy_v', &
193 & iobounds(ng)%xy_v, dimids(19))
194 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
195# endif
196
197# ifdef SOLVE3D
198# if defined WRITE_WATER && defined MASKING
199 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xyz_rho', &
200 & iobounds(ng)%xy_rho*n(ng), dimids(20))
201 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
202
203 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xyz_u', &
204 & iobounds(ng)%xy_u*n(ng), dimids(21))
205 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
206
207 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xyz_v', &
208 & iobounds(ng)%xy_v*n(ng), dimids(22))
209 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
210
211 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xyz_w', &
212 & iobounds(ng)%xy_rho*(n(ng)+1), dimids(23))
213 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
214# endif
215
216 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 's_rho', &
217 & n(ng), dimids( 9))
218 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
219
220 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 's_w', &
221 & n(ng)+1, dimids(10))
222 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
223
224 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'tracer', &
225 & nt(ng), dimids(11))
226 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
227
228# ifdef SEDIMENT
229 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'NST', &
230 & nst, dimids(32))
231 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
232
233 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'Nbed', &
234 & nbed, dimids(16))
235 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
236
237# if defined WRITE_WATER && defined MASKING
238 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'xybed', &
239 & iobounds(ng)%xy_rho*nbed, dimids(24))
240 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
241# endif
242# endif
243
244# ifdef ECOSIM
245 status=def_dim(ng, inlm, tlf(ng)%ncid, ncname, 'Nbands', &
246 & nbands, dimids(33))
247 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
248
249 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'Nphy', &
250 & nphy, dimids(25))
251 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
252
253 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'Nbac', &
254 & nbac, dimids(26))
255 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
256
257 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'Ndom', &
258 & ndom, dimids(27))
259 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
260
261 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'Nfec', &
262 & nfec, dimids(28))
263 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
264# endif
265# endif
266
267 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'boundary', &
268 & 4, dimids(14))
269 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
270
271# ifdef FOUR_DVAR
272 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, 'Nstate', &
273 & nstatevar(ng), dimids(29))
274 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
275# endif
276
277 status=def_dim(ng, itlm, tlf(ng)%ncid, ncname, &
278 & trim(adjustl(vname(5,idtime))), &
279 & nf90_unlimited, dimids(12))
280 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
281
282 recdim=dimids(12)
283!
284! Set number of dimensions for output variables.
285!
286# if defined WRITE_WATER && defined MASKING
287 nvd3=2
288 nvd4=2
289# else
290 nvd3=3
291 nvd4=4
292# endif
293!
294! Define dimension vectors for staggered tracer type variables.
295!
296# if defined WRITE_WATER && defined MASKING
297 t2dgrd(1)=dimids(17)
298 t2dgrd(2)=dimids(12)
299# ifdef SOLVE3D
300 t3dgrd(1)=dimids(20)
301 t3dgrd(2)=dimids(12)
302# endif
303# else
304 t2dgrd(1)=dimids( 1)
305 t2dgrd(2)=dimids( 5)
306 t2dgrd(3)=dimids(12)
307# ifdef SOLVE3D
308 t3dgrd(1)=dimids( 1)
309 t3dgrd(2)=dimids( 5)
310 t3dgrd(3)=dimids( 9)
311 t3dgrd(4)=dimids(12)
312# endif
313# endif
314!
315! Define dimension vectors for staggered u-momentum type variables.
316!
317# if defined WRITE_WATER && defined MASKING
318 u2dgrd(1)=dimids(18)
319 u2dgrd(2)=dimids(12)
320# ifdef SOLVE3D
321 u3dgrd(1)=dimids(21)
322 u3dgrd(2)=dimids(12)
323# endif
324# else
325 u2dgrd(1)=dimids( 2)
326 u2dgrd(2)=dimids( 6)
327 u2dgrd(3)=dimids(12)
328# ifdef SOLVE3D
329 u3dgrd(1)=dimids( 2)
330 u3dgrd(2)=dimids( 6)
331 u3dgrd(3)=dimids( 9)
332 u3dgrd(4)=dimids(12)
333# endif
334# endif
335!
336! Define dimension vectors for staggered v-momentum type variables.
337!
338# if defined WRITE_WATER && defined MASKING
339 v2dgrd(1)=dimids(19)
340 v2dgrd(2)=dimids(12)
341# ifdef SOLVE3D
342 v3dgrd(1)=dimids(22)
343 v3dgrd(2)=dimids(12)
344# endif
345# else
346 v2dgrd(1)=dimids( 3)
347 v2dgrd(2)=dimids( 7)
348 v2dgrd(3)=dimids(12)
349# ifdef SOLVE3D
350 v3dgrd(1)=dimids( 3)
351 v3dgrd(2)=dimids( 7)
352 v3dgrd(3)=dimids( 9)
353 v3dgrd(4)=dimids(12)
354# endif
355# endif
356!
357! Initialize unlimited time record dimension.
358!
359 tlf(ng)%Rindex=0
360!
361! Initialize local information variable arrays.
362!
363 DO i=1,natt
364 DO j=1,len(vinfo(1))
365 vinfo(i)(j:j)=' '
366 END DO
367 END DO
368 DO i=1,6
369 aval(i)=0.0_r8
370 END DO
371!
372!-----------------------------------------------------------------------
373! Define time-recordless information variables.
374!-----------------------------------------------------------------------
375!
376 CALL def_info (ng, itlm, tlf(ng)%ncid, ncname, dimids)
377 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
378!
379!-----------------------------------------------------------------------
380! Define TLM/RPM impulse forcing.
381!-----------------------------------------------------------------------
382!
383! Define model time.
384!
385 vinfo( 1)=vname(1,idtime)
386 vinfo( 2)=vname(2,idtime)
387 WRITE (vinfo( 3),'(a,a)') 'seconds since ', trim(rclock%string)
388 vinfo( 4)=trim(rclock%calendar)
389 vinfo(14)=vname(4,idtime)
390 vinfo(21)=vname(6,idtime)
391 status=def_var(ng, itlm, tlf(ng)%ncid, tlf(ng)%Vid(idtime), &
392 & nf_tout, 1, (/recdim/), aval, vinfo, ncname, &
393 & setparaccess = .true.)
394 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
395!
396! Define free-surface impulse forcing.
397!
398 vinfo( 1)=vname(1,idztlf)
399 vinfo( 2)=vname(2,idztlf)
400 vinfo( 3)=vname(3,idztlf)
401 vinfo(14)=vname(4,idztlf)
402 vinfo(16)=vname(1,idtime)
403# if defined WRITE_WATER && defined MASKING
404 vinfo(20)='mask_rho'
405# endif
406 vinfo(21)=vname(6,idztlf)
407 vinfo(22)='coordinates'
408 aval(5)=real(iinfo(1,idztlf,ng),r8)
409 status=def_var(ng, itlm, tlf(ng)%ncid, tlf(ng)%Vid(idztlf), &
410 & nf_fout, nvd3, t2dgrd, aval, vinfo, ncname)
411 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
412
413# ifndef SOLVE3D
414!
415! Define 2D U-momentum component impulse forcing.
416!
417 vinfo( 1)=vname(1,idubtf)
418 vinfo( 2)=vname(2,idubtf)
419 vinfo( 3)=vname(3,idubtf)
420 vinfo(14)=vname(4,idubtf)
421 vinfo(16)=vname(1,idtime)
422# if defined WRITE_WATER && defined MASKING
423 vinfo(20)='mask_u'
424# endif
425 vinfo(21)=vname(6,idubtf)
426 vinfo(22)='coordinates'
427 aval(5)=real(iinfo(1,idubtf,ng),r8)
428 status=def_var(ng, itlm, tlf(ng)%ncid, tlf(ng)%Vid(idubtf), &
429 & nf_fout, nvd3, u2dgrd, aval, vinfo, ncname)
430 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
431!
432! Define 2D V-momentum component impulse forcing.
433!
434 vinfo( 1)=vname(1,idvbtf)
435 vinfo( 2)=vname(2,idvbtf)
436 vinfo( 3)=vname(3,idvbtf)
437 vinfo(14)=vname(4,idvbtf)
438 vinfo(16)=vname(1,idtime)
439# if defined WRITE_WATER && defined MASKING
440 vinfo(20)='mask_v'
441# endif
442 vinfo(21)=vname(6,idvbtf)
443 vinfo(22)='coordinates'
444 aval(5)=real(iinfo(1,idvbtf,ng),r8)
445 status=def_var(ng, itlm, tlf(ng)%ncid, tlf(ng)%Vid(idvbtf), &
446 & nf_fout, nvd3, v2dgrd, aval, vinfo, ncname)
447 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
448
449# else
450!
451! Define 3D U-momentum component impulse forcing.
452!
453 vinfo( 1)=vname(1,idutlf)
454 vinfo( 2)=vname(2,idutlf)
455 vinfo( 3)=vname(3,idutlf)
456 vinfo(14)=vname(4,idutlf)
457 vinfo(16)=vname(1,idtime)
458# if defined WRITE_WATER && defined MASKING
459 vinfo(20)='mask_u'
460# endif
461 vinfo(21)=vname(6,idutlf)
462 vinfo(22)='coordinates'
463 aval(5)=real(iinfo(1,idutlf,ng),r8)
464 status=def_var(ng, itlm, tlf(ng)%ncid, tlf(ng)%Vid(idutlf), &
465 & nf_fout, nvd4, u3dgrd, aval, vinfo, ncname)
466 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
467!
468! Define 3D V-momentum component impulse forcing.
469!
470 vinfo( 1)=vname(1,idvtlf)
471 vinfo( 2)=vname(2,idvtlf)
472 vinfo( 3)=vname(3,idvtlf)
473 vinfo(14)=vname(4,idvtlf)
474 vinfo(16)=vname(1,idtime)
475# if defined WRITE_WATER && defined MASKING
476 vinfo(20)='mask_v'
477# endif
478 vinfo(21)=vname(6,idvtlf)
479 vinfo(22)='coordinates'
480 aval(5)=real(iinfo(1,idvtlf,ng),r8)
481 status=def_var(ng, itlm, tlf(ng)%ncid, tlf(ng)%Vid(idvtlf), &
482 & nf_fout, nvd4, v3dgrd, aval, vinfo, ncname)
483 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
484!
485! Define tracer type impulse forcing variables.
486!
487 DO itrc=1,nt(ng)
488 vinfo( 1)=vname(1,idttlf(itrc))
489 vinfo( 2)=vname(2,idttlf(itrc))
490 vinfo( 3)=vname(3,idttlf(itrc))
491 vinfo(14)=vname(4,idttlf(itrc))
492 vinfo(16)=vname(1,idtime)
493# ifdef SEDIMENT
494 DO i=1,nst
495 IF (itrc.eq.idsed(i)) THEN
496 WRITE (vinfo(19),40) 1000.0_r8*sd50(i,ng)
497 END IF
498 END DO
499# endif
500# if defined WRITE_WATER && defined MASKING
501 vinfo(20)='mask_rho'
502# endif
503 vinfo(21)=vname(6,idttlf(itrc))
504 vinfo(22)='coordinates'
505 aval(5)=real(r3dvar,r8)
506 status=def_var(ng, itlm, tlf(ng)%ncid, tlf(ng)%Tid(itrc), &
507 & nf_fout, nvd4, t3dgrd, aval, vinfo, ncname)
508 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
509 END DO
510# endif
511!
512!-----------------------------------------------------------------------
513! Leave definition mode.
514!-----------------------------------------------------------------------
515!
516 CALL netcdf_enddef (ng, itlm, ncname, tlf(ng)%ncid)
517 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
518!
519!-----------------------------------------------------------------------
520! Write out time-recordless, information variables. Deactive file
521! creation switch.
522!-----------------------------------------------------------------------
523!
524 CALL wrt_info (ng, itlm, tlf(ng)%ncid, ncname)
525 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
526 ldeftlf(ng)=.false.
527 END IF define
528!
529!=======================================================================
530! Open an existing impulse forcing file, check its contents, and
531! prepare for appending data.
532!=======================================================================
533!
534 query : IF (.not.ldeftlf(ng)) THEN
535 ncname=tlf(ng)%name
536!
537! Open impulse forcing file for read/write.
538!
539 IF (tlf(ng)%ncid.eq.-1) THEN
540 CALL netcdf_open (ng, itlm, ncname, 1, tlf(ng)%ncid)
541 IF (founderror(exit_flag, noerror, __line__, myfile)) THEN
542 WRITE (stdout,50) trim(ncname)
543 RETURN
544 END IF
545 END IF
546!
547! Inquire about the dimensions and check for consistency.
548!
549 CALL netcdf_check_dim (ng, itlm, ncname, &
550 & ncid = tlf(ng)%ncid)
551 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
552!
553! Inquire about the variables.
554!
555 CALL netcdf_inq_var (ng, itlm, ncname, &
556 & ncid = tlf(ng)%ncid)
557 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
558!
559! Initialize logical switches.
560!
561 DO i=1,nv
562 got_var(i)=.false.
563 END DO
564!
565! Scan variable list from input NetCDF and activate switches for
566! impulse forcing variables. Get variable IDs.
567!
568 DO i=1,n_var
569 IF (trim(var_name(i)).eq.trim(vname(1,idtime))) THEN
570 got_var(idtime)=.true.
571 tlf(ng)%Vid(idtime)=var_id(i)
572 ELSE IF (trim(var_name(i)).eq.trim(vname(1,idztlf))) THEN
573 got_var(idztlf)=.true.
574 tlf(ng)%Vid(idztlf)=var_id(i)
575# ifndef SOLVE3D
576
577 ELSE IF (trim(var_name(i)).eq.trim(vname(1,idubtf))) THEN
578 got_var(idubtf)=.true.
579 tlf(ng)%Vid(idubtf)=var_id(i)
580 ELSE IF (trim(var_name(i)).eq.trim(vname(1,idvbtf))) THEN
581 got_var(idvbtf)=.true.
582 tlf(ng)%Vid(idvbtf)=var_id(i)
583# else
584 ELSE IF (trim(var_name(i)).eq.trim(vname(1,idutlf))) THEN
585 got_var(idutlf)=.true.
586 tlf(ng)%Vid(idutlf)=var_id(i)
587 ELSE IF (trim(var_name(i)).eq.trim(vname(1,idvtlf))) THEN
588 got_var(idvtlf)=.true.
589 tlf(ng)%Vid(idvtlf)=var_id(i)
590# endif
591 END IF
592# ifdef SOLVE3D
593 DO itrc=1,nt(ng)
594 IF (trim(var_name(i)).eq.trim(vname(1,idttlf(itrc)))) THEN
595 got_var(idttlf(itrc))=.true.
596 tlf(ng)%Tid(itrc)=var_id(i)
597 END IF
598 END DO
599# endif
600 END DO
601!
602! Check if impulse forcing variables are available in input NetCDF
603! file.
604!
605 IF (.not.got_var(idtime)) THEN
606 IF (master) WRITE (stdout,60) trim(vname(1,idtime)), &
607 & trim(ncname)
608 exit_flag=3
609 RETURN
610 END IF
611 IF (.not.got_var(idztlf)) THEN
612 IF (master) WRITE (stdout,60) trim(vname(1,idztlf)), &
613 & trim(ncname)
614 exit_flag=3
615 RETURN
616 END IF
617# ifndef SOLVE3D
618 IF (.not.got_var(idubtf)) THEN
619 IF (master) WRITE (stdout,60) trim(vname(1,idubtf)), &
620 & trim(ncname)
621 exit_flag=3
622 RETURN
623 END IF
624 IF (.not.got_var(idvbtf)) THEN
625 IF (master) WRITE (stdout,60) trim(vname(1,idvbtf)), &
626 & trim(ncname)
627 exit_flag=3
628 RETURN
629 END IF
630# else
631 IF (.not.got_var(idutlf)) THEN
632 IF (master) WRITE (stdout,60) trim(vname(1,idutlf)), &
633 & trim(ncname)
634 exit_flag=3
635 RETURN
636 END IF
637 IF (.not.got_var(idvtlf)) THEN
638 IF (master) WRITE (stdout,60) trim(vname(1,idvtlf)), &
639 & trim(ncname)
640 exit_flag=3
641 RETURN
642 END IF
643 DO itrc=1,nt(ng)
644 IF (.not.got_var(idttlf(itrc))) THEN
645 IF (master) WRITE (stdout,60) trim(vname(1,idttlf(itrc))), &
646 & trim(ncname)
647 exit_flag=3
648 RETURN
649 END IF
650 END DO
651# endif
652!
653! Set unlimited time record dimension to the appropriate value.
654!
655 tlf(ng)%Rindex=rec_size
656 fcount=tlf(ng)%Fcount
657 tlf(ng)%Nrec(fcount)=rec_size
658 END IF query
659!
660
661 10 FORMAT (2x,'DEF_IMPULSE_NF90 - creating impulse forcing file,', &
662 & t56,'Grid ',i2.2,': ',a)
663 20 FORMAT (2x,'DEF_IMPULSE_NF90 - inquiring impulse forcing file,', &
664 & t56,'Grid ',i2.2,': ',a)
665 30 FORMAT (/,' DEF_IMPULSE_NF90 - unable to create impulse forcing', &
666 & ' NetCDF file: ',a)
667 40 FORMAT (1pe11.4,1x,'millimeter')
668 50 FORMAT (/,' DEF_IMPULSE_NF90 - unable to open norm NetCDF', &
669 & ' file: ',a)
670 60 FORMAT (/,' DEF_IMPULSE_NF90 - unable to find variable: ',a,2x, &
671 & ' in impulse forcing NetCDF file: ',a)
672!
673 RETURN
674 END SUBROUTINE def_impulse_nf90
675
676# if defined PIO_LIB && defined DISTRIBUTE
677!
678!***********************************************************************
679 SUBROUTINE def_impulse_pio (ng)
680!***********************************************************************
681!
682 USE mod_pio_netcdf
683!
684! Imported variable declarations.
685!
686 integer, intent(in) :: ng
687!
688! Local variable declarations.
689!
690 logical :: ldefine, got_var(nv)
691!
692 integer, parameter :: natt = 25
693
694 integer :: i, j, nvd3, nvd4
695 integer :: recdim, status
696 integer :: fcount
697
698 integer :: dimids(ndimid)
699 integer :: t2dgrd(3), u2dgrd(3), v2dgrd(3)
700
701# ifdef SOLVE3D
702 integer :: itrc
703
704 integer :: t3dgrd(4), u3dgrd(4), v3dgrd(4)
705# endif
706!
707 real(r8) :: aval(6)
708!
709 character (len=256) :: ncname
710 character (len=MaxLen) :: vinfo(natt)
711
712 character (len=*), parameter :: myfile = &
713 & __FILE__//", def_impulse_pio"
714!
715 sourcefile=myfile
716!
717!=======================================================================
718! Create a new impulse forcing file.
719!=======================================================================
720!
721 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
722 ncname=tlf(ng)%name
723!
724 IF (master) THEN
725 IF (ldeftlf(ng)) THEN
726 WRITE (stdout,10) ng, trim(ncname)
727 ELSE
728 WRITE (stdout,20) ng, trim(ncname)
729 END IF
730 END IF
731!
732 define : IF (ldeftlf(ng)) THEN
733 CALL pio_netcdf_create (ng, itlm, trim(ncname), tlf(ng)%pioFile)
734 IF (founderror(exit_flag, noerror, __line__, myfile)) THEN
735 IF (master) WRITE (stdout,30) trim(ncname)
736 RETURN
737 END IF
738!
739!-----------------------------------------------------------------------
740! Define file dimensions.
741!-----------------------------------------------------------------------
742!
743 dimids=0
744!
745 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xi_rho', &
746 & iobounds(ng)%xi_rho, dimids( 1))
747 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
748
749 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xi_u', &
750 & iobounds(ng)%xi_u, dimids( 2))
751 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
752
753 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xi_v', &
754 & iobounds(ng)%xi_v, dimids( 3))
755 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
756
757 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xi_psi', &
758 & iobounds(ng)%xi_psi, dimids( 4))
759 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
760
761 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'eta_rho', &
762 & iobounds(ng)%eta_rho, dimids( 5))
763 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
764
765 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'eta_u', &
766 & iobounds(ng)%eta_u, dimids( 6))
767 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
768
769 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'eta_v', &
770 & iobounds(ng)%eta_v, dimids( 7))
771 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
772
773 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'eta_psi', &
774 & iobounds(ng)%eta_psi, dimids( 8))
775 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
776
777# if defined WRITE_WATER && defined MASKING
778 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xy_rho', &
779 & iobounds(ng)%xy_rho, dimids(17))
780 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
781
782 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xy_u', &
783 & iobounds(ng)%xy_u, dimids(18))
784 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
785
786 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xy_v', &
787 & iobounds(ng)%xy_v, dimids(19))
788 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
789# endif
790
791# ifdef SOLVE3D
792# if defined WRITE_WATER && defined MASKING
793 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xyz_rho', &
794 & iobounds(ng)%xy_rho*n(ng), dimids(20))
795 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
796
797 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xyz_u', &
798 & iobounds(ng)%xy_u*n(ng), dimids(21))
799 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
800
801 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xyz_v', &
802 & iobounds(ng)%xy_v*n(ng), dimids(22))
803 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
804
805 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xyz_w', &
806 & iobounds(ng)%xy_rho*(n(ng)+1), dimids(23))
807 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
808# endif
809
810 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 's_rho', &
811 & n(ng), dimids( 9))
812 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
813
814 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 's_w', &
815 & n(ng)+1, dimids(10))
816 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
817
818 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'tracer', &
819 & nt(ng), dimids(11))
820 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
821
822# ifdef SEDIMENT
823 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'NST', &
824 & nst, dimids(32))
825 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
826
827 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'Nbed', &
828 & nbed, dimids(16))
829 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
830
831# if defined WRITE_WATER && defined MASKING
832 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'xybed', &
833 & iobounds(ng)%xy_rho*nbed, dimids(24))
834 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
835# endif
836# endif
837
838# ifdef ECOSIM
839 status=def_dim(ng, inlm, tlf(ng)%pioFile, ncname, 'Nbands', &
840 & nbands, dimids(33))
841 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
842
843 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'Nphy', &
844 & nphy, dimids(25))
845 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
846
847 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'Nbac', &
848 & nbac, dimids(26))
849 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
850
851 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'Ndom', &
852 & ndom, dimids(27))
853 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
854
855 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'Nfec', &
856 & nfec, dimids(28))
857 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
858# endif
859# endif
860
861 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'boundary', &
862 & 4, dimids(14))
863 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
864
865# ifdef FOUR_DVAR
866 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, 'Nstate', &
867 & nstatevar(ng), dimids(29))
868 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
869# endif
870
871 status=def_dim(ng, itlm, tlf(ng)%pioFile, ncname, &
872 & trim(adjustl(vname(5,idtime))), &
873 & nf90_unlimited, dimids(12))
874 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
875
876 recdim=dimids(12)
877!
878! Set number of dimensions for output variables.
879!
880# if defined WRITE_WATER && defined MASKING
881 nvd3=2
882 nvd4=2
883# else
884 nvd3=3
885 nvd4=4
886# endif
887!
888! Define dimension vectors for staggered tracer type variables.
889!
890# if defined WRITE_WATER && defined MASKING
891 t2dgrd(1)=dimids(17)
892 t2dgrd(2)=dimids(12)
893# ifdef SOLVE3D
894 t3dgrd(1)=dimids(20)
895 t3dgrd(2)=dimids(12)
896# endif
897# else
898 t2dgrd(1)=dimids( 1)
899 t2dgrd(2)=dimids( 5)
900 t2dgrd(3)=dimids(12)
901# ifdef SOLVE3D
902 t3dgrd(1)=dimids( 1)
903 t3dgrd(2)=dimids( 5)
904 t3dgrd(3)=dimids( 9)
905 t3dgrd(4)=dimids(12)
906# endif
907# endif
908!
909! Define dimension vectors for staggered u-momentum type variables.
910!
911# if defined WRITE_WATER && defined MASKING
912 u2dgrd(1)=dimids(18)
913 u2dgrd(2)=dimids(12)
914# ifdef SOLVE3D
915 u3dgrd(1)=dimids(21)
916 u3dgrd(2)=dimids(12)
917# endif
918# else
919 u2dgrd(1)=dimids( 2)
920 u2dgrd(2)=dimids( 6)
921 u2dgrd(3)=dimids(12)
922# ifdef SOLVE3D
923 u3dgrd(1)=dimids( 2)
924 u3dgrd(2)=dimids( 6)
925 u3dgrd(3)=dimids( 9)
926 u3dgrd(4)=dimids(12)
927# endif
928# endif
929!
930! Define dimension vectors for staggered v-momentum type variables.
931!
932# if defined WRITE_WATER && defined MASKING
933 v2dgrd(1)=dimids(19)
934 v2dgrd(2)=dimids(12)
935# ifdef SOLVE3D
936 v3dgrd(1)=dimids(22)
937 v3dgrd(2)=dimids(12)
938# endif
939# else
940 v2dgrd(1)=dimids( 3)
941 v2dgrd(2)=dimids( 7)
942 v2dgrd(3)=dimids(12)
943# ifdef SOLVE3D
944 v3dgrd(1)=dimids( 3)
945 v3dgrd(2)=dimids( 7)
946 v3dgrd(3)=dimids( 9)
947 v3dgrd(4)=dimids(12)
948# endif
949# endif
950!
951! Initialize unlimited time record dimension.
952!
953 tlf(ng)%Rindex=0
954!
955! Initialize local information variable arrays.
956!
957 DO i=1,natt
958 DO j=1,len(vinfo(1))
959 vinfo(i)(j:j)=' '
960 END DO
961 END DO
962 DO i=1,6
963 aval(i)=0.0_r8
964 END DO
965!
966!-----------------------------------------------------------------------
967! Define time-recordless information variables.
968!-----------------------------------------------------------------------
969!
970 CALL def_info (ng, itlm, tlf(ng)%pioFile, ncname, dimids)
971 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
972!
973!-----------------------------------------------------------------------
974! Define TLM/RPM impulse forcing.
975!-----------------------------------------------------------------------
976!
977! Define model time.
978!
979 vinfo( 1)=vname(1,idtime)
980 vinfo( 2)=vname(2,idtime)
981 WRITE (vinfo( 3),'(a,a)') 'seconds since ', trim(rclock%string)
982 vinfo( 4)=trim(rclock%calendar)
983 vinfo(14)=vname(4,idtime)
984 vinfo(21)=vname(6,idtime)
985 tlf(ng)%pioVar(idtime)%dkind=pio_tout
986 tlf(ng)%pioVar(idtime)%gtype=0
987!
988 status=def_var(ng, itlm, tlf(ng)%pioFile, &
989 & tlf(ng)%pioVar(idtime)%vd, &
990 & pio_tout, 1, (/recdim/), aval, vinfo, ncname, &
991 & setparaccess = .true.)
992 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
993!
994! Define free-surface impulse forcing.
995!
996 vinfo( 1)=vname(1,idztlf)
997 vinfo( 2)=vname(2,idztlf)
998 vinfo( 3)=vname(3,idztlf)
999 vinfo(14)=vname(4,idztlf)
1000 vinfo(16)=vname(1,idtime)
1001# if defined WRITE_WATER && defined MASKING
1002 vinfo(20)='mask_rho'
1003# endif
1004 vinfo(21)=vname(6,idztlf)
1005 vinfo(22)='coordinates'
1006 aval(5)=real(iinfo(1,idztlf,ng),r8)
1007 tlf(ng)%pioVar(idztlf)%dkind=pio_fout
1008 tlf(ng)%pioVar(idztlf)%gtype=r2dvar
1009!
1010 status=def_var(ng, itlm, tlf(ng)%pioFile, &
1011 & tlf(ng)%pioVar(idztlf)%vd, &
1012 & pio_fout, nvd3, t2dgrd, aval, vinfo, ncname)
1013 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1014
1015# ifndef SOLVE3D
1016!
1017! Define 2D U-momentum component impulse forcing.
1018!
1019 vinfo( 1)=vname(1,idubtf)
1020 vinfo( 2)=vname(2,idubtf)
1021 vinfo( 3)=vname(3,idubtf)
1022 vinfo(14)=vname(4,idubtf)
1023 vinfo(16)=vname(1,idtime)
1024# if defined WRITE_WATER && defined MASKING
1025 vinfo(20)='mask_u'
1026# endif
1027 vinfo(21)=vname(6,idubtf)
1028 vinfo(22)='coordinates'
1029 aval(5)=real(iinfo(1,idubtf,ng),r8)
1030 tlf(ng)%pioVar(idubtf)%dkind=pio_fout
1031 tlf(ng)%pioVar(idubtf)%gtype=u2dvar
1032!
1033 status=def_var(ng, itlm, tlf(ng)%pioFile, &
1034 & tlf(ng)%pioVar(idubtf)%vd, &
1035 & pio_fout, nvd3, u2dgrd, aval, vinfo, ncname)
1036 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1037!
1038! Define 2D V-momentum component impulse forcing.
1039!
1040 vinfo( 1)=vname(1,idvbtf)
1041 vinfo( 2)=vname(2,idvbtf)
1042 vinfo( 3)=vname(3,idvbtf)
1043 vinfo(14)=vname(4,idvbtf)
1044 vinfo(16)=vname(1,idtime)
1045# if defined WRITE_WATER && defined MASKING
1046 vinfo(20)='mask_v'
1047# endif
1048 vinfo(21)=vname(6,idvbtf)
1049 vinfo(22)='coordinates'
1050 aval(5)=real(iinfo(1,idvbtf,ng),r8)
1051 tlf(ng)%pioVar(idvbtf)%dkind=pio_fout
1052 tlf(ng)%pioVar(idvbtf)%gtype=v2dvar
1053!
1054 status=def_var(ng, itlm, tlf(ng)%pioFile, &
1055 & tlf(ng)%pioVar(idvbtf)%vd, &
1056 & pio_fout, nvd3, v2dgrd, aval, vinfo, ncname)
1057 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1058
1059# else
1060!
1061! Define 3D U-momentum component impulse forcing.
1062!
1063 vinfo( 1)=vname(1,idutlf)
1064 vinfo( 2)=vname(2,idutlf)
1065 vinfo( 3)=vname(3,idutlf)
1066 vinfo(14)=vname(4,idutlf)
1067 vinfo(16)=vname(1,idtime)
1068# if defined WRITE_WATER && defined MASKING
1069 vinfo(20)='mask_u'
1070# endif
1071 vinfo(21)=vname(6,idutlf)
1072 vinfo(22)='coordinates'
1073 aval(5)=real(iinfo(1,idutlf,ng),r8)
1074 tlf(ng)%pioVar(idutlf)%dkind=pio_fout
1075 tlf(ng)%pioVar(idutlf)%gtype=u3dvar
1076!
1077 status=def_var(ng, itlm, tlf(ng)%pioFile, &
1078 & tlf(ng)%pioVar(idutlf)%vd, &
1079 & pio_fout, nvd4, u3dgrd, aval, vinfo, ncname)
1080 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1081!
1082! Define 3D V-momentum component impulse forcing.
1083!
1084 vinfo( 1)=vname(1,idvtlf)
1085 vinfo( 2)=vname(2,idvtlf)
1086 vinfo( 3)=vname(3,idvtlf)
1087 vinfo(14)=vname(4,idvtlf)
1088 vinfo(16)=vname(1,idtime)
1089# if defined WRITE_WATER && defined MASKING
1090 vinfo(20)='mask_v'
1091# endif
1092 vinfo(21)=vname(6,idvtlf)
1093 vinfo(22)='coordinates'
1094 aval(5)=real(iinfo(1,idvtlf,ng),r8)
1095 tlf(ng)%pioVar(idvtlf)%dkind=pio_fout
1096 tlf(ng)%pioVar(idvtlf)%gtype=v3dvar
1097!
1098 status=def_var(ng, itlm, tlf(ng)%pioFile, &
1099 & tlf(ng)%pioVar(idvtlf)%vd, &
1100 & pio_fout, nvd4, v3dgrd, aval, vinfo, ncname)
1101 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1102!
1103! Define tracer type impulse forcing variables.
1104!
1105 DO itrc=1,nt(ng)
1106 vinfo( 1)=vname(1,idttlf(itrc))
1107 vinfo( 2)=vname(2,idttlf(itrc))
1108 vinfo( 3)=vname(3,idttlf(itrc))
1109 vinfo(14)=vname(4,idttlf(itrc))
1110 vinfo(16)=vname(1,idtime)
1111# ifdef SEDIMENT
1112 DO i=1,nst
1113 IF (itrc.eq.idsed(i)) THEN
1114 WRITE (vinfo(19),40) 1000.0_r8*sd50(i,ng)
1115 END IF
1116 END DO
1117# endif
1118# if defined WRITE_WATER && defined MASKING
1119 vinfo(20)='mask_rho'
1120# endif
1121 vinfo(21)=vname(6,idttlf(itrc))
1122 vinfo(22)='coordinates'
1123 aval(5)=real(r3dvar,r8)
1124 tlf(ng)%pioTrc(itrc)%dkind=pio_fout
1125 tlf(ng)%pioTrc(itrc)%gtype=r3dvar
1126!
1127 status=def_var(ng, itlm, tlf(ng)%pioFile, &
1128 & tlf(ng)%pioTrc(itrc)%vd, &
1129 & pio_fout, nvd4, t3dgrd, aval, vinfo, ncname)
1130 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1131 END DO
1132# endif
1133!
1134!-----------------------------------------------------------------------
1135! Leave definition mode.
1136!-----------------------------------------------------------------------
1137!
1138 CALL pio_netcdf_enddef (ng, itlm, ncname, tlf(ng)%pioFile)
1139 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1140!
1141!-----------------------------------------------------------------------
1142! Write out time-recordless, information variables. Deactive file
1143! creation switch.
1144!-----------------------------------------------------------------------
1145!
1146 CALL wrt_info (ng, itlm, tlf(ng)%pioFile, ncname)
1147 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1148 ldeftlf(ng)=.false.
1149 END IF define
1150!
1151!=======================================================================
1152! Open an existing impulse forcing file, check its contents, and
1153! prepare for appending data.
1154!=======================================================================
1155!
1156 query : IF (.not.ldeftlf(ng)) THEN
1157 ncname=tlf(ng)%name
1158!
1159! Open impulse forcing file for read/write.
1160!
1161 IF (tlf(ng)%pioFile%fh.eq.-1) THEN
1162 CALL pio_netcdf_open (ng, itlm, ncname, 1, tlf(ng)%pioFile)
1163 IF (founderror(exit_flag, noerror, __line__, myfile)) THEN
1164 WRITE (stdout,50) trim(ncname)
1165 RETURN
1166 END IF
1167 END IF
1168!
1169! Inquire about the dimensions and check for consistency.
1170!
1171 CALL pio_netcdf_check_dim (ng, itlm, ncname, &
1172 & piofile = tlf(ng)%pioFile)
1173 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1174!
1175! Inquire about the variables.
1176!
1177 CALL pio_netcdf_inq_var (ng, itlm, ncname, &
1178 & piofile = tlf(ng)%pioFile)
1179 IF (founderror(exit_flag, noerror, __line__, myfile)) RETURN
1180!
1181! Initialize logical switches.
1182!
1183 DO i=1,nv
1184 got_var(i)=.false.
1185 END DO
1186!
1187! Scan variable list from input NetCDF and activate switches for
1188! impulse forcing variables. Get variable IDs.
1189!
1190 DO i=1,n_var
1191 IF (trim(var_name(i)).eq.trim(vname(1,idtime))) THEN
1192 got_var(idtime)=.true.
1193 tlf(ng)%pioVar(idtime)%vd=var_desc(i)
1194 tlf(ng)%pioVar(idtime)%dkind=pio_tout
1195 tlf(ng)%pioVar(idtime)%gtype=0
1196 ELSE IF (trim(var_name(i)).eq.trim(vname(1,idztlf))) THEN
1197 got_var(idztlf)=.true.
1198 tlf(ng)%pioVar(idztlf)%vd=var_desc(i)
1199 tlf(ng)%pioVar(idztlf)%dkind=pio_fout
1200 tlf(ng)%pioVar(idztlf)%gtype=r2dvar
1201# ifndef SOLVE3D
1202 ELSE IF (trim(var_name(i)).eq.trim(vname(1,idubtf))) THEN
1203 got_var(idubtf)=.true.
1204 tlf(ng)%pioVar(idubtf)%vd=var_desc(i)
1205 tlf(ng)%pioVar(idubtf)%dkind=pio_fout
1206 tlf(ng)%pioVar(idubtf)%gtype=u2dvar
1207 ELSE IF (trim(var_name(i)).eq.trim(vname(1,idvbtf))) THEN
1208 got_var(idvbtf)=.true.
1209 tlf(ng)%pioVar(idvbtf)%vd=var_desc(i)
1210 tlf(ng)%pioVar(idvbtf)%dkind=pio_fout
1211 tlf(ng)%pioVar(idvbtf)%gtype=v2dvar
1212# else
1213 ELSE IF (trim(var_name(i)).eq.trim(vname(1,idutlf))) THEN
1214 got_var(idutlf)=.true.
1215 tlf(ng)%pioVar(idutlf)%vd=var_desc(i)
1216 tlf(ng)%pioVar(idutlf)%dkind=pio_fout
1217 tlf(ng)%pioVar(idutlf)%gtype=u3dvar
1218 ELSE IF (trim(var_name(i)).eq.trim(vname(1,idvtlf))) THEN
1219 got_var(idvtlf)=.true.
1220 tlf(ng)%pioVar(idvtlf)%vd=var_desc(i)
1221 tlf(ng)%pioVar(idvtlf)%dkind=pio_fout
1222 tlf(ng)%pioVar(idvtlf)%gtype=v3dvar
1223# endif
1224 END IF
1225# ifdef SOLVE3D
1226 DO itrc=1,nt(ng)
1227 IF (trim(var_name(i)).eq.trim(vname(1,idttlf(itrc)))) THEN
1228 got_var(idttlf(itrc))=.true.
1229 tlf(ng)%pioTrc(itrc)%vd=var_desc(i)
1230 tlf(ng)%pioTrc(itrc)%dkind=pio_fout
1231 tlf(ng)%pioTrc(itrc)%gtype=r3dvar
1232 END IF
1233 END DO
1234# endif
1235 END DO
1236!
1237! Check if impulse forcing variables are available in input NetCDF
1238! file.
1239!
1240 IF (.not.got_var(idtime)) THEN
1241 IF (master) WRITE (stdout,60) trim(vname(1,idtime)), &
1242 & trim(ncname)
1243 exit_flag=3
1244 RETURN
1245 END IF
1246 IF (.not.got_var(idztlf)) THEN
1247 IF (master) WRITE (stdout,60) trim(vname(1,idztlf)), &
1248 & trim(ncname)
1249 exit_flag=3
1250 RETURN
1251 END IF
1252# ifndef SOLVE3D
1253 IF (.not.got_var(idubtf)) THEN
1254 IF (master) WRITE (stdout,60) trim(vname(1,idubtf)), &
1255 & trim(ncname)
1256 exit_flag=3
1257 RETURN
1258 END IF
1259 IF (.not.got_var(idvbtf)) THEN
1260 IF (master) WRITE (stdout,60) trim(vname(1,idvbtf)), &
1261 & trim(ncname)
1262 exit_flag=3
1263 RETURN
1264 END IF
1265# else
1266 IF (.not.got_var(idutlf)) THEN
1267 IF (master) WRITE (stdout,60) trim(vname(1,idutlf)), &
1268 & trim(ncname)
1269 exit_flag=3
1270 RETURN
1271 END IF
1272 IF (.not.got_var(idvtlf)) THEN
1273 IF (master) WRITE (stdout,60) trim(vname(1,idvtlf)), &
1274 & trim(ncname)
1275 exit_flag=3
1276 RETURN
1277 END IF
1278 DO itrc=1,nt(ng)
1279 IF (.not.got_var(idttlf(itrc))) THEN
1280 IF (master) WRITE (stdout,60) trim(vname(1,idttlf(itrc))), &
1281 & trim(ncname)
1282 exit_flag=3
1283 RETURN
1284 END IF
1285 END DO
1286# endif
1287!
1288! Set unlimited time record dimension to the appropriate value.
1289!
1290 tlf(ng)%Rindex=rec_size
1291 fcount=tlf(ng)%Fcount
1292 tlf(ng)%Nrec(fcount)=rec_size
1293 END IF query
1294!
1295 10 FORMAT (2x,'DEF_IMPULSE_PIO - creating impulse forcing file,', &
1296 & t56,'Grid ',i2.2,': ',a)
1297 20 FORMAT (2x,'DEF_IMPULSE_PIO - inquiring impulse forcing file,', &
1298 & t56,'Grid ',i2.2,': ',a)
1299 30 FORMAT (/,' DEF_IMPULSE_PIO - unable to create impulse forcing', &
1300 & ' NetCDF file: ',a)
1301 40 FORMAT (1pe11.4,1x,'millimeter')
1302 50 FORMAT (/,' DEF_IMPULSE_PIO - unable to open norm NetCDF', &
1303 & ' file: ',a)
1304 60 FORMAT (/,' DEF_IMPULSE_PIO - unable to find variable: ',a,2x, &
1305 & ' in impulse forcing NetCDF file: ',a)
1306!
1307 RETURN
1308 END SUBROUTINE def_impulse_pio
1309# endif
1310#endif
1311 END MODULE def_impulse_mod
def_dim_mod::def_dim
Definition def_dim.F:24
def_info_mod::def_info
Definition def_info.F:72
def_var_mod::def_var
Definition def_var.F:88
wrt_info_mod::wrt_info
Definition wrt_info.F:54
def_dim_mod
Definition def_dim.F:2
def_impulse_mod
Definition def_impulse.F:2
def_impulse_mod::def_impulse_pio
subroutine, private def_impulse_pio(ng)
Definition def_impulse.F:680
def_impulse_mod::def_impulse_nf90
subroutine, private def_impulse_nf90(ng)
Definition def_impulse.F:86
def_impulse_mod::def_impulse
subroutine, public def_impulse(ng)
Definition def_impulse.F:49
def_info_mod
Definition def_info.F:2
def_var_mod
Definition def_var.F:2
mod_biology
Definition ecosim_mod.h:1
mod_biology::nfec
integer, parameter nfec
Definition ecosim_mod.h:204
mod_biology::nbac
integer, parameter nbac
Definition ecosim_mod.h:202
mod_biology::ndom
integer, parameter ndom
Definition ecosim_mod.h:203
mod_biology::nbands
integer, parameter nbands
Definition ecosim_mod.h:201
mod_biology::nphy
integer, parameter nphy
Definition ecosim_mod.h:205
mod_fourdvar
Definition mod_fourdvar.F:2
mod_fourdvar::nstatevar
integer, dimension(:), allocatable nstatevar
Definition mod_fourdvar.F:362
mod_iounits
Definition mod_iounits.F:2
mod_iounits::tlf
type(t_io), dimension(:), allocatable tlf
Definition mod_iounits.F:249
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::idubtf
integer idubtf
Definition mod_ncparam.F:333
mod_ncparam::io_nf90
integer, parameter io_nf90
Definition mod_ncparam.F:95
mod_ncparam::nv
integer, parameter nv
Definition mod_ncparam.F:105
mod_ncparam::io_pio
integer, parameter io_pio
Definition mod_ncparam.F:96
mod_ncparam::idztlf
integer idztlf
Definition mod_ncparam.F:434
mod_ncparam::idvbtf
integer idvbtf
Definition mod_ncparam.F:368
mod_ncparam::idttlf
integer, dimension(:), allocatable idttlf
Definition mod_ncparam.F:454
mod_ncparam::vname
character(len=maxlen), dimension(6, 0:nv) vname
Definition mod_ncparam.F:591
mod_ncparam::idtime
integer idtime
Definition mod_ncparam.F:307
mod_ncparam::idutlf
integer idutlf
Definition mod_ncparam.F:342
mod_ncparam::iinfo
integer, dimension(:,:,:), allocatable iinfo
Definition mod_ncparam.F:578
mod_ncparam::idvtlf
integer idvtlf
Definition mod_ncparam.F:380
mod_ncparam::ndimid
integer, parameter ndimid
Definition mod_ncparam.F:110
mod_netcdf
Definition mod_netcdf.F:2
mod_netcdf::nf_tout
integer, parameter nf_tout
Definition mod_netcdf.F:207
mod_netcdf::netcdf_check_dim
subroutine, public netcdf_check_dim(ng, model, ncname, ncid)
Definition mod_netcdf.F:538
mod_netcdf::netcdf_open
subroutine, public netcdf_open(ng, model, ncname, omode, ncid)
Definition mod_netcdf.F:9293
mod_netcdf::nf_fout
integer, parameter nf_fout
Definition mod_netcdf.F:188
mod_netcdf::netcdf_enddef
subroutine, public netcdf_enddef(ng, model, ncname, ncid)
Definition mod_netcdf.F:9220
mod_netcdf::var_name
character(len=100), dimension(mvars) var_name
Definition mod_netcdf.F:169
mod_netcdf::var_id
integer, dimension(mvars) var_id
Definition mod_netcdf.F:160
mod_netcdf::n_var
integer n_var
Definition mod_netcdf.F:152
mod_netcdf::rec_size
integer rec_size
Definition mod_netcdf.F:156
mod_netcdf::netcdf_create
subroutine, public netcdf_create(ng, model, ncname, ncid)
Definition mod_netcdf.F:9089
mod_netcdf::netcdf_inq_var
subroutine, public netcdf_inq_var(ng, model, ncname, ncid, myvarname, searchvar, varid, nvardim, nvaratt)
Definition mod_netcdf.F:1371
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::inlm
integer, parameter inlm
Definition mod_param.F:662
mod_param::nbed
integer nbed
Definition mod_param.F:517
mod_param::n
integer, dimension(:), allocatable n
Definition mod_param.F:479
mod_param::r3dvar
integer, parameter r3dvar
Definition mod_param.F:721
mod_param::iobounds
type(t_iobounds), dimension(:), allocatable iobounds
Definition mod_param.F:282
mod_param::u3dvar
integer, parameter u3dvar
Definition mod_param.F:722
mod_param::u2dvar
integer, parameter u2dvar
Definition mod_param.F:718
mod_param::itlm
integer, parameter itlm
Definition mod_param.F:663
mod_param::nt
integer, dimension(:), allocatable nt
Definition mod_param.F:489
mod_param::r2dvar
integer, parameter r2dvar
Definition mod_param.F:717
mod_param::v2dvar
integer, parameter v2dvar
Definition mod_param.F:719
mod_param::nst
integer nst
Definition mod_param.F:521
mod_param::v3dvar
integer, parameter v3dvar
Definition mod_param.F:723
mod_pio_netcdf
Definition mod_pio_netcdf.F:2
mod_pio_netcdf::pio_fout
integer, parameter pio_fout
Definition mod_pio_netcdf.F:569
mod_pio_netcdf::var_desc
type(var_desc_t), dimension(:), pointer var_desc
Definition mod_pio_netcdf.F:437
mod_pio_netcdf::pio_netcdf_create
subroutine, public pio_netcdf_create(ng, model, ncname, piofile)
Definition mod_pio_netcdf.F:8997
mod_pio_netcdf::pio_netcdf_inq_var
subroutine, public pio_netcdf_inq_var(ng, model, ncname, piofile, myvarname, searchvar, piovar, nvardim, nvaratt)
Definition mod_pio_netcdf.F:1923
mod_pio_netcdf::pio_netcdf_open
subroutine, public pio_netcdf_open(ng, model, ncname, omode, piofile)
Definition mod_pio_netcdf.F:9148
mod_pio_netcdf::pio_netcdf_check_dim
subroutine, public pio_netcdf_check_dim(ng, model, ncname, piofile)
Definition mod_pio_netcdf.F:1080
mod_pio_netcdf::pio_tout
integer, parameter pio_tout
Definition mod_pio_netcdf.F:588
mod_pio_netcdf::pio_netcdf_enddef
subroutine, public pio_netcdf_enddef(ng, model, ncname, piofile)
Definition mod_pio_netcdf.F:9096
mod_scalars
Definition mod_scalars.F:2
mod_scalars::ldeftlf
logical, dimension(:), allocatable ldeftlf
Definition mod_scalars.F:982
mod_scalars::rclock
type(t_clock) rclock
Definition mod_scalars.F:120
mod_scalars::exit_flag
integer exit_flag
Definition mod_scalars.F:559
mod_scalars::noerror
integer noerror
Definition mod_scalars.F:561
mod_sediment
Definition sediment_mod.h:1
mod_sediment::idsed
integer, dimension(:), allocatable idsed
Definition sediment_mod.h:88
mod_sediment::sd50
real(r8), dimension(:,:), allocatable sd50
Definition sediment_mod.h:173
strings_mod
Definition strings.F:2
strings_mod::founderror
logical function, public founderror(flag, noerr, line, routine)
Definition strings.F:52
wrt_info_mod
Definition wrt_info.F:2