Line data Source code
1 : module cam_history
2 : !-------------------------------------------------------------------------------------------
3 : !
4 : ! The cam_history module provides the user interface for CAM's history output capabilities.
5 : ! It maintains the lists of fields that are written to each history file, and the associated
6 : ! metadata for those fields such as descriptive names, physical units, time axis properties,
7 : ! etc. It also contains the programmer interface which provides routines that are called from
8 : ! the physics and dynamics initialization routines to define the fields that are produced by
9 : ! the model and are available for output, and the routine that is called from the corresponding
10 : ! run method to add the field values into a history buffer so that they may be output to disk.
11 : !
12 : ! There are two special history files. The initial file and the satellite track file.
13 : !
14 : ! Public functions/subroutines:
15 : ! addfld, add_default
16 : ! intht
17 : ! history_initialized
18 : ! write_restart_history
19 : ! read_restart_history
20 : ! outfld
21 : ! wshist
22 : !-----------------------------------------------------------------------
23 :
24 : use shr_kind_mod, only: r8 => shr_kind_r8, r4 => shr_kind_r4
25 : use shr_kind_mod, only: cl=>SHR_KIND_CL
26 : use shr_sys_mod, only: shr_sys_flush
27 : use spmd_utils, only: masterproc
28 : use ppgrid, only: pcols, psubcols
29 : use cam_instance, only: inst_suffix
30 : use cam_control_mod, only: caseid, ctitle
31 : use filenames, only: interpret_filename_spec
32 : use cam_initfiles, only: ncdata, bnd_topo
33 : use cam_abortutils, only: endrun
34 :
35 : use pio, only: file_desc_t, var_desc_t, pio_setframe, pio_write, &
36 : pio_noerr, pio_bcast_error, pio_internal_error, &
37 : pio_seterrorhandling, pio_get_var, pio_clobber, &
38 : pio_int, pio_real, pio_double, pio_char, &
39 : pio_offset_kind, pio_unlimited, pio_global, &
40 : pio_inq_dimlen, pio_def_var, pio_enddef, &
41 : pio_put_att, pio_put_var, pio_get_att, &
42 : pio_file_is_open
43 :
44 :
45 : use perf_mod, only: t_startf, t_stopf
46 : use cam_logfile, only: iulog
47 : use cam_history_support, only: max_fieldname_len, fieldname_suffix_len, &
48 : max_chars, ptapes, fieldname_len, &
49 : max_string_len, pflds, fieldname_lenp2, &
50 : field_info, active_entry, hentry, &
51 : horiz_only, write_hist_coord_attrs, &
52 : write_hist_coord_vars, interp_info_t, &
53 : lookup_hist_coord_indices, get_hist_coord_index, &
54 : field_op_len
55 : use string_utils, only: date2yyyymmdd, sec2hms
56 : use sat_hist, only: is_satfile
57 : use solar_parms_data, only: solar_parms_on, kp=>solar_parms_kp, ap=>solar_parms_ap
58 : use solar_parms_data, only: f107=>solar_parms_f107, f107a=>solar_parms_f107a, f107p=>solar_parms_f107p
59 : use solar_wind_data, only: solar_wind_on, byimf=>solar_wind_byimf, bzimf=>solar_wind_bzimf
60 : use solar_wind_data, only: swvel=>solar_wind_swvel, swden=>solar_wind_swden
61 : use epotential_params, only: epot_active, epot_crit_colats
62 : use cam_grid_support, only: maxsplitfiles
63 :
64 : implicit none
65 : private
66 : save
67 :
68 : ! Forward common parameters to present unified interface to cam_history
69 : public :: fieldname_len, horiz_only
70 : public :: get_field_properties
71 : public :: cam_history_snapshot_deactivate
72 : public :: cam_history_snapshot_activate
73 :
74 : type grid_area_entry
75 : integer :: decomp_type = -1 ! type of decomposition (e.g., physics or dynamics)
76 : real(r8), allocatable :: wbuf(:,:) ! for area weights
77 : end type grid_area_entry
78 : type (grid_area_entry), target, allocatable:: grid_wts(:) ! area wts for each decomp type
79 : type (grid_area_entry), pointer :: allgrids_wt(:) => null() ! area wts for each decomp type
80 : !
81 : ! master_entry: elements of an entry in the master field list
82 : !
83 : type master_entry
84 : type (field_info) :: field ! field information
85 : character(len=max_fieldname_len) :: meridional_field = '' ! for vector fields
86 : character(len=max_fieldname_len) :: zonal_field = '' ! for vector fields
87 : character(len=1) :: avgflag(ptapes) ! averaging flag
88 : character(len=max_chars) :: time_op(ptapes) ! time operator (e.g. max, min, avg)
89 : character(len=field_op_len) :: field_op = '' ! field derived from sum or dif of field1 and field2
90 : character(len=max_fieldname_len) :: op_field1 = '' ! first field name to be operated on
91 : character(len=max_fieldname_len) :: op_field2 = '' ! second field name to be operated on
92 : logical :: act_sometape ! Field is active on some tape
93 : logical :: actflag(ptapes) ! Per tape active/inactive flag
94 : integer :: htapeindx(ptapes)! This field's index on particular history tape
95 : type(master_entry), pointer :: next_entry => null() ! The next master entry
96 : end type master_entry
97 :
98 : type (master_entry), pointer :: masterlinkedlist => null() ! master field linkedlist top
99 :
100 : type master_list
101 : type(master_entry), pointer :: thisentry => null()
102 : end type master_list
103 :
104 : type (master_list), pointer :: masterlist(:) => null() ! master field array for hash lookup of field
105 :
106 : ! history tape info
107 : type (active_entry), pointer :: tape(:) => null() ! history tapes
108 : type (active_entry), target,allocatable :: history_tape(:) ! history tapes
109 : type (active_entry), target, allocatable :: restarthistory_tape(:) ! restart history tapes
110 :
111 : type rvar_id
112 : type(var_desc_t), pointer :: vdesc => null()
113 : integer :: type
114 : integer :: ndims
115 : integer :: dims(4)
116 : character(len=fieldname_lenp2) :: name
117 : logical :: fillset = .false.
118 : integer :: ifill
119 : real(r4) :: rfill
120 : real(r8) :: dfill
121 : end type rvar_id
122 : type rdim_id
123 : integer :: len
124 : integer :: dimid
125 : character(len=fieldname_lenp2) :: name
126 : end type rdim_id
127 : !
128 : ! The size of these parameters should match the assignments in restart_vars_setnames and restart_dims_setnames below
129 : !
130 : integer, parameter :: restartvarcnt = 45
131 : integer, parameter :: restartdimcnt = 11
132 : type(rvar_id) :: restartvars(restartvarcnt)
133 : type(rdim_id) :: restartdims(restartdimcnt)
134 : integer, parameter :: ptapes_dim_ind = 1
135 : integer, parameter :: max_string_len_dim_ind = 2
136 : integer, parameter :: fieldname_lenp2_dim_ind = 3
137 : integer, parameter :: pflds_dim_ind = 4
138 : integer, parameter :: max_chars_dim_ind = 5
139 : integer, parameter :: max_fieldname_len_dim_ind = 6
140 : integer, parameter :: maxnflds_dim_ind = 7
141 : integer, parameter :: maxvarmdims_dim_ind = 8
142 : integer, parameter :: registeredmdims_dim_ind = 9
143 : integer, parameter :: max_hcoordname_len_dim_ind = 10
144 : integer, parameter :: max_num_split_files = 11
145 :
146 : ! Indices for split history files; must be 1 and 2
147 : integer, parameter :: instantaneous_file_index = 1
148 : integer, parameter :: accumulated_file_index = 2
149 : ! Indices for non-split history files; must be 1 or 2
150 : integer, parameter :: sat_file_index = 1
151 : integer, parameter :: restart_file_index = 1
152 : integer, parameter :: init_file_index = 1
153 :
154 : integer :: nfmaster = 0 ! number of fields in master field list
155 : integer :: nflds(ptapes) ! number of fields per tape
156 :
157 : ! per tape sampling frequency (0=monthly avg)
158 :
159 : integer :: idx ! index for nhtfrq initialization
160 : integer :: nhtfrq(ptapes) = (/0, (-24, idx=2,ptapes)/) ! history write frequency (0 = monthly)
161 : integer :: mfilt(ptapes) = 30 ! number of time samples per tape
162 : integer :: nfils(ptapes) ! Array of no. of files on current h-file
163 : integer :: ndens(ptapes) = 2 ! packing density (double (1) or real (2))
164 : integer :: ncprec(ptapes) = -999 ! netcdf packing parameter based on ndens
165 : real(r8) :: beg_time(ptapes) ! time at beginning of an averaging interval
166 :
167 : logical :: rgnht(ptapes) = .false. ! flag array indicating regeneration volumes
168 : logical :: hstwr(ptapes) = .false. ! Flag for history writes
169 : logical :: empty_htapes = .false. ! Namelist flag indicates no default history fields
170 : logical :: write_nstep0 = .false. ! write nstep==0 time sample to history files (except monthly)
171 : logical :: htapes_defined = .false. ! flag indicates history contents have been defined
172 :
173 : character(len=cl) :: model_doi_url = '' ! Model DOI
174 : ! NB: This name must match the group name in namelist_definition.xml
175 : character(len=*), parameter :: history_namelist = 'cam_history_nl'
176 : character(len=max_string_len) :: hrestpath(ptapes) = (/(' ',idx=1,ptapes)/) ! Full history restart pathnames
177 : character(len=max_string_len) :: nfpath(ptapes) = (/(' ',idx=1,ptapes)/) ! Array of first pathnames, for header
178 : character(len=max_string_len) :: cpath(ptapes,maxsplitfiles) ! Array of current pathnames
179 : character(len=max_string_len) :: nhfil(ptapes,maxsplitfiles) ! Array of current file names
180 : character(len=1) :: avgflag_pertape(ptapes) = (/(' ',idx=1,ptapes)/) ! per tape averaging flag
181 : character(len=16) :: logname ! user name
182 : character(len=16) :: host ! host name
183 : character(len=8) :: inithist = 'YEARLY' ! If set to '6-HOURLY, 'DAILY', 'MONTHLY' or
184 : ! 'YEARLY' then write IC file
185 : logical :: write_camiop = .false. ! setup to use iop fields if true.
186 : logical :: inithist_all = .false. ! Flag to indicate set of fields to be
187 : ! included on IC file
188 : ! .false. include only required fields
189 : ! .true. include required *and* optional fields
190 : character(len=fieldname_lenp2) :: fincl(pflds,ptapes) ! List of fields to add to primary h-file
191 : character(len=max_chars) :: fincllonlat(pflds,ptapes) ! List of fields to add to primary h-file
192 : character(len=fieldname_lenp2) :: fexcl(pflds,ptapes) ! List of fields to rm from primary h-file
193 : character(len=fieldname_lenp2) :: fwrtpr(pflds,ptapes) ! List of fields to change default history output prec
194 : character(len=fieldname_suffix_len ) :: fieldname_suffix = '&IC' ! Suffix appended to field names for IC file
195 :
196 : ! Parameters for interpolated output tapes
197 : logical, public :: interpolate_output(ptapes) = .false.
198 : ! The last two history files are not supported for interpolation
199 : type(interp_info_t) :: interpolate_info(ptapes - 2)
200 :
201 : ! Allowed history averaging flags
202 : ! This should match namelist_definition.xml => avgflag_pertape (+ ' ')
203 : character(len=9), parameter :: HIST_AVG_FLAGS = ' ABILMNSX'
204 : character(len=22) ,parameter :: LT_DESC = 'mean (over local time)' ! local time description
205 : logical :: collect_column_output(ptapes)
206 :
207 : integer :: maxvarmdims=1
208 : !
209 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
210 : !
211 : ! Hashing.
212 : !
213 : ! Accelerate outfld processing by using a hash function of the field name
214 : ! to index masterlist and determine whehter the particular field is to
215 : ! be written to any history tape.
216 : !
217 : !
218 : ! Note: the outfld hashing logic will fail if any of the following are true:
219 : !
220 : ! 1) The lower bound on the dimension of 'masterlist' is less than 1.
221 : !
222 : ! 2) 'outfld' is called with field names that are not defined on
223 : ! masterlist. This applies to both initial/branch and restart
224 : ! runs.
225 : !
226 : ! 3) An inconsistency between a field's tape active flag
227 : ! 'masterlist(ff)%actflag(t)' and active fields read from
228 : ! restart files.
229 : !
230 : ! 4) Invoking function 'gen_hash_key' before the primary and secondary
231 : ! hash tables have been created (routine bld_outfld_hash_tbls).
232 : !
233 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
234 :
235 : !
236 : ! User definable constants for hash and overflow tables.
237 : ! Define size of primary hash table (specified as 2**size).
238 : !
239 : integer, parameter :: tbl_hash_pri_sz_lg2 = 20
240 : !
241 : ! Define size of overflow hash table % of primary hash table.
242 : !
243 : integer, parameter :: tbl_hash_oflow_percent = 20
244 : !
245 : ! Do *not* modify the parameters below.
246 : !
247 : integer, parameter :: tbl_hash_pri_sz = 2**tbl_hash_pri_sz_lg2
248 : integer, parameter :: tbl_hash_oflow_sz = int(tbl_hash_pri_sz * &
249 : (tbl_hash_oflow_percent / 100.0_r8))
250 : !
251 : ! The primary and overflow tables are organized to mimimize space (read:
252 : ! try to maximimze cache line usage).
253 : !
254 : ! gen_hash_key(fieldname) will return an index on the interval
255 : ! [0 ... tbl_hash_pri_sz-1].
256 : !
257 : !
258 : ! Primary:
259 : ! gen_hash_key(fieldname)-------+ +----------+
260 : ! | | -ii | 1 ------>tbl_hash_oflow(ii)
261 : ! | +----------+
262 : ! +--> | ff | 2 ------>masterlist(ff)
263 : ! +----------+
264 : ! | | ...
265 : ! +----------+
266 : ! | | tbl_hash_pri_sz
267 : ! +----------+
268 : !
269 : ! Overflow (if tbl_hash_pri() < 0):
270 : ! tbl_hash_pri(gen_hash_key(fieldname))
271 : ! |
272 : ! | +----------+
273 : ! | | 1 | 1 (one entry on O.F. chain)
274 : ! | +----------+
275 : ! | | ff_m | 2
276 : ! | +----------+
277 : ! +---------> | 3 | 3 (three entries on chain)
278 : ! +----------+
279 : ! | ff_x | 4
280 : ! +----------+
281 : ! | ff_y | 5
282 : ! +----------+
283 : ! | ff_z | 6
284 : ! +----------+
285 : ! | | ...
286 : ! +----------+
287 : ! | | tbl_hash_oflow_sz
288 : ! +----------+
289 : !
290 : !
291 : integer, dimension(0:tbl_hash_pri_sz-1) :: tbl_hash_pri ! Primary hash table
292 : integer, dimension(tbl_hash_oflow_sz) :: tbl_hash_oflow ! Overflow hash table
293 : !
294 : ! Constants used in hashing function gen_hash_key.
295 : ! Note: if the constants in table 'tbl_gen_hash_key' below are modified,
296 : ! changes are required to routine 'gen_hash_key' because of specific
297 : ! logic in the routine that optimizes character strings of length 8.
298 : !
299 :
300 : integer, parameter :: gen_hash_key_offset = z'000053db'
301 :
302 : integer, parameter :: tbl_max_idx = 15 ! 2**N - 1
303 : integer, dimension(0:tbl_max_idx) :: tbl_gen_hash_key = &
304 : (/61,59,53,47,43,41,37,31,29,23,17,13,11,7,3,1/)
305 :
306 : !
307 : ! Filename specifiers for history, initial files and restart history files
308 : ! (%c = caseid, $y = year, $m = month, $d = day, $s = seconds in day, %t = tape number)
309 : !
310 : character(len=max_string_len) :: rhfilename_spec = '%c.cam.rh%t.%y-%m-%d-%s.nc' ! history restart
311 : character(len=max_string_len) :: hfilename_spec(ptapes) = (/ (' ', idx=1, ptapes) /) ! filename specifyer
312 : logical :: default_monthly_filename(ptapes) = .false.
313 : ! Flag for if there are accumulated fields specified for a given tape
314 : logical :: hfile_accum(ptapes) = .false.
315 :
316 :
317 : interface addfld
318 : module procedure addfld_1d
319 : module procedure addfld_nd
320 : end interface
321 :
322 :
323 : public :: inithist_all ! Needed by cam_diagnostics
324 : public :: write_camiop ! Needed by cam_comp
325 :
326 : integer :: lcltod_start(ptapes) ! start time of day for local time averaging (sec)
327 : integer :: lcltod_stop(ptapes) ! stop time of day for local time averaging, stop > start is wrap around (sec)
328 :
329 : ! Needed by stepon and cam_restart
330 : public :: hstwr
331 : public :: nfils, mfilt
332 :
333 : ! Functions
334 : public :: history_readnl ! Namelist reader for CAM history
335 : public :: init_restart_history ! Write restart history data
336 : public :: write_restart_history ! Write restart history data
337 : public :: read_restart_history ! Read restart history data
338 : public :: wshist ! Write files out
339 : public :: outfld ! Output a field
340 : public :: intht ! Initialization
341 : public :: history_initialized ! .true. iff cam history initialized
342 : public :: wrapup ! process history files at end of run
343 : public :: write_inithist ! logical flag to allow dump of IC history buffer to IC file
344 : public :: addfld ! Add a field to history file
345 : public :: add_default ! Add the default fields
346 : public :: register_vector_field ! Register vector field set for interpolated output
347 : public :: get_hfilepath ! Return history filename
348 : public :: get_ptapes ! Return the number of tapes being used
349 : public :: get_hist_restart_filepath ! Return the full filepath to the history restart file
350 : public :: hist_fld_active ! Determine if a field is active on any history file
351 : public :: hist_fld_col_active ! Determine if a field is active on any history file at
352 : ! each column in a chunk
353 :
354 : CONTAINS
355 :
356 0 : subroutine intht (model_doi_url_in)
357 : !
358 : !-----------------------------------------------------------------------
359 : !
360 : ! Purpose: Initialize history file handler for initial or continuation run.
361 : ! For example, on an initial run, this routine initializes "ptapes"
362 : ! history files. On a restart or regeneration run, this routine
363 : ! only initializes history files declared beyond what existed on the
364 : ! previous run. Files which already existed on the previous run have
365 : ! already been initialized (i.e. named and opened) in routine RESTRT.
366 : !
367 : ! Method: Loop over tapes and fields per tape setting appropriate variables and
368 : ! calling appropriate routines
369 : !
370 : ! Author: CCM Core Group
371 : !
372 : !-----------------------------------------------------------------------
373 : use shr_sys_mod, only: shr_sys_getenv
374 : use time_manager, only: get_prev_time, get_curr_time
375 : use cam_control_mod, only: restart_run, branch_run
376 : use sat_hist, only: sat_hist_init
377 : use spmd_utils, only: mpicom, masterprocid, mpi_character
378 : use cam_grid_support, only: cam_grid_get_areawt
379 : use cam_history_support, only: dim_index_2d
380 : !
381 : !-----------------------------------------------------------------------
382 : !
383 : ! Dummy argument
384 : !
385 : character(len=cl), intent(in) :: model_doi_url_in
386 : !
387 : ! Local workspace
388 : !
389 : integer :: t, fld ! tape, field indices
390 : integer :: begdim1 ! on-node dim1 start index
391 : integer :: enddim1 ! on-node dim1 end index
392 : integer :: begdim2 ! on-node dim2 start index
393 : integer :: enddim2 ! on-node dim2 end index
394 : integer :: begdim3 ! on-node chunk or lat start index
395 : integer :: enddim3 ! on-node chunk or lat end index
396 : integer :: day, sec ! day and seconds from base date
397 : integer :: rcode ! shr_sys_getenv return code
398 : integer :: wtidx(1) ! area weight index
399 : integer :: i,k,c,ib,ie,jb,je,count ! index
400 : integer :: fdecomp ! field decomp
401 : type(dim_index_2d) :: dimind ! 2-D dimension index
402 1536 : real(r8), pointer :: areawt(:) ! pointer to areawt values for attribute
403 : type(master_entry), pointer :: listentry
404 : character(len=32) :: fldname ! temp variable used to produce a left justified field name
405 : ! in the formatted logfile output
406 :
407 : !
408 : ! Save the DOI
409 : !
410 1536 : model_doi_url = trim(model_doi_url_in)
411 :
412 : !
413 : ! Print master field list
414 : !
415 :
416 1536 : if (masterproc) then
417 2 : write(iulog,*) ' '
418 2 : write(iulog,*)' ******* MASTER FIELD LIST *******'
419 : end if
420 1536 : listentry=>masterlinkedlist
421 1536 : fld=0
422 12481536 : do while(associated(listentry))
423 12480000 : fld=fld+1
424 12480000 : if(masterproc) then
425 16250 : fldname = listentry%field%name
426 16250 : write(iulog,9000) fld, fldname, listentry%field%units, listentry%field%numlev, &
427 32500 : listentry%avgflag(1), trim(listentry%field%long_name)
428 : 9000 format(i5, 1x, a32, 1x, a16, 1x, i4, 1x, a1, 2x, a)
429 : end if
430 12480000 : listentry=>listentry%next_entry
431 : end do
432 1536 : nfmaster = fld
433 1536 : if(masterproc) write(iulog,*)'intht:nfmaster=',nfmaster
434 :
435 : !
436 : ! Now that masterlinkedlist is defined and we are performing a restart run
437 : ! (after all addfld calls), construct primary and secondary hashing tables.
438 : !
439 1536 : if (restart_run) then
440 768 : call print_active_fldlst()
441 768 : call bld_outfld_hash_tbls()
442 768 : call bld_htapefld_indices()
443 768 : return
444 : end if
445 : !
446 : ! Get users logname and machine hostname
447 : !
448 768 : if ( masterproc )then
449 1 : logname = ' '
450 1 : call shr_sys_getenv ('LOGNAME',logname,rcode)
451 1 : host = ' '
452 1 : call shr_sys_getenv ('HOST',host,rcode)
453 : end if
454 : ! PIO requires netcdf attributes have consistant values on all tasks
455 768 : call mpi_bcast(logname, len(logname), mpi_character, masterprocid, mpicom, rcode)
456 768 : call mpi_bcast(host, len(host), mpi_character, masterprocid, mpicom, rcode)
457 : !
458 : ! Override averaging flag for all fields on a particular tape if namelist input so specifies
459 : !
460 9984 : do t=1,ptapes
461 9984 : if (avgflag_pertape(t) /= ' ') then
462 6912 : call h_override (t)
463 : end if
464 : end do
465 : !
466 : ! Define field list information for all history files.
467 : !
468 768 : call fldlst ()
469 : !
470 : ! Loop over max. no. of history files permitted
471 : !
472 768 : if (branch_run) then
473 0 : call get_prev_time(day, sec) ! elapased time since reference date
474 : else
475 768 : call get_curr_time(day, sec) ! elapased time since reference date
476 : end if
477 9984 : do t=1,ptapes
478 9216 : nfils(t) = 0 ! no. of time samples in hist. file no. t
479 :
480 : ! Time at beginning of current averaging interval.
481 :
482 9984 : beg_time(t) = day + sec/86400._r8
483 : end do
484 :
485 : !
486 : ! Initialize history variables
487 : !
488 9984 : do t=1,ptapes
489 1122816 : do fld=1,nflds(t)
490 1112832 : if ((.not. tape(t)%hlist(fld)%field%sampled_on_subcycle) .and. nhtfrq(t) == 1) then
491 : ! Override accumulate flag to "I" if nhtfrq equals 1 and subcycle
492 : ! averaging is not enabled
493 0 : tape(t)%hlist(fld)%avgflag = 'I'
494 : end if
495 :
496 1112832 : if (tape(t)%hlist(fld)%avgflag .ne. 'I') then
497 953856 : hfile_accum(t) = .true.
498 : end if
499 1112832 : begdim1 = tape(t)%hlist(fld)%field%begdim1
500 1112832 : enddim1 = tape(t)%hlist(fld)%field%enddim1
501 1112832 : begdim2 = tape(t)%hlist(fld)%field%begdim2
502 1112832 : enddim2 = tape(t)%hlist(fld)%field%enddim2
503 1112832 : begdim3 = tape(t)%hlist(fld)%field%begdim3
504 1112832 : enddim3 = tape(t)%hlist(fld)%field%enddim3
505 5564160 : allocate(tape(t)%hlist(fld)%hbuf(begdim1:enddim1,begdim2:enddim2,begdim3:enddim3))
506 3552148224 : tape(t)%hlist(fld)%hbuf = 0._r8
507 1112832 : if (tape(t)%hlist(fld)%avgflag .eq. 'S') then ! allocate the variance buffer for standard dev
508 0 : allocate(tape(t)%hlist(fld)%sbuf(begdim1:enddim1,begdim2:enddim2,begdim3:enddim3))
509 0 : tape(t)%hlist(fld)%sbuf = 0._r8
510 : endif
511 1112832 : if (tape(t)%hlist(fld)%avgflag .eq. 'N') then ! set up areawt weight buffer
512 0 : fdecomp = tape(t)%hlist(fld)%field%decomp_type
513 0 : if (any(allgrids_wt(:)%decomp_type == fdecomp)) then
514 0 : wtidx=MAXLOC(allgrids_wt(:)%decomp_type, MASK = allgrids_wt(:)%decomp_type .EQ. fdecomp)
515 0 : tape(t)%hlist(fld)%wbuf => allgrids_wt(wtidx(1))%wbuf
516 : else
517 : ! area weights not found for this grid, then create them
518 : ! first check for an available spot in the array
519 0 : if (any(allgrids_wt(:)%decomp_type == -1)) then
520 0 : wtidx=MINLOC(allgrids_wt(:)%decomp_type)
521 : else
522 0 : call endrun('cam_history:intht: Error initializing allgrids_wt with area weights')
523 : end if
524 0 : allgrids_wt(wtidx)%decomp_type=fdecomp
525 0 : areawt => cam_grid_get_areawt(fdecomp)
526 0 : allocate(allgrids_wt(wtidx(1))%wbuf(begdim1:enddim1,begdim3:enddim3))
527 0 : allgrids_wt(wtidx(1))%wbuf(begdim1:enddim1,begdim3:enddim3)=0._r8
528 0 : count=0
529 0 : do c=begdim3,enddim3
530 0 : dimind = tape(t)%hlist(fld)%field%get_dims(c)
531 0 : ib=dimind%beg1
532 0 : ie=dimind%end1
533 0 : do i=ib,ie
534 0 : count=count+1
535 0 : allgrids_wt(wtidx(1))%wbuf(i,c)=areawt(count)
536 : end do
537 : end do
538 0 : tape(t)%hlist(fld)%wbuf => allgrids_wt(wtidx(1))%wbuf
539 : endif
540 : endif
541 1112832 : if(tape(t)%hlist(fld)%field%flag_xyfill .or. (avgflag_pertape(t) .eq. 'L')) then
542 141312 : allocate (tape(t)%hlist(fld)%nacs(begdim1:enddim1,begdim3:enddim3))
543 : else
544 3232512 : allocate (tape(t)%hlist(fld)%nacs(1,begdim3:enddim3))
545 : end if
546 14211840 : tape(t)%hlist(fld)%nacs(:,:) = 0
547 1112832 : tape(t)%hlist(fld)%beg_nstep = 0
548 1112832 : tape(t)%hlist(fld)%field%meridional_complement = -1
549 1122048 : tape(t)%hlist(fld)%field%zonal_complement = -1
550 : end do
551 : end do
552 : ! Setup vector pairs for unstructured grid interpolation
553 768 : call setup_interpolation_and_define_vector_complements()
554 : ! Initialize the sat following history subsystem
555 768 : call sat_hist_init()
556 :
557 768 : return
558 3072 : end subroutine intht
559 :
560 1536 : logical function history_initialized()
561 1536 : history_initialized = associated(masterlist)
562 1536 : end function history_initialized
563 :
564 1536 : subroutine history_readnl(nlfile)
565 :
566 : use namelist_utils, only: find_group_name
567 : use units, only: getunit, freeunit
568 : use spmd_utils, only: masterproc, masterprocid, mpicom
569 : use spmd_utils, only: mpi_integer, mpi_logical, mpi_character
570 : use shr_string_mod, only: shr_string_toUpper
571 : use time_manager, only: get_step_size
572 : use sat_hist, only: sat_hist_readnl
573 :
574 : ! Dummy argument
575 : character(len=*), intent(in) :: nlfile ! filepath of namelist input file
576 :
577 : !
578 : ! Local variables
579 : integer :: dtime ! Step time in seconds
580 : integer :: unitn, ierr, f, t
581 : character(len=8) :: ctemp ! Temporary character string
582 : integer :: filename_len
583 :
584 : character(len=fieldname_lenp2) :: fincl1(pflds)
585 : character(len=fieldname_lenp2) :: fincl2(pflds)
586 : character(len=fieldname_lenp2) :: fincl3(pflds)
587 : character(len=fieldname_lenp2) :: fincl4(pflds)
588 : character(len=fieldname_lenp2) :: fincl5(pflds)
589 : character(len=fieldname_lenp2) :: fincl6(pflds)
590 : character(len=fieldname_lenp2) :: fincl7(pflds)
591 : character(len=fieldname_lenp2) :: fincl8(pflds)
592 : character(len=fieldname_lenp2) :: fincl9(pflds)
593 : character(len=fieldname_lenp2) :: fincl10(pflds)
594 :
595 : character(len=max_chars) :: fincl1lonlat(pflds)
596 : character(len=max_chars) :: fincl2lonlat(pflds)
597 : character(len=max_chars) :: fincl3lonlat(pflds)
598 : character(len=max_chars) :: fincl4lonlat(pflds)
599 : character(len=max_chars) :: fincl5lonlat(pflds)
600 : character(len=max_chars) :: fincl6lonlat(pflds)
601 : character(len=max_chars) :: fincl7lonlat(pflds)
602 : character(len=max_chars) :: fincl8lonlat(pflds)
603 : character(len=max_chars) :: fincl9lonlat(pflds)
604 : character(len=max_chars) :: fincl10lonlat(pflds)
605 :
606 : character(len=fieldname_len) :: fexcl1(pflds)
607 : character(len=fieldname_len) :: fexcl2(pflds)
608 : character(len=fieldname_len) :: fexcl3(pflds)
609 : character(len=fieldname_len) :: fexcl4(pflds)
610 : character(len=fieldname_len) :: fexcl5(pflds)
611 : character(len=fieldname_len) :: fexcl6(pflds)
612 : character(len=fieldname_len) :: fexcl7(pflds)
613 : character(len=fieldname_len) :: fexcl8(pflds)
614 : character(len=fieldname_len) :: fexcl9(pflds)
615 : character(len=fieldname_len) :: fexcl10(pflds)
616 :
617 : character(len=fieldname_lenp2) :: fwrtpr1(pflds)
618 : character(len=fieldname_lenp2) :: fwrtpr2(pflds)
619 : character(len=fieldname_lenp2) :: fwrtpr3(pflds)
620 : character(len=fieldname_lenp2) :: fwrtpr4(pflds)
621 : character(len=fieldname_lenp2) :: fwrtpr5(pflds)
622 : character(len=fieldname_lenp2) :: fwrtpr6(pflds)
623 : character(len=fieldname_lenp2) :: fwrtpr7(pflds)
624 : character(len=fieldname_lenp2) :: fwrtpr8(pflds)
625 : character(len=fieldname_lenp2) :: fwrtpr9(pflds)
626 : character(len=fieldname_lenp2) :: fwrtpr10(pflds)
627 :
628 : integer :: interpolate_nlat(size(interpolate_info))
629 : integer :: interpolate_nlon(size(interpolate_info))
630 : integer :: interpolate_gridtype(size(interpolate_info))
631 : integer :: interpolate_type(size(interpolate_info))
632 :
633 : ! History namelist items
634 : namelist /cam_history_nl/ ndens, nhtfrq, mfilt, inithist, inithist_all, &
635 : avgflag_pertape, empty_htapes, write_nstep0, lcltod_start, lcltod_stop,&
636 : fincl1lonlat, fincl2lonlat, fincl3lonlat, fincl4lonlat, fincl5lonlat, &
637 : fincl6lonlat, fincl7lonlat, fincl8lonlat, fincl9lonlat, &
638 : fincl10lonlat, collect_column_output, hfilename_spec, &
639 : fincl1, fincl2, fincl3, fincl4, fincl5, &
640 : fincl6, fincl7, fincl8, fincl9, fincl10, &
641 : fexcl1, fexcl2, fexcl3, fexcl4, fexcl5, &
642 : fexcl6, fexcl7, fexcl8, fexcl9, fexcl10, &
643 : fwrtpr1, fwrtpr2, fwrtpr3, fwrtpr4, fwrtpr5, &
644 : fwrtpr6, fwrtpr7, fwrtpr8, fwrtpr9, fwrtpr10, &
645 : interpolate_nlat, interpolate_nlon, &
646 : interpolate_gridtype, interpolate_type, interpolate_output
647 :
648 : ! Set namelist defaults (these should match initial values if given)
649 18451968 : fincl(:,:) = ' '
650 18451968 : fincllonlat(:,:) = ' '
651 18451968 : fexcl(:,:) = ' '
652 18451968 : fwrtpr(:,:) = ' '
653 1536 : collect_column_output(:) = .false.
654 19968 : avgflag_pertape(:) = ' '
655 19968 : ndens = 2
656 1536 : nhtfrq(1) = 0
657 18432 : nhtfrq(2:) = -24
658 19968 : mfilt = 30
659 1536 : inithist = 'YEARLY'
660 1536 : inithist_all = .false.
661 1536 : empty_htapes = .false.
662 1536 : lcltod_start(:) = 0
663 1536 : lcltod_stop(:) = 0
664 19968 : hfilename_spec(:) = ' '
665 1536 : interpolate_nlat(:) = 0
666 1536 : interpolate_nlon(:) = 0
667 16896 : interpolate_gridtype(:) = 1
668 16896 : interpolate_type(:) = 1
669 1536 : interpolate_output(:) = .false.
670 :
671 : ! Initialize namelist 'temporary variables'
672 1537536 : do f = 1, pflds
673 1536000 : fincl1(f) = ' '
674 1536000 : fincl2(f) = ' '
675 1536000 : fincl3(f) = ' '
676 1536000 : fincl4(f) = ' '
677 1536000 : fincl5(f) = ' '
678 1536000 : fincl6(f) = ' '
679 1536000 : fincl7(f) = ' '
680 1536000 : fincl8(f) = ' '
681 1536000 : fincl9(f) = ' '
682 1536000 : fincl10(f) = ' '
683 1536000 : fincl1lonlat(f) = ' '
684 1536000 : fincl2lonlat(f) = ' '
685 1536000 : fincl3lonlat(f) = ' '
686 1536000 : fincl4lonlat(f) = ' '
687 1536000 : fincl5lonlat(f) = ' '
688 1536000 : fincl6lonlat(f) = ' '
689 1536000 : fincl7lonlat(f) = ' '
690 1536000 : fincl8lonlat(f) = ' '
691 1536000 : fincl9lonlat(f) = ' '
692 1536000 : fincl10lonlat(f) = ' '
693 1536000 : fexcl1(f) = ' '
694 1536000 : fexcl2(f) = ' '
695 1536000 : fexcl3(f) = ' '
696 1536000 : fexcl4(f) = ' '
697 1536000 : fexcl5(f) = ' '
698 1536000 : fexcl6(f) = ' '
699 1536000 : fexcl7(f) = ' '
700 1536000 : fexcl8(f) = ' '
701 1536000 : fexcl9(f) = ' '
702 1536000 : fexcl10(f) = ' '
703 1536000 : fwrtpr1(f) = ' '
704 1536000 : fwrtpr2(f) = ' '
705 1536000 : fwrtpr3(f) = ' '
706 1536000 : fwrtpr4(f) = ' '
707 1536000 : fwrtpr5(f) = ' '
708 1536000 : fwrtpr6(f) = ' '
709 1536000 : fwrtpr7(f) = ' '
710 1536000 : fwrtpr8(f) = ' '
711 1536000 : fwrtpr9(f) = ' '
712 1537536 : fwrtpr10(f) = ' '
713 : end do
714 :
715 : if (trim(history_namelist) /= 'cam_history_nl') then
716 : call endrun('HISTORY_READNL: CAM history namelist mismatch')
717 : end if
718 1536 : if (masterproc) then
719 2 : write(iulog, *) 'Read in ',history_namelist,' namelist from: ',trim(nlfile)
720 2 : unitn = getunit()
721 2 : open(unitn, file=trim(nlfile), status='old')
722 2 : call find_group_name(unitn, history_namelist, status=ierr)
723 2 : if (ierr == 0) then
724 2 : read(unitn, cam_history_nl, iostat=ierr)
725 2 : if (ierr /= 0) then
726 0 : call endrun('history_readnl: ERROR reading namelist, '//trim(history_namelist))
727 : end if
728 : end if
729 2 : close(unitn)
730 2 : call freeunit(unitn)
731 :
732 2002 : do f = 1, pflds
733 2000 : fincl(f, 1) = fincl1(f)
734 2000 : fincl(f, 2) = fincl2(f)
735 2000 : fincl(f, 3) = fincl3(f)
736 2000 : fincl(f, 4) = fincl4(f)
737 2000 : fincl(f, 5) = fincl5(f)
738 2000 : fincl(f, 6) = fincl6(f)
739 2000 : fincl(f, 7) = fincl7(f)
740 2000 : fincl(f, 8) = fincl8(f)
741 2000 : fincl(f, 9) = fincl9(f)
742 2000 : fincl(f,10) = fincl10(f)
743 :
744 2000 : fincllonlat(f, 1) = fincl1lonlat(f)
745 2000 : fincllonlat(f, 2) = fincl2lonlat(f)
746 2000 : fincllonlat(f, 3) = fincl3lonlat(f)
747 2000 : fincllonlat(f, 4) = fincl4lonlat(f)
748 2000 : fincllonlat(f, 5) = fincl5lonlat(f)
749 2000 : fincllonlat(f, 6) = fincl6lonlat(f)
750 2000 : fincllonlat(f, 7) = fincl7lonlat(f)
751 2000 : fincllonlat(f, 8) = fincl8lonlat(f)
752 2000 : fincllonlat(f, 9) = fincl9lonlat(f)
753 2000 : fincllonlat(f,10) = fincl10lonlat(f)
754 :
755 2000 : fexcl(f, 1) = fexcl1(f)
756 2000 : fexcl(f, 2) = fexcl2(f)
757 2000 : fexcl(f, 3) = fexcl3(f)
758 2000 : fexcl(f, 4) = fexcl4(f)
759 2000 : fexcl(f, 5) = fexcl5(f)
760 2000 : fexcl(f, 6) = fexcl6(f)
761 2000 : fexcl(f, 7) = fexcl7(f)
762 2000 : fexcl(f, 8) = fexcl8(f)
763 2000 : fexcl(f, 9) = fexcl9(f)
764 2000 : fexcl(f,10) = fexcl10(f)
765 :
766 2000 : fwrtpr(f, 1) = fwrtpr1(f)
767 2000 : fwrtpr(f, 2) = fwrtpr2(f)
768 2000 : fwrtpr(f, 3) = fwrtpr3(f)
769 2000 : fwrtpr(f, 4) = fwrtpr4(f)
770 2000 : fwrtpr(f, 5) = fwrtpr5(f)
771 2000 : fwrtpr(f, 6) = fwrtpr6(f)
772 2000 : fwrtpr(f, 7) = fwrtpr7(f)
773 2000 : fwrtpr(f, 8) = fwrtpr8(f)
774 2000 : fwrtpr(f, 9) = fwrtpr9(f)
775 2002 : fwrtpr(f,10) = fwrtpr10(f)
776 : end do
777 :
778 : !
779 : ! If generate an initial conditions history file as an auxillary tape:
780 : !
781 2 : ctemp = shr_string_toUpper(inithist)
782 2 : inithist = trim(ctemp)
783 : if ( (inithist /= '6-HOURLY') .and. (inithist /= 'DAILY') .and. &
784 : (inithist /= 'MONTHLY') .and. (inithist /= 'YEARLY') .and. &
785 2 : (inithist /= 'CAMIOP') .and. (inithist /= 'ENDOFRUN')) then
786 0 : inithist = 'NONE'
787 : end if
788 : !
789 : ! History file write times
790 : ! Convert write freq. of hist files from hours to timesteps if necessary.
791 : !
792 2 : dtime = get_step_size()
793 26 : do t = 1, ptapes
794 26 : if (nhtfrq(t) < 0) then
795 22 : nhtfrq(t) = nint((-nhtfrq(t) * 3600._r8) / dtime)
796 : end if
797 : end do
798 : ! If nhtfrq == 1, then the output is instantaneous. Enforce this by setting
799 : ! the per-file averaging flag.
800 26 : do t = 1, ptapes
801 26 : if (nhtfrq(t) == 1) then
802 0 : avgflag_pertape(t) = 'I'
803 : end if
804 : end do
805 : !
806 : ! Initialize the filename specifier if not already set
807 : ! This is the format for the history filenames:
808 : ! %c= caseid, %t=tape no., %y=year, %m=month, %d=day, %s=second, %%=%
809 : ! See the filenames module for more information
810 : !
811 26 : do t = 1, ptapes
812 24 : if ( len_trim(hfilename_spec(t)) == 0 )then
813 24 : if ( nhtfrq(t) == 0 )then
814 : ! Monthly files
815 0 : hfilename_spec(t) = '%c.cam' // trim(inst_suffix) // '.h%t%f.%y-%m.nc'
816 0 : default_monthly_filename(t) = .true.
817 : else
818 24 : hfilename_spec(t) = '%c.cam' // trim(inst_suffix) // '.h%t%f.%y-%m-%d-%s.nc'
819 : end if
820 : else
821 : ! Append file type - instantaneous or accumulated - to filename
822 : ! specifier provided (in front of the .nc extension).
823 0 : filename_len = len_trim(hfilename_spec(t))
824 0 : hfilename_spec(t) = hfilename_spec(t)(:filename_len-3) // '%f.nc'
825 : end if
826 : !
827 : ! Only one time sample allowed per monthly average file
828 : !
829 26 : if (nhtfrq(t) == 0) then
830 0 : mfilt(t) = 1
831 : end if
832 : end do
833 : end if ! masterproc
834 :
835 : ! log output
836 1536 : if (masterproc) then
837 :
838 2 : if (write_nstep0) then
839 0 : write(iulog,*)'nstep==0 time sample will be written to all files except monthly average.'
840 : end if
841 :
842 : ! Print per-tape averaging flags
843 26 : do t = 1, ptapes
844 24 : if (avgflag_pertape(t) /= ' ') then
845 18 : write(iulog,*)'Unless overridden by namelist input on a per-field basis (FINCL),'
846 18 : write(iulog,*)'All fields on history file ',t,' will have averaging flag ',avgflag_pertape(t)
847 : end if
848 : ! Enforce no interpolation for satellite files
849 24 : if (is_satfile(t) .and. interpolate_output(t)) then
850 0 : write(iulog, *) 'WARNING: Interpolated output not supported for a satellite history file, ignored'
851 0 : interpolate_output(t) = .false.
852 : end if
853 : ! Enforce no interpolation for IC files
854 26 : if (is_initfile(t) .and. interpolate_output(t)) then
855 0 : write(iulog, *) 'WARNING: Interpolated output not supported for an initial data (IC) history file, ignored'
856 0 : interpolate_output(t) = .false.
857 : end if
858 : end do
859 : end if
860 :
861 : ! Print out column-output information
862 19968 : do t = 1, size(fincllonlat, 2)
863 18451968 : if (ANY(len_trim(fincllonlat(:,t)) > 0)) then
864 0 : if (collect_column_output(t)) then
865 0 : write(iulog, '(a,i2,a)') 'History file, ',t,', has patch output, columns will be collected into ncol dimension'
866 : else
867 0 : write(iulog, '(a,i2,a)') 'History file, ',t,', has patch output, patches will be written to individual variables'
868 : end if
869 : end if
870 : end do
871 :
872 : ! Broadcast namelist variables
873 1536 : call mpi_bcast(ndens, ptapes, mpi_integer, masterprocid, mpicom, ierr)
874 1536 : call mpi_bcast(nhtfrq, ptapes, mpi_integer, masterprocid, mpicom, ierr)
875 1536 : call mpi_bcast(mfilt, ptapes, mpi_integer, masterprocid, mpicom, ierr)
876 1536 : call mpi_bcast(inithist,len(inithist), mpi_character, masterprocid, mpicom, ierr)
877 1536 : call mpi_bcast(inithist_all,1, mpi_logical, masterprocid, mpicom, ierr)
878 1536 : call mpi_bcast(lcltod_start, ptapes, mpi_integer, masterprocid, mpicom, ierr)
879 1536 : call mpi_bcast(lcltod_stop, ptapes, mpi_integer, masterprocid, mpicom, ierr)
880 1536 : call mpi_bcast(collect_column_output, ptapes, mpi_logical, masterprocid, mpicom, ierr)
881 1536 : call mpi_bcast(empty_htapes,1, mpi_logical, masterprocid, mpicom, ierr)
882 1536 : call mpi_bcast(write_nstep0,1, mpi_logical, masterprocid, mpicom, ierr)
883 1536 : call mpi_bcast(avgflag_pertape, ptapes, mpi_character, masterprocid, mpicom, ierr)
884 1536 : call mpi_bcast(hfilename_spec, len(hfilename_spec(1))*ptapes, mpi_character, masterprocid, mpicom, ierr)
885 1536 : call mpi_bcast(default_monthly_filename, ptapes, mpi_logical, masterprocid, mpicom, ierr)
886 1536 : call mpi_bcast(fincl, len(fincl (1,1))*pflds*ptapes, mpi_character, masterprocid, mpicom, ierr)
887 1536 : call mpi_bcast(fexcl, len(fexcl (1,1))*pflds*ptapes, mpi_character, masterprocid, mpicom, ierr)
888 :
889 1536 : call mpi_bcast(fincllonlat, len(fincllonlat (1,1))*pflds*ptapes, mpi_character, masterprocid, mpicom, ierr)
890 :
891 1536 : call mpi_bcast(fwrtpr, len(fwrtpr(1,1))*pflds*ptapes, mpi_character, masterprocid, mpicom, ierr)
892 1536 : t = size(interpolate_nlat, 1)
893 1536 : call mpi_bcast(interpolate_nlat, t, mpi_integer, masterprocid, mpicom, ierr)
894 1536 : call mpi_bcast(interpolate_nlon, t, mpi_integer, masterprocid, mpicom, ierr)
895 1536 : call mpi_bcast(interpolate_gridtype, t, mpi_integer, masterprocid, mpicom, ierr)
896 1536 : call mpi_bcast(interpolate_type, t, mpi_integer, masterprocid, mpicom, ierr)
897 1536 : call mpi_bcast(interpolate_output, ptapes, mpi_logical, masterprocid, mpicom, ierr)
898 :
899 : ! Setup the interpolate_info structures
900 16896 : do t = 1, size(interpolate_info)
901 15360 : interpolate_info(t)%interp_type = interpolate_type(t)
902 15360 : interpolate_info(t)%interp_gridtype = interpolate_gridtype(t)
903 15360 : interpolate_info(t)%interp_nlat = interpolate_nlat(t)
904 16896 : interpolate_info(t)%interp_nlon = interpolate_nlon(t)
905 : end do
906 :
907 : ! Write out inithist info
908 1536 : if (masterproc) then
909 2 : if (inithist == '6-HOURLY' ) then
910 0 : write(iulog,*)'Initial conditions history files will be written 6-hourly.'
911 2 : else if (inithist == 'DAILY' ) then
912 0 : write(iulog,*)'Initial conditions history files will be written daily.'
913 2 : else if (inithist == 'MONTHLY' ) then
914 0 : write(iulog,*)'Initial conditions history files will be written monthly.'
915 2 : else if (inithist == 'YEARLY' ) then
916 2 : write(iulog,*)'Initial conditions history files will be written yearly.'
917 0 : else if (inithist == 'CAMIOP' ) then
918 0 : write(iulog,*)'Initial conditions history files will be written for IOP.'
919 0 : else if (inithist == 'ENDOFRUN' ) then
920 0 : write(iulog,*)'Initial conditions history files will be written at end of run.'
921 : else
922 0 : write(iulog,*)'Initial conditions history files will not be created'
923 : end if
924 : end if
925 1536 : if (inithist == 'CAMIOP') then
926 0 : write_camiop=.true.
927 : end if
928 : ! separate namelist reader for the satellite history file
929 1536 : call sat_hist_readnl(nlfile, hfilename_spec, mfilt, fincl, nhtfrq, avgflag_pertape)
930 :
931 1536 : end subroutine history_readnl
932 :
933 : !==================================================================================================
934 :
935 13685760 : subroutine set_field_dimensions(field)
936 1536 : use cam_history_support, only: hist_coord_size
937 : use cam_grid_support, only: cam_grid_get_array_bounds, cam_grid_is_block_indexed
938 : ! Dummy arguments
939 : type(field_info), intent(inout) :: field
940 :
941 : ! Local variables
942 : integer :: i
943 : integer :: msize
944 : integer :: dimbounds(2,2)
945 :
946 13685760 : call cam_grid_get_array_bounds(field%decomp_type, dimbounds)
947 13685760 : field%begdim1 = dimbounds(1,1)
948 13685760 : field%enddim1 = dimbounds(1,2)
949 13685760 : field%begdim2 = 1
950 13685760 : if (associated(field%mdims)) then
951 13135104 : if (size(field%mdims) > 0) then
952 8679168 : field%enddim2 = 1
953 17358336 : do i = 1, size(field%mdims)
954 8679168 : msize = hist_coord_size(field%mdims(i))
955 8679168 : if (msize <= 0) then
956 0 : call endrun('set_field_dimensions: mdim size must be > 0')
957 : end if
958 17358336 : field%enddim2 = field%enddim2 * msize
959 : end do
960 : else
961 4455936 : if (field%numlev < 1) then
962 0 : if (masterproc) then
963 0 : write(iulog, *) 'SET_FIELD_DIMENSIONS WARNING: illegal numlev for ', trim(field%name)
964 : end if
965 0 : field%numlev = 1
966 : end if
967 4455936 : field%enddim2 = field%numlev
968 : end if
969 : else
970 550656 : if (field%numlev < 1) then
971 0 : if (masterproc) then
972 0 : write(iulog, *) 'SET_FIELD_DIMENSIONS WARNING: illegal numlev for ', trim(field%name)
973 : end if
974 0 : field%numlev = 1
975 : end if
976 550656 : field%enddim2 = field%numlev
977 : end if
978 13685760 : field%begdim3 = dimbounds(2,1)
979 13685760 : field%enddim3 = dimbounds(2,2)
980 13685760 : field%colperchunk = cam_grid_is_block_indexed(field%decomp_type)
981 :
982 13685760 : end subroutine set_field_dimensions
983 :
984 1536 : subroutine setup_interpolation_and_define_vector_complements()
985 13685760 : use interp_mod, only: setup_history_interpolation
986 :
987 : ! Local variables
988 : integer :: hf, fld, ffld
989 : logical :: interp_ok
990 : character(len=max_fieldname_len) :: mname
991 : character(len=max_fieldname_len) :: zname
992 : character(len=*), parameter :: subname='setup_interpolation_and_define_vector_complements'
993 :
994 : ! Do not interpolate IC history and sat hist files
995 19968 : if (any(interpolate_output)) then
996 : call setup_history_interpolation(interp_ok, ptapes-2, &
997 0 : interpolate_output, interpolate_info)
998 0 : do hf = 1, ptapes - 2
999 0 : if((.not. is_satfile(hf)) .and. (.not. is_initfile(hf))) then
1000 0 : do fld = 1, nflds(hf)
1001 0 : if (field_part_of_vector(trim(tape(hf)%hlist(fld)%field%name), &
1002 0 : mname, zname)) then
1003 0 : if (len_trim(mname) > 0) then
1004 : ! This field is a zonal part of a set, find the meridional partner
1005 0 : do ffld = 1, nflds(hf)
1006 0 : if (trim(mname) == trim(tape(hf)%hlist(ffld)%field%name)) then
1007 0 : tape(hf)%hlist(fld)%field%meridional_complement = ffld
1008 0 : tape(hf)%hlist(ffld)%field%zonal_complement = fld
1009 0 : exit
1010 : end if
1011 0 : if (ffld == nflds(hf)) then
1012 0 : call endrun(trim(subname)//': No meridional match for '//trim(tape(hf)%hlist(fld)%field%name))
1013 : end if
1014 : end do
1015 0 : else if (len_trim(zname) > 0) then
1016 : ! This field is a meridional part of a set, find the zonal partner
1017 0 : do ffld = 1, nflds(hf)
1018 0 : if (trim(zname) == trim(tape(hf)%hlist(ffld)%field%name)) then
1019 0 : tape(hf)%hlist(fld)%field%zonal_complement = ffld
1020 0 : tape(hf)%hlist(ffld)%field%meridional_complement = fld
1021 0 : exit
1022 : end if
1023 0 : if (ffld == nflds(hf)) then
1024 0 : call endrun(trim(subname)//': No zonal match for '//trim(tape(hf)%hlist(fld)%field%name))
1025 : end if
1026 : end do
1027 : else
1028 0 : call endrun(trim(subname)//': INTERNAL ERROR, bad vector field')
1029 : end if
1030 : end if
1031 : end do
1032 : end if
1033 : end do
1034 : end if
1035 1536 : end subroutine setup_interpolation_and_define_vector_complements
1036 :
1037 9216 : subroutine define_composed_field_ids(t)
1038 :
1039 : ! Dummy arguments
1040 : integer, intent(in) :: t ! Current tape
1041 :
1042 : ! Local variables
1043 : integer :: fld, ffld
1044 : character(len=max_fieldname_len) :: field1
1045 : character(len=max_fieldname_len) :: field2
1046 : character(len=*), parameter :: subname='define_composed_field_ids'
1047 : logical :: is_composed
1048 :
1049 1122048 : do fld = 1, nflds(t)
1050 1112832 : call composed_field_info(tape(t)%hlist(fld)%field%name,is_composed,fname1=field1,fname2=field2)
1051 1122048 : if (is_composed) then
1052 0 : if (len_trim(field1) > 0 .and. len_trim(field2) > 0) then
1053 : ! set field1/field2 names for htape from the masterfield list
1054 0 : tape(t)%hlist(fld)%op_field1=trim(field1)
1055 0 : tape(t)%hlist(fld)%op_field2=trim(field2)
1056 : ! find ids for field1/2
1057 0 : do ffld = 1, nflds(t)
1058 0 : if (trim(field1) == trim(tape(t)%hlist(ffld)%field%name)) then
1059 0 : tape(t)%hlist(fld)%field%op_field1_id = ffld
1060 : end if
1061 0 : if (trim(field2) == trim(tape(t)%hlist(ffld)%field%name)) then
1062 0 : tape(t)%hlist(fld)%field%op_field2_id = ffld
1063 : end if
1064 : end do
1065 0 : if (tape(t)%hlist(fld)%field%op_field1_id == -1) then
1066 0 : call endrun(trim(subname)//': No op_field1 match for '//trim(tape(t)%hlist(fld)%field%name))
1067 : end if
1068 0 : if (tape(t)%hlist(fld)%field%op_field2_id == -1) then
1069 0 : call endrun(trim(subname)//': No op_field2 match for '//trim(tape(t)%hlist(fld)%field%name))
1070 : end if
1071 : else
1072 0 : call endrun(trim(subname)//': Component fields not found for composed field')
1073 : end if
1074 : end if
1075 : end do
1076 9216 : end subroutine define_composed_field_ids
1077 :
1078 1536 : subroutine restart_vars_setnames()
1079 :
1080 : ! Local variable
1081 : integer :: rvindex
1082 :
1083 1536 : rvindex = 1
1084 1536 : restartvars(rvindex)%name = 'rgnht'
1085 1536 : restartvars(rvindex)%type = pio_int
1086 1536 : restartvars(rvindex)%ndims = 1
1087 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1088 :
1089 1536 : rvindex = rvindex + 1
1090 1536 : restartvars(rvindex)%name = 'nhtfrq'
1091 1536 : restartvars(rvindex)%type = pio_int
1092 1536 : restartvars(rvindex)%ndims = 1
1093 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1094 :
1095 1536 : rvindex = rvindex + 1
1096 1536 : restartvars(rvindex)%name = 'nflds'
1097 1536 : restartvars(rvindex)%type = pio_int
1098 1536 : restartvars(rvindex)%ndims = 1
1099 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1100 :
1101 1536 : rvindex = rvindex + 1
1102 1536 : restartvars(rvindex)%name = 'nfils'
1103 1536 : restartvars(rvindex)%type = pio_int
1104 1536 : restartvars(rvindex)%ndims = 1
1105 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1106 :
1107 1536 : rvindex = rvindex + 1
1108 1536 : restartvars(rvindex)%name = 'mfilt'
1109 1536 : restartvars(rvindex)%type = pio_int
1110 1536 : restartvars(rvindex)%ndims = 1
1111 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1112 :
1113 1536 : rvindex = rvindex + 1
1114 1536 : restartvars(rvindex)%name = 'nfpath'
1115 1536 : restartvars(rvindex)%type = pio_char
1116 1536 : restartvars(rvindex)%ndims = 2
1117 1536 : restartvars(rvindex)%dims(1) = max_string_len_dim_ind
1118 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1119 :
1120 1536 : rvindex = rvindex + 1
1121 1536 : restartvars(rvindex)%name = 'cpath'
1122 1536 : restartvars(rvindex)%type = pio_char
1123 1536 : restartvars(rvindex)%ndims = 3
1124 1536 : restartvars(rvindex)%dims(1) = max_string_len_dim_ind
1125 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1126 1536 : restartvars(rvindex)%dims(3) = max_num_split_files
1127 :
1128 1536 : rvindex = rvindex + 1
1129 1536 : restartvars(rvindex)%name = 'nhfil'
1130 1536 : restartvars(rvindex)%type = pio_char
1131 1536 : restartvars(rvindex)%ndims = 3
1132 1536 : restartvars(rvindex)%dims(1) = max_string_len_dim_ind
1133 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1134 1536 : restartvars(rvindex)%dims(3) = max_num_split_files
1135 :
1136 1536 : rvindex = rvindex + 1
1137 1536 : restartvars(rvindex)%name = 'ndens'
1138 1536 : restartvars(rvindex)%type = pio_int
1139 1536 : restartvars(rvindex)%ndims = 1
1140 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1141 :
1142 1536 : rvindex = rvindex + 1
1143 1536 : restartvars(rvindex)%name = 'fincllonlat'
1144 1536 : restartvars(rvindex)%type = pio_char
1145 1536 : restartvars(rvindex)%ndims = 3
1146 1536 : restartvars(rvindex)%dims(1) = max_chars_dim_ind
1147 1536 : restartvars(rvindex)%dims(2) = pflds_dim_ind
1148 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1149 :
1150 1536 : rvindex = rvindex + 1
1151 1536 : restartvars(rvindex)%name = 'ncprec'
1152 1536 : restartvars(rvindex)%type = pio_int
1153 1536 : restartvars(rvindex)%ndims = 1
1154 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1155 :
1156 1536 : rvindex = rvindex + 1
1157 1536 : restartvars(rvindex)%name = 'beg_time'
1158 1536 : restartvars(rvindex)%type = pio_double
1159 1536 : restartvars(rvindex)%ndims = 1
1160 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1161 :
1162 1536 : rvindex = rvindex + 1
1163 1536 : restartvars(rvindex)%name = 'fincl'
1164 1536 : restartvars(rvindex)%type = pio_char
1165 1536 : restartvars(rvindex)%ndims = 3
1166 1536 : restartvars(rvindex)%dims(1) = fieldname_lenp2_dim_ind
1167 1536 : restartvars(rvindex)%dims(2) = pflds_dim_ind
1168 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1169 :
1170 1536 : rvindex = rvindex + 1
1171 1536 : restartvars(rvindex)%name = 'fexcl'
1172 1536 : restartvars(rvindex)%type = pio_char
1173 1536 : restartvars(rvindex)%ndims = 3
1174 1536 : restartvars(rvindex)%dims(1) = fieldname_lenp2_dim_ind
1175 1536 : restartvars(rvindex)%dims(2) = pflds_dim_ind
1176 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1177 :
1178 1536 : rvindex = rvindex + 1
1179 1536 : restartvars(rvindex)%name = 'field_name'
1180 1536 : restartvars(rvindex)%type = pio_char
1181 1536 : restartvars(rvindex)%ndims = 3
1182 1536 : restartvars(rvindex)%dims(1) = max_fieldname_len_dim_ind
1183 1536 : restartvars(rvindex)%dims(2) = maxnflds_dim_ind
1184 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1185 :
1186 1536 : rvindex = rvindex + 1
1187 1536 : restartvars(rvindex)%name = 'decomp_type'
1188 1536 : restartvars(rvindex)%type = pio_int
1189 1536 : restartvars(rvindex)%ndims = 2
1190 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1191 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1192 1536 : restartvars(rvindex)%fillset = .true.
1193 1536 : restartvars(rvindex)%ifill = 0
1194 :
1195 1536 : rvindex = rvindex + 1
1196 1536 : restartvars(rvindex)%name = 'numlev'
1197 1536 : restartvars(rvindex)%type = pio_int
1198 1536 : restartvars(rvindex)%ndims = 2
1199 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1200 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1201 1536 : restartvars(rvindex)%fillset = .true.
1202 1536 : restartvars(rvindex)%ifill = 0
1203 :
1204 1536 : rvindex = rvindex + 1
1205 1536 : restartvars(rvindex)%name = 'hrestpath'
1206 1536 : restartvars(rvindex)%type = pio_char
1207 1536 : restartvars(rvindex)%ndims = 2
1208 1536 : restartvars(rvindex)%dims(1) = max_string_len_dim_ind
1209 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1210 :
1211 1536 : rvindex = rvindex + 1
1212 1536 : restartvars(rvindex)%name = 'hwrt_prec'
1213 1536 : restartvars(rvindex)%type = pio_int
1214 1536 : restartvars(rvindex)%ndims = 2
1215 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1216 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1217 1536 : restartvars(rvindex)%fillset = .true.
1218 1536 : restartvars(rvindex)%ifill = 0
1219 :
1220 1536 : rvindex = rvindex + 1
1221 1536 : restartvars(rvindex)%name = 'beg_nstep'
1222 1536 : restartvars(rvindex)%type = pio_int
1223 1536 : restartvars(rvindex)%ndims = 2
1224 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1225 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1226 1536 : restartvars(rvindex)%fillset = .true.
1227 1536 : restartvars(rvindex)%ifill = 0
1228 :
1229 1536 : rvindex = rvindex + 1
1230 1536 : restartvars(rvindex)%name = 'hbuf_integral'
1231 1536 : restartvars(rvindex)%type = pio_double
1232 1536 : restartvars(rvindex)%ndims = 2
1233 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1234 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1235 1536 : restartvars(rvindex)%fillset = .true.
1236 1536 : restartvars(rvindex)%ifill = 0
1237 :
1238 :
1239 1536 : rvindex = rvindex + 1
1240 1536 : restartvars(rvindex)%name = 'avgflag'
1241 1536 : restartvars(rvindex)%type = pio_char
1242 1536 : restartvars(rvindex)%ndims = 2
1243 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1244 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1245 :
1246 1536 : rvindex = rvindex + 1
1247 1536 : restartvars(rvindex)%name = 'sampling_seq'
1248 1536 : restartvars(rvindex)%type = pio_char
1249 1536 : restartvars(rvindex)%ndims = 3
1250 1536 : restartvars(rvindex)%dims(1) = max_chars_dim_ind
1251 1536 : restartvars(rvindex)%dims(2) = maxnflds_dim_ind
1252 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1253 :
1254 1536 : rvindex = rvindex + 1
1255 1536 : restartvars(rvindex)%name = 'cell_methods'
1256 1536 : restartvars(rvindex)%type = pio_char
1257 1536 : restartvars(rvindex)%ndims = 3
1258 1536 : restartvars(rvindex)%dims(1) = max_chars_dim_ind
1259 1536 : restartvars(rvindex)%dims(2) = maxnflds_dim_ind
1260 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1261 :
1262 1536 : rvindex = rvindex + 1
1263 1536 : restartvars(rvindex)%name = 'long_name'
1264 1536 : restartvars(rvindex)%type = pio_char
1265 1536 : restartvars(rvindex)%ndims = 3
1266 1536 : restartvars(rvindex)%dims(1) = max_chars_dim_ind
1267 1536 : restartvars(rvindex)%dims(2) = maxnflds_dim_ind
1268 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1269 :
1270 1536 : rvindex = rvindex + 1
1271 1536 : restartvars(rvindex)%name = 'units'
1272 1536 : restartvars(rvindex)%type = pio_char
1273 1536 : restartvars(rvindex)%ndims = 3
1274 1536 : restartvars(rvindex)%dims(1) = max_chars_dim_ind
1275 1536 : restartvars(rvindex)%dims(2) = maxnflds_dim_ind
1276 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1277 :
1278 1536 : rvindex = rvindex + 1
1279 1536 : restartvars(rvindex)%name = 'xyfill'
1280 1536 : restartvars(rvindex)%type = pio_int
1281 1536 : restartvars(rvindex)%ndims = 2
1282 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1283 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1284 :
1285 1536 : rvindex = rvindex + 1
1286 1536 : restartvars(rvindex)%name = 'lcltod_start'
1287 1536 : restartvars(rvindex)%type = pio_int
1288 1536 : restartvars(rvindex)%ndims = 1
1289 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1290 :
1291 1536 : rvindex = rvindex + 1
1292 1536 : restartvars(rvindex)%name = 'lcltod_stop'
1293 1536 : restartvars(rvindex)%type = pio_int
1294 1536 : restartvars(rvindex)%ndims = 1
1295 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1296 :
1297 1536 : rvindex = rvindex + 1
1298 1536 : restartvars(rvindex)%name = 'fillvalue'
1299 1536 : restartvars(rvindex)%type = pio_double
1300 1536 : restartvars(rvindex)%ndims = 2
1301 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1302 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1303 1536 : restartvars(rvindex)%fillset = .true.
1304 1536 : restartvars(rvindex)%dfill = 0.0_r8
1305 :
1306 :
1307 1536 : rvindex = rvindex + 1
1308 1536 : restartvars(rvindex)%name = 'mdims'
1309 1536 : restartvars(rvindex)%type = pio_int
1310 1536 : restartvars(rvindex)%ndims = 3
1311 1536 : restartvars(rvindex)%dims(1) = maxvarmdims_dim_ind
1312 1536 : restartvars(rvindex)%dims(2) = maxnflds_dim_ind
1313 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1314 1536 : restartvars(rvindex)%fillset = .true.
1315 1536 : restartvars(rvindex)%ifill = 0
1316 :
1317 1536 : rvindex = rvindex + 1
1318 1536 : restartvars(rvindex)%name = 'mdimnames'
1319 1536 : restartvars(rvindex)%type = pio_char
1320 1536 : restartvars(rvindex)%ndims = 2
1321 1536 : restartvars(rvindex)%dims(1) = max_hcoordname_len_dim_ind
1322 1536 : restartvars(rvindex)%dims(2) = registeredmdims_dim_ind
1323 :
1324 1536 : rvindex = rvindex + 1
1325 1536 : restartvars(rvindex)%name = 'is_subcol'
1326 1536 : restartvars(rvindex)%type = pio_int
1327 1536 : restartvars(rvindex)%ndims = 2
1328 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1329 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1330 :
1331 1536 : rvindex = rvindex + 1
1332 1536 : restartvars(rvindex)%name = 'interpolate_output'
1333 1536 : restartvars(rvindex)%type = pio_int
1334 1536 : restartvars(rvindex)%ndims = 1
1335 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1336 :
1337 1536 : rvindex = rvindex + 1
1338 1536 : restartvars(rvindex)%name = 'interpolate_type'
1339 1536 : restartvars(rvindex)%type = pio_int
1340 1536 : restartvars(rvindex)%ndims = 1
1341 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1342 :
1343 1536 : rvindex = rvindex + 1
1344 1536 : restartvars(rvindex)%name = 'interpolate_gridtype'
1345 1536 : restartvars(rvindex)%type = pio_int
1346 1536 : restartvars(rvindex)%ndims = 1
1347 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1348 :
1349 1536 : rvindex = rvindex + 1
1350 1536 : restartvars(rvindex)%name = 'interpolate_nlat'
1351 1536 : restartvars(rvindex)%type = pio_int
1352 1536 : restartvars(rvindex)%ndims = 1
1353 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1354 :
1355 1536 : rvindex = rvindex + 1
1356 1536 : restartvars(rvindex)%name = 'interpolate_nlon'
1357 1536 : restartvars(rvindex)%type = pio_int
1358 1536 : restartvars(rvindex)%ndims = 1
1359 1536 : restartvars(rvindex)%dims(1) = ptapes_dim_ind
1360 :
1361 1536 : rvindex = rvindex + 1
1362 1536 : restartvars(rvindex)%name = 'meridional_complement'
1363 1536 : restartvars(rvindex)%type = pio_int
1364 1536 : restartvars(rvindex)%ndims = 2
1365 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1366 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1367 1536 : restartvars(rvindex)%fillset = .true.
1368 1536 : restartvars(rvindex)%ifill = 0
1369 :
1370 1536 : rvindex = rvindex + 1
1371 1536 : restartvars(rvindex)%name = 'zonal_complement'
1372 1536 : restartvars(rvindex)%type = pio_int
1373 1536 : restartvars(rvindex)%ndims = 2
1374 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1375 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1376 1536 : restartvars(rvindex)%fillset = .true.
1377 1536 : restartvars(rvindex)%ifill = 0
1378 :
1379 1536 : rvindex = rvindex + 1
1380 1536 : restartvars(rvindex)%name = 'field_op'
1381 1536 : restartvars(rvindex)%type = pio_char
1382 1536 : restartvars(rvindex)%ndims = 3
1383 1536 : restartvars(rvindex)%dims(1) = max_chars_dim_ind
1384 1536 : restartvars(rvindex)%dims(2) = maxnflds_dim_ind
1385 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1386 :
1387 1536 : rvindex = rvindex + 1
1388 1536 : restartvars(rvindex)%name = 'op_field1_id'
1389 1536 : restartvars(rvindex)%type = pio_int
1390 1536 : restartvars(rvindex)%ndims = 2
1391 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1392 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1393 1536 : restartvars(rvindex)%fillset = .true.
1394 1536 : restartvars(rvindex)%ifill = 0
1395 :
1396 1536 : rvindex = rvindex + 1
1397 1536 : restartvars(rvindex)%name = 'op_field2_id'
1398 1536 : restartvars(rvindex)%type = pio_int
1399 1536 : restartvars(rvindex)%ndims = 2
1400 1536 : restartvars(rvindex)%dims(1) = maxnflds_dim_ind
1401 1536 : restartvars(rvindex)%dims(2) = ptapes_dim_ind
1402 1536 : restartvars(rvindex)%fillset = .true.
1403 1536 : restartvars(rvindex)%ifill = 0
1404 :
1405 1536 : rvindex = rvindex + 1
1406 1536 : restartvars(rvindex)%name = 'op_field1'
1407 1536 : restartvars(rvindex)%type = pio_char
1408 1536 : restartvars(rvindex)%ndims = 3
1409 1536 : restartvars(rvindex)%dims(1) = max_fieldname_len_dim_ind
1410 1536 : restartvars(rvindex)%dims(2) = maxnflds_dim_ind
1411 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1412 :
1413 1536 : rvindex = rvindex + 1
1414 1536 : restartvars(rvindex)%name = 'op_field2'
1415 1536 : restartvars(rvindex)%type = pio_char
1416 1536 : restartvars(rvindex)%ndims = 3
1417 1536 : restartvars(rvindex)%dims(1) = max_fieldname_len_dim_ind
1418 1536 : restartvars(rvindex)%dims(2) = maxnflds_dim_ind
1419 1536 : restartvars(rvindex)%dims(3) = ptapes_dim_ind
1420 :
1421 1536 : end subroutine restart_vars_setnames
1422 :
1423 1536 : subroutine restart_dims_setnames()
1424 : use cam_grid_support, only: max_hcoordname_len
1425 : use cam_history_support, only: registeredmdims
1426 :
1427 1536 : restartdims(ptapes_dim_ind)%name = 'ptapes'
1428 1536 : restartdims(ptapes_dim_ind)%len = ptapes
1429 :
1430 1536 : restartdims(max_string_len_dim_ind)%name = 'max_string_len'
1431 1536 : restartdims(max_string_len_dim_ind)%len = max_string_len
1432 :
1433 1536 : restartdims(fieldname_lenp2_dim_ind)%name = 'fieldname_lenp2'
1434 1536 : restartdims(fieldname_lenp2_dim_ind)%len = fieldname_lenp2
1435 :
1436 1536 : restartdims(pflds_dim_ind)%name = 'pflds'
1437 1536 : restartdims(pflds_dim_ind)%len = pflds
1438 :
1439 1536 : restartdims(max_chars_dim_ind)%name = 'max_chars'
1440 1536 : restartdims(max_chars_dim_ind)%len = max_chars
1441 :
1442 1536 : restartdims(max_fieldname_len_dim_ind)%name = 'max_fieldname_len'
1443 1536 : restartdims(max_fieldname_len_dim_ind)%len = max_fieldname_len
1444 :
1445 1536 : restartdims(maxnflds_dim_ind)%name = 'maxnflds'
1446 19968 : restartdims(maxnflds_dim_ind)%len = maxval(nflds)
1447 :
1448 1536 : restartdims(maxvarmdims_dim_ind)%name = 'maxvarmdims'
1449 1536 : restartdims(maxvarmdims_dim_ind)%len = maxvarmdims
1450 :
1451 1536 : restartdims(registeredmdims_dim_ind)%name = 'registeredmdims'
1452 1536 : restartdims(registeredmdims_dim_ind)%len = registeredmdims
1453 :
1454 1536 : restartdims(max_hcoordname_len_dim_ind)%name = 'max_hcoordname_len'
1455 1536 : restartdims(max_hcoordname_len_dim_ind)%len = max_hcoordname_len
1456 :
1457 1536 : restartdims(max_num_split_files)%name = 'max_num_split_files'
1458 1536 : restartdims(max_num_split_files)%len = maxsplitfiles
1459 :
1460 1536 : end subroutine restart_dims_setnames
1461 :
1462 :
1463 1536 : subroutine init_restart_history (File)
1464 1536 : use cam_pio_utils, only: cam_pio_def_dim
1465 : use cam_pio_utils, only: cam_pio_handle_error
1466 :
1467 : !---------------------------------------------------------------------------
1468 : !
1469 : ! Arguments
1470 : !
1471 : type(file_desc_t), intent(inout) :: File ! Pio file Handle
1472 : !
1473 : ! Local
1474 : !
1475 : integer :: dimids(4), ndims
1476 : integer :: ierr, i, k
1477 :
1478 : ! Don't need to write restart data if we have written the file this step
1479 19968 : where (hstwr(:))
1480 : rgnht(:) = .false.
1481 : elsewhere
1482 : rgnht(:) = .true.
1483 : end where
1484 :
1485 19968 : if(maxval(nflds)>0) then
1486 1536 : call restart_vars_setnames()
1487 1536 : call restart_dims_setnames()
1488 :
1489 18432 : do i=1,restartdimcnt
1490 : ! it's possible that one or more of these have been defined elsewhere
1491 16896 : call cam_pio_def_dim(File, restartdims(i)%name, restartdims(i)%len, &
1492 35328 : restartdims(i)%dimid, existOK=.true.)
1493 : end do
1494 :
1495 70656 : do i = 1, restartvarcnt
1496 69120 : ndims = restartvars(i)%ndims
1497 205824 : do k = 1 ,ndims
1498 205824 : dimids(k) = restartdims(restartvars(i)%dims(k))%dimid
1499 : end do
1500 69120 : allocate(restartvars(i)%vdesc)
1501 69120 : ierr = pio_def_var(File, restartvars(i)%name, restartvars(i)%type, dimids(1:ndims), restartvars(i)%vdesc)
1502 69120 : call cam_pio_handle_error(ierr, 'INIT_RESTART_HISTORY: Error defining '//trim(restartvars(i)%name))
1503 70656 : if(restartvars(i)%fillset) then
1504 16896 : if(restartvars(i)%type == PIO_INT) then
1505 : ierr = pio_put_att(File, restartvars(i)%vdesc, "_FillValue", &
1506 13824 : restartvars(i)%ifill)
1507 3072 : else if(restartvars(i)%type == PIO_REAL) then
1508 : ierr = pio_put_att(File, restartvars(i)%vdesc, "_FillValue", &
1509 0 : restartvars(i)%rfill)
1510 3072 : else if(restartvars(i)%type == PIO_DOUBLE) then
1511 : ierr = pio_put_att(File, restartvars(i)%vdesc, "_FillValue", &
1512 3072 : restartvars(i)%dfill)
1513 : end if
1514 16896 : call cam_pio_handle_error(ierr, 'INIT_RESTART_HISTORY: Error setting fill'//trim(restartvars(i)%name))
1515 : end if
1516 : end do
1517 : end if
1518 1536 : end subroutine init_restart_history
1519 :
1520 69120 : function restartvar_getdesc(name) result(vdesc)
1521 : character(len=*), intent(in) :: name
1522 : type(var_desc_t), pointer :: vdesc
1523 : character(len=max_chars) :: errmsg
1524 : integer :: i
1525 :
1526 69120 : nullify(vdesc)
1527 1589760 : do i=1,restartvarcnt
1528 1589760 : if(name .eq. restartvars(i)%name) then
1529 69120 : vdesc=>restartvars(i)%vdesc
1530 69120 : exit
1531 : end if
1532 : end do
1533 69120 : if(.not.associated(vdesc)) then
1534 0 : errmsg = 'Could not find restart variable '//name
1535 0 : call endrun(errmsg)
1536 : end if
1537 1536 : end function restartvar_getdesc
1538 :
1539 :
1540 : !#######################################################################
1541 :
1542 1536 : subroutine write_restart_history ( File, &
1543 : yr_spec, mon_spec, day_spec, sec_spec )
1544 : use cam_history_support, only: hist_coord_name, registeredmdims
1545 :
1546 : implicit none
1547 : !--------------------------------------------------------------------------------------------------
1548 : !
1549 : ! Arguments
1550 : !
1551 : type(file_desc_t), intent(inout) :: file ! PIO restart file pointer
1552 : integer, intent(in), optional :: yr_spec ! Simulation year
1553 : integer, intent(in), optional :: mon_spec ! Simulation month
1554 : integer, intent(in), optional :: day_spec ! Simulation day
1555 : integer, intent(in), optional :: sec_spec ! Seconds into current simulation day
1556 : !
1557 : ! Local workspace
1558 : !
1559 : integer :: ierr, t, fld
1560 : integer :: rgnht_int(ptapes), start(2), startc(3)
1561 : type(var_desc_t), pointer :: vdesc
1562 :
1563 : ! PIO variable descriptors
1564 : type(var_desc_t), pointer :: field_name_desc ! Restart field names
1565 : type(var_desc_t), pointer :: decomp_type_desc
1566 : type(var_desc_t), pointer :: numlev_desc
1567 : type(var_desc_t), pointer :: avgflag_desc
1568 : type(var_desc_t), pointer :: sseq_desc
1569 : type(var_desc_t), pointer :: cm_desc
1570 : type(var_desc_t), pointer :: longname_desc
1571 : type(var_desc_t), pointer :: units_desc
1572 : type(var_desc_t), pointer :: hwrt_prec_desc
1573 : type(var_desc_t), pointer :: hbuf_integral_desc
1574 : type(var_desc_t), pointer :: beg_nstep_desc
1575 : type(var_desc_t), pointer :: xyfill_desc
1576 : type(var_desc_t), pointer :: mdims_desc ! mdim name indices
1577 : type(var_desc_t), pointer :: mdimname_desc ! mdim names
1578 : type(var_desc_t), pointer :: issubcol_desc
1579 : type(var_desc_t), pointer :: fillval_desc
1580 : type(var_desc_t), pointer :: interpolate_output_desc
1581 : type(var_desc_t), pointer :: interpolate_type_desc
1582 : type(var_desc_t), pointer :: interpolate_gridtype_desc
1583 : type(var_desc_t), pointer :: interpolate_nlat_desc
1584 : type(var_desc_t), pointer :: interpolate_nlon_desc
1585 : type(var_desc_t), pointer :: meridional_complement_desc
1586 : type(var_desc_t), pointer :: zonal_complement_desc
1587 : type(var_desc_t), pointer :: field_op_desc
1588 : type(var_desc_t), pointer :: op_field1_id_desc
1589 : type(var_desc_t), pointer :: op_field2_id_desc
1590 : type(var_desc_t), pointer :: op_field1_desc
1591 : type(var_desc_t), pointer :: op_field2_desc
1592 :
1593 1536 : integer, allocatable :: allmdims(:,:,:)
1594 1536 : integer, allocatable :: xyfill(:,:)
1595 1536 : integer, allocatable :: is_subcol(:,:)
1596 1536 : integer, allocatable :: interp_output(:)
1597 :
1598 : integer :: maxnflds
1599 : real(r8) :: integral ! hbuf area weighted integral
1600 :
1601 19968 : maxnflds = maxval(nflds)
1602 4608 : allocate(xyfill(maxnflds, ptapes))
1603 20700672 : xyfill = 0
1604 3072 : allocate(is_subcol(maxnflds, ptapes))
1605 20700672 : is_subcol = 0
1606 1536 : allocate(interp_output(ptapes))
1607 19968 : interp_output = 0
1608 :
1609 : !
1610 : !-----------------------------------------------------------------------
1611 : ! Write the history restart data if necessary
1612 : !-----------------------------------------------------------------------
1613 :
1614 1536 : rgnht_int(:) = 0
1615 :
1616 23040 : if(.not.allocated(restarthistory_tape)) allocate(restarthistory_tape(ptapes))
1617 :
1618 19968 : do t=1,ptapes
1619 : ! No need to write history IC restart because it is always instantaneous
1620 18432 : if (is_initfile(file_index=t)) rgnht(t) = .false.
1621 : ! No need to write restart data for empty files
1622 18432 : if (nflds(t) == 0) rgnht(t) = .false.
1623 19968 : if(rgnht(t)) then
1624 4608 : rgnht_int(t) = 1
1625 4608 : restarthistory_tape(t)%hlist => history_tape(t)%hlist
1626 :
1627 4608 : if(associated(history_tape(t)%grid_ids)) then
1628 4608 : restarthistory_tape(t)%grid_ids => history_tape(t)%grid_ids
1629 : end if
1630 4608 : if(associated(history_tape(t)%patches)) then
1631 0 : restarthistory_tape(t)%patches => history_tape(t)%patches
1632 : end if
1633 : end if
1634 : end do
1635 :
1636 19968 : if(maxval(nflds)<=0) return
1637 :
1638 1536 : call wshist(rgnht)
1639 :
1640 1536 : vdesc => restartvar_getdesc('fincl')
1641 1536 : ierr= pio_put_var(File, vdesc, fincl(:,1:ptapes))
1642 :
1643 1536 : vdesc => restartvar_getdesc('fincllonlat')
1644 1536 : ierr= pio_put_var(File, vdesc, fincllonlat(:,1:ptapes))
1645 :
1646 1536 : vdesc => restartvar_getdesc('fexcl')
1647 1536 : ierr= pio_put_var(File, vdesc, fexcl(:,1:ptapes))
1648 :
1649 1536 : vdesc => restartvar_getdesc('rgnht')
1650 1536 : ierr= pio_put_var(File, vdesc, rgnht_int(1:ptapes))
1651 :
1652 1536 : vdesc => restartvar_getdesc('nhtfrq')
1653 1536 : ierr= pio_put_var(File, vdesc, nhtfrq(1:ptapes))
1654 :
1655 1536 : vdesc => restartvar_getdesc('nflds')
1656 1536 : ierr= pio_put_var(File, vdesc, nflds(1:ptapes))
1657 :
1658 1536 : vdesc => restartvar_getdesc('nfils')
1659 1536 : ierr= pio_put_var(File, vdesc, nfils(1:ptapes))
1660 :
1661 1536 : vdesc => restartvar_getdesc('mfilt')
1662 1536 : ierr= pio_put_var(File, vdesc, mfilt(1:ptapes))
1663 :
1664 1536 : vdesc => restartvar_getdesc('nfpath')
1665 1536 : ierr= pio_put_var(File, vdesc, nfpath(1:ptapes))
1666 :
1667 1536 : vdesc => restartvar_getdesc('cpath')
1668 1536 : ierr= pio_put_var(File, vdesc, cpath(1:ptapes,:))
1669 :
1670 1536 : vdesc => restartvar_getdesc('nhfil')
1671 1536 : ierr= pio_put_var(File, vdesc, nhfil(1:ptapes,:))
1672 :
1673 1536 : vdesc => restartvar_getdesc('ndens')
1674 1536 : ierr= pio_put_var(File, vdesc, ndens(1:ptapes))
1675 1536 : vdesc => restartvar_getdesc('ncprec')
1676 1536 : ierr= pio_put_var(File, vdesc, ncprec(1:ptapes))
1677 1536 : vdesc => restartvar_getdesc('beg_time')
1678 1536 : ierr= pio_put_var(File, vdesc, beg_time(1:ptapes))
1679 :
1680 1536 : vdesc => restartvar_getdesc('hrestpath')
1681 1536 : ierr = pio_put_var(File, vdesc, hrestpath(1:ptapes))
1682 :
1683 1536 : vdesc => restartvar_getdesc('lcltod_start')
1684 1536 : ierr = pio_put_var(File, vdesc, lcltod_start(1:ptapes))
1685 :
1686 1536 : vdesc => restartvar_getdesc('lcltod_stop')
1687 1536 : ierr = pio_put_var(File, vdesc, lcltod_stop(1:ptapes))
1688 :
1689 1536 : field_name_desc => restartvar_getdesc('field_name')
1690 1536 : decomp_type_desc => restartvar_getdesc('decomp_type')
1691 1536 : numlev_desc => restartvar_getdesc('numlev')
1692 1536 : hwrt_prec_desc => restartvar_getdesc('hwrt_prec')
1693 1536 : hbuf_integral_desc => restartvar_getdesc('hbuf_integral')
1694 1536 : beg_nstep_desc => restartvar_getdesc('beg_nstep')
1695 :
1696 1536 : sseq_desc => restartvar_getdesc('sampling_seq')
1697 1536 : cm_desc => restartvar_getdesc('cell_methods')
1698 1536 : longname_desc => restartvar_getdesc('long_name')
1699 1536 : units_desc => restartvar_getdesc('units')
1700 1536 : avgflag_desc => restartvar_getdesc('avgflag')
1701 1536 : xyfill_desc => restartvar_getdesc('xyfill')
1702 1536 : issubcol_desc => restartvar_getdesc('is_subcol')
1703 :
1704 1536 : interpolate_output_desc => restartvar_getdesc('interpolate_output')
1705 1536 : interpolate_type_desc => restartvar_getdesc('interpolate_type')
1706 1536 : interpolate_gridtype_desc => restartvar_getdesc('interpolate_gridtype')
1707 1536 : interpolate_nlat_desc => restartvar_getdesc('interpolate_nlat')
1708 1536 : interpolate_nlon_desc => restartvar_getdesc('interpolate_nlon')
1709 :
1710 1536 : meridional_complement_desc => restartvar_getdesc('meridional_complement')
1711 1536 : zonal_complement_desc => restartvar_getdesc('zonal_complement')
1712 :
1713 1536 : field_op_desc => restartvar_getdesc('field_op')
1714 1536 : op_field1_id_desc => restartvar_getdesc('op_field1_id')
1715 1536 : op_field2_id_desc => restartvar_getdesc('op_field2_id')
1716 1536 : op_field1_desc => restartvar_getdesc('op_field1')
1717 1536 : op_field2_desc => restartvar_getdesc('op_field2')
1718 :
1719 1536 : mdims_desc => restartvar_getdesc('mdims')
1720 1536 : mdimname_desc => restartvar_getdesc('mdimnames')
1721 1536 : fillval_desc => restartvar_getdesc('fillvalue')
1722 :
1723 1536 : tape=>history_tape
1724 :
1725 : ! allmdims specifies the mdim indices for each field
1726 26112 : allocate(allmdims(maxvarmdims,maxval(nflds),ptapes))
1727 41381376 : allmdims=-1
1728 :
1729 1536 : startc(1)=1
1730 19968 : do t = 1,ptapes
1731 18432 : start(2)=t
1732 18432 : startc(3)=t
1733 2244096 : do fld=1,nflds(t)
1734 2225664 : start(1)=fld
1735 2225664 : startc(2)=fld
1736 2225664 : ierr = pio_put_var(File, field_name_desc,startc,tape(t)%hlist(fld)%field%name)
1737 2225664 : ierr = pio_put_var(File, decomp_type_desc,start,tape(t)%hlist(fld)%field%decomp_type)
1738 2225664 : ierr = pio_put_var(File, numlev_desc,start,tape(t)%hlist(fld)%field%numlev)
1739 :
1740 2225664 : ierr = pio_put_var(File, hwrt_prec_desc,start,tape(t)%hlist(fld)%hwrt_prec)
1741 2225664 : call tape(t)%hlist(fld)%get_global(integral)
1742 2225664 : ierr = pio_put_var(File, hbuf_integral_desc,start,integral)
1743 2225664 : ierr = pio_put_var(File, beg_nstep_desc,start,tape(t)%hlist(fld)%beg_nstep)
1744 2225664 : ierr = pio_put_var(File, sseq_desc,startc,tape(t)%hlist(fld)%field%sampling_seq)
1745 2225664 : ierr = pio_put_var(File, cm_desc,startc,tape(t)%hlist(fld)%field%cell_methods)
1746 2225664 : ierr = pio_put_var(File, longname_desc,startc,tape(t)%hlist(fld)%field%long_name)
1747 2225664 : ierr = pio_put_var(File, units_desc,startc,tape(t)%hlist(fld)%field%units)
1748 2225664 : ierr = pio_put_var(File, avgflag_desc,start, tape(t)%hlist(fld)%avgflag)
1749 :
1750 2225664 : ierr = pio_put_var(File, fillval_desc,start, tape(t)%hlist(fld)%field%fillvalue)
1751 2225664 : ierr = pio_put_var(File, meridional_complement_desc,start, tape(t)%hlist(fld)%field%meridional_complement)
1752 2225664 : ierr = pio_put_var(File, zonal_complement_desc,start, tape(t)%hlist(fld)%field%zonal_complement)
1753 2225664 : ierr = pio_put_var(File, field_op_desc,startc, tape(t)%hlist(fld)%field%field_op)
1754 2225664 : ierr = pio_put_var(File, op_field1_id_desc,start, tape(t)%hlist(fld)%field%op_field1_id)
1755 2225664 : ierr = pio_put_var(File, op_field2_id_desc,start, tape(t)%hlist(fld)%field%op_field2_id)
1756 2225664 : ierr = pio_put_var(File, op_field1_desc,startc, tape(t)%hlist(fld)%op_field1)
1757 2225664 : ierr = pio_put_var(File, op_field2_desc,startc, tape(t)%hlist(fld)%op_field2)
1758 2225664 : if(associated(tape(t)%hlist(fld)%field%mdims)) then
1759 2958336 : allmdims(1:size(tape(t)%hlist(fld)%field%mdims),fld,t) = tape(t)%hlist(fld)%field%mdims
1760 : else
1761 : end if
1762 2225664 : if(tape(t)%hlist(fld)%field%flag_xyfill) then
1763 70656 : xyfill(fld,t) = 1
1764 : end if
1765 2244096 : if(tape(t)%hlist(fld)%field%is_subcol) then
1766 0 : is_subcol(fld,t) = 1
1767 : end if
1768 : end do
1769 19968 : if (interpolate_output(t)) then
1770 0 : interp_output(t) = 1
1771 : end if
1772 : end do
1773 1536 : ierr = pio_put_var(File, xyfill_desc, xyfill)
1774 1536 : ierr = pio_put_var(File, mdims_desc, allmdims)
1775 1536 : ierr = pio_put_var(File, issubcol_desc, is_subcol)
1776 : !! Interpolated output variables
1777 1536 : ierr = pio_put_var(File, interpolate_output_desc, interp_output)
1778 19968 : interp_output = 1
1779 16896 : do t = 1, size(interpolate_info)
1780 16896 : interp_output(t) = interpolate_info(t)%interp_type
1781 : end do
1782 1536 : ierr = pio_put_var(File, interpolate_type_desc, interp_output)
1783 19968 : interp_output = 1
1784 16896 : do t = 1, size(interpolate_info)
1785 16896 : interp_output(t) = interpolate_info(t)%interp_gridtype
1786 : end do
1787 1536 : ierr = pio_put_var(File, interpolate_gridtype_desc, interp_output)
1788 19968 : interp_output = 0
1789 16896 : do t = 1, size(interpolate_info)
1790 16896 : interp_output(t) = interpolate_info(t)%interp_nlat
1791 : end do
1792 1536 : ierr = pio_put_var(File, interpolate_nlat_desc, interp_output)
1793 19968 : interp_output = 0
1794 16896 : do t = 1, size(interpolate_info)
1795 16896 : interp_output(t) = interpolate_info(t)%interp_nlon
1796 : end do
1797 1536 : ierr = pio_put_var(File, interpolate_nlon_desc, interp_output)
1798 : ! Registered history coordinates
1799 1536 : start(1) = 1
1800 7680 : do fld = 1, registeredmdims
1801 6144 : start(2) = fld
1802 7680 : ierr = pio_put_var(File, mdimname_desc, start, hist_coord_name(fld))
1803 : end do
1804 :
1805 1536 : deallocate(xyfill, allmdims, is_subcol, interp_output, restarthistory_tape)
1806 :
1807 1536 : end subroutine write_restart_history
1808 :
1809 :
1810 : !#######################################################################
1811 :
1812 768 : subroutine read_restart_history (File)
1813 1536 : use pio, only: pio_inq_dimid
1814 : use pio, only: pio_inq_varid, pio_inq_dimname
1815 : use cam_pio_utils, only: cam_pio_openfile, cam_pio_closefile
1816 : use cam_pio_utils, only: cam_pio_var_info
1817 : use ioFileMod, only: getfil
1818 : use sat_hist, only: sat_hist_define, sat_hist_init
1819 : use cam_grid_support, only: cam_grid_read_dist_array, cam_grid_num_grids
1820 : use cam_history_support, only: get_hist_coord_index, add_hist_coord, dim_index_2d
1821 : use constituents, only: cnst_get_ind, cnst_get_type_byind
1822 : use cam_grid_support, only: cam_grid_get_areawt
1823 :
1824 : use shr_sys_mod, only: shr_sys_getenv
1825 : use spmd_utils, only: mpicom, mpi_character, masterprocid
1826 : use time_manager, only: get_nstep
1827 : !
1828 : !-----------------------------------------------------------------------
1829 : !
1830 : ! Arguments
1831 : !
1832 : type(file_desc_t), intent(inout) :: File ! unit number
1833 : !
1834 : ! Local workspace
1835 : !
1836 : integer t, f, fld, ffld ! tape, file, field indices
1837 : integer begdim2 ! on-node vert start index
1838 : integer enddim2 ! on-node vert end index
1839 : integer begdim1 ! on-node dim1 start index
1840 : integer enddim1 ! on-node dim1 end index
1841 : integer begdim3 ! on-node chunk or lat start index
1842 : integer enddim3 ! on-node chunk or lat end index
1843 :
1844 :
1845 : integer rgnht_int(ptapes)
1846 : integer :: ierr
1847 :
1848 : character(len=max_string_len) :: locfn ! Local filename
1849 768 : character(len=max_fieldname_len), allocatable :: tmpname(:,:)
1850 768 : character(len=max_fieldname_len), allocatable :: tmpf1name(:,:)
1851 768 : character(len=max_fieldname_len), allocatable :: tmpf2name(:,:)
1852 768 : integer, allocatable :: decomp(:,:), tmpnumlev(:,:)
1853 768 : integer, pointer :: nacs(:,:) ! outfld accumulation counter
1854 : integer :: beg_nstep ! start timestep of this slice for nstep accumulation counter
1855 : character(len=max_fieldname_len) :: fname_tmp ! local copy of field name
1856 : character(len=max_fieldname_len) :: dname_tmp ! local copy of dim name
1857 :
1858 : integer :: i, ptapes_dimid
1859 :
1860 : type(var_desc_t) :: vdesc
1861 : type(var_desc_t) :: longname_desc
1862 : type(var_desc_t) :: units_desc
1863 : type(var_desc_t) :: avgflag_desc
1864 : type(var_desc_t) :: sseq_desc
1865 : type(var_desc_t) :: cm_desc
1866 : type(var_desc_t) :: fillval_desc
1867 : type(var_desc_t) :: meridional_complement_desc
1868 : type(var_desc_t) :: zonal_complement_desc
1869 : type(var_desc_t) :: field_op_desc
1870 : type(var_desc_t) :: op_field1_id_desc
1871 : type(var_desc_t) :: op_field2_id_desc
1872 : type(var_desc_t) :: op_field1_desc
1873 : type(var_desc_t) :: op_field2_desc
1874 : type(dim_index_2d) :: dimind ! 2-D dimension index
1875 768 : integer, allocatable :: tmpprec(:,:)
1876 768 : real(r8), allocatable :: tmpintegral(:,:)
1877 768 : integer, allocatable :: tmpbeg_nstep(:,:)
1878 768 : integer, allocatable :: xyfill(:,:)
1879 768 : integer, allocatable :: allmdims(:,:,:)
1880 768 : integer, allocatable :: is_subcol(:,:)
1881 768 : integer, allocatable :: interp_output(:)
1882 : integer :: nacsdimcnt, nacsval
1883 : integer :: maxnflds, dimid
1884 :
1885 : ! List of active grids (first dim) for each tape (second dim)
1886 : ! An active grid is one for which there is a least one field being output
1887 : ! on that grid.
1888 768 : integer, allocatable :: gridsontape(:,:)
1889 :
1890 768 : character(len=16), allocatable :: mdimnames(:) ! Names of all hist coords (inc. vertical)
1891 : integer :: ndims, dimids(8)
1892 : integer :: tmpdims(8), dimcnt
1893 : integer :: dimlens(7)
1894 : integer :: mtapes, mdimcnt
1895 : integer :: fdims(3) ! Field dims
1896 : integer :: nfdims ! 2 or 3 (for 2D,3D)
1897 : integer :: fdecomp ! Grid ID for field
1898 : integer :: idx
1899 : character(len=3) :: mixing_ratio
1900 : integer :: c,ib,ie,jb,je,k,cnt,wtidx(1)
1901 768 : real(r8), pointer :: areawt(:) ! pointer to areawt values for attribute
1902 :
1903 : !
1904 : ! Get users logname and machine hostname
1905 : !
1906 770 : if ( masterproc )then
1907 1 : logname = ' '
1908 1 : call shr_sys_getenv ('LOGNAME',logname,ierr)
1909 1 : host = ' '
1910 1 : call shr_sys_getenv ('HOST',host,ierr)
1911 : end if
1912 : ! PIO requires netcdf attributes have consistant values on all tasks
1913 768 : call mpi_bcast(logname, len(logname), mpi_character, masterprocid, mpicom, ierr)
1914 768 : call mpi_bcast(host, len(host), mpi_character, masterprocid, mpicom, ierr)
1915 :
1916 768 : call pio_seterrorhandling(File, PIO_BCAST_ERROR)
1917 :
1918 768 : ierr = pio_inq_dimid(File, 'ptapes', ptapes_dimid)
1919 768 : if(ierr/= PIO_NOERR) then
1920 0 : if(masterproc) write(iulog,*) 'Not reading history info from restart file', ierr
1921 0 : return ! no history info in restart file
1922 : end if
1923 768 : call pio_seterrorhandling(File, PIO_INTERNAL_ERROR)
1924 :
1925 768 : ierr = pio_inq_dimlen(File, ptapes_dimid, mtapes)
1926 :
1927 768 : ierr = pio_inq_dimid(File, 'maxnflds', dimid)
1928 768 : ierr = pio_inq_dimlen(File, dimid, maxnflds)
1929 :
1930 768 : ierr = pio_inq_dimid(File, 'maxvarmdims', dimid)
1931 768 : ierr = pio_inq_dimlen(File, dimid, maxvarmdims)
1932 :
1933 768 : ierr = pio_inq_varid(File, 'rgnht', vdesc)
1934 768 : ierr = pio_get_var(File, vdesc, rgnht_int(1:mtapes))
1935 :
1936 768 : ierr = pio_inq_varid(File, 'nhtfrq', vdesc)
1937 768 : ierr = pio_get_var(File, vdesc, nhtfrq(1:mtapes))
1938 :
1939 768 : ierr = pio_inq_varid(File, 'nflds', vdesc)
1940 768 : ierr = pio_get_var(File, vdesc, nflds(1:mtapes))
1941 768 : ierr = pio_inq_varid(File, 'nfils', vdesc)
1942 768 : ierr = pio_get_var(File, vdesc, nfils(1:mtapes))
1943 768 : ierr = pio_inq_varid(File, 'mfilt', vdesc)
1944 768 : ierr = pio_get_var(File, vdesc, mfilt(1:mtapes))
1945 :
1946 768 : ierr = pio_inq_varid(File, 'nfpath', vdesc)
1947 768 : ierr = pio_get_var(File, vdesc, nfpath(1:mtapes))
1948 768 : ierr = pio_inq_varid(File, 'cpath', vdesc)
1949 768 : ierr = pio_get_var(File, vdesc, cpath(1:mtapes,:))
1950 768 : ierr = pio_inq_varid(File, 'nhfil', vdesc)
1951 768 : ierr = pio_get_var(File, vdesc, nhfil(1:mtapes,:))
1952 768 : ierr = pio_inq_varid(File, 'hrestpath', vdesc)
1953 768 : ierr = pio_get_var(File, vdesc, hrestpath(1:mtapes))
1954 :
1955 :
1956 768 : ierr = pio_inq_varid(File, 'ndens', vdesc)
1957 768 : ierr = pio_get_var(File, vdesc, ndens(1:mtapes))
1958 768 : ierr = pio_inq_varid(File, 'ncprec', vdesc)
1959 768 : ierr = pio_get_var(File, vdesc, ncprec(1:mtapes))
1960 768 : ierr = pio_inq_varid(File, 'beg_time', vdesc)
1961 768 : ierr = pio_get_var(File, vdesc, beg_time(1:mtapes))
1962 :
1963 :
1964 768 : ierr = pio_inq_varid(File, 'fincl', vdesc)
1965 768 : ierr = pio_get_var(File, vdesc, fincl(:,1:mtapes))
1966 :
1967 768 : ierr = pio_inq_varid(File, 'fincllonlat', vdesc)
1968 768 : ierr = pio_get_var(File, vdesc, fincllonlat(:,1:mtapes))
1969 :
1970 768 : ierr = pio_inq_varid(File, 'fexcl', vdesc)
1971 768 : ierr = pio_get_var(File, vdesc, fexcl(:,1:mtapes))
1972 :
1973 768 : ierr = pio_inq_varid(File, 'lcltod_start', vdesc)
1974 768 : ierr = pio_get_var(File, vdesc, lcltod_start(1:mtapes))
1975 :
1976 768 : ierr = pio_inq_varid(File, 'lcltod_stop', vdesc)
1977 768 : ierr = pio_get_var(File, vdesc, lcltod_stop(1:mtapes))
1978 :
1979 6912 : allocate(tmpname(maxnflds, mtapes), decomp(maxnflds, mtapes), tmpnumlev(maxnflds,mtapes))
1980 768 : ierr = pio_inq_varid(File, 'field_name', vdesc)
1981 768 : ierr = pio_get_var(File, vdesc, tmpname)
1982 768 : ierr = pio_inq_varid(File, 'decomp_type', vdesc)
1983 768 : ierr = pio_get_var(File, vdesc, decomp)
1984 768 : ierr = pio_inq_varid(File, 'numlev', vdesc)
1985 768 : ierr = pio_get_var(File, vdesc, tmpnumlev)
1986 :
1987 768 : ierr = pio_inq_varid(File, 'hbuf_integral',vdesc)
1988 3072 : allocate(tmpintegral(maxnflds,mtapes))
1989 768 : ierr = pio_get_var(File, vdesc, tmpintegral(:,:))
1990 :
1991 :
1992 768 : ierr = pio_inq_varid(File, 'hwrt_prec',vdesc)
1993 3072 : allocate(tmpprec(maxnflds,mtapes))
1994 768 : ierr = pio_get_var(File, vdesc, tmpprec(:,:))
1995 :
1996 768 : ierr = pio_inq_varid(File, 'beg_nstep',vdesc)
1997 3072 : allocate(tmpbeg_nstep(maxnflds,mtapes))
1998 768 : ierr = pio_get_var(File, vdesc, tmpbeg_nstep(:,:))
1999 :
2000 768 : ierr = pio_inq_varid(File, 'xyfill', vdesc)
2001 3072 : allocate(xyfill(maxnflds,mtapes))
2002 768 : ierr = pio_get_var(File, vdesc, xyfill)
2003 :
2004 768 : ierr = pio_inq_varid(File, 'is_subcol', vdesc)
2005 3072 : allocate(is_subcol(maxnflds,mtapes))
2006 768 : ierr = pio_get_var(File, vdesc, is_subcol)
2007 :
2008 : !! interpolated output
2009 768 : ierr = pio_inq_varid(File, 'interpolate_output', vdesc)
2010 2304 : allocate(interp_output(mtapes))
2011 768 : ierr = pio_get_var(File, vdesc, interp_output)
2012 9984 : interpolate_output(1:mtapes) = interp_output(1:mtapes) > 0
2013 768 : if (ptapes > mtapes) then
2014 0 : interpolate_output(mtapes+1:ptapes) = .false.
2015 : end if
2016 768 : ierr = pio_inq_varid(File, 'interpolate_type', vdesc)
2017 768 : ierr = pio_get_var(File, vdesc, interp_output)
2018 9984 : do t = 1, mtapes
2019 9984 : if (interpolate_output(t)) then
2020 0 : interpolate_info(t)%interp_type = interp_output(t)
2021 : end if
2022 : end do
2023 768 : ierr = pio_inq_varid(File, 'interpolate_gridtype', vdesc)
2024 768 : ierr = pio_get_var(File, vdesc, interp_output)
2025 9984 : do t = 1, mtapes
2026 9984 : if (interpolate_output(t)) then
2027 0 : interpolate_info(t)%interp_gridtype = interp_output(t)
2028 : end if
2029 : end do
2030 768 : ierr = pio_inq_varid(File, 'interpolate_nlat', vdesc)
2031 768 : ierr = pio_get_var(File, vdesc, interp_output)
2032 9984 : do t = 1, mtapes
2033 9984 : if (interpolate_output(t)) then
2034 0 : interpolate_info(t)%interp_nlat = interp_output(t)
2035 : end if
2036 : end do
2037 768 : ierr = pio_inq_varid(File, 'interpolate_nlon', vdesc)
2038 768 : ierr = pio_get_var(File, vdesc, interp_output)
2039 9984 : do t = 1, mtapes
2040 9984 : if (interpolate_output(t)) then
2041 0 : interpolate_info(t)%interp_nlon = interp_output(t)
2042 : end if
2043 : end do
2044 :
2045 : !! mdim indices
2046 3840 : allocate(allmdims(maxvarmdims,maxnflds,mtapes))
2047 768 : ierr = pio_inq_varid(File, 'mdims', vdesc)
2048 768 : ierr = pio_get_var(File, vdesc, allmdims)
2049 :
2050 : !! mdim names
2051 : ! Read the hist coord names to make sure they are all registered
2052 768 : ierr = pio_inq_varid(File, 'mdimnames', vdesc)
2053 768 : call cam_pio_var_info(File, vdesc, ndims, dimids, dimlens)
2054 768 : mdimcnt = dimlens(2)
2055 2304 : allocate(mdimnames(mdimcnt))
2056 768 : ierr = pio_get_var(File, vdesc, mdimnames)
2057 3840 : do f = 1, mdimcnt
2058 : ! Check to see if the mdim is registered
2059 3840 : if (get_hist_coord_index(trim(mdimnames(f))) <= 0) then
2060 : ! We need to register this mdim (hist_coord)
2061 0 : call add_hist_coord(trim(mdimnames(f)))
2062 : end if
2063 : end do
2064 :
2065 4608 : allocate(tmpf1name(maxnflds, mtapes), tmpf2name(maxnflds, mtapes))
2066 768 : ierr = pio_inq_varid(File, 'op_field1', vdesc)
2067 768 : ierr = pio_get_var(File, vdesc, tmpf1name)
2068 768 : ierr = pio_inq_varid(File, 'op_field2', vdesc)
2069 768 : ierr = pio_get_var(File, vdesc, tmpf2name)
2070 :
2071 :
2072 768 : ierr = pio_inq_varid(File, 'avgflag', avgflag_desc)
2073 :
2074 768 : ierr = pio_inq_varid(File, 'long_name', longname_desc)
2075 768 : ierr = pio_inq_varid(File, 'units', units_desc)
2076 768 : ierr = pio_inq_varid(File, 'sampling_seq', sseq_desc)
2077 768 : ierr = pio_inq_varid(File, 'cell_methods', cm_desc)
2078 :
2079 768 : ierr = pio_inq_varid(File, 'fillvalue', fillval_desc)
2080 768 : ierr = pio_inq_varid(File, 'meridional_complement', meridional_complement_desc)
2081 768 : ierr = pio_inq_varid(File, 'zonal_complement', zonal_complement_desc)
2082 768 : ierr = pio_inq_varid(File, 'field_op', field_op_desc)
2083 768 : ierr = pio_inq_varid(File, 'op_field1_id', op_field1_id_desc)
2084 768 : ierr = pio_inq_varid(File, 'op_field2_id', op_field2_id_desc)
2085 :
2086 768 : rgnht(:)=.false.
2087 :
2088 13056 : allocate(history_tape(mtapes))
2089 :
2090 768 : tape => history_tape
2091 :
2092 9984 : do t=1,mtapes
2093 :
2094 9216 : if(rgnht_int(t)==1) rgnht(t)=.true.
2095 :
2096 :
2097 : call strip_null(nfpath(t))
2098 9216 : call strip_null(cpath(t,1))
2099 9216 : call strip_null(cpath(t,2))
2100 9216 : call strip_null(hrestpath(t))
2101 1135104 : allocate(tape(t)%hlist(nflds(t)))
2102 :
2103 1159680 : do fld=1,nflds(t)
2104 1112832 : if (associated(tape(t)%hlist(fld)%field%mdims)) then
2105 0 : deallocate(tape(t)%hlist(fld)%field%mdims)
2106 : end if
2107 1112832 : nullify(tape(t)%hlist(fld)%field%mdims)
2108 3338496 : ierr = pio_get_var(File,fillval_desc, (/fld,t/), tape(t)%hlist(fld)%field%fillvalue)
2109 3338496 : ierr = pio_get_var(File,meridional_complement_desc, (/fld,t/), tape(t)%hlist(fld)%field%meridional_complement)
2110 3338496 : ierr = pio_get_var(File,zonal_complement_desc, (/fld,t/), tape(t)%hlist(fld)%field%zonal_complement)
2111 1112832 : tape(t)%hlist(fld)%field%field_op(1:field_op_len) = ' '
2112 4451328 : ierr = pio_get_var(File,field_op_desc, (/1,fld,t/), tape(t)%hlist(fld)%field%field_op)
2113 1112832 : call strip_null(tape(t)%hlist(fld)%field%field_op)
2114 3338496 : ierr = pio_get_var(File,op_field1_id_desc, (/fld,t/), tape(t)%hlist(fld)%field%op_field1_id)
2115 3338496 : ierr = pio_get_var(File,op_field2_id_desc, (/fld,t/), tape(t)%hlist(fld)%field%op_field2_id)
2116 3338496 : ierr = pio_get_var(File,avgflag_desc, (/fld,t/), tape(t)%hlist(fld)%avgflag)
2117 4451328 : ierr = pio_get_var(File,longname_desc, (/1,fld,t/), tape(t)%hlist(fld)%field%long_name)
2118 4451328 : ierr = pio_get_var(File,units_desc, (/1,fld,t/), tape(t)%hlist(fld)%field%units)
2119 1112832 : tape(t)%hlist(fld)%field%sampling_seq(1:max_chars) = ' '
2120 4451328 : ierr = pio_get_var(File,sseq_desc, (/1,fld,t/), tape(t)%hlist(fld)%field%sampling_seq)
2121 1112832 : call strip_null(tape(t)%hlist(fld)%field%sampling_seq)
2122 1112832 : tape(t)%hlist(fld)%field%cell_methods(1:max_chars) = ' '
2123 4451328 : ierr = pio_get_var(File,cm_desc, (/1,fld,t/), tape(t)%hlist(fld)%field%cell_methods)
2124 1112832 : call strip_null(tape(t)%hlist(fld)%field%cell_methods)
2125 1112832 : if(xyfill(fld,t) ==1) then
2126 35328 : tape(t)%hlist(fld)%field%flag_xyfill=.true.
2127 : else
2128 1077504 : tape(t)%hlist(fld)%field%flag_xyfill=.false.
2129 : end if
2130 1112832 : if(is_subcol(fld,t) ==1) then
2131 0 : tape(t)%hlist(fld)%field%is_subcol=.true.
2132 : else
2133 1112832 : tape(t)%hlist(fld)%field%is_subcol=.false.
2134 : end if
2135 1112832 : call strip_null(tmpname(fld,t))
2136 1112832 : call strip_null(tmpf1name(fld,t))
2137 1112832 : call strip_null(tmpf2name(fld,t))
2138 1112832 : tape(t)%hlist(fld)%field%name = tmpname(fld,t)
2139 1112832 : tape(t)%hlist(fld)%op_field1 = tmpf1name(fld,t)
2140 1112832 : tape(t)%hlist(fld)%op_field2 = tmpf2name(fld,t)
2141 1112832 : tape(t)%hlist(fld)%field%decomp_type = decomp(fld,t)
2142 1112832 : tape(t)%hlist(fld)%field%numlev = tmpnumlev(fld,t)
2143 1112832 : tape(t)%hlist(fld)%hwrt_prec = tmpprec(fld,t)
2144 1112832 : tape(t)%hlist(fld)%beg_nstep = tmpbeg_nstep(fld,t)
2145 1112832 : call tape(t)%hlist(fld)%put_global(tmpintegral(fld,t))
2146 : ! If the field is an advected constituent set the mixing_ratio attribute
2147 1112832 : fname_tmp = strip_suffix(tape(t)%hlist(fld)%field%name)
2148 1112832 : call cnst_get_ind(fname_tmp, idx, abort=.false.)
2149 1112832 : mixing_ratio = ''
2150 1112832 : if (idx > 0) then
2151 323328 : mixing_ratio = cnst_get_type_byind(idx)
2152 : end if
2153 1112832 : tape(t)%hlist(fld)%field%mixing_ratio = mixing_ratio
2154 :
2155 2225664 : mdimcnt = count(allmdims(:,fld,t) > 0)
2156 7799040 : if(mdimcnt > 0) then
2157 1845504 : allocate(tape(t)%hlist(fld)%field%mdims(mdimcnt))
2158 1230336 : do i = 1, mdimcnt
2159 1230336 : tape(t)%hlist(fld)%field%mdims(i) = get_hist_coord_index(mdimnames(allmdims(i,fld,t)))
2160 : end do
2161 : end if
2162 : end do
2163 : end do
2164 768 : deallocate(tmpname, tmpnumlev, tmpprec, tmpbeg_nstep, decomp, xyfill, is_subcol, tmpintegral)
2165 768 : deallocate(mdimnames)
2166 768 : deallocate(tmpf1name,tmpf2name)
2167 :
2168 6912 : allocate(grid_wts(cam_grid_num_grids() + 1))
2169 768 : allgrids_wt => grid_wts
2170 :
2171 3072 : allocate(gridsontape(cam_grid_num_grids() + 1, ptapes))
2172 65280 : gridsontape = -1
2173 9984 : do t = 1, ptapes
2174 1122816 : do fld = 1, nflds(t)
2175 1112832 : if (tape(t)%hlist(fld)%avgflag .ne. 'I') then
2176 953856 : hfile_accum(t) = .true.
2177 : end if
2178 1112832 : call set_field_dimensions(tape(t)%hlist(fld)%field)
2179 :
2180 1112832 : begdim1 = tape(t)%hlist(fld)%field%begdim1
2181 1112832 : enddim1 = tape(t)%hlist(fld)%field%enddim1
2182 1112832 : begdim2 = tape(t)%hlist(fld)%field%begdim2
2183 1112832 : enddim2 = tape(t)%hlist(fld)%field%enddim2
2184 1112832 : begdim3 = tape(t)%hlist(fld)%field%begdim3
2185 1112832 : enddim3 = tape(t)%hlist(fld)%field%enddim3
2186 :
2187 5564160 : allocate(tape(t)%hlist(fld)%hbuf(begdim1:enddim1,begdim2:enddim2,begdim3:enddim3))
2188 1112832 : if (tape(t)%hlist(fld)%avgflag .eq. 'S') then ! allocate the variance buffer for standard dev
2189 0 : allocate(tape(t)%hlist(fld)%sbuf(begdim1:enddim1,begdim2:enddim2,begdim3:enddim3))
2190 : endif
2191 :
2192 1112832 : if (associated(tape(t)%hlist(fld)%varid)) then
2193 0 : deallocate(tape(t)%hlist(fld)%varid)
2194 : end if
2195 1112832 : nullify(tape(t)%hlist(fld)%varid)
2196 1112832 : if (associated(tape(t)%hlist(fld)%nacs)) then
2197 0 : deallocate(tape(t)%hlist(fld)%nacs)
2198 : end if
2199 1112832 : nullify(tape(t)%hlist(fld)%nacs)
2200 1112832 : if(tape(t)%hlist(fld)%field%flag_xyfill .or. (avgflag_pertape(t)=='L')) then
2201 141312 : allocate (tape(t)%hlist(fld)%nacs(begdim1:enddim1,begdim3:enddim3))
2202 : else
2203 3232512 : allocate(tape(t)%hlist(fld)%nacs(1,begdim3:enddim3))
2204 : end if
2205 : ! initialize all buffers to zero - this will be overwritten later by the
2206 : ! data in the history restart file if it exists.
2207 1112832 : call h_zero(fld,t)
2208 :
2209 : ! Make sure this field's decomp is listed on the tape
2210 1112832 : fdecomp = tape(t)%hlist(fld)%field%decomp_type
2211 1136640 : do ffld = 1, size(gridsontape, 1)
2212 1136640 : if (fdecomp == gridsontape(ffld, t)) then
2213 : exit
2214 32256 : else if (gridsontape(ffld, t) < 0) then
2215 8448 : gridsontape(ffld, t) = fdecomp
2216 8448 : exit
2217 : end if
2218 : end do
2219 : !
2220 : !rebuild area wt array and set field wbuf pointer
2221 : !
2222 2234880 : if (tape(t)%hlist(fld)%avgflag .eq. 'N') then ! set up area weight buffer
2223 0 : nullify(tape(t)%hlist(fld)%wbuf)
2224 :
2225 0 : if (any(allgrids_wt(:)%decomp_type == tape(t)%hlist(fld)%field%decomp_type)) then
2226 0 : wtidx=MAXLOC(allgrids_wt(:)%decomp_type, MASK = allgrids_wt(:)%decomp_type .EQ. fdecomp)
2227 0 : tape(t)%hlist(fld)%wbuf => allgrids_wt(wtidx(1))%wbuf
2228 : else
2229 : ! area weights not found for this grid, then create them
2230 : ! first check for an available spot in the array
2231 0 : if (any(allgrids_wt(:)%decomp_type == -1)) then
2232 0 : wtidx=MINLOC(allgrids_wt(:)%decomp_type)
2233 : else
2234 0 : call endrun('cam_history.F90:read_restart_history: Error initializing allgrids_wt with area weights')
2235 : end if
2236 0 : allgrids_wt(wtidx)%decomp_type=fdecomp
2237 0 : areawt => cam_grid_get_areawt(fdecomp)
2238 0 : allocate(allgrids_wt(wtidx(1))%wbuf(begdim1:enddim1,begdim3:enddim3))
2239 0 : cnt=0
2240 0 : do c=begdim3,enddim3
2241 0 : dimind = tape(t)%hlist(fld)%field%get_dims(c)
2242 0 : ib=dimind%beg1
2243 0 : ie=dimind%end1
2244 0 : do i=ib,ie
2245 0 : cnt=cnt+1
2246 0 : allgrids_wt(wtidx(1))%wbuf(i,c)=areawt(cnt)
2247 : end do
2248 : end do
2249 0 : tape(t)%hlist(fld)%wbuf => allgrids_wt(wtidx(1))%wbuf
2250 : endif
2251 : endif
2252 : end do
2253 : end do
2254 : !
2255 : !-----------------------------------------------------------------------
2256 : ! Read history restart files
2257 : !-----------------------------------------------------------------------
2258 : !
2259 : ! Loop over the total number of history files declared and
2260 : ! read the pathname for any history restart files
2261 : ! that are present (if any). Test to see if the run is a restart run
2262 : ! AND if any history buffer regen files exist (rgnht=.T.). Note, rgnht
2263 : ! is preset to false, reset to true in routine WSDS if hbuf restart files
2264 : ! are written and saved in the master restart file. Each history buffer
2265 : ! restart file is then obtained.
2266 : ! Note: some f90 compilers (e.g. SGI) complain about I/O of
2267 : ! derived types which have pointer components, so explicitly read each one.
2268 : !
2269 9984 : do t=1,mtapes
2270 9216 : if (rgnht(t)) then
2271 : !
2272 : ! Open history restart file
2273 : !
2274 : call getfil (hrestpath(t), locfn)
2275 2304 : call cam_pio_openfile(tape(t)%Files(restart_file_index), locfn, 0)
2276 : !
2277 : ! Read history restart file
2278 : !
2279 95232 : do fld = 1, nflds(t)
2280 :
2281 92928 : fname_tmp = strip_suffix(tape(t)%hlist(fld)%field%name)
2282 92928 : if(masterproc) write(iulog, *) 'Reading history variable ',fname_tmp
2283 92928 : ierr = pio_inq_varid(tape(t)%Files(restart_file_index), fname_tmp, vdesc)
2284 92928 : call cam_pio_var_info(tape(t)%Files(restart_file_index), vdesc, ndims, dimids, dimlens)
2285 :
2286 92928 : if(.not. associated(tape(t)%hlist(fld)%field%mdims)) then
2287 52992 : dimcnt = 0
2288 158976 : do i=1,ndims
2289 105984 : ierr = pio_inq_dimname(tape(t)%Files(restart_file_index), dimids(i), dname_tmp)
2290 105984 : dimid = get_hist_coord_index(dname_tmp)
2291 158976 : if(dimid >= 1) then
2292 0 : dimcnt = dimcnt + 1
2293 0 : tmpdims(dimcnt) = dimid
2294 : ! No else, just looking for mdims (grid dims won't be hist coords)
2295 : end if
2296 : end do
2297 52992 : if(dimcnt > 0) then
2298 0 : allocate(tape(t)%hlist(fld)%field%mdims(dimcnt))
2299 0 : tape(t)%hlist(fld)%field%mdims(:) = tmpdims(1:dimcnt)
2300 0 : if(dimcnt > maxvarmdims) maxvarmdims=dimcnt
2301 : end if
2302 : end if
2303 92928 : call set_field_dimensions(tape(t)%hlist(fld)%field)
2304 92928 : begdim1 = tape(t)%hlist(fld)%field%begdim1
2305 92928 : enddim1 = tape(t)%hlist(fld)%field%enddim1
2306 92928 : fdims(1) = enddim1 - begdim1 + 1
2307 92928 : begdim2 = tape(t)%hlist(fld)%field%begdim2
2308 92928 : enddim2 = tape(t)%hlist(fld)%field%enddim2
2309 92928 : fdims(2) = enddim2 - begdim2 + 1
2310 92928 : begdim3 = tape(t)%hlist(fld)%field%begdim3
2311 92928 : enddim3 = tape(t)%hlist(fld)%field%enddim3
2312 92928 : fdims(3) = enddim3 - begdim3 + 1
2313 92928 : if (fdims(2) > 1) then
2314 : nfdims = 3
2315 : else
2316 52992 : nfdims = 2
2317 52992 : fdims(2) = fdims(3)
2318 : end if
2319 92928 : fdecomp = tape(t)%hlist(fld)%field%decomp_type
2320 92928 : if (nfdims > 2) then
2321 : call cam_grid_read_dist_array(tape(t)%Files(restart_file_index), fdecomp, &
2322 39936 : fdims(1:nfdims), dimlens(1:ndims), tape(t)%hlist(fld)%hbuf, vdesc)
2323 : else
2324 : call cam_grid_read_dist_array(tape(t)%Files(restart_file_index), fdecomp, &
2325 52992 : fdims(1:nfdims), dimlens(1:ndims), tape(t)%hlist(fld)%hbuf(:,1,:), vdesc)
2326 : end if
2327 :
2328 92928 : if ( associated(tape(t)%hlist(fld)%sbuf) ) then
2329 : ! read in variance for standard deviation
2330 0 : ierr = pio_inq_varid(tape(t)%Files(restart_file_index), trim(fname_tmp)//'_var', vdesc)
2331 0 : if (nfdims > 2) then
2332 0 : call cam_grid_read_dist_array(tape(t)%Files(restart_file_index), fdecomp, &
2333 0 : fdims(1:nfdims), dimlens(1:ndims), tape(t)%hlist(fld)%sbuf, vdesc)
2334 : else
2335 0 : call cam_grid_read_dist_array(tape(t)%Files(restart_file_index), fdecomp, &
2336 0 : fdims(1:nfdims), dimlens(1:ndims), tape(t)%hlist(fld)%sbuf(:,1,:), vdesc)
2337 : end if
2338 : endif
2339 :
2340 92928 : ierr = pio_inq_varid(tape(t)%Files(restart_file_index), trim(fname_tmp)//'_nacs', vdesc)
2341 92928 : call cam_pio_var_info(tape(t)%Files(restart_file_index), vdesc, nacsdimcnt, dimids, dimlens)
2342 :
2343 92928 : if(nacsdimcnt > 0) then
2344 5376 : if (nfdims > 2) then
2345 : ! nacs only has 2 dims (no levels)
2346 0 : fdims(2) = fdims(3)
2347 : end if
2348 21504 : allocate(tape(t)%hlist(fld)%nacs(begdim1:enddim1,begdim3:enddim3))
2349 5376 : nacs => tape(t)%hlist(fld)%nacs(:,:)
2350 : call cam_grid_read_dist_array(tape(t)%Files(restart_file_index), fdecomp, fdims(1:2), &
2351 5376 : dimlens(1:nacsdimcnt), nacs, vdesc)
2352 : else
2353 262656 : allocate(tape(t)%hlist(fld)%nacs(1,begdim3:enddim3))
2354 87552 : ierr = pio_get_var(tape(t)%Files(restart_file_index), vdesc, nacsval)
2355 513024 : tape(t)%hlist(fld)%nacs(1,:)= nacsval
2356 : end if
2357 :
2358 92928 : ierr = pio_inq_varid(tape(t)%Files(restart_file_index), trim(fname_tmp)//'_nacs', vdesc)
2359 188160 : call cam_pio_var_info(tape(t)%Files(restart_file_index), vdesc, nacsdimcnt, dimids, dimlens)
2360 :
2361 : end do
2362 : !
2363 : ! Done reading this history restart file
2364 : !
2365 2304 : call cam_pio_closefile(tape(t)%Files(restart_file_index))
2366 :
2367 : end if ! rgnht(t)
2368 :
2369 : ! (re)create the master list of grid IDs
2370 9216 : ffld = 0
2371 64512 : do fld = 1, size(gridsontape, 1)
2372 64512 : if (gridsontape(fld, t) > 0) then
2373 8448 : ffld = ffld + 1
2374 : end if
2375 : end do
2376 22272 : allocate(tape(t)%grid_ids(ffld))
2377 9216 : ffld = 1
2378 64512 : do fld = 1, size(gridsontape, 1)
2379 64512 : if (gridsontape(fld, t) > 0) then
2380 8448 : tape(t)%grid_ids(ffld) = gridsontape(fld, t)
2381 8448 : ffld = ffld + 1
2382 : end if
2383 : end do
2384 9984 : call patch_init(t)
2385 : end do ! end of do mtapes loop
2386 :
2387 : !
2388 : ! If the history files are partially complete (contain less than
2389 : ! mfilt(t) time samples, then get the files and open them.)
2390 : !
2391 : ! NOTE: No need to perform this operation for IC history files or empty files
2392 : !
2393 9984 : do t=1,mtapes
2394 9984 : if (is_initfile(file_index=t)) then
2395 : ! Initialize filename specifier for IC file
2396 768 : hfilename_spec(t) = '%c.cam' // trim(inst_suffix) // '.i.%y-%m-%d-%s.nc'
2397 768 : nfils(t) = 0
2398 8448 : else if (nflds(t) == 0) then
2399 5376 : nfils(t) = 0
2400 : else
2401 3072 : if (nfils(t) > 0) then
2402 : ! Always create the instantaneous file
2403 : call getfil (cpath(t,instantaneous_file_index), locfn)
2404 768 : call cam_pio_openfile(tape(t)%Files(instantaneous_file_index), locfn, PIO_WRITE)
2405 768 : if (hfile_accum(t)) then
2406 : ! Conditionally create the accumulated file
2407 768 : call getfil (cpath(t,accumulated_file_index), locfn)
2408 768 : call cam_pio_openfile(tape(t)%Files(accumulated_file_index), locfn, PIO_WRITE)
2409 : end if
2410 768 : call h_inquire (t)
2411 768 : if(is_satfile(t)) then
2412 : ! Initialize the sat following history subsystem
2413 0 : call sat_hist_init()
2414 0 : call sat_hist_define(tape(t)%Files(sat_file_index))
2415 : end if
2416 : end if
2417 : !
2418 : ! If the history file is full, close the current unit
2419 : !
2420 3072 : if (nfils(t) >= mfilt(t)) then
2421 768 : if (masterproc) then
2422 3 : do f = 1, maxsplitfiles
2423 3 : if (pio_file_is_open(tape(t)%Files(f))) then
2424 2 : write(iulog,*)'READ_RESTART_HISTORY: nf_close(',t,')=',nhfil(t,f), mfilt(t)
2425 : end if
2426 : end do
2427 : end if
2428 862464 : do fld=1,nflds(t)
2429 861696 : deallocate(tape(t)%hlist(fld)%varid)
2430 862464 : nullify(tape(t)%hlist(fld)%varid)
2431 : end do
2432 2304 : do f = 1, maxsplitfiles
2433 2304 : if (pio_file_is_open(tape(t)%Files(f))) then
2434 1536 : call cam_pio_closefile(tape(t)%Files(f))
2435 : end if
2436 : end do
2437 768 : nfils(t) = 0
2438 : end if
2439 : end if
2440 : end do
2441 :
2442 : ! Setup vector pairs for unstructured grid interpolation
2443 768 : call setup_interpolation_and_define_vector_complements()
2444 :
2445 768 : if(mtapes/=ptapes .and. masterproc) then
2446 0 : write(iulog,*) ' WARNING: Restart file ptapes setting ',mtapes,' not equal to model setting ',ptapes
2447 : end if
2448 :
2449 : return
2450 1536 : end subroutine read_restart_history
2451 :
2452 : !#######################################################################
2453 :
2454 0 : character(len=max_string_len) function get_hfilepath( tape, accumulated_flag )
2455 : !
2456 : !-----------------------------------------------------------------------
2457 : !
2458 : ! Purpose: Return full filepath of history file for given tape number
2459 : ! This allows public read access to the filenames without making
2460 : ! the filenames public data.
2461 : !
2462 : !-----------------------------------------------------------------------
2463 : !
2464 : integer, intent(in) :: tape ! Tape number
2465 : logical, intent(in) :: accumulated_flag ! True if calling routine wants the accumulated
2466 : ! file path, False for instantaneous
2467 :
2468 0 : if (accumulated_flag) then
2469 0 : get_hfilepath = cpath( tape, accumulated_file_index )
2470 : else
2471 0 : get_hfilepath = cpath( tape, instantaneous_file_index )
2472 : end if
2473 768 : end function get_hfilepath
2474 :
2475 : !#######################################################################
2476 :
2477 0 : character(len=max_string_len) function get_hist_restart_filepath( tape )
2478 : !
2479 : !-----------------------------------------------------------------------
2480 : !
2481 : ! Purpose: Return full filepath of restart file for given tape number
2482 : ! This allows public read access to the filenames without making
2483 : ! the filenames public data.
2484 : !
2485 : !-----------------------------------------------------------------------
2486 : !
2487 : integer, intent(in) :: tape ! Tape number
2488 :
2489 0 : get_hist_restart_filepath = hrestpath( tape )
2490 0 : end function get_hist_restart_filepath
2491 :
2492 : !#######################################################################
2493 :
2494 0 : integer function get_ptapes( )
2495 : !
2496 : !-----------------------------------------------------------------------
2497 : !
2498 : ! Purpose: Return the number of tapes being used.
2499 : ! This allows public read access to the number of tapes without making
2500 : ! ptapes public data.
2501 : !
2502 : !-----------------------------------------------------------------------
2503 : !
2504 0 : get_ptapes = ptapes
2505 0 : end function get_ptapes
2506 :
2507 : !#######################################################################
2508 :
2509 69552254976 : recursive function get_entry_by_name(listentry, name) result(entry)
2510 : type(master_entry), pointer :: listentry
2511 : character(len=*), intent(in) :: name ! variable name
2512 : type(master_entry), pointer :: entry
2513 :
2514 69552254976 : if(associated(listentry)) then
2515 69539774976 : if(listentry%field%name .eq. name) then
2516 : entry => listentry
2517 : else
2518 69534296832 : entry=>get_entry_by_name(listentry%next_entry, name)
2519 : end if
2520 : else
2521 : nullify(entry)
2522 : end if
2523 69552254976 : end function get_entry_by_name
2524 :
2525 : !#######################################################################
2526 :
2527 211596288 : subroutine AvgflagToString(avgflag, time_op)
2528 : ! Dummy arguments
2529 : character(len=1), intent(in) :: avgflag ! averaging flag
2530 : character(len=max_chars), intent(out) :: time_op ! time op (e.g. max)
2531 :
2532 : ! Local variable
2533 : character(len=*), parameter :: subname = 'AvgflagToString'
2534 :
2535 167734272 : select case (avgflag)
2536 : case ('A')
2537 167734272 : time_op(:) = 'mean'
2538 : case ('B')
2539 0 : time_op(:) = 'mean00z'
2540 : case ('N')
2541 0 : time_op(:) = 'mean_over_nsteps'
2542 : case ('I')
2543 43717632 : time_op(:) = 'point'
2544 : case ('X')
2545 99840 : time_op(:) = 'maximum'
2546 : case ('M')
2547 44544 : time_op(:) = 'minimum'
2548 : case('L')
2549 0 : time_op(:) = LT_DESC
2550 : case ('S')
2551 0 : time_op(:) = 'standard_deviation'
2552 : case default
2553 211596288 : call endrun(subname//': unknown avgflag = '//avgflag)
2554 : end select
2555 211596288 : end subroutine AvgflagToString
2556 :
2557 : !#######################################################################
2558 :
2559 768 : subroutine fldlst ()
2560 :
2561 : use cam_grid_support, only: cam_grid_num_grids
2562 : use spmd_utils, only: mpicom
2563 : use dycore, only: dycore_is
2564 : use shr_kind_mod, only: cm => shr_kind_cm
2565 :
2566 : !-----------------------------------------------------------------------
2567 : !
2568 : ! Purpose: Define the contents of each history file based on namelist input for initial or branch
2569 : ! run, and restart data if a restart run.
2570 : !
2571 : ! Method: Use arrays fincl and fexcl to modify default history tape contents.
2572 : ! Then sort the result alphanumerically for later use by OUTFLD to
2573 : ! allow an n log n search time.
2574 : !
2575 : !---------------------------Local variables-----------------------------
2576 : !
2577 : integer t, fld ! tape, field indices
2578 : integer ffld ! index into include, exclude and fprec list
2579 : integer :: i
2580 : character(len=cm) :: duplicate_error ! string to be populated if an incompatible duplicate is found
2581 : character(len=cm) :: tempmsg ! string to be populated if an incompatible duplicate is found
2582 : character(len=fieldname_len) :: name ! field name portion of fincl (i.e. no avgflag separator)
2583 : character(len=max_fieldname_len) :: mastername ! name from masterlist field
2584 : character(len=max_chars) :: errormsg ! error output field
2585 : character(len=1) :: avgflag ! averaging flag
2586 : character(len=1) :: prec_wrt ! history buffer write precision flag
2587 :
2588 : type (hentry) :: tmp ! temporary used for swapping
2589 :
2590 : type(master_entry), pointer :: listentry
2591 : logical :: fieldontape ! .true. iff field on tape
2592 : integer :: errors_found
2593 :
2594 : ! List of active grids (first dim) for each tape (second dim)
2595 : ! An active grid is one for which there is a least one field being output
2596 : ! on that grid.
2597 768 : integer, allocatable :: gridsontape(:,:)
2598 :
2599 : integer :: n_vec_comp, add_fincl_idx
2600 : integer, parameter :: nvecmax = 50 ! max number of vector components in a fincl list
2601 : character(len=2) :: avg_suffix
2602 : character(len=max_fieldname_len) :: vec_comp_names(nvecmax)
2603 : character(len=1) :: vec_comp_avgflag(nvecmax)
2604 : !--------------------------------------------------------------------------
2605 :
2606 : ! First ensure contents of fincl, fexcl, and fwrtpr are all valid names
2607 : !
2608 768 : errors_found = 0
2609 9984 : do t=1,ptapes
2610 :
2611 9216 : fld = 1
2612 9216 : n_vec_comp = 0
2613 470016 : vec_comp_names = ' '
2614 470016 : vec_comp_avgflag = ' '
2615 309504 : do while (fld < pflds .and. fincl(fld,t) /= ' ')
2616 300288 : name = getname (fincl(fld,t))
2617 :
2618 300288 : mastername=''
2619 300288 : listentry => get_entry_by_name(masterlinkedlist, name)
2620 300288 : if (associated(listentry)) mastername = listentry%field%name
2621 300288 : if (name /= mastername) then
2622 0 : write(errormsg,'(3a,2(i0,a))')'FLDLST: ', trim(name), ' in fincl(', fld,', ',t, ') not found'
2623 0 : if (masterproc) then
2624 0 : write(iulog,*) trim(errormsg)
2625 0 : call shr_sys_flush(iulog)
2626 : end if
2627 0 : errors_found = errors_found + 1
2628 : else
2629 300288 : if (len_trim(mastername)>0 .and. interpolate_output(t)) then
2630 0 : if (n_vec_comp >= nvecmax) call endrun('FLDLST: need to increase nvecmax')
2631 : ! If this is a vector component then save the name of the complement
2632 0 : avgflag = getflag(fincl(fld,t))
2633 0 : if (len_trim(listentry%meridional_field) > 0) then
2634 0 : n_vec_comp = n_vec_comp + 1
2635 0 : vec_comp_names(n_vec_comp) = listentry%meridional_field
2636 0 : vec_comp_avgflag(n_vec_comp) = avgflag
2637 0 : else if (len_trim(listentry%zonal_field) > 0) then
2638 0 : n_vec_comp = n_vec_comp + 1
2639 0 : vec_comp_names(n_vec_comp) = listentry%zonal_field
2640 0 : vec_comp_avgflag(n_vec_comp) = avgflag
2641 : end if
2642 : end if
2643 : end if
2644 300288 : fld = fld + 1
2645 : end do
2646 :
2647 : ! Interpolation of vector components requires that both be present. If the fincl
2648 : ! specifier contains any vector components, then the complement was saved in the
2649 : ! array vec_comp_names. Next insure (for interpolated output only) that all complements
2650 : ! are also present in the fincl array.
2651 :
2652 : ! The first empty slot in the current fincl array is index fld from loop above.
2653 9216 : add_fincl_idx = fld
2654 9216 : if (fld > 1 .and. interpolate_output(t)) then
2655 0 : do i = 1, n_vec_comp
2656 0 : call list_index(fincl(:,t), vec_comp_names(i), ffld)
2657 0 : if (ffld == 0) then
2658 :
2659 : ! Add vector component to fincl. Don't need to check whether its in the master
2660 : ! list since this was done at the time of registering the vector components.
2661 0 : avg_suffix = ' '
2662 0 : if (len_trim(vec_comp_avgflag(i)) > 0) avg_suffix = ':' // vec_comp_avgflag(i)
2663 0 : fincl(add_fincl_idx,t) = trim(vec_comp_names(i)) // avg_suffix
2664 0 : add_fincl_idx = add_fincl_idx + 1
2665 :
2666 0 : write(errormsg,'(3a,1(i0,a))')'FLDLST: ', trim(vec_comp_names(i)), &
2667 0 : ' added to fincl', t, '. Both vector components are required for interpolated output.'
2668 0 : if (masterproc) then
2669 0 : write(iulog,*) trim(errormsg)
2670 0 : call shr_sys_flush(iulog)
2671 : end if
2672 : end if
2673 : end do
2674 : end if
2675 :
2676 9216 : fld = 1
2677 9984 : do while (fld < pflds .and. fexcl(fld,t) /= ' ')
2678 768 : mastername=''
2679 768 : listentry => get_entry_by_name(masterlinkedlist, fexcl(fld,t))
2680 768 : if(associated(listentry)) mastername = listentry%field%name
2681 :
2682 768 : if (fexcl(fld,t) /= mastername) then
2683 0 : write(errormsg,'(3a,2(i0,a))')'FLDLST: ', trim(fexcl(fld,t)), ' in fexcl(', fld,', ',t, ') not found'
2684 0 : if (masterproc) then
2685 0 : write(iulog,*) trim(errormsg)
2686 0 : call shr_sys_flush(iulog)
2687 : end if
2688 0 : errors_found = errors_found + 1
2689 : end if
2690 768 : fld = fld + 1
2691 : end do
2692 :
2693 9216 : fld = 1
2694 9984 : do while (fld < pflds .and. fwrtpr(fld,t) /= ' ')
2695 0 : name = getname (fwrtpr(fld,t))
2696 0 : mastername=''
2697 0 : listentry => get_entry_by_name(masterlinkedlist, name)
2698 0 : if(associated(listentry)) mastername = listentry%field%name
2699 0 : if (name /= mastername) then
2700 0 : write(errormsg,'(3a,i0,a)')'FLDLST: ', trim(name), ' in fwrtpr(', fld, ') not found'
2701 0 : if (masterproc) then
2702 0 : write(iulog,*) trim(errormsg)
2703 0 : call shr_sys_flush(iulog)
2704 : end if
2705 0 : errors_found = errors_found + 1
2706 : end if
2707 0 : do ffld=1,fld-1 ! If duplicate entry is found, stop
2708 0 : if (trim(name) == trim(getname(fwrtpr(ffld,t)))) then
2709 0 : write(errormsg,'(3a)')'FLDLST: Duplicate field ', trim(name), ' in fwrtpr'
2710 0 : if (masterproc) then
2711 0 : write(iulog,*) trim(errormsg)
2712 0 : call shr_sys_flush(iulog)
2713 : end if
2714 0 : errors_found = errors_found + 1
2715 : end if
2716 : end do
2717 0 : fld = fld + 1
2718 : end do
2719 : end do
2720 :
2721 768 : if (errors_found > 0) then
2722 : ! Give masterproc a chance to write all the log messages
2723 0 : call mpi_barrier(mpicom, t)
2724 0 : write(errormsg, '(a,i0,a)') 'FLDLST: ',errors_found,' errors found, see log'
2725 0 : call endrun(trim(errormsg))
2726 : end if
2727 :
2728 768 : nflds(:) = 0
2729 : ! IC history file is to be created, set properties
2730 768 : if(is_initfile()) then
2731 768 : hfilename_spec(ptapes) = '%c.cam' // trim(inst_suffix) // '.i.%y-%m-%d-%s.nc'
2732 :
2733 768 : ncprec(ptapes) = pio_double
2734 768 : ndens (ptapes) = 1
2735 768 : mfilt (ptapes) = 1
2736 : end if
2737 :
2738 :
2739 6912 : allocate(grid_wts(cam_grid_num_grids() + 1))
2740 768 : allgrids_wt => grid_wts
2741 :
2742 3072 : allocate(gridsontape(cam_grid_num_grids() + 1, ptapes))
2743 65280 : gridsontape = -1
2744 768 : errormsg = ''
2745 9984 : do t=1,ptapes
2746 : !
2747 : ! Add the field to the tape if specified via namelist (FINCL[1-ptapes]), or if
2748 : ! it is on by default and was not excluded via namelist (FEXCL[1-ptapes]).
2749 : ! Also set history buffer accumulation and output precision values according
2750 : ! to the values specified via namelist (FWRTPR[1-ptapes])
2751 : ! or, if not on the list, to the default values given by ndens(t).
2752 : !
2753 9216 : listentry => masterlinkedlist
2754 74889984 : do while(associated(listentry))
2755 74880000 : mastername = listentry%field%name
2756 74880000 : call list_index (fincl(1,t), mastername, ffld, duplicate_error=duplicate_error)
2757 74880000 : if (len(trim(duplicate_error)) > 0) then
2758 0 : if (len_trim(errormsg) == 0) then
2759 : write(errormsg,*) &
2760 0 : 'FLDLST: Found duplicate field(s) with different averaging flags. Place in separate fincl lists: '
2761 : end if
2762 0 : write(tempmsg, '(2a, i0, a)') trim(duplicate_error), ' (fincl', t, '). '
2763 0 : errormsg = trim(errormsg) // trim(tempmsg)
2764 : end if
2765 :
2766 74880000 : fieldontape = .false.
2767 74880000 : if (ffld > 0) then
2768 : fieldontape = .true.
2769 74582784 : else if ((.not. empty_htapes) .or. (is_initfile(file_index=t))) then
2770 74582784 : call list_index (fexcl(1,t), mastername, ffld)
2771 74582784 : if (ffld == 0 .and. listentry%actflag(t)) then
2772 : fieldontape = .true.
2773 : end if
2774 : end if
2775 : if (fieldontape) then
2776 : ! The field is active so increment the number of fields and add
2777 : ! its decomp type to the list of decomp types on this tape
2778 1112832 : nflds(t) = nflds(t) + 1
2779 3147264 : do ffld = 1, size(gridsontape, 1)
2780 3147264 : if (listentry%field%decomp_type == gridsontape(ffld, t)) then
2781 : exit
2782 2042880 : else if (gridsontape(ffld, t) < 0) then
2783 8448 : gridsontape(ffld, t) = listentry%field%decomp_type
2784 8448 : exit
2785 : end if
2786 : end do
2787 : end if
2788 74880000 : listentry=>listentry%next_entry
2789 : end do
2790 : end do
2791 768 : if (len_trim(errormsg) > 0) then
2792 0 : call endrun(trim(errormsg))
2793 : end if
2794 : !
2795 : ! Determine total number of active history tapes
2796 : !
2797 768 : if (masterproc) then
2798 13 : do t=1,ptapes
2799 13 : if (nflds(t) == 0) then
2800 7 : write(iulog,*)'FLDLST: Tape ',t,' is empty'
2801 : end if
2802 : end do
2803 : endif
2804 11520 : allocate(history_tape(ptapes))
2805 768 : tape=>history_tape
2806 :
2807 :
2808 9984 : do t=1,ptapes
2809 9216 : nullify(tape(t)%hlist)
2810 : ! Now we have a field count and can allocate
2811 9216 : if(nflds(t) > 0) then
2812 : ! Allocate the correct number of hentry slots
2813 1124352 : allocate(tape(t)%hlist(nflds(t)))
2814 : ! Count up the number of grids output on this tape
2815 3840 : ffld = 0
2816 26880 : do fld = 1, size(gridsontape, 1)
2817 26880 : if (gridsontape(fld, t) > 0) then
2818 8448 : ffld = ffld + 1
2819 : end if
2820 : end do
2821 11520 : allocate(tape(t)%grid_ids(ffld))
2822 3840 : ffld = 1
2823 26880 : do fld = 1, size(gridsontape, 1)
2824 26880 : if (gridsontape(fld, t) > 0) then
2825 8448 : tape(t)%grid_ids(ffld) = gridsontape(fld, t)
2826 8448 : ffld = ffld + 1
2827 : end if
2828 : end do
2829 : end if
2830 1122048 : do ffld=1,nflds(t)
2831 1112832 : nullify(tape(t)%hlist(ffld)%hbuf)
2832 1112832 : nullify(tape(t)%hlist(ffld)%sbuf)
2833 1112832 : nullify(tape(t)%hlist(ffld)%wbuf)
2834 1112832 : nullify(tape(t)%hlist(ffld)%nacs)
2835 1122048 : nullify(tape(t)%hlist(ffld)%varid)
2836 : end do
2837 :
2838 :
2839 9216 : nflds(t) = 0 ! recount to support array based method
2840 9216 : listentry => masterlinkedlist
2841 74889216 : do while(associated(listentry))
2842 74880000 : mastername = listentry%field%name
2843 :
2844 74880000 : call list_index (fwrtpr(1,t), mastername, ffld)
2845 74880000 : if (ffld > 0) then
2846 0 : prec_wrt = getflag(fwrtpr(ffld,t))
2847 : else
2848 74880000 : prec_wrt = ' '
2849 : end if
2850 :
2851 74880000 : call list_index (fincl(1,t), mastername, ffld)
2852 :
2853 74880000 : if (ffld > 0) then
2854 297216 : avgflag = getflag (fincl(ffld,t))
2855 297216 : call inifld (t, listentry, avgflag, prec_wrt)
2856 74582784 : else if ((.not. empty_htapes) .or. (is_initfile(file_index=t))) then
2857 74582784 : call list_index (fexcl(1,t), mastername, ffld)
2858 74582784 : if (ffld == 0 .and. listentry%actflag(t)) then
2859 815616 : call inifld (t, listentry, ' ', prec_wrt)
2860 : else
2861 73767168 : listentry%actflag(t) = .false.
2862 : end if
2863 : else
2864 0 : listentry%actflag(t) = .false.
2865 : end if
2866 74880000 : listentry=>listentry%next_entry
2867 :
2868 : end do
2869 : !
2870 : ! If column output is specified make sure there are some fields defined
2871 : ! for that tape
2872 : !
2873 9216 : if (nflds(t) .eq. 0 .and. fincllonlat(1,t) .ne. ' ') then
2874 0 : write(errormsg,'(a,i2,a)') 'FLDLST: Column output is specified for tape ',t,' but no fields defined for that tape.'
2875 0 : call endrun(errormsg)
2876 : else
2877 9216 : call patch_init(t)
2878 : end if
2879 : !
2880 : ! Specification of tape contents now complete. Sort each list of active
2881 : ! entries for efficiency in OUTFLD. Simple bubble sort.
2882 : !
2883 : !!XXgoldyXX: v In the future, we will sort according to decomp to speed I/O
2884 1118208 : do fld=nflds(t)-1,1,-1
2885 503109120 : do ffld=1,fld
2886 :
2887 503109120 : if (tape(t)%hlist(ffld)%field%numlev > tape(t)%hlist(ffld+1)%field%numlev) then
2888 112841472 : tmp = tape(t)%hlist(ffld)
2889 112841472 : tape(t)%hlist(ffld ) = tape(t)%hlist(ffld+1)
2890 112841472 : tape(t)%hlist(ffld+1) = tmp
2891 : end if
2892 :
2893 : end do
2894 :
2895 503118336 : do ffld=1,fld
2896 :
2897 502000128 : if ((tape(t)%hlist(ffld)%field%numlev == tape(t)%hlist(ffld+1)%field%numlev) .and. &
2898 1108992 : (tape(t)%hlist(ffld)%field%name > tape(t)%hlist(ffld+1)%field%name)) then
2899 :
2900 115102464 : tmp = tape(t)%hlist(ffld)
2901 115102464 : tape(t)%hlist(ffld ) = tape(t)%hlist(ffld+1)
2902 115102464 : tape(t)%hlist(ffld+1) = tmp
2903 :
2904 386897664 : else if (tape(t)%hlist(ffld)%field%name == tape(t)%hlist(ffld+1)%field%name) then
2905 0 : write(errormsg,'(2a,2(a,i3))') 'FLDLST: Duplicate field: ', &
2906 0 : trim(tape(t)%hlist(ffld)%field%name),', tape = ', t, ', ffld = ', ffld
2907 0 : call endrun(errormsg)
2908 :
2909 : end if
2910 :
2911 : end do
2912 : end do
2913 :
2914 : ! Initialize the field names/ids for each composed field on tapes
2915 9984 : call define_composed_field_ids(t)
2916 :
2917 : end do ! do t=1,ptapes
2918 768 : deallocate(gridsontape)
2919 :
2920 768 : call print_active_fldlst()
2921 :
2922 : !
2923 : ! Packing density, ndens: With netcdf, only 1 (nf_double) and 2 (pio_real)
2924 : ! are allowed
2925 : !
2926 9984 : do t=1,ptapes
2927 9984 : if (ndens(t) == 1) then
2928 768 : ncprec(t) = pio_double
2929 8448 : else if (ndens(t) == 2) then
2930 8448 : ncprec(t) = pio_real
2931 : else
2932 0 : call endrun ('FLDLST: ndens must be 1 or 2')
2933 : end if
2934 :
2935 : end do
2936 : !
2937 : ! Now that masterlinkedlist is defined, construct primary and secondary hashing
2938 : ! tables.
2939 : !
2940 768 : call bld_outfld_hash_tbls()
2941 768 : call bld_htapefld_indices()
2942 :
2943 768 : return
2944 1536 : end subroutine fldlst
2945 :
2946 : !#########################################################################################
2947 :
2948 1536 : subroutine print_active_fldlst()
2949 :
2950 : integer :: fld, ffld, i, t
2951 : integer :: num_patches
2952 :
2953 : character(len=6) :: prec_str
2954 : character(len=max_chars) :: fldname, fname_tmp
2955 :
2956 : type(active_entry), pointer :: hfile(:) => null() ! history files
2957 :
2958 1536 : if (masterproc) then
2959 :
2960 2 : hfile=>history_tape
2961 :
2962 26 : do t=1,ptapes
2963 :
2964 24 : if (nflds(t) > 0) then
2965 10 : write(iulog,*) ' '
2966 10 : write(iulog,*)'FLDLST: History stream ', t, ' contains ', nflds(t), ' fields'
2967 :
2968 10 : if (is_initfile(file_index=t)) then
2969 2 : write(iulog,*) ' Write frequency: ',inithist,' (INITIAL CONDITIONS)'
2970 : else
2971 8 : if (nhtfrq(t) == 0) then
2972 0 : write(iulog,*) ' Write frequency: MONTHLY'
2973 : else
2974 8 : write(iulog,*) ' Write frequency: ',nhtfrq(t)
2975 : end if
2976 : end if
2977 :
2978 10 : write(iulog,*) ' Filename specifier: ', trim(hfilename_spec(t))
2979 :
2980 10 : prec_str = 'double'
2981 10 : if (ndens(t) == 2) prec_str = 'single'
2982 10 : write(iulog,*) ' Output precision: ', prec_str
2983 10 : write(iulog,*) ' Number of time samples per file: ', mfilt(t)
2984 :
2985 : ! grid info
2986 10 : if (associated(hfile(t)%patches)) then
2987 0 : write(iulog,*) ' Fields are represented on columns (FIELD_LON_LAT)'
2988 10 : else if (associated(hfile(t)%grid_ids)) then
2989 10 : write(iulog,*) ' Fields are represented on global grids:'
2990 32 : do i = 1, size(hfile(t)%grid_ids)
2991 32 : write(iulog,*) ' ', hfile(t)%grid_ids(i)
2992 : end do
2993 : else
2994 0 : call endrun('print_active_fldlst: error in active_entry object')
2995 : end if
2996 :
2997 10 : write(iulog,*)' Included fields are:'
2998 :
2999 : end if
3000 :
3001 2924 : do fld = 1, nflds(t)
3002 2922 : if (associated(hfile(t)%patches)) then
3003 0 : num_patches = size(hfile(t)%patches)
3004 0 : fldname = strip_suffix(hfile(t)%hlist(fld)%field%name)
3005 0 : do i = 1, num_patches
3006 0 : ffld = (fld-1)*num_patches + i
3007 0 : fname_tmp = trim(fldname)
3008 0 : call hfile(t)%patches(i)%field_name(fname_tmp)
3009 0 : write(iulog,9000) ffld, fname_tmp, hfile(t)%hlist(fld)%field%units, &
3010 0 : hfile(t)%hlist(fld)%field%numlev, hfile(t)%hlist(fld)%avgflag, &
3011 0 : trim(hfile(t)%hlist(fld)%field%long_name)
3012 : end do
3013 : else
3014 2898 : fldname = hfile(t)%hlist(fld)%field%name
3015 2898 : write(iulog,9000) fld, fldname, hfile(t)%hlist(fld)%field%units, &
3016 2898 : hfile(t)%hlist(fld)%field%numlev, hfile(t)%hlist(fld)%avgflag, &
3017 5796 : trim(hfile(t)%hlist(fld)%field%long_name)
3018 : end if
3019 :
3020 : end do
3021 :
3022 : end do
3023 :
3024 : end if
3025 :
3026 : 9000 format(i5, 1x, a32, 1x, a16, 1x, i4, 1x, a1, 2x, 256a)
3027 :
3028 768 : end subroutine print_active_fldlst
3029 :
3030 : !#########################################################################################
3031 :
3032 1112832 : subroutine inifld (t, listentry, avgflag, prec_wrt)
3033 : use cam_grid_support, only: cam_grid_is_zonal
3034 : !
3035 : !-----------------------------------------------------------------------
3036 : !
3037 : ! Purpose: Add a field to the active list for a history tape
3038 : !
3039 : ! Method: Copy the data from the master field list to the active list for the tape
3040 : ! Also: define mapping arrays from (col,chunk) -> (lon,lat)
3041 : !
3042 : ! Author: CCM Core Group
3043 : !
3044 : !-----------------------------------------------------------------------
3045 :
3046 :
3047 : !
3048 : ! Arguments
3049 : !
3050 : integer, intent(in) :: t ! history tape index
3051 :
3052 : type(master_entry), pointer :: listentry
3053 :
3054 : character(len=1), intent(in) :: avgflag ! averaging flag
3055 : character(len=1), intent(in) :: prec_wrt ! history output precision flag
3056 : !
3057 : ! Local workspace
3058 : !
3059 : integer :: n ! field index on defined tape
3060 :
3061 :
3062 : !
3063 : ! Ensure that it is not to late to add a field to the history tape
3064 : !
3065 1112832 : if (htapes_defined) then
3066 0 : call endrun ('INIFLD: Attempt to add field '//listentry%field%name//' after history files set')
3067 : end if
3068 :
3069 1112832 : nflds(t) = nflds(t) + 1
3070 1112832 : n = nflds(t)
3071 : !
3072 : ! Copy field info.
3073 : !
3074 1112832 : if(n > size(tape(t)%hlist)) then
3075 0 : write(iulog,*) 'tape field miscount error ', n, size(tape(t)%hlist)
3076 0 : call endrun()
3077 : end if
3078 :
3079 1112832 : tape(t)%hlist(n)%field = listentry%field
3080 :
3081 : select case (prec_wrt)
3082 : case (' ')
3083 1112832 : if (ndens(t) == 1) then
3084 158208 : tape(t)%hlist(n)%hwrt_prec = 8
3085 : else
3086 954624 : tape(t)%hlist(n)%hwrt_prec = 4
3087 : end if
3088 : case ('4')
3089 0 : tape(t)%hlist(n)%hwrt_prec = 4
3090 0 : if (masterproc) then
3091 0 : write(iulog,*) 'INIFLD: Output data type for ', tape(t)%hlist(n)%field%name, &
3092 0 : ' is real*4'
3093 : end if
3094 : case ('8')
3095 0 : tape(t)%hlist(n)%hwrt_prec = 8
3096 0 : if (masterproc) then
3097 0 : write(iulog,*) 'INIFLD: Output data type for ', tape(t)%hlist(n)%field%name, &
3098 0 : ' is real*8'
3099 : end if
3100 : case default
3101 1112832 : call endrun ('INIFLD: unknown prec_wrt='//prec_wrt)
3102 : end select
3103 : !
3104 : ! Override the default averaging (masterlist) averaging flag if non-blank
3105 : !
3106 1112832 : if (avgflag == ' ') then
3107 1108992 : tape(t)%hlist(n)%avgflag = listentry%avgflag(t)
3108 1108992 : tape(t)%hlist(n)%time_op = listentry%time_op(t)
3109 : else
3110 3840 : tape(t)%hlist(n)%avgflag = avgflag
3111 3840 : call AvgflagToString(avgflag, tape(t)%hlist(n)%time_op)
3112 : end if
3113 :
3114 : ! Some things can't be done with zonal fields
3115 1112832 : if (cam_grid_is_zonal(listentry%field%decomp_type)) then
3116 8448 : if (tape(t)%hlist(n)%avgflag == 'L') then
3117 0 : call endrun("Cannot perform local time processing on zonal data ("//trim(listentry%field%name)//")")
3118 8448 : else if (is_satfile(t)) then
3119 0 : call endrun("Zonal data not valid for satellite history ("//trim(listentry%field%name)//")")
3120 : end if
3121 : end if
3122 :
3123 : #ifdef HDEBUG
3124 : if (masterproc) then
3125 : write(iulog,'(a,i0,3a,i0,a,i2)')'HDEBUG: ',__LINE__,' field ', &
3126 : trim(tape(t)%hlist(n)%field%name), ' added as field number ', n, &
3127 : ' on tape ', t
3128 : write(iulog,'(2a)')' units = ',trim(tape(t)%hlist(n)%field%units)
3129 : write(iulog,'(a,i0)')' numlev = ',tape(t)%hlist(n)%field%numlev
3130 : write(iulog,'(2a)')' avgflag = ',tape(t)%hlist(n)%avgflag
3131 : write(iulog,'(3a)')' time_op = "',trim(tape(t)%hlist(n)%time_op),'"'
3132 : write(iulog,'(a,i0)')' hwrt_prec = ',tape(t)%hlist(n)%hwrt_prec
3133 : end if
3134 : #endif
3135 :
3136 1112832 : return
3137 1112832 : end subroutine inifld
3138 :
3139 :
3140 18432 : subroutine patch_init(t)
3141 1112832 : use cam_history_support, only: history_patch_t
3142 : use cam_grid_support, only: cam_grid_compute_patch
3143 :
3144 : ! Dummy arguments
3145 : integer, intent(in) :: t ! Current tape
3146 :
3147 : ! Local variables
3148 : integer :: ff ! Loop over fincllonlat entries
3149 : integer :: i ! General loop index
3150 : integer :: npatches
3151 : type(history_patch_t), pointer :: patchptr
3152 :
3153 : character(len=max_chars) :: errormsg
3154 : character(len=max_chars) :: lonlatname(pflds)
3155 : real(r8) :: beglon, beglat, endlon, endlat
3156 :
3157 : !
3158 : ! Setup column information if this field will be written as group
3159 : ! First verify the column information in the namelist
3160 : ! Duplicates are an error, but we can just ignore them
3161 : !
3162 :
3163 : ! I know, this shouldn't happen . . . yet: (better safe than sorry)
3164 18432 : if (associated(tape(t)%patches)) then
3165 0 : do i = 1, size(tape(t)%patches)
3166 0 : call tape(t)%patches(i)%deallocate()
3167 : end do
3168 0 : deallocate(tape(t)%patches)
3169 0 : nullify(tape(t)%patches)
3170 : end if
3171 :
3172 : ! First, count the number of patches and check for duplicates
3173 : ff = 1 ! Index of fincllonlat entry
3174 : npatches = 0 ! Number of unique patches in namelist entry
3175 18432 : do while (len_trim(fincllonlat(ff, t)) > 0)
3176 0 : npatches = npatches + 1
3177 0 : lonlatname(npatches) = trim(fincllonlat(ff, t))
3178 : ! Check for duplicates
3179 0 : do i = 1, npatches - 1
3180 0 : if (trim(lonlatname(i)) == trim(lonlatname(npatches))) then
3181 0 : write(errormsg, '(a,i0,3a)') 'Duplicate fincl', t, 'lonlat entry.', &
3182 0 : 'Duplicate entry is ', trim(lonlatname(i))
3183 0 : write(iulog, *) 'patch_init: WARNING: '//errormsg
3184 : ! Remove the new entry
3185 0 : lonlatname(npatches) = ''
3186 0 : npatches = npatches - 1
3187 0 : exit
3188 : end if
3189 : end do
3190 0 : ff = ff + 1
3191 : end do
3192 :
3193 : ! Now we know how many patches, allocate space
3194 18432 : if (npatches > 0) then
3195 0 : if (collect_column_output(t)) then
3196 0 : allocate(tape(t)%patches(1))
3197 : else
3198 0 : allocate(tape(t)%patches(npatches))
3199 : end if
3200 :
3201 : ! For each lat/lon specification, parse and create a patch for each grid
3202 0 : do ff = 1, npatches
3203 0 : if (collect_column_output(t)) then
3204 : ! For colleccted column output, we only have one patch
3205 0 : patchptr => tape(t)%patches(1)
3206 : else
3207 0 : patchptr => tape(t)%patches(ff)
3208 0 : patchptr%namelist_entry = trim(lonlatname(ff))
3209 : end if
3210 : ! We need to set up one patch per (active) grid
3211 0 : patchptr%collected_output = collect_column_output(t)
3212 0 : call parseLonLat(lonlatname(ff), &
3213 : beglon, endlon, patchptr%lon_axis_name, &
3214 0 : beglat, endlat, patchptr%lat_axis_name)
3215 0 : if (associated(patchptr%patches)) then
3216 : ! One last sanity check
3217 0 : if (.not. collect_column_output(t)) then
3218 0 : write(errormsg, '(a,i0,2a)') 'Attempt to overwrite fincl', t, &
3219 0 : 'lonlat entry, ', trim(patchptr%namelist_entry)
3220 0 : call endrun('patch_init: '//errormsg)
3221 : end if
3222 : else
3223 0 : allocate(patchptr%patches(size(tape(t)%grid_ids)))
3224 : end if
3225 0 : do i = 1, size(tape(t)%grid_ids)
3226 0 : call cam_grid_compute_patch(tape(t)%grid_ids(i), patchptr%patches(i),&
3227 0 : beglon, endlon, beglat, endlat, collect_column_output(t))
3228 : end do
3229 0 : nullify(patchptr)
3230 : end do
3231 : end if
3232 : ! We are done processing this tape's fincl#lonlat entries. Now,
3233 : ! compact each patch so that the output variables have no holes
3234 : ! We wait until now for when collect_column_output(t) is .true. since
3235 : ! all the fincl#lonlat entries are concatenated
3236 18432 : if (associated(tape(t)%patches)) then
3237 0 : do ff = 1, size(tape(t)%patches)
3238 0 : call tape(t)%patches(ff)%compact()
3239 : end do
3240 : end if
3241 :
3242 18432 : end subroutine patch_init
3243 :
3244 : !#######################################################################
3245 :
3246 6713856 : subroutine strip_null(str)
3247 : character(len=*), intent(inout) :: str
3248 : integer :: i
3249 847664640 : do i=1,len(str)
3250 847664640 : if(ichar(str(i:i))==0) str(i:i)=' '
3251 : end do
3252 18432 : end subroutine strip_null
3253 :
3254 24583680 : character(len=max_fieldname_len) function strip_suffix (name)
3255 : !
3256 : !----------------------------------------------------------
3257 : !
3258 : ! Purpose: Strip "&IC" suffix from fieldnames if it exists
3259 : !
3260 : !----------------------------------------------------------
3261 : !
3262 : ! Arguments
3263 : !
3264 : character(len=*), intent(in) :: name
3265 : !
3266 : ! Local workspace
3267 : !
3268 : integer :: n
3269 : !
3270 : !-----------------------------------------------------------------------
3271 : !
3272 24583680 : strip_suffix = ' '
3273 :
3274 200352768 : do n = 1,fieldname_len
3275 200352768 : strip_suffix(n:n) = name(n:n)
3276 200352768 : if(name(n+1:n+1 ) == ' ' ) return
3277 176262144 : if(name(n+1:n+fieldname_suffix_len) == fieldname_suffix) return
3278 : end do
3279 :
3280 0 : strip_suffix(fieldname_len+1:max_fieldname_len) = name(fieldname_len+1:max_fieldname_len)
3281 :
3282 0 : return
3283 :
3284 : end function strip_suffix
3285 :
3286 : !#######################################################################
3287 :
3288 5265849600 : character(len=fieldname_len) function getname (inname)
3289 : !
3290 : !-----------------------------------------------------------------------
3291 : !
3292 : ! Purpose: retrieve name portion of inname
3293 : !
3294 : ! Method: If an averaging flag separater character is present (":") in inname,
3295 : ! lop it off
3296 : !
3297 : !-------------------------------------------------------------------------------
3298 : !
3299 : ! Arguments
3300 : !
3301 : character(len=*), intent(in) :: inname
3302 : !
3303 : ! Local workspace
3304 : !
3305 : integer :: length
3306 : integer :: i
3307 :
3308 5265849600 : length = len (inname)
3309 :
3310 5265849600 : if (length < fieldname_len .or. length > fieldname_lenp2) then
3311 0 : write(iulog,*) 'GETNAME: bad length=',length
3312 0 : call endrun
3313 : end if
3314 :
3315 5265849600 : getname = ' '
3316 >17206*10^7 : do i=1,fieldname_len
3317 >16685*10^7 : if (inname(i:i) == ':') exit
3318 >17206*10^7 : getname(i:i) = inname(i:i)
3319 : end do
3320 :
3321 5265849600 : return
3322 : end function getname
3323 :
3324 : !#######################################################################
3325 :
3326 : ! parseRangeString: Parse either a coordinate descriptor (e.g., 10S) or a
3327 : ! coordinate range (e.g., 10e:20e)
3328 : ! chars represents the allowed coordinate character.
3329 : ! NB: Does not validate numerical values (e.g., lat <= 90)
3330 0 : subroutine parseRangeString(rangestr, chars, begval, begchar, begname, endval, endchar, endname)
3331 :
3332 : ! Dummy arguments
3333 : character(len=*), intent(in) :: rangestr
3334 : character(len=*), intent(in) :: chars
3335 : real(r8), intent(out) :: begval
3336 : character, intent(out) :: begchar
3337 : character(len=*), intent(out) :: begname
3338 : real(r8), intent(out) :: endval
3339 : character, intent(out) :: endchar
3340 : character(len=*), intent(out) :: endname
3341 :
3342 : ! Local variables
3343 : character(len=128) :: errormsg
3344 : integer :: colonpos
3345 : integer :: beglen, endlen
3346 :
3347 : ! First, see if we have a position or a range
3348 0 : colonpos = scan(rangestr, ':')
3349 0 : if (colonpos == 0) then
3350 0 : begname = trim(rangestr)
3351 0 : beglen = len_trim(begname)
3352 0 : endname = trim(begname)
3353 : else
3354 0 : beglen = colonpos - 1
3355 0 : begname = rangestr(1:beglen)
3356 0 : endname = trim(rangestr(colonpos+1:))
3357 0 : endlen = len_trim(endname)
3358 : end if
3359 : ! begname should be a number (integer or real) followed by a character
3360 0 : if (verify(begname, '0123456789.') /= beglen) then
3361 0 : write(errormsg, *) 'Coordinate range must begin with number, ', begname
3362 0 : call endrun('parseRangeString: '//errormsg)
3363 : end if
3364 0 : if (verify(begname(beglen:beglen), chars) /= 0) then
3365 0 : write(errormsg, *) 'Coordinate range must end with character in the ', &
3366 0 : 'set [', trim(chars), '] ', begname
3367 0 : call endrun('parseRangeString: '//errormsg)
3368 : end if
3369 : ! begname parses so collect the values
3370 0 : read(begname(1:beglen-1), *) begval
3371 0 : begchar = begname(beglen:beglen)
3372 0 : if (colonpos /= 0) then
3373 : ! endname should be a number (integer or real) followed by a character
3374 0 : if (verify(endname, '0123456789.') /= endlen) then
3375 0 : write(errormsg, *) 'Coordinate range must begin with number, ', endname
3376 0 : call endrun('parseRangeString: '//errormsg)
3377 : end if
3378 0 : if (verify(endname(endlen:endlen), chars) /= 0) then
3379 0 : write(errormsg, *) 'Coordinate range must end with character in the ',&
3380 0 : 'set [', trim(chars), '] ', endname
3381 0 : call endrun('parseRangeString: '//errormsg)
3382 : end if
3383 : ! endname parses so collect the values
3384 0 : read(endname(1:endlen-1), *) endval
3385 0 : endchar = endname(endlen:endlen)
3386 : else
3387 0 : endval = begval
3388 0 : endchar = begchar
3389 : end if
3390 :
3391 0 : end subroutine parseRangeString
3392 :
3393 : ! parseLonLat: Parse a lon_lat description allowed by the fincllonlat(n)
3394 : ! namelist entries. Returns the starting and ending values of
3395 : ! the point or range specified.
3396 : ! NB: Does not validate the range against any particular grid
3397 0 : subroutine parseLonLat(lonlatname, beglon, endlon, lonname, beglat, endlat, latname)
3398 :
3399 : ! Dummy arguments
3400 : character(len=*), intent(in) :: lonlatname
3401 : real(r8), intent(out) :: beglon
3402 : real(r8), intent(out) :: endlon
3403 : character(len=*), intent(out) :: lonname
3404 : real(r8), intent(out) :: beglat
3405 : real(r8), intent(out) :: endlat
3406 : character(len=*), intent(out) :: latname
3407 :
3408 : ! Local variables
3409 : character(len=128) :: errormsg
3410 : character(len=MAX_CHARS) :: lonstr, latstr
3411 : character(len=MAX_CHARS) :: begname, endname
3412 : character :: begchar, endchar
3413 : integer :: underpos
3414 :
3415 : !
3416 : ! make sure _ separator is present
3417 : !
3418 0 : underpos = scan(lonlatname, '_')
3419 0 : if (underpos == 0) then
3420 0 : write(errormsg,*) 'Improperly formatted fincllonlat string. ', &
3421 0 : 'Missing underscore character (xxxE_yyyS) ', lonlatname
3422 0 : call endrun('parseLonLat: '//errormsg)
3423 : end if
3424 :
3425 : ! Break out the longitude and latitude sections
3426 0 : lonstr = lonlatname(:underpos-1)
3427 0 : latstr = trim(lonlatname(underpos+1:))
3428 :
3429 : ! Parse the longitude section
3430 0 : call parseRangeString(lonstr, 'eEwW', beglon, begchar, begname, endlon, endchar, endname)
3431 : ! Convert longitude to degrees East
3432 0 : if ((begchar == 'w') .or. (begchar == 'W')) then
3433 0 : if (beglon > 0.0_r8) then
3434 0 : beglon = 360._r8 - beglon
3435 : end if
3436 : end if
3437 0 : if ((beglon < 0._r8) .or. (beglon > 360._r8)) then
3438 0 : write(errormsg, *) 'Longitude specification out of range, ', trim(begname)
3439 0 : call endrun('parseLonLat: '//errormsg)
3440 : end if
3441 0 : if ((endchar == 'w') .or. (endchar == 'W')) then
3442 0 : if (endlon > 0.0_r8) then
3443 0 : endlon = 360._r8 - endlon
3444 : end if
3445 : end if
3446 0 : if ((endlon < 0._r8) .or. (endlon > 360._r8)) then
3447 0 : write(errormsg, *) 'Longitude specification out of range, ', trim(endname)
3448 0 : call endrun('parseLonLat: '//errormsg)
3449 : end if
3450 0 : if (beglon == endlon) then
3451 0 : lonname = trim(begname)
3452 : else
3453 0 : lonname = trim(begname)//'_to_'//trim(endname)
3454 : end if
3455 :
3456 : ! Parse the latitude section
3457 0 : call parseRangeString(latstr, 'nNsS', beglat, begchar, begname, endlat, endchar, endname)
3458 : ! Convert longitude to degrees East
3459 0 : if ((begchar == 's') .or. (begchar == 'S')) then
3460 0 : beglat = (-1._r8) * beglat
3461 : end if
3462 0 : if ((beglat < -90._r8) .or. (beglat > 90._r8)) then
3463 0 : write(errormsg, *) 'Latitude specification out of range, ', trim(begname)
3464 0 : call endrun('parseLonLat: '//errormsg)
3465 : end if
3466 0 : if ((endchar == 's') .or. (endchar == 'S')) then
3467 0 : endlat = (-1._r8) * endlat
3468 : end if
3469 0 : if ((endlat < -90._r8) .or. (endlat > 90._r8)) then
3470 0 : write(errormsg, *) 'Latitude specification out of range, ', trim(endname)
3471 0 : call endrun('parseLonLat: '//errormsg)
3472 : end if
3473 0 : if (beglat == endlat) then
3474 0 : latname = trim(begname)
3475 : else
3476 0 : latname = trim(begname)//'_to_'//trim(endname)
3477 : end if
3478 :
3479 0 : end subroutine parseLonLat
3480 :
3481 :
3482 : !#######################################################################
3483 :
3484 899328 : character(len=1) function getflag (inname)
3485 : !
3486 : !-----------------------------------------------------------------------
3487 : !
3488 : ! Purpose: retrieve flag portion of inname
3489 : !
3490 : ! Method: If an averaging flag separater character is present (":") in inname,
3491 : ! return the character after it as the flag
3492 : !
3493 : !-------------------------------------------------------------------------------
3494 : !
3495 : ! Arguments
3496 : !
3497 : character(len=*), intent(in) :: inname ! character string
3498 : !
3499 : ! Local workspace
3500 : !
3501 : integer :: length ! length of inname
3502 : integer :: i ! loop index
3503 :
3504 899328 : length = len (inname)
3505 :
3506 899328 : if (length /= fieldname_lenp2) then
3507 0 : write(iulog,*) 'GETFLAG: bad length=',length
3508 0 : call endrun
3509 : end if
3510 :
3511 899328 : getflag = ' '
3512 30249984 : do i=1,fieldname_lenp2-1
3513 30249984 : if (inname(i:i) == ':') then
3514 11520 : getflag = inname(i+1:i+1)
3515 11520 : exit
3516 : end if
3517 : end do
3518 :
3519 899328 : return
3520 : end function getflag
3521 :
3522 : !#######################################################################
3523 :
3524 373805568 : subroutine list_index (list, name, index, duplicate_error)
3525 : !
3526 : ! Input arguments
3527 : !
3528 : character(len=*), intent(in) :: list(pflds) ! input list of names, possibly ":" delimited
3529 : character(len=*), intent(in) :: name ! name to be searched for
3530 : character(len=*), optional, intent(out) :: duplicate_error ! if present, check the flags and return an error if incompatible
3531 : !
3532 : ! Output arguments
3533 : !
3534 : integer, intent(out) :: index ! index of "name" in "list"
3535 : !
3536 : ! Local workspace
3537 : !
3538 : character(len=fieldname_len) :: listname ! input name with ":" stripped off.
3539 : character(len=fieldname_len) :: flag ! accumulate flag for field
3540 : character(len=fieldname_len) :: flag_comp ! accumulate flag to compare with previous entry
3541 : integer :: f ! field index
3542 :
3543 373805568 : index = 0
3544 373805568 : if (present(duplicate_error)) then
3545 74880000 : duplicate_error = ''
3546 : end if
3547 :
3548 5265549312 : do f=1,pflds
3549 : !
3550 : ! Only list items
3551 : !
3552 5265549312 : listname = getname (list(f))
3553 5265549312 : if (listname == ' ') exit
3554 5265549312 : if (listname == name) then
3555 602112 : if (index /= 0 .and. present(duplicate_error)) then
3556 : ! This already exists in the field list - check the flag
3557 3072 : flag_comp = getflag(list(f))
3558 3072 : if (trim(flag_comp) /= trim(flag)) then
3559 : write(duplicate_error,*) &
3560 0 : '"', trim(list(f)), '", "', trim(name), &
3561 0 : ':', trim(flag), '"'
3562 0 : return
3563 : ! No else - if the flags are identical, we're ok to return the first
3564 : ! instance
3565 : end if
3566 : else
3567 599040 : index = f
3568 599040 : flag = getflag(list(f))
3569 : end if
3570 : end if
3571 : end do
3572 :
3573 : return
3574 373805568 : end subroutine list_index
3575 :
3576 : !#######################################################################
3577 :
3578 1142059008 : recursive subroutine outfld (fname, field, idim, c, avg_subcol_field)
3579 : use cam_history_buffers, only: hbuf_accum_inst, hbuf_accum_add, hbuf_accum_variance, &
3580 : hbuf_accum_add00z, hbuf_accum_max, hbuf_accum_min, &
3581 : hbuf_accum_addlcltime
3582 : use cam_history_support, only: dim_index_2d
3583 : use subcol_pack_mod, only: subcol_unpack
3584 : use cam_grid_support, only: cam_grid_id
3585 :
3586 : interface
3587 : subroutine subcol_field_avg_handler(idim, field_in, c, field_out)
3588 : use shr_kind_mod, only: r8 => shr_kind_r8
3589 : integer, intent(in) :: idim
3590 : real(r8), intent(in) :: field_in(idim, *)
3591 : integer, intent(in) :: c
3592 : real(r8), intent(out) :: field_out(:,:)
3593 : end subroutine subcol_field_avg_handler
3594 : end interface
3595 :
3596 : !
3597 : !-----------------------------------------------------------------------
3598 : !
3599 : ! Purpose: Accumulate (or take min, max, etc. as appropriate) input field
3600 : ! into its history buffer for appropriate tapes
3601 : !
3602 : ! Method: Check 'masterlist' whether the requested field 'fname' is active
3603 : ! on one or more history tapes, and if so do the accumulation.
3604 : ! If not found, return silently.
3605 : ! subcol_field_avg_handler:
3606 : ! An interface into subcol_field_avg without creating a dependency as
3607 : ! this would cause a dependency loop. See subcol.F90
3608 : ! Note: We cannot know a priori if field is a grid average field or a subcolumn
3609 : ! field because many fields passed to outfld are defined on ncol rather
3610 : ! than pcols or psetcols. Therefore, we use the avg_subcol_field input
3611 : ! to determine whether to average the field input before accumulation.
3612 : ! NB: If output is on a subcolumn grid (requested in addfle), it is
3613 : ! an error to use avg_subcol_field. A subcolumn field is assumed and
3614 : ! subcol_unpack is called before accumulation.
3615 : !
3616 : ! Author: CCM Core Group
3617 : !
3618 : !-----------------------------------------------------------------------
3619 : !
3620 : ! Arguments
3621 : !
3622 : character(len=*), intent(in) :: fname ! Field name--should be 8 chars long
3623 :
3624 : ! For structured grids, idim is the local longitude dimension.
3625 : ! For unstructured grids, idim is the local column dimension
3626 : ! For phys_decomp, it should be pcols or pcols*psubcols
3627 : integer, intent(in) :: idim
3628 : real(r8), intent(in) :: field(idim,*) ! Array containing field values
3629 : integer, intent(in) :: c ! chunk (physics) or latitude (dynamics) index
3630 : logical, optional, intent(in) :: avg_subcol_field
3631 : !
3632 : ! Local variables
3633 : !
3634 : integer :: t, fld ! tape, field indices
3635 :
3636 : character*1 :: avgflag ! averaging flag
3637 :
3638 571029504 : type (active_entry), pointer :: otape(:) ! Local history_tape pointer
3639 571029504 : real(r8),pointer :: hbuf(:,:) ! history buffer
3640 571029504 : real(r8),pointer :: wbuf(:) ! area weights for field
3641 571029504 : real(r8),pointer :: sbuf(:,:) ! variance buffer
3642 571029504 : integer, pointer :: nacs(:) ! accumulation counter
3643 : integer :: begdim2, enddim2, endi
3644 : integer :: phys_decomp
3645 : type (dim_index_2d) :: dimind ! 2-D dimension index
3646 : logical :: flag_xyfill ! non-applicable xy points flagged with fillvalue
3647 : real(r8) :: fillvalue
3648 571029504 : real(r8), allocatable :: afield(:,:) ! Averaged field values
3649 571029504 : real(r8), allocatable :: ufield(:,:,:) ! Unpacked field values
3650 : integer :: ff ! masterlist index pointer
3651 : integer :: i, j
3652 : logical :: found
3653 : logical :: avg_subcols ! average subcols before accum
3654 : !-----------------------------------------------------------------------
3655 :
3656 571029504 : call get_field_properties(fname, found, tape_out=otape, ff_out=ff)
3657 571029504 : phys_decomp = cam_grid_id('physgrid')
3658 :
3659 : ! If this field is not active, return now
3660 571029504 : if (.not. found) then
3661 : return
3662 : end if
3663 :
3664 : !
3665 : ! Note, the field may be on any or all of the history files (primary
3666 : ! and auxiliary).
3667 : !
3668 : ! write(iulog,*)'fname_loc=',fname_loc
3669 1119635712 : do t = 1, ptapes
3670 1033509888 : if ( .not. masterlist(ff)%thisentry%actflag(t)) cycle
3671 94502400 : fld = masterlist(ff)%thisentry%htapeindx(t)
3672 : !
3673 : ! Update history buffer
3674 : !
3675 94502400 : flag_xyfill = otape(t)%hlist(fld)%field%flag_xyfill
3676 94502400 : fillvalue = otape(t)%hlist(fld)%field%fillvalue
3677 94502400 : avgflag = otape(t)%hlist(fld)%avgflag
3678 94502400 : nacs => otape(t)%hlist(fld)%nacs(:,c)
3679 94502400 : hbuf => otape(t)%hlist(fld)%hbuf(:,:,c)
3680 94502400 : if (associated(tape(t)%hlist(fld)%wbuf)) then
3681 0 : wbuf => otape(t)%hlist(fld)%wbuf(:,c)
3682 : endif
3683 94502400 : if (associated(tape(t)%hlist(fld)%sbuf)) then
3684 0 : sbuf => otape(t)%hlist(fld)%sbuf(:,:,c)
3685 : endif
3686 94502400 : dimind = otape(t)%hlist(fld)%field%get_dims(c)
3687 :
3688 : ! See notes above about validity of avg_subcol_field
3689 94502400 : if (otape(t)%hlist(fld)%field%is_subcol) then
3690 0 : if (present(avg_subcol_field)) then
3691 0 : call endrun('OUTFLD: Cannot average '//trim(fname)//', subcolumn output was requested in addfld')
3692 : end if
3693 : avg_subcols = .false.
3694 94502400 : else if (otape(t)%hlist(fld)%field%decomp_type == phys_decomp) then
3695 93776640 : if (present(avg_subcol_field)) then
3696 1693440 : avg_subcols = avg_subcol_field
3697 : else
3698 : avg_subcols = .false.
3699 : end if
3700 : else ! Any dynamics decomposition
3701 725760 : if (present(avg_subcol_field)) then
3702 0 : call endrun('OUTFLD: avg_subcol_field only valid for physgrid')
3703 : else
3704 : avg_subcols = .false.
3705 : end if
3706 : end if
3707 :
3708 94502400 : begdim2 = otape(t)%hlist(fld)%field%begdim2
3709 94502400 : enddim2 = otape(t)%hlist(fld)%field%enddim2
3710 180628224 : if (avg_subcols) then
3711 0 : allocate(afield(pcols, begdim2:enddim2))
3712 0 : call subcol_field_avg_handler(idim, field, c, afield)
3713 : ! Hack! Avoid duplicating select statement below
3714 0 : call outfld(fname, afield, pcols, c)
3715 0 : deallocate(afield)
3716 94502400 : else if (otape(t)%hlist(fld)%field%is_subcol) then
3717 : ! We have to assume that using mdimnames (e.g., psubcols) is
3718 : ! incompatible with the begdimx, enddimx usage (checked in addfld)
3719 : ! Since psubcols is included in levels, take that out
3720 0 : endi = (enddim2 - begdim2 + 1) / psubcols
3721 0 : allocate(ufield(pcols, psubcols, endi))
3722 0 : allocate(afield(pcols*psubcols, endi))
3723 0 : do j = 1, endi
3724 0 : do i = 1, idim
3725 0 : afield(i, j) = field(i, j)
3726 : end do
3727 : end do
3728 : ! Initialize unused aray locations.
3729 0 : if (idim < pcols*psubcols) then
3730 0 : if (flag_xyfill) then
3731 0 : afield(idim+1:pcols*psubcols, :) = fillvalue
3732 : else
3733 0 : afield(idim+1:pcols*psubcols, :) = 0.0_r8
3734 : end if
3735 : end if
3736 0 : if (flag_xyfill) then
3737 0 : call subcol_unpack(c, afield, ufield, fillvalue)
3738 : else
3739 0 : call subcol_unpack(c, afield, ufield)
3740 : end if
3741 0 : deallocate(afield)
3742 0 : select case (avgflag)
3743 :
3744 : case ('I') ! Instantaneous
3745 : call hbuf_accum_inst(hbuf, ufield, nacs, dimind, pcols, &
3746 0 : flag_xyfill, fillvalue)
3747 :
3748 : case ('A') ! Time average
3749 : call hbuf_accum_add(hbuf, ufield, nacs, dimind, pcols, &
3750 0 : flag_xyfill, fillvalue)
3751 :
3752 : case ('B') ! Time average only 00z values
3753 : call hbuf_accum_add00z(hbuf, ufield, nacs, dimind, pcols, &
3754 0 : flag_xyfill, fillvalue)
3755 :
3756 : case ('N') ! Time average over nsteps
3757 : call hbuf_accum_add(hbuf, ufield, nacs, dimind, pcols, &
3758 0 : flag_xyfill, fillvalue)
3759 :
3760 : case ('X') ! Maximum over time
3761 : call hbuf_accum_max (hbuf, ufield, nacs, dimind, pcols, &
3762 0 : flag_xyfill, fillvalue)
3763 :
3764 : case ('M') ! Minimum over time
3765 : call hbuf_accum_min(hbuf, ufield, nacs, dimind, pcols, &
3766 0 : flag_xyfill, fillvalue)
3767 :
3768 : case ('L')
3769 : call hbuf_accum_addlcltime(hbuf, ufield, nacs, dimind, pcols, &
3770 : flag_xyfill, fillvalue, c, &
3771 0 : otape(t)%hlist(fld)%field%decomp_type, &
3772 0 : lcltod_start(t), lcltod_stop(t))
3773 :
3774 : case ('S') ! Standard deviation
3775 : call hbuf_accum_variance(hbuf, sbuf, ufield, nacs, dimind, pcols,&
3776 0 : flag_xyfill, fillvalue)
3777 :
3778 : case default
3779 0 : call endrun ('OUTFLD: invalid avgflag='//avgflag)
3780 :
3781 : end select
3782 0 : deallocate(ufield)
3783 : else
3784 72960 : select case (avgflag)
3785 :
3786 : case ('I') ! Instantaneous
3787 : call hbuf_accum_inst(hbuf, field, nacs, dimind, idim, &
3788 72960 : flag_xyfill, fillvalue)
3789 :
3790 : case ('A') ! Time average
3791 : call hbuf_accum_add(hbuf, field, nacs, dimind, idim, &
3792 94137600 : flag_xyfill, fillvalue)
3793 :
3794 : case ('B') ! Time average only 00z values
3795 : call hbuf_accum_add00z(hbuf, field, nacs, dimind, idim, &
3796 0 : flag_xyfill, fillvalue)
3797 :
3798 : case ('N') ! Time average over nsteps
3799 : call hbuf_accum_add (hbuf, field, nacs, dimind, idim, &
3800 0 : flag_xyfill, fillvalue)
3801 :
3802 : case ('X') ! Maximum over time
3803 : call hbuf_accum_max (hbuf, field, nacs, dimind, idim, &
3804 145920 : flag_xyfill, fillvalue)
3805 :
3806 : case ('M') ! Minimum over time
3807 : call hbuf_accum_min(hbuf, field, nacs, dimind, idim, &
3808 145920 : flag_xyfill, fillvalue)
3809 :
3810 : case ('L')
3811 : call hbuf_accum_addlcltime(hbuf, field, nacs, dimind, idim, &
3812 : flag_xyfill, fillvalue, c, &
3813 : otape(t)%hlist(fld)%field%decomp_type, &
3814 0 : lcltod_start(t), lcltod_stop(t))
3815 :
3816 : case ('S') ! Standard deviation
3817 : call hbuf_accum_variance(hbuf, sbuf, field, nacs, dimind, idim,&
3818 0 : flag_xyfill, fillvalue)
3819 :
3820 : case default
3821 1033509888 : call endrun ('OUTFLD: invalid avgflag='//avgflag)
3822 :
3823 : end select
3824 : end if
3825 :
3826 : end do
3827 :
3828 : return
3829 1142059008 : end subroutine outfld
3830 :
3831 : !#######################################################################
3832 :
3833 0 : subroutine get_field_properties(fname, found, tape_out, ff_out, no_tape_check_in, f_out)
3834 :
3835 : implicit none
3836 : !
3837 : !-----------------------------------------------------------------------
3838 : !
3839 : ! Purpose: If fname is active, lookup and return field information
3840 : !
3841 : ! Method: Check 'masterlist' whether the requested field 'fname' is active
3842 : ! on one or more history tapes, and if so, return the requested
3843 : ! field information
3844 : !
3845 : ! Author: goldy
3846 : !
3847 : !-----------------------------------------------------------------------
3848 : !
3849 : ! Arguments
3850 : !
3851 : character(len=*), intent(in) :: fname ! Field name--should be 8 chars long
3852 : logical, intent(out) :: found ! Set to true if fname is active
3853 : type(active_entry), pointer, optional :: tape_out(:)
3854 : integer, intent(out), optional :: ff_out
3855 : logical, intent(in), optional :: no_tape_check_in
3856 : integer, intent(out), optional :: f_out(:)
3857 :
3858 : !
3859 : ! Local variables
3860 : !
3861 : character*(max_fieldname_len) :: fname_loc ! max-char equivalent of fname
3862 : integer :: t, ff ! tape, masterindex indices
3863 : logical :: no_tape_check
3864 : !-----------------------------------------------------------------------
3865 :
3866 : ! Need to re-cast the field name so that the hashing works #hackalert
3867 571029504 : fname_loc = fname
3868 571029504 : ff = get_masterlist_indx(fname_loc)
3869 :
3870 : ! Set the no_tape_check to false, unless is passed in
3871 571029504 : if (present(no_tape_check_in)) then
3872 0 : no_tape_check = no_tape_check_in
3873 : else
3874 : no_tape_check = .false.
3875 : end if
3876 :
3877 : ! Set found to .false. so we can return early if fname is not active
3878 571029504 : found = .false.
3879 571029504 : if (present(tape_out)) then
3880 571029504 : nullify(tape_out)
3881 : end if
3882 571029504 : if (present(ff_out)) then
3883 571029504 : ff_out = -1
3884 : end if
3885 571029504 : if (present(f_out)) then
3886 0 : f_out = -1
3887 : end if
3888 :
3889 : !
3890 : ! If ( ff < 0 ), the field is not defined on the masterlist. This check
3891 : ! is necessary because of coding errors calling outfld without first defining
3892 : ! the field on masterlist.
3893 : !
3894 571029504 : if ( ff < 0 ) then
3895 484903680 : return
3896 : end if
3897 : !
3898 : ! Next, check to see whether this field is active on one or more history
3899 : ! tapes.
3900 : !
3901 571029504 : if (no_tape_check) then
3902 0 : if (present(ff_out)) ff_out = ff ! Set the output index and return without checking tapes
3903 0 : return
3904 571029504 : else if ( .not. masterlist(ff)%thisentry%act_sometape ) then
3905 : return
3906 : end if
3907 : !
3908 : ! Note, the field may be on any or all of the history files (primary
3909 : ! and auxiliary).
3910 : !
3911 :
3912 88012800 : do t=1, ptapes
3913 174138624 : if (masterlist(ff)%thisentry%actflag(t)) then
3914 86125824 : found = .true.
3915 86125824 : if (present(tape_out)) then
3916 86125824 : tape_out => history_tape
3917 : end if
3918 86125824 : if (present(ff_out)) then
3919 86125824 : ff_out = ff
3920 : end if
3921 86125824 : if (present(f_out)) then
3922 0 : f_out(t) = masterlist(ff)%thisentry%htapeindx(t)
3923 : else
3924 : ! only need to loop through all ptapes if f_out present
3925 : exit
3926 : end if
3927 : end if
3928 : end do
3929 :
3930 1142059008 : end subroutine get_field_properties
3931 :
3932 : !#######################################################################
3933 :
3934 160355374 : logical function is_initfile (file_index)
3935 : !
3936 : !------------------------------------------------------------------------
3937 : !
3938 : ! Purpose: to determine:
3939 : !
3940 : ! a) if an IC file is active in this model run at all
3941 : ! OR,
3942 : ! b) if it is active, is the current file index referencing the IC file
3943 : ! (IC file is always at ptapes)
3944 : !
3945 : !------------------------------------------------------------------------
3946 : !
3947 : ! Arguments
3948 : !
3949 : integer, intent(in), optional :: file_index ! index of file in question
3950 :
3951 160355374 : is_initfile = .false.
3952 :
3953 160355374 : if (present(file_index)) then
3954 160243246 : if (inithist /= 'NONE' .and. file_index == ptapes) is_initfile = .true.
3955 : else
3956 112128 : if (inithist /= 'NONE' ) is_initfile = .true.
3957 : end if
3958 :
3959 : return
3960 :
3961 : end function is_initfile
3962 :
3963 : !#######################################################################
3964 :
3965 : integer function strcmpf (name1, name2)
3966 : !
3967 : !-----------------------------------------------------------------------
3968 : !
3969 : ! Purpose: Return the lexical difference between two strings
3970 : !
3971 : ! Method: Use ichar() intrinsic as we loop through the names
3972 : !
3973 : !-----------------------------------------------------------------------
3974 : !
3975 : ! Arguments
3976 : !
3977 : character(len=max_fieldname_len), intent(in) :: name1, name2 ! strings to compare
3978 : integer n ! loop index
3979 :
3980 : do n=1,max_fieldname_len
3981 : strcmpf = ichar(name1(n:n)) - ichar(name2(n:n))
3982 : if (strcmpf /= 0) exit
3983 : end do
3984 :
3985 : return
3986 : end function strcmpf
3987 :
3988 : !#######################################################################
3989 :
3990 768 : subroutine h_inquire (t)
3991 : use pio, only: pio_inq_varid, pio_inq_attlen
3992 : use cam_pio_utils, only: cam_pio_handle_error
3993 : !
3994 : !-----------------------------------------------------------------------
3995 : !
3996 : ! Purpose: Ensure that the proper variables are on a history file
3997 : !
3998 : ! Method: Issue the appropriate netcdf wrapper calls
3999 : !
4000 : !-----------------------------------------------------------------------
4001 : !
4002 : ! Arguments
4003 : !
4004 : integer, intent(in) :: t ! tape index
4005 : !
4006 : ! Local workspace
4007 : !
4008 : integer :: f, fld ! file, field index
4009 : integer :: ierr
4010 : integer :: i
4011 : integer :: num_patches
4012 : integer(pio_offset_kind) :: mdimsize
4013 : character(len=max_chars) :: fldname, fname_tmp, basename
4014 :
4015 : !
4016 : !
4017 : ! Dimension id's
4018 : !
4019 768 : tape => history_tape
4020 :
4021 : !
4022 : ! Create variables for model timing and header information
4023 : !
4024 2304 : do f = 1, maxsplitfiles
4025 1536 : if (.not. pio_file_is_open(tape(t)%Files(f))) then
4026 : cycle
4027 : end if
4028 1536 : if(.not. is_satfile(t)) then
4029 1536 : if (f == instantaneous_file_index) then
4030 768 : ierr=pio_inq_varid (tape(t)%Files(f),'ndcur ', tape(t)%ndcurid)
4031 768 : ierr=pio_inq_varid (tape(t)%Files(f),'nscur ', tape(t)%nscurid)
4032 768 : ierr=pio_inq_varid (tape(t)%Files(f),'nsteph ', tape(t)%nstephid)
4033 : end if
4034 1536 : if (f == accumulated_file_index) then
4035 768 : ierr=pio_inq_varid (tape(t)%Files(f),'time_bounds', tape(t)%tbndid)
4036 : end if
4037 1536 : ierr=pio_inq_varid (tape(t)%Files(f),'date_written', tape(t)%date_writtenid)
4038 1536 : ierr=pio_inq_varid (tape(t)%Files(f),'time_written', tape(t)%time_writtenid)
4039 : #if ( defined BFB_CAM_SCAM_IOP )
4040 : ierr=pio_inq_varid (tape(t)%Files(f),'tsec ',tape(t)%tsecid)
4041 : ierr=pio_inq_varid (tape(t)%Files(f),'bdate ',tape(t)%bdateid)
4042 : #endif
4043 1536 : if (.not. is_initfile(file_index=t) .and. f == instantaneous_file_index) then
4044 : ! Don't write the GHG/Solar forcing data to the IC file. It is never
4045 : ! read from that file so it's confusing to have it there.
4046 : ! Only write the GHG/Solar forcing data to the instantaneous file
4047 768 : ierr=pio_inq_varid (tape(t)%Files(f),'co2vmr ', tape(t)%co2vmrid)
4048 768 : ierr=pio_inq_varid (tape(t)%Files(f),'ch4vmr ', tape(t)%ch4vmrid)
4049 768 : ierr=pio_inq_varid (tape(t)%Files(f),'n2ovmr ', tape(t)%n2ovmrid)
4050 768 : ierr=pio_inq_varid (tape(t)%Files(f),'f11vmr ', tape(t)%f11vmrid)
4051 768 : ierr=pio_inq_varid (tape(t)%Files(f),'f12vmr ', tape(t)%f12vmrid)
4052 768 : ierr=pio_inq_varid (tape(t)%Files(f),'sol_tsi ', tape(t)%sol_tsiid)
4053 768 : if (solar_parms_on) then
4054 768 : ierr=pio_inq_varid (tape(t)%Files(f),'f107 ', tape(t)%f107id)
4055 768 : ierr=pio_inq_varid (tape(t)%Files(f),'f107a ', tape(t)%f107aid)
4056 768 : ierr=pio_inq_varid (tape(t)%Files(f),'f107p ', tape(t)%f107pid)
4057 768 : ierr=pio_inq_varid (tape(t)%Files(f),'kp ', tape(t)%kpid)
4058 768 : ierr=pio_inq_varid (tape(t)%Files(f),'ap ', tape(t)%apid)
4059 : endif
4060 768 : if (solar_wind_on) then
4061 0 : ierr=pio_inq_varid (tape(t)%Files(f),'byimf', tape(t)%byimfid)
4062 0 : ierr=pio_inq_varid (tape(t)%Files(f),'bzimf', tape(t)%bzimfid)
4063 0 : ierr=pio_inq_varid (tape(t)%Files(f),'swvel', tape(t)%swvelid)
4064 0 : ierr=pio_inq_varid (tape(t)%Files(f),'swden', tape(t)%swdenid)
4065 : endif
4066 768 : if (epot_active) then
4067 0 : ierr=pio_inq_varid (tape(t)%Files(f),'colat_crit1', tape(t)%colat_crit1_id)
4068 0 : ierr=pio_inq_varid (tape(t)%Files(f),'colat_crit2', tape(t)%colat_crit2_id)
4069 : endif
4070 : end if
4071 : end if
4072 1536 : ierr=pio_inq_varid (tape(t)%Files(f),'date ', tape(t)%dateid)
4073 1536 : ierr=pio_inq_varid (tape(t)%Files(f),'datesec ', tape(t)%datesecid)
4074 1536 : ierr=pio_inq_varid (tape(t)%Files(f),'time ', tape(t)%timeid)
4075 :
4076 : !
4077 : ! Obtain variable name from ID which was read from restart file
4078 : !
4079 1725696 : do fld=1,nflds(t)
4080 1723392 : if (f == accumulated_file_index) then
4081 : ! this is the accumulated file - skip instantaneous fields
4082 861696 : if (tape(t)%hlist(fld)%avgflag == 'I') then
4083 : cycle
4084 : end if
4085 : else
4086 : ! this is the instantaneous file - skip accumulated fields
4087 861696 : if (tape(t)%hlist(fld)%avgflag /= 'I') then
4088 : cycle
4089 : end if
4090 : end if
4091 :
4092 861696 : if(.not. associated(tape(t)%hlist(fld)%varid)) then
4093 861696 : if (associated(tape(t)%patches)) then
4094 0 : allocate(tape(t)%hlist(fld)%varid(size(tape(t)%patches)))
4095 : else
4096 861696 : allocate(tape(t)%hlist(fld)%varid(1))
4097 : end if
4098 : end if
4099 : !
4100 : ! If this field will be put out as columns then get column names for field
4101 : !
4102 861696 : if (associated(tape(t)%patches)) then
4103 0 : num_patches = size(tape(t)%patches)
4104 0 : fldname = strip_suffix(tape(t)%hlist(fld)%field%name)
4105 0 : do i = 1, num_patches
4106 0 : fname_tmp = trim(fldname)
4107 0 : call tape(t)%patches(i)%field_name(fname_tmp)
4108 0 : ierr = pio_inq_varid(tape(t)%Files(f), trim(fname_tmp), tape(t)%hlist(fld)%varid(i))
4109 0 : call cam_pio_handle_error(ierr, 'H_INQUIRE: Error getting ID for '//trim(fname_tmp))
4110 0 : ierr = pio_get_att(tape(t)%Files(f), tape(t)%hlist(fld)%varid(i), 'basename', basename)
4111 0 : call cam_pio_handle_error(ierr, 'H_INQUIRE: Error getting basename for '//trim(fname_tmp))
4112 0 : if (trim(fldname) /= trim(basename)) then
4113 0 : call endrun('H_INQUIRE: basename ('//trim(basename)//') does not match fldname ('//trim(fldname)//')')
4114 : end if
4115 : end do
4116 : else
4117 861696 : fldname = tape(t)%hlist(fld)%field%name
4118 861696 : ierr = pio_inq_varid(tape(t)%Files(f), trim(fldname), tape(t)%hlist(fld)%varid(1))
4119 861696 : call cam_pio_handle_error(ierr, 'H_INQUIRE: Error getting ID for '//trim(fldname))
4120 : end if
4121 863232 : if(tape(t)%hlist(fld)%field%numlev>1) then
4122 417792 : ierr = pio_inq_attlen(tape(t)%Files(f),tape(t)%hlist(fld)%varid(1),'mdims', mdimsize)
4123 417792 : if(.not. associated(tape(t)%hlist(fld)%field%mdims)) then
4124 0 : allocate(tape(t)%hlist(fld)%field%mdims(mdimsize))
4125 : end if
4126 0 : ierr=pio_get_att(tape(t)%Files(f),tape(t)%hlist(fld)%varid(1),'mdims', &
4127 417792 : tape(t)%hlist(fld)%field%mdims(1:mdimsize))
4128 417792 : if(mdimsize > int(maxvarmdims, kind=pio_offset_kind)) then
4129 0 : maxvarmdims = int(mdimsize)
4130 : end if
4131 : end if
4132 :
4133 : end do
4134 : end do
4135 768 : if(masterproc) then
4136 1 : write(iulog,*)'H_INQUIRE: Successfully opened netcdf file '
4137 : end if
4138 :
4139 768 : return
4140 768 : end subroutine h_inquire
4141 :
4142 : !#######################################################################
4143 :
4144 1712640 : subroutine add_default (name, tindex, flag)
4145 : !
4146 : !-----------------------------------------------------------------------
4147 : !
4148 : ! Purpose: Add a field to the default "on" list for a given history file
4149 : !
4150 : ! Method:
4151 : !
4152 : !-----------------------------------------------------------------------
4153 : !
4154 : ! Arguments
4155 : !
4156 : character(len=*), intent(in) :: name ! field name
4157 : character(len=1), intent(in) :: flag ! averaging flag
4158 :
4159 : integer, intent(in) :: tindex ! history tape index
4160 : !
4161 : ! Local workspace
4162 : !
4163 : integer :: t ! file index
4164 : type(master_entry), pointer :: listentry
4165 :
4166 1712640 : if (htapes_defined) then
4167 0 : call endrun ('ADD_DEFAULT: Attempt to add hist default '//trim(name)//' after history files set')
4168 : end if
4169 : !
4170 : ! Check validity of input arguments
4171 : !
4172 1712640 : if (tindex > ptapes) then
4173 0 : write(iulog,*)'ADD_DEFAULT: tape index=', tindex, ' is too big'
4174 0 : call endrun
4175 : end if
4176 :
4177 : ! Add to IC file if tindex = 0, reset to ptapes
4178 1712640 : if (tindex == 0) then
4179 316416 : t = ptapes
4180 316416 : if ( .not. is_initfile(file_index=t) ) return
4181 : else
4182 1396224 : t = tindex
4183 : end if
4184 :
4185 1712640 : if (verify(flag, HIST_AVG_FLAGS) /= 0) then
4186 0 : call endrun ('ADD_DEFAULT: unknown averaging flag='//flag)
4187 : end if
4188 : !
4189 : ! Look through master list for input field name. When found, set active
4190 : ! flag for that tape to true. Also set averaging flag if told to use other
4191 : ! than default.
4192 : !
4193 1712640 : listentry => get_entry_by_name(masterlinkedlist, trim(name))
4194 1712640 : if(.not.associated(listentry)) then
4195 0 : call endrun ('ADD_DEFAULT: field = "'//trim(name)//'" not found')
4196 : end if
4197 1712640 : listentry%actflag(t) = .true.
4198 1712640 : if (flag /= ' ') then
4199 316416 : listentry%avgflag(t) = flag
4200 : call AvgflagToString(flag, listentry%time_op(t))
4201 : end if
4202 :
4203 : return
4204 768 : end subroutine add_default
4205 :
4206 : !#######################################################################
4207 :
4208 6912 : subroutine h_override (t)
4209 : !
4210 : !-----------------------------------------------------------------------
4211 : !
4212 : ! Purpose: Override default history tape contents for a specific tape
4213 : !
4214 : ! Method: Copy the flag into the master field list
4215 : !
4216 : !-----------------------------------------------------------------------
4217 : !
4218 : ! Arguments
4219 : !
4220 : integer, intent(in) :: t ! history tape index
4221 : !
4222 : ! Local workspace
4223 : !
4224 : character(len=1) :: avgflg ! lcl equiv of avgflag_pertape(t) (to address xlf90 compiler bug)
4225 :
4226 : type(master_entry), pointer :: listentry
4227 :
4228 6912 : avgflg = avgflag_pertape(t)
4229 :
4230 6912 : listentry=>masterlinkedlist
4231 56166912 : do while(associated(listentry))
4232 : ! Budgets require flag to be N, dont override
4233 56160000 : if (listentry%avgflag(t) /= 'N' ) then
4234 : call AvgflagToString(avgflg, listentry%time_op(t))
4235 56160000 : listentry%avgflag(t) = avgflag_pertape(t)
4236 : end if
4237 56160000 : listentry=>listentry%next_entry
4238 : end do
4239 :
4240 6912 : end subroutine h_override
4241 :
4242 : !#######################################################################
4243 :
4244 9216 : subroutine h_define (t, restart)
4245 : !
4246 : !-----------------------------------------------------------------------
4247 : !
4248 : ! Purpose: Define contents of history file t
4249 : !
4250 : ! Method: Issue the required netcdf wrapper calls to define the history file contents
4251 : !
4252 : !-----------------------------------------------------------------------
4253 : use phys_control, only: phys_getopts
4254 : use cam_grid_support, only: cam_grid_header_info_t
4255 : use cam_grid_support, only: cam_grid_write_attr, cam_grid_write_var
4256 : use time_manager, only: get_step_size, get_ref_date, timemgr_get_calendar_cf
4257 : use cam_abortutils, only: endrun
4258 : use cam_pio_utils, only: vdesc_ptr, cam_pio_handle_error, cam_pio_def_dim
4259 : use cam_pio_utils, only: cam_pio_createfile, cam_pio_def_var
4260 : use sat_hist, only: sat_hist_define
4261 :
4262 : !-----------------------------------------------------------------------
4263 :
4264 : !
4265 : ! Input arguments
4266 : !
4267 : integer, intent(in) :: t ! tape index
4268 : logical, intent(in) :: restart
4269 : !
4270 : ! Local workspace
4271 : !
4272 : integer :: i, j, f ! longitude, latitude, file indices
4273 : integer :: grd ! indices for looping through grids
4274 : integer :: fld ! field index
4275 : integer :: ncreal ! real data type for output
4276 : integer :: dtime ! timestep size
4277 : integer :: sec_nhtfrq ! nhtfrq converted to seconds
4278 : integer :: ndbase = 0 ! days component of base time
4279 : integer :: nsbase = 0 ! seconds component of base time
4280 : integer :: nbdate ! base date in yyyymmdd format
4281 : integer :: nbsec ! time of day component of base date [seconds]
4282 : integer :: yr, mon, day ! year, month, day components of a date
4283 :
4284 : character(len=max_chars) :: str ! character temporary
4285 : character(len=max_chars) :: fname_tmp ! local copy of field name
4286 : character(len=max_chars) :: calendar ! Calendar type
4287 : character(len=max_chars) :: cell_methods ! For cell_methods attribute
4288 : character(len=16) :: time_per_freq
4289 : character(len=128) :: errormsg
4290 :
4291 : integer :: ret ! function return value
4292 :
4293 : !
4294 : ! netcdf dimensions
4295 : !
4296 : integer :: chardim ! character dimension id
4297 : integer :: dimenchar(2) ! character dimension ids
4298 : integer :: nacsdims(2) ! dimension ids for nacs (used in restart file)
4299 : integer :: bnddim ! bounds dimension id
4300 : integer :: timdim ! unlimited dimension id
4301 :
4302 : integer :: dimindex(8) ! dimension ids for variable declaration
4303 : integer :: dimids_tmp(8) ! dimension ids for variable declaration
4304 :
4305 : !
4306 : ! netcdf variables
4307 : !
4308 : ! A structure to hold the horizontal dimension and coordinate info
4309 9216 : type(cam_grid_header_info_t), allocatable :: header_info(:)
4310 : ! For satellite files and column output
4311 9216 : type(vdesc_ptr), allocatable :: latvar(:) ! latitude variable ids
4312 9216 : type(vdesc_ptr), allocatable :: lonvar(:) ! longitude variable ids
4313 :
4314 : type(var_desc_t), pointer :: varid => NULL() ! temporary variable descriptor
4315 : integer :: num_hdims, fdims
4316 : integer :: num_patches ! How many entries for a field on this tape?
4317 : integer, pointer :: mdims(:) => NULL()
4318 : integer :: mdimsize
4319 : integer :: ierr
4320 9216 : integer, allocatable :: mdimids(:)
4321 : integer :: amode
4322 : logical :: interpolate
4323 : logical :: patch_output
4324 : integer :: cam_snapshot_before_num
4325 : integer :: cam_snapshot_after_num
4326 : character(len=32) :: cam_take_snapshot_before
4327 : character(len=32) :: cam_take_snapshot_after
4328 :
4329 :
4330 : call phys_getopts(cam_take_snapshot_before_out= cam_take_snapshot_before, &
4331 : cam_take_snapshot_after_out = cam_take_snapshot_after, &
4332 : cam_snapshot_before_num_out = cam_snapshot_before_num, &
4333 9216 : cam_snapshot_after_num_out = cam_snapshot_after_num)
4334 :
4335 9216 : if(restart) then
4336 4608 : tape => restarthistory_tape
4337 4608 : if(masterproc) write(iulog,*)'Opening netcdf history restart file ', trim(hrestpath(t))
4338 : else
4339 4608 : tape => history_tape
4340 4608 : if(masterproc) then
4341 6 : if (hfile_accum(t)) then
4342 : ! We have an accumulated file in addition to the instantaneous
4343 6 : write(iulog,*)'Opening netcdf history files ', trim(nhfil(t,accumulated_file_index)), &
4344 12 : ' ', trim(nhfil(t,instantaneous_file_index))
4345 : else
4346 : ! We just have the instantaneous file
4347 0 : write(iulog,*)'Opening instantaneous netcdf history file ', trim(nhfil(t,instantaneous_file_index))
4348 : end if
4349 : end if
4350 : end if
4351 :
4352 9216 : amode = PIO_CLOBBER
4353 :
4354 9216 : if(restart) then
4355 4608 : call cam_pio_createfile (tape(t)%Files(restart_file_index), hrestpath(t), amode)
4356 4608 : else if (is_initfile(file_index=t) .or. is_satfile(t)) then
4357 0 : call cam_pio_createfile (tape(t)%Files(sat_file_index), nhfil(t,sat_file_index), amode)
4358 : else
4359 : ! figure out how many history files to generate for this tape
4360 : ! Always create the instantaneous file
4361 4608 : call cam_pio_createfile (tape(t)%Files(instantaneous_file_index), nhfil(t,instantaneous_file_index), amode)
4362 4608 : if (hfile_accum(t)) then
4363 : ! Conditionally create the accumulated file
4364 4608 : call cam_pio_createfile (tape(t)%Files(accumulated_file_index), nhfil(t,accumulated_file_index), amode)
4365 : end if
4366 : end if
4367 9216 : if(is_satfile(t)) then
4368 0 : interpolate = .false. ! !!XXgoldyXX: Do we ever want to support this?
4369 0 : patch_output = .false.
4370 0 : call cam_pio_def_dim(tape(t)%Files(sat_file_index), 'ncol', pio_unlimited, timdim)
4371 0 : call cam_pio_def_dim(tape(t)%Files(sat_file_index), 'nbnd', 2, bnddim)
4372 :
4373 0 : allocate(latvar(1), lonvar(1))
4374 0 : allocate(latvar(1)%vd, lonvar(1)%vd)
4375 0 : call cam_pio_def_var(tape(t)%Files(sat_file_index), 'lat', pio_double, (/timdim/), &
4376 0 : latvar(1)%vd)
4377 0 : ierr=pio_put_att (tape(t)%Files(sat_file_index), latvar(1)%vd, 'long_name', 'latitude')
4378 0 : ierr=pio_put_att (tape(t)%Files(sat_file_index), latvar(1)%vd, 'units', 'degrees_north')
4379 :
4380 0 : call cam_pio_def_var(tape(t)%Files(sat_file_index), 'lon', pio_double, (/timdim/), &
4381 0 : lonvar(1)%vd)
4382 0 : ierr=pio_put_att (tape(t)%Files(sat_file_index), lonvar(1)%vd,'long_name','longitude')
4383 0 : ierr=pio_put_att (tape(t)%Files(sat_file_index), lonvar(1)%vd,'units','degrees_east')
4384 : else
4385 : !
4386 : ! Setup netcdf file - create the dimensions of lat,lon,time,level
4387 : !
4388 : ! interpolate is only supported for unstructured dycores
4389 9216 : interpolate = (interpolate_output(t) .and. (.not. restart))
4390 9216 : patch_output = (associated(tape(t)%patches) .and. (.not. restart))
4391 :
4392 : ! First define the horizontal grid dims
4393 : ! Interpolation is special in that we ignore the native grids
4394 9216 : if(interpolate) then
4395 0 : allocate(header_info(1))
4396 0 : do f = 1, maxsplitfiles
4397 0 : if (pio_file_is_open(tape(t)%Files(f))) then
4398 0 : call cam_grid_write_attr(tape(t)%Files(f), interpolate_info(t)%grid_id, header_info(1), file_index=f)
4399 : end if
4400 : end do
4401 9216 : else if (patch_output) then
4402 : ! We are doing patch (column) output
4403 : if (allocated(header_info)) then
4404 : ! We shouldn't have any header_info yet
4405 : call endrun('H_DEFINE: header_info should not be allocated for patch output')
4406 : end if
4407 0 : do i = 1, size(tape(t)%patches)
4408 0 : do f = 1, maxsplitfiles
4409 0 : if (pio_file_is_open(tape(t)%Files(f))) then
4410 0 : call tape(t)%patches(i)%write_attrs(tape(t)%Files(f))
4411 : end if
4412 : end do
4413 : end do
4414 : else
4415 49152 : allocate(header_info(size(tape(t)%grid_ids)))
4416 30720 : do i = 1, size(tape(t)%grid_ids)
4417 73728 : do f = 1, maxsplitfiles
4418 64512 : if (pio_file_is_open(tape(t)%Files(f))) then
4419 35328 : call cam_grid_write_attr(tape(t)%Files(f), tape(t)%grid_ids(i), header_info(i), file_index=f)
4420 : end if
4421 : end do
4422 : end do
4423 : end if ! interpolate
4424 : ! Define the unlimited time dim
4425 27648 : do f = 1, maxsplitfiles
4426 27648 : if (pio_file_is_open(tape(t)%Files(f))) then
4427 13824 : call cam_pio_def_dim(tape(t)%Files(f), 'time', pio_unlimited, timdim)
4428 13824 : call cam_pio_def_dim(tape(t)%Files(f), 'nbnd', 2, bnddim, existOK=.true.)
4429 13824 : call cam_pio_def_dim(tape(t)%Files(f), 'chars', 8, chardim)
4430 : end if
4431 : end do
4432 : end if ! is satfile
4433 :
4434 9216 : call get_ref_date(yr, mon, day, nbsec)
4435 9216 : nbdate = yr*10000 + mon*100 + day
4436 9216 : calendar = timemgr_get_calendar_cf()
4437 : ! Determine what time period frequency is being output for each file
4438 : ! Note that nhtfrq is now in timesteps
4439 9216 : sec_nhtfrq = nhtfrq(t)
4440 : ! If nhtfrq is in hours, convert to seconds
4441 9216 : if (nhtfrq(t) < 0) then
4442 0 : sec_nhtfrq = abs(nhtfrq(t))*3600
4443 : end if
4444 9216 : dtime = get_step_size()
4445 9216 : if (sec_nhtfrq == 0) then !month
4446 0 : time_per_freq = 'month_1'
4447 9216 : else if (mod(sec_nhtfrq*dtime,86400) == 0) then ! day
4448 4608 : write(time_per_freq,999) 'day_',sec_nhtfrq*dtime/86400
4449 4608 : else if (mod(sec_nhtfrq*dtime,3600) == 0) then ! hour
4450 0 : write(time_per_freq,999) 'hour_',(sec_nhtfrq*dtime)/3600
4451 4608 : else if (mod(sec_nhtfrq*dtime,60) == 0) then ! minute
4452 4608 : write(time_per_freq,999) 'minute_',(sec_nhtfrq*dtime)/60
4453 : else ! second
4454 0 : write(time_per_freq,999) 'second_',sec_nhtfrq*dtime
4455 : end if
4456 : 999 format(a,i0)
4457 27648 : do f = 1, maxsplitfiles
4458 18432 : if (.not. pio_file_is_open(tape(t)%Files(f))) then
4459 : cycle
4460 : end if
4461 : ! Store snapshot location
4462 13824 : if (t == cam_snapshot_before_num) then
4463 0 : ierr=pio_put_att(tape(t)%Files(f), PIO_GLOBAL, 'cam_snapshot_before', &
4464 0 : trim(cam_take_snapshot_before))
4465 : end if
4466 13824 : if (t == cam_snapshot_after_num) then
4467 0 : ierr=pio_put_att(tape(t)%Files(f), PIO_GLOBAL, 'cam_snapshot_after', &
4468 0 : trim(cam_take_snapshot_after))
4469 : end if
4470 :
4471 : ! Populate the history coordinate (well, mdims anyway) attributes
4472 : ! This routine also allocates the mdimids array
4473 13824 : call write_hist_coord_attrs(tape(t)%Files(f), bnddim, mdimids, restart)
4474 :
4475 27648 : ierr=pio_def_var (tape(t)%Files(f),'time',pio_double,(/timdim/),tape(t)%timeid)
4476 :
4477 13824 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%timeid, 'long_name', 'time')
4478 13824 : str = 'days since ' // date2yyyymmdd(nbdate) // ' ' // sec2hms(nbsec)
4479 13824 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%timeid, 'units', trim(str))
4480 :
4481 13824 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%timeid, 'calendar', trim(calendar))
4482 :
4483 27648 : ierr=pio_def_var (tape(t)%Files(f),'date ',pio_int,(/timdim/),tape(t)%dateid)
4484 13824 : str = 'current date (YYYYMMDD)'
4485 13824 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%dateid, 'long_name', trim(str))
4486 :
4487 27648 : ierr=pio_def_var (tape(t)%Files(f),'datesec ',pio_int,(/timdim/), tape(t)%datesecid)
4488 13824 : str = 'current seconds of current date'
4489 13824 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%datesecid, 'long_name', trim(str))
4490 :
4491 : !
4492 : ! Character header information
4493 : !
4494 13824 : str = 'CF-1.0'
4495 13824 : ierr=pio_put_att (tape(t)%Files(f), PIO_GLOBAL, 'Conventions', trim(str))
4496 13824 : ierr=pio_put_att (tape(t)%Files(f), PIO_GLOBAL, 'source', 'CAM')
4497 : #if ( defined BFB_CAM_SCAM_IOP )
4498 : ierr=pio_put_att (tape(t)%Files(f), PIO_GLOBAL, 'CAM_GENERATED_FORCING','create SCAM IOP dataset')
4499 : #endif
4500 13824 : ierr=pio_put_att (tape(t)%Files(f), PIO_GLOBAL, 'case',caseid)
4501 13824 : ierr=pio_put_att (tape(t)%Files(f), PIO_GLOBAL, 'logname',logname)
4502 13824 : ierr=pio_put_att (tape(t)%Files(f), PIO_GLOBAL, 'host', host)
4503 :
4504 13824 : ierr=pio_put_att (tape(t)%Files(f), PIO_GLOBAL, 'initial_file', ncdata)
4505 13824 : ierr=pio_put_att (tape(t)%Files(f), PIO_GLOBAL, 'topography_file', bnd_topo)
4506 13824 : if (len_trim(model_doi_url) > 0) then
4507 13824 : ierr=pio_put_att (tape(t)%Files(f), PIO_GLOBAL, 'model_doi_url', model_doi_url)
4508 : end if
4509 :
4510 13824 : ierr=pio_put_att (tape(t)%Files(f), PIO_GLOBAL, 'time_period_freq', trim(time_per_freq))
4511 :
4512 13824 : if(.not. is_satfile(t)) then
4513 :
4514 : !
4515 : ! Character
4516 : !
4517 13824 : dimenchar(1) = chardim
4518 13824 : dimenchar(2) = timdim
4519 13824 : ierr=pio_def_var (tape(t)%Files(f),'date_written',PIO_CHAR,dimenchar, tape(t)%date_writtenid)
4520 13824 : ierr=pio_def_var (tape(t)%Files(f),'time_written',PIO_CHAR,dimenchar, tape(t)%time_writtenid)
4521 : !
4522 : ! Integer Header
4523 : !
4524 :
4525 13824 : ierr=pio_def_var (tape(t)%Files(f),'ndbase',PIO_INT,tape(t)%ndbaseid)
4526 13824 : str = 'base day'
4527 13824 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%ndbaseid, 'long_name', trim(str))
4528 :
4529 13824 : ierr=pio_def_var (tape(t)%Files(f),'nsbase',PIO_INT,tape(t)%nsbaseid)
4530 13824 : str = 'seconds of base day'
4531 13824 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%nsbaseid, 'long_name', trim(str))
4532 :
4533 13824 : ierr=pio_def_var (tape(t)%Files(f),'nbdate',PIO_INT,tape(t)%nbdateid)
4534 13824 : str = 'base date (YYYYMMDD)'
4535 13824 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%nbdateid, 'long_name', trim(str))
4536 :
4537 : #if ( defined BFB_CAM_SCAM_IOP )
4538 : ierr=pio_def_var (tape(t)%Files(f),'bdate',PIO_INT,tape(t)%bdateid)
4539 : str = 'base date (YYYYMMDD)'
4540 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%bdateid, 'long_name', trim(str))
4541 : #endif
4542 13824 : ierr=pio_def_var (tape(t)%Files(f),'nbsec',PIO_INT,tape(t)%nbsecid)
4543 13824 : str = 'seconds of base date'
4544 13824 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%nbsecid, 'long_name', trim(str))
4545 :
4546 13824 : ierr=pio_def_var (tape(t)%Files(f),'mdt',PIO_INT,tape(t)%mdtid)
4547 13824 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%mdtid, 'long_name', 'timestep')
4548 13824 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%mdtid, 'units', 's')
4549 :
4550 : !
4551 : ! Create variables for model timing and header information
4552 : !
4553 13824 : if (f == instantaneous_file_index) then
4554 18432 : ierr=pio_def_var (tape(t)%Files(f),'ndcur ',pio_int,(/timdim/),tape(t)%ndcurid)
4555 9216 : str = 'current day (from base day)'
4556 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%ndcurid, 'long_name', trim(str))
4557 18432 : ierr=pio_def_var (tape(t)%Files(f),'nscur ',pio_int,(/timdim/),tape(t)%nscurid)
4558 9216 : str = 'current seconds of current day'
4559 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%nscurid, 'long_name', trim(str))
4560 : end if
4561 :
4562 13824 : if (.not. is_initfile(file_index=t) .and. f == instantaneous_file_index) then
4563 : ! Don't write the GHG/Solar forcing data to the IC file.
4564 : ! Only write the GHG/Solar forcing data to the instantaneous file
4565 18432 : ierr=pio_def_var (tape(t)%Files(f),'co2vmr ',pio_double,(/timdim/),tape(t)%co2vmrid)
4566 9216 : str = 'co2 volume mixing ratio'
4567 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%co2vmrid, 'long_name', trim(str))
4568 :
4569 18432 : ierr=pio_def_var (tape(t)%Files(f),'ch4vmr ',pio_double,(/timdim/),tape(t)%ch4vmrid)
4570 9216 : str = 'ch4 volume mixing ratio'
4571 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%ch4vmrid, 'long_name', trim(str))
4572 :
4573 18432 : ierr=pio_def_var (tape(t)%Files(f),'n2ovmr ',pio_double,(/timdim/),tape(t)%n2ovmrid)
4574 9216 : str = 'n2o volume mixing ratio'
4575 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%n2ovmrid, 'long_name', trim(str))
4576 :
4577 18432 : ierr=pio_def_var (tape(t)%Files(f),'f11vmr ',pio_double,(/timdim/),tape(t)%f11vmrid)
4578 9216 : str = 'f11 volume mixing ratio'
4579 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%f11vmrid, 'long_name', trim(str))
4580 :
4581 18432 : ierr=pio_def_var (tape(t)%Files(f),'f12vmr ',pio_double,(/timdim/),tape(t)%f12vmrid)
4582 9216 : str = 'f12 volume mixing ratio'
4583 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%f12vmrid, 'long_name', trim(str))
4584 :
4585 18432 : ierr=pio_def_var (tape(t)%Files(f),'sol_tsi ',pio_double,(/timdim/),tape(t)%sol_tsiid)
4586 9216 : str = 'total solar irradiance'
4587 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%sol_tsiid, 'long_name', trim(str))
4588 9216 : str = 'W/m2'
4589 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%sol_tsiid, 'units', trim(str))
4590 :
4591 9216 : if (solar_parms_on) then
4592 : ! solar / geomagnetic activity indices...
4593 18432 : ierr=pio_def_var (tape(t)%Files(f),'f107',pio_double,(/timdim/),tape(t)%f107id)
4594 9216 : str = '10.7 cm solar radio flux (F10.7)'
4595 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%f107id, 'long_name', trim(str))
4596 9216 : str = '10^-22 W m^-2 Hz^-1'
4597 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%f107id, 'units', trim(str))
4598 :
4599 18432 : ierr=pio_def_var (tape(t)%Files(f),'f107a',pio_double,(/timdim/),tape(t)%f107aid)
4600 9216 : str = '81-day centered mean of 10.7 cm solar radio flux (F10.7)'
4601 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%f107aid, 'long_name', trim(str))
4602 :
4603 18432 : ierr=pio_def_var (tape(t)%Files(f),'f107p',pio_double,(/timdim/),tape(t)%f107pid)
4604 9216 : str = 'Pervious day 10.7 cm solar radio flux (F10.7)'
4605 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%f107pid, 'long_name', trim(str))
4606 :
4607 18432 : ierr=pio_def_var (tape(t)%Files(f),'kp',pio_double,(/timdim/),tape(t)%kpid)
4608 9216 : str = 'Daily planetary K geomagnetic index'
4609 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%kpid, 'long_name', trim(str))
4610 :
4611 18432 : ierr=pio_def_var (tape(t)%Files(f),'ap',pio_double,(/timdim/),tape(t)%apid)
4612 9216 : str = 'Daily planetary A geomagnetic index'
4613 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%apid, 'long_name', trim(str))
4614 : endif
4615 9216 : if (solar_wind_on) then
4616 :
4617 0 : ierr=pio_def_var (tape(t)%Files(f),'byimf',pio_double,(/timdim/),tape(t)%byimfid)
4618 0 : str = 'Y component of the interplanetary magnetic field'
4619 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%byimfid, 'long_name', trim(str))
4620 0 : str = 'nT'
4621 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%byimfid, 'units', trim(str))
4622 :
4623 0 : ierr=pio_def_var (tape(t)%Files(f),'bzimf',pio_double,(/timdim/),tape(t)%bzimfid)
4624 0 : str = 'Z component of the interplanetary magnetic field'
4625 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%bzimfid, 'long_name', trim(str))
4626 0 : str = 'nT'
4627 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%bzimfid, 'units', trim(str))
4628 :
4629 0 : ierr=pio_def_var (tape(t)%Files(f),'swvel',pio_double,(/timdim/),tape(t)%swvelid)
4630 0 : str = 'Solar wind speed'
4631 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%swvelid, 'long_name', trim(str))
4632 0 : str = 'km/sec'
4633 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%swvelid, 'units', trim(str))
4634 :
4635 0 : ierr=pio_def_var (tape(t)%Files(f),'swden',pio_double,(/timdim/),tape(t)%swdenid)
4636 0 : str = 'Solar wind ion number density'
4637 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%swdenid, 'long_name', trim(str))
4638 0 : str = 'cm-3'
4639 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%swdenid, 'units', trim(str))
4640 :
4641 : endif
4642 9216 : if (epot_active) then
4643 0 : ierr=pio_def_var (tape(t)%Files(f),'colat_crit1',pio_double,(/timdim/),tape(t)%colat_crit1_id)
4644 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%colat_crit1_id, 'long_name', &
4645 0 : 'First co-latitude of electro-potential critical angle')
4646 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%colat_crit1_id, 'units', 'degrees')
4647 :
4648 0 : ierr=pio_def_var (tape(t)%Files(f),'colat_crit2',pio_double,(/timdim/),tape(t)%colat_crit2_id)
4649 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%colat_crit2_id, 'long_name',&
4650 0 : 'Second co-latitude of electro-potential critical angle')
4651 0 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%colat_crit2_id, 'units', 'degrees')
4652 : endif
4653 : end if
4654 :
4655 13824 : if (f == instantaneous_file_index) then
4656 : #if ( defined BFB_CAM_SCAM_IOP )
4657 : ierr=pio_def_var (tape(t)%Files(f),'tsec ',pio_int,(/timdim/), tape(t)%tsecid)
4658 : str = 'current seconds of current date needed for scam'
4659 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%tsecid, 'long_name', trim(str))
4660 : #endif
4661 18432 : ierr=pio_def_var (tape(t)%Files(f),'nsteph ',pio_int,(/timdim/),tape(t)%nstephid)
4662 9216 : str = 'current timestep'
4663 9216 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%nstephid, 'long_name', trim(str))
4664 4608 : else if (f == accumulated_file_index) then
4665 13824 : ierr=pio_def_var (tape(t)%Files(f),'time_bounds',pio_double,(/bnddim,timdim/),tape(t)%tbndid)
4666 4608 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%timeid, 'bounds', 'time_bounds')
4667 4608 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%tbndid, 'long_name', 'time interval endpoints')
4668 4608 : str = 'days since ' // date2yyyymmdd(nbdate) // ' ' // sec2hms(nbsec)
4669 4608 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%tbndid, 'units', trim(str))
4670 4608 : ierr=pio_put_att (tape(t)%Files(f), tape(t)%tbndid, 'calendar', trim(calendar))
4671 : end if
4672 : end if ! .not. is_satfile
4673 :
4674 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4675 : !
4676 : ! Create variables and attributes for field list
4677 : !
4678 : !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
4679 :
4680 10540032 : do fld = 1, nflds(t)
4681 10526208 : if (.not. is_satfile(t) .and. .not. restart .and. .not. is_initfile(t)) then
4682 10340352 : if (f == accumulated_file_index) then
4683 : ! this is the accumulated file of a potentially split history tape - skip instantaneous fields
4684 5170176 : if (tape(t)%hlist(fld)%avgflag == 'I') then
4685 : cycle
4686 : end if
4687 : else
4688 : ! this is the instantaneous file of a potentially split history tape - skip accumulated fields
4689 5170176 : if (tape(t)%hlist(fld)%avgflag /= 'I') then
4690 : cycle
4691 : end if
4692 : end if
4693 : end if
4694 : !! Collect some field properties
4695 5356032 : call AvgflagToString(tape(t)%hlist(fld)%avgflag, tape(t)%hlist(fld)%time_op)
4696 5356032 : if ((tape(t)%hlist(fld)%hwrt_prec == 8) .or. restart) then
4697 185856 : ncreal = pio_double
4698 : else
4699 5170176 : ncreal = pio_real
4700 : end if
4701 :
4702 5356032 : if(associated(tape(t)%hlist(fld)%field%mdims)) then
4703 3971328 : mdims => tape(t)%hlist(fld)%field%mdims
4704 3971328 : mdimsize = size(mdims)
4705 1384704 : else if(tape(t)%hlist(fld)%field%numlev > 1) then
4706 0 : call endrun('mdims not defined for variable '//trim(tape(t)%hlist(fld)%field%name))
4707 : else
4708 : mdimsize=0
4709 : end if
4710 :
4711 : ! num_patches will loop through the number of patches (or just one
4712 : ! for the whole grid) for this field for this tape
4713 5356032 : if (patch_output) then
4714 0 : num_patches = size(tape(t)%patches)
4715 : else
4716 : num_patches = 1
4717 : end if
4718 5356032 : if(.not.associated(tape(t)%hlist(fld)%varid)) then
4719 16068096 : allocate(tape(t)%hlist(fld)%varid(num_patches))
4720 : end if
4721 5356032 : fname_tmp = strip_suffix(tape(t)%hlist(fld)%field%name)
4722 :
4723 5356032 : if(is_satfile(t)) then
4724 0 : num_hdims=0
4725 0 : nfils(t)=1
4726 0 : call sat_hist_define(tape(t)%Files(f))
4727 5356032 : else if (interpolate) then
4728 : ! Interpolate can't use normal grid code since we are forcing fields
4729 : ! to use interpolate decomp
4730 0 : if (.not. allocated(header_info)) then
4731 : ! Safety check
4732 0 : call endrun('h_define: header_info not allocated')
4733 : end if
4734 0 : num_hdims = 2
4735 0 : do i = 1, num_hdims
4736 0 : dimindex(i) = header_info(1)%get_hdimid(i)
4737 : end do
4738 5356032 : else if (patch_output) then
4739 : ! All patches for this variable should be on the same grid
4740 0 : num_hdims = tape(t)%patches(1)%num_hdims(tape(t)%hlist(fld)%field%decomp_type)
4741 : else
4742 : ! Normal grid output
4743 : ! Find appropriate grid in header_info
4744 5356032 : if (.not. allocated(header_info)) then
4745 : ! Safety check
4746 0 : call endrun('h_define: header_info not allocated')
4747 : end if
4748 5356032 : grd = -1
4749 10544640 : do i = 1, size(header_info)
4750 10544640 : if (header_info(i)%get_gridid() == tape(t)%hlist(fld)%field%decomp_type) then
4751 5356032 : grd = i
4752 5356032 : exit
4753 : end if
4754 : end do
4755 5356032 : if (grd < 0) then
4756 0 : write(errormsg, '(a,i0,2a)') 'grid, ',tape(t)%hlist(fld)%field%decomp_type,', not found for ',trim(fname_tmp)
4757 0 : call endrun('H_DEFINE: '//errormsg)
4758 : end if
4759 5356032 : num_hdims = header_info(grd)%num_hdims()
4760 16068096 : do i = 1, num_hdims
4761 16068096 : dimindex(i) = header_info(grd)%get_hdimid(i)
4762 : end do
4763 : end if ! is_satfile
4764 :
4765 : !
4766 : ! Create variables and atributes for fields written out as columns
4767 : !
4768 :
4769 16081920 : do i = 1, num_patches
4770 5356032 : fname_tmp = strip_suffix(tape(t)%hlist(fld)%field%name)
4771 5356032 : varid => tape(t)%hlist(fld)%varid(i)
4772 5356032 : dimids_tmp = dimindex
4773 : ! Figure the dimension ID array for this field
4774 : ! We have defined the horizontal grid dimensions in dimindex
4775 5356032 : fdims = num_hdims
4776 7942656 : do j = 1, mdimsize
4777 2586624 : fdims = fdims + 1
4778 7942656 : dimids_tmp(fdims) = mdimids(mdims(j))
4779 : end do
4780 5356032 : if(.not. restart) then
4781 : ! Only add time dimension if this is not a restart history tape
4782 5170176 : fdims = fdims + 1
4783 5170176 : dimids_tmp(fdims) = timdim
4784 : end if
4785 5356032 : if (patch_output) then
4786 : ! For patch output, we need new dimension IDs and a different name
4787 0 : call tape(t)%patches(i)%get_var_data(fname_tmp, &
4788 0 : dimids_tmp(1:fdims), tape(t)%hlist(fld)%field%decomp_type)
4789 : end if
4790 : ! Define the variable
4791 5356032 : call cam_pio_def_var(tape(t)%Files(f), trim(fname_tmp), ncreal, &
4792 10712064 : dimids_tmp(1:fdims), varid)
4793 5356032 : if (mdimsize > 0) then
4794 2586624 : ierr = pio_put_att(tape(t)%Files(f), varid, 'mdims', mdims(1:mdimsize))
4795 2586624 : call cam_pio_handle_error(ierr, 'h_define: cannot define mdims for '//trim(fname_tmp))
4796 : end if
4797 5356032 : str = tape(t)%hlist(fld)%field%sampling_seq
4798 5356032 : if (len_trim(str) > 0) then
4799 172032 : ierr = pio_put_att(tape(t)%Files(f), varid, 'Sampling_Sequence', trim(str))
4800 172032 : call cam_pio_handle_error(ierr, 'h_define: cannot define Sampling_Sequence for '//trim(fname_tmp))
4801 : end if
4802 :
4803 5356032 : if (tape(t)%hlist(fld)%field%flag_xyfill) then
4804 : ! Add both _FillValue and missing_value to cover expectations
4805 : ! of various applications.
4806 : ! The attribute type must match the data type.
4807 190464 : if ((tape(t)%hlist(fld)%hwrt_prec == 8) .or. restart) then
4808 10752 : ierr = pio_put_att(tape(t)%Files(f), varid, '_FillValue', &
4809 21504 : tape(t)%hlist(fld)%field%fillvalue)
4810 : call cam_pio_handle_error(ierr, &
4811 10752 : 'h_define: cannot define _FillValue for '//trim(fname_tmp))
4812 10752 : ierr = pio_put_att(tape(t)%Files(f), varid, 'missing_value', &
4813 21504 : tape(t)%hlist(fld)%field%fillvalue)
4814 : call cam_pio_handle_error(ierr, &
4815 10752 : 'h_define: cannot define missing_value for '//trim(fname_tmp))
4816 : else
4817 179712 : ierr = pio_put_att(tape(t)%Files(f), varid, '_FillValue', &
4818 359424 : REAL(tape(t)%hlist(fld)%field%fillvalue,r4))
4819 : call cam_pio_handle_error(ierr, &
4820 179712 : 'h_define: cannot define _FillValue for '//trim(fname_tmp))
4821 179712 : ierr = pio_put_att(tape(t)%Files(f), varid, 'missing_value', &
4822 359424 : REAL(tape(t)%hlist(fld)%field%fillvalue,r4))
4823 : call cam_pio_handle_error(ierr, &
4824 179712 : 'h_define: cannot define missing_value for '//trim(fname_tmp))
4825 : end if
4826 : end if
4827 :
4828 5356032 : str = tape(t)%hlist(fld)%field%units
4829 5356032 : if (len_trim(str) > 0) then
4830 5237760 : ierr=pio_put_att (tape(t)%Files(f), varid, 'units', trim(str))
4831 : call cam_pio_handle_error(ierr, &
4832 5237760 : 'h_define: cannot define units for '//trim(fname_tmp))
4833 : end if
4834 :
4835 5356032 : str = tape(t)%hlist(fld)%field%mixing_ratio
4836 5356032 : if (len_trim(str) > 0) then
4837 956928 : ierr=pio_put_att (tape(t)%Files(f), varid, 'mixing_ratio', trim(str))
4838 : call cam_pio_handle_error(ierr, &
4839 956928 : 'h_define: cannot define mixing_ratio for '//trim(fname_tmp))
4840 : end if
4841 :
4842 5356032 : str = tape(t)%hlist(fld)%field%long_name
4843 5356032 : ierr=pio_put_att (tape(t)%Files(f), varid, 'long_name', trim(str))
4844 : call cam_pio_handle_error(ierr, &
4845 5356032 : 'h_define: cannot define long_name for '//trim(fname_tmp))
4846 :
4847 : ! Assign field attributes defining valid levels and averaging info
4848 :
4849 5356032 : cell_methods = ''
4850 5356032 : if (len_trim(tape(t)%hlist(fld)%field%cell_methods) > 0) then
4851 29184 : if (len_trim(cell_methods) > 0) then
4852 0 : cell_methods = trim(cell_methods)//' '//trim(tape(t)%hlist(fld)%field%cell_methods)
4853 : else
4854 29184 : cell_methods = trim(cell_methods)//trim(tape(t)%hlist(fld)%field%cell_methods)
4855 : end if
4856 : end if
4857 : ! Time cell methods is after field method because time averaging is
4858 : ! applied later (just before output) than field method which is applied
4859 : ! before outfld call.
4860 5356032 : str = tape(t)%hlist(fld)%time_op
4861 5356032 : if (tape(t)%hlist(fld)%avgflag == 'I') then
4862 1536 : str = 'point'
4863 : else
4864 5354496 : str = tape(t)%hlist(fld)%time_op
4865 : end if
4866 5356032 : cell_methods = adjustl(trim(cell_methods)//' '//'time: '//str)
4867 5356032 : if (len_trim(cell_methods) > 0) then
4868 5356032 : ierr = pio_put_att(tape(t)%Files(f), varid, 'cell_methods', trim(cell_methods))
4869 : call cam_pio_handle_error(ierr, &
4870 5356032 : 'h_define: cannot define cell_methods for '//trim(fname_tmp))
4871 : end if
4872 5356032 : if (patch_output) then
4873 0 : ierr = pio_put_att(tape(t)%Files(f), varid, 'basename', &
4874 0 : tape(t)%hlist(fld)%field%name)
4875 : call cam_pio_handle_error(ierr, &
4876 0 : 'h_define: cannot define basename for '//trim(fname_tmp))
4877 : end if
4878 15882240 : if(restart) then
4879 : ! for standard deviation
4880 185856 : if (associated(tape(t)%hlist(fld)%sbuf)) then
4881 0 : fname_tmp = strip_suffix(tape(t)%hlist(fld)%field%name)
4882 0 : fname_tmp = trim(fname_tmp)//'_var'
4883 0 : if ( .not.associated(tape(t)%hlist(fld)%sbuf_varid)) then
4884 0 : allocate(tape(t)%hlist(fld)%sbuf_varid)
4885 : endif
4886 0 : call cam_pio_def_var(tape(t)%Files(f), trim(fname_tmp), pio_double, &
4887 0 : dimids_tmp(1:fdims), tape(t)%hlist(fld)%sbuf_varid)
4888 : endif
4889 : endif
4890 : end do ! Loop over output patches
4891 : end do ! Loop over fields
4892 13824 : if (restart) then
4893 190464 : do fld = 1, nflds(t)
4894 185856 : if(is_satfile(t)) then
4895 0 : num_hdims=0
4896 0 : nfils(t)=1
4897 185856 : else if (interpolate) then
4898 : ! Interpolate can't use normal grid code since we are forcing fields
4899 : ! to use interpolate decomp
4900 0 : if (.not. allocated(header_info)) then
4901 : ! Safety check
4902 0 : call endrun('h_define: header_info not allocated')
4903 : end if
4904 0 : num_hdims = 2
4905 0 : do i = 1, num_hdims
4906 0 : nacsdims(i) = header_info(1)%get_hdimid(i)
4907 : end do
4908 185856 : else if (patch_output) then
4909 : ! All patches for this variable should be on the same grid
4910 0 : num_hdims = tape(t)%patches(1)%num_hdims(tape(t)%hlist(fld)%field%decomp_type)
4911 : else
4912 : ! Normal grid output
4913 : ! Find appropriate grid in header_info
4914 185856 : if (.not. allocated(header_info)) then
4915 : ! Safety check
4916 0 : call endrun('h_define: header_info not allocated')
4917 : end if
4918 185856 : grd = -1
4919 204288 : do i = 1, size(header_info)
4920 204288 : if (header_info(i)%get_gridid() == tape(t)%hlist(fld)%field%decomp_type) then
4921 185856 : grd = i
4922 185856 : exit
4923 : end if
4924 : end do
4925 185856 : if (grd < 0) then
4926 0 : write(errormsg, '(a,i0,2a)') 'grid, ',tape(t)%hlist(fld)%field%decomp_type,', not found for ',trim(fname_tmp)
4927 0 : call endrun('H_DEFINE: '//errormsg)
4928 : end if
4929 185856 : num_hdims = header_info(grd)%num_hdims()
4930 557568 : do i = 1, num_hdims
4931 557568 : nacsdims(i) = header_info(grd)%get_hdimid(i)
4932 : end do
4933 : end if ! is_satfile
4934 :
4935 185856 : fname_tmp = strip_suffix(tape(t)%hlist(fld)%field%name)
4936 : ! For restart history files, we need to save accumulation counts
4937 185856 : fname_tmp = trim(fname_tmp)//'_nacs'
4938 185856 : if (.not. associated(tape(t)%hlist(fld)%nacs_varid)) then
4939 185856 : allocate(tape(t)%hlist(fld)%nacs_varid)
4940 : end if
4941 190464 : if (size(tape(t)%hlist(fld)%nacs, 1) > 1) then
4942 10752 : call cam_pio_def_var(tape(t)%Files(f), trim(fname_tmp), pio_int, &
4943 21504 : nacsdims(1:num_hdims), tape(t)%hlist(fld)%nacs_varid)
4944 : else
4945 : ! Save just one value representing all chunks
4946 175104 : call cam_pio_def_var(tape(t)%Files(f), trim(fname_tmp), pio_int, &
4947 350208 : tape(t)%hlist(fld)%nacs_varid)
4948 : end if
4949 :
4950 : end do ! Loop over fields
4951 : end if
4952 : !
4953 13824 : deallocate(mdimids)
4954 13824 : ret = pio_enddef(tape(t)%Files(f))
4955 13824 : if (ret /= PIO_NOERR) then
4956 0 : call endrun('H_DEFINE: ERROR exiting define mode in PIO')
4957 : end if
4958 :
4959 36864 : if(masterproc) then
4960 18 : write(iulog,*)'H_DEFINE: Successfully opened netcdf file '
4961 : endif
4962 : end do ! Loop over files
4963 : !
4964 : ! Write time-invariant portion of history header
4965 : !
4966 9216 : if(.not. is_satfile(t)) then
4967 9216 : if(interpolate) then
4968 0 : do f = 1, maxsplitfiles
4969 0 : if (pio_file_is_open(tape(t)%Files(f))) then
4970 0 : call cam_grid_write_var(tape(t)%Files(f), interpolate_info(t)%grid_id, file_index=f)
4971 : end if
4972 : end do
4973 9216 : else if((.not. patch_output) .or. restart) then
4974 30720 : do i = 1, size(tape(t)%grid_ids)
4975 73728 : do f = 1, maxsplitfiles
4976 64512 : if (pio_file_is_open(tape(t)%Files(f))) then
4977 35328 : call cam_grid_write_var(tape(t)%Files(f), tape(t)%grid_ids(i), file_index=f)
4978 : end if
4979 : end do
4980 : end do
4981 : else
4982 : ! Patch output
4983 0 : do i = 1, size(tape(t)%patches)
4984 0 : do f = 1, maxsplitfiles
4985 0 : if (pio_file_is_open(tape(t)%Files(f))) then
4986 0 : call tape(t)%patches(i)%write_vals(tape(t)%Files(f))
4987 : end if
4988 : end do
4989 : end do
4990 : end if ! interpolate
4991 9216 : if (allocated(lonvar)) then
4992 0 : deallocate(lonvar)
4993 : end if
4994 9216 : if (allocated(latvar)) then
4995 0 : deallocate(latvar)
4996 : end if
4997 :
4998 9216 : dtime = get_step_size()
4999 27648 : do f = 1, maxsplitfiles
5000 18432 : if (.not. pio_file_is_open(tape(t)%Files(f))) then
5001 : cycle
5002 : end if
5003 27648 : ierr = pio_put_var(tape(t)%Files(f), tape(t)%mdtid, (/dtime/))
5004 13824 : call cam_pio_handle_error(ierr, 'h_define: cannot put mdt')
5005 : !
5006 : ! Model date info
5007 : !
5008 27648 : ierr = pio_put_var(tape(t)%Files(f), tape(t)%ndbaseid, (/ndbase/))
5009 13824 : call cam_pio_handle_error(ierr, 'h_define: cannot put ndbase')
5010 27648 : ierr = pio_put_var(tape(t)%Files(f), tape(t)%nsbaseid, (/nsbase/))
5011 13824 : call cam_pio_handle_error(ierr, 'h_define: cannot put nsbase')
5012 :
5013 27648 : ierr = pio_put_var(tape(t)%Files(f), tape(t)%nbdateid, (/nbdate/))
5014 13824 : call cam_pio_handle_error(ierr, 'h_define: cannot put nbdate')
5015 : #if ( defined BFB_CAM_SCAM_IOP )
5016 : ierr = pio_put_var(tape(t)%Files(f), tape(t)%bdateid, (/nbdate/))
5017 : call cam_pio_handle_error(ierr, 'h_define: cannot put bdate')
5018 : #endif
5019 27648 : ierr = pio_put_var(tape(t)%Files(f), tape(t)%nbsecid, (/nbsec/))
5020 27648 : call cam_pio_handle_error(ierr, 'h_define: cannot put nbsec')
5021 : !
5022 : ! Reduced grid info
5023 : !
5024 : end do
5025 : end if ! .not. is_satfile
5026 :
5027 9216 : if (allocated(header_info)) then
5028 30720 : do i = 1, size(header_info)
5029 30720 : call header_info(i)%deallocate()
5030 : end do
5031 30720 : deallocate(header_info)
5032 : end if
5033 :
5034 :
5035 : ! Write the mdim variable data
5036 27648 : do f = 1, maxsplitfiles
5037 27648 : if (pio_file_is_open(tape(t)%Files(f))) then
5038 13824 : call write_hist_coord_vars(tape(t)%Files(f), restart)
5039 : end if
5040 : end do
5041 :
5042 9216 : end subroutine h_define
5043 :
5044 : !#######################################################################
5045 :
5046 5170176 : subroutine h_normalize (fld, t)
5047 :
5048 9216 : use cam_history_support, only: dim_index_2d
5049 : use time_manager, only: get_nstep
5050 :
5051 : !
5052 : !-----------------------------------------------------------------------
5053 : !
5054 : ! Purpose: Normalize fields on a history file by the number of accumulations
5055 : !
5056 : ! Method: Loop over fields on the tape. Need averaging flag and number of
5057 : ! accumulations to perform normalization.
5058 : !
5059 : !-----------------------------------------------------------------------
5060 : !
5061 : ! Input arguments
5062 : !
5063 : integer, intent(in) :: fld ! field index
5064 : integer, intent(in) :: t ! tape index
5065 : !
5066 : ! Local workspace
5067 : !
5068 : type (dim_index_2d) :: dimind ! 2-D dimension index
5069 : integer :: c ! chunk (or lat) index
5070 : integer :: ib, ie ! beginning and ending indices of first dimension
5071 : integer :: jb, je ! beginning and ending indices of second dimension
5072 : integer :: begdim3, enddim3 ! Chunk or block bounds
5073 : integer :: k ! level
5074 : integer :: i, ii
5075 : integer :: currstep, nsteps
5076 : real(r8) :: variance, tmpfill
5077 :
5078 : logical :: flag_xyfill ! non-applicable xy points flagged with fillvalue
5079 : character*1 :: avgflag ! averaging flag
5080 : character(len=max_chars) :: errmsg
5081 : character(len=*), parameter :: sub='H_NORMALIZE:'
5082 :
5083 5170176 : call t_startf ('h_normalize')
5084 :
5085 5170176 : call tape(t)%hlist(fld)%field%get_bounds(3, begdim3, enddim3)
5086 :
5087 : !
5088 : ! normalize by number of accumulations for averaged case
5089 : !
5090 5170176 : flag_xyfill = tape(t)%hlist(fld)%field%flag_xyfill
5091 5170176 : avgflag = tape(t)%hlist(fld)%avgflag
5092 :
5093 30956544 : do c = begdim3, enddim3
5094 25786368 : dimind = tape(t)%hlist(fld)%field%get_dims(c)
5095 :
5096 25786368 : ib = dimind%beg1
5097 25786368 : ie = dimind%end1
5098 25786368 : jb = dimind%beg2
5099 25786368 : je = dimind%end2
5100 :
5101 25786368 : if (flag_xyfill) then
5102 11335680 : do k = jb, je
5103 172067328 : where (tape(t)%hlist(fld)%nacs(ib:ie, c) == 0)
5104 20874240 : tape(t)%hlist(fld)%hbuf(ib:ie,k,c) = tape(t)%hlist(fld)%field%fillvalue
5105 : endwhere
5106 : end do
5107 : end if
5108 :
5109 25786368 : if (avgflag == 'A' .or. avgflag == 'B' .or. avgflag == 'L') then
5110 25740288 : if (size(tape(t)%hlist(fld)%nacs, 1) > 1) then
5111 11335680 : do k = jb, je
5112 161630208 : where (tape(t)%hlist(fld)%nacs(ib:ie,c) /= 0)
5113 : tape(t)%hlist(fld)%hbuf(ib:ie,k,c) = &
5114 20874240 : tape(t)%hlist(fld)%hbuf(ib:ie,k,c) &
5115 20874240 : / tape(t)%hlist(fld)%nacs(ib:ie,c)
5116 : endwhere
5117 : end do
5118 24841728 : else if(tape(t)%hlist(fld)%nacs(1,c) > 0) then
5119 898324992 : do k=jb,je
5120 : tape(t)%hlist(fld)%hbuf(ib:ie,k,c) = &
5121 0 : tape(t)%hlist(fld)%hbuf(ib:ie,k,c) &
5122 13443383808 : / tape(t)%hlist(fld)%nacs(1,c)
5123 : end do
5124 : end if
5125 : end if
5126 25786368 : currstep=get_nstep()
5127 25786368 : if (avgflag == 'N' .and. currstep > 0) then
5128 0 : if( currstep > tape(t)%hlist(fld)%beg_nstep) then
5129 0 : nsteps=currstep-tape(t)%hlist(fld)%beg_nstep
5130 0 : do k=jb,je
5131 : tape(t)%hlist(fld)%hbuf(ib:ie,k,c) = &
5132 0 : tape(t)%hlist(fld)%hbuf(ib:ie,k,c) &
5133 0 : / nsteps
5134 : end do
5135 : else
5136 0 : write(errmsg,*) sub,'FATAL: bad nstep normalization, currstep, beg_nstep=',currstep,',',tape(t)%hlist(fld)%beg_nstep
5137 0 : call endrun(trim(errmsg))
5138 : end if
5139 : end if
5140 30956544 : if (avgflag == 'S') then
5141 : ! standard deviation ...
5142 : ! from http://www.johndcook.com/blog/standard_deviation/
5143 0 : tmpfill = merge(tape(t)%hlist(fld)%field%fillvalue,0._r8,flag_xyfill)
5144 0 : do k=jb,je
5145 0 : do i = ib,ie
5146 0 : ii = merge(i,1,flag_xyfill)
5147 0 : if (tape(t)%hlist(fld)%nacs(ii,c) > 1) then
5148 0 : variance = tape(t)%hlist(fld)%sbuf(i,k,c)/(tape(t)%hlist(fld)%nacs(ii,c)-1)
5149 0 : tape(t)%hlist(fld)%hbuf(i,k,c) = sqrt(variance)
5150 : else
5151 0 : tape(t)%hlist(fld)%hbuf(i,k,c) = tmpfill
5152 : endif
5153 : end do
5154 : end do
5155 : endif
5156 : end do
5157 :
5158 5170176 : call t_stopf ('h_normalize')
5159 :
5160 5170176 : return
5161 5170176 : end subroutine h_normalize
5162 :
5163 : !#######################################################################
5164 :
5165 7237632 : subroutine h_zero (fld, t)
5166 5170176 : use cam_history_support, only: dim_index_2d
5167 : use time_manager, only: get_nstep, is_first_restart_step
5168 : !
5169 : !-----------------------------------------------------------------------
5170 : !
5171 : ! Purpose: Zero out accumulation buffers for a tape
5172 : !
5173 : ! Method: Loop through fields on the tape
5174 : !
5175 : !-----------------------------------------------------------------------
5176 : !
5177 : integer, intent(in) :: fld ! field index
5178 : integer, intent(in) :: t ! tape index
5179 : !
5180 : ! Local workspace
5181 : !
5182 : type (dim_index_2d) :: dimind ! 2-D dimension index
5183 : integer :: c ! chunk index
5184 : integer :: begdim3 ! on-node chunk or lat start index
5185 : integer :: enddim3 ! on-node chunk or lat end index
5186 :
5187 7237632 : call t_startf ('h_zero')
5188 :
5189 7237632 : call tape(t)%hlist(fld)%field%get_bounds(3, begdim3, enddim3)
5190 :
5191 42998784 : do c = begdim3, enddim3
5192 35761152 : dimind = tape(t)%hlist(fld)%field%get_dims(c)
5193 19420848384 : tape(t)%hlist(fld)%hbuf(dimind%beg1:dimind%end1,dimind%beg2:dimind%end2,c)=0._r8
5194 42998784 : if (associated(tape(t)%hlist(fld)%sbuf)) then ! zero out variance buffer for standard deviation
5195 0 : tape(t)%hlist(fld)%sbuf(dimind%beg1:dimind%end1,dimind%beg2:dimind%end2,c)=0._r8
5196 : end if
5197 : end do
5198 97537536 : tape(t)%hlist(fld)%nacs(:,:) = 0
5199 :
5200 : !Don't reset beg_nstep if this is a restart
5201 7237632 : if (.not. is_first_restart_step()) tape(t)%hlist(fld)%beg_nstep = get_nstep()
5202 :
5203 7237632 : call t_stopf ('h_zero')
5204 :
5205 7237632 : return
5206 7237632 : end subroutine h_zero
5207 :
5208 : !#######################################################################
5209 :
5210 5356032 : subroutine h_global (fld, t)
5211 :
5212 7237632 : use cam_history_support, only: dim_index_2d
5213 : use shr_reprosum_mod, only: shr_reprosum_calc
5214 : use spmd_utils, only: mpicom
5215 : !
5216 : !-----------------------------------------------------------------------
5217 : !
5218 : ! Purpose: compute globals of field
5219 : !
5220 : ! Method: Loop through fields on the tape
5221 : !
5222 : !-----------------------------------------------------------------------
5223 : !
5224 : integer, intent(in) :: fld ! field index
5225 : integer, intent(in) :: t ! tape index
5226 : !
5227 : ! Local workspace
5228 : !
5229 : type (dim_index_2d) :: dimind ! 2-D dimension index
5230 : integer :: ie ! dim3 index
5231 : integer :: count ! tmp index
5232 : integer :: i1 ! dim1 index
5233 : integer :: j1 ! dim2 index
5234 : integer :: fdims(3) ! array shape
5235 : integer :: begdim1,enddim1,begdim2,enddim2,begdim3,enddim3 !
5236 : real(r8) :: globalsum(1) ! globalsum
5237 5356032 : real(r8), allocatable :: globalarr(:) ! globalarr values for this pe
5238 :
5239 5356032 : call t_startf ('h_global')
5240 :
5241 : ! wbuf contains the area weighting for this field decomposition
5242 5356032 : if (associated(tape(t)%hlist(fld)%wbuf) ) then
5243 :
5244 0 : begdim1 = tape(t)%hlist(fld)%field%begdim1
5245 0 : enddim1 = tape(t)%hlist(fld)%field%enddim1
5246 0 : fdims(1) = enddim1 - begdim1 + 1
5247 0 : begdim2 = tape(t)%hlist(fld)%field%begdim2
5248 0 : enddim2 = tape(t)%hlist(fld)%field%enddim2
5249 0 : fdims(2) = enddim2 - begdim2 + 1
5250 0 : begdim3 = tape(t)%hlist(fld)%field%begdim3
5251 0 : enddim3 = tape(t)%hlist(fld)%field%enddim3
5252 0 : fdims(3) = enddim3 - begdim3 + 1
5253 :
5254 0 : allocate(globalarr(fdims(1)*fdims(2)*fdims(3)))
5255 0 : count=0
5256 0 : globalarr=0._r8
5257 0 : do ie = begdim3, enddim3
5258 0 : dimind = tape(t)%hlist(fld)%field%get_dims(ie)
5259 0 : do j1 = dimind%beg2, dimind%end2
5260 0 : do i1 = dimind%beg1, dimind%end1
5261 0 : count=count+1
5262 0 : globalarr(count)=globalarr(count)+tape(t)%hlist(fld)%hbuf(i1,j1,ie)*tape(t)%hlist(fld)%wbuf(i1,ie)
5263 : end do
5264 : end do
5265 : end do
5266 : ! call fixed-point algorithm
5267 0 : call shr_reprosum_calc (globalarr, globalsum, count, count, 1, commid=mpicom)
5268 0 : if (masterproc) write(iulog,*)'h_global:field:',trim(tape(t)%hlist(fld)%field%name),' global integral=',globalsum(1)
5269 : ! store global entry for this history tape entry
5270 0 : call tape(t)%hlist(fld)%put_global(globalsum(1))
5271 : ! deallocate temp array
5272 0 : deallocate(globalarr)
5273 : end if
5274 5356032 : call t_stopf ('h_global')
5275 5356032 : end subroutine h_global
5276 :
5277 0 : subroutine h_field_op (fld, t)
5278 5356032 : use cam_history_support, only: dim_index_2d
5279 : !
5280 : !-----------------------------------------------------------------------
5281 : !
5282 : ! Purpose: run field sum or dif opperation on all contructed fields
5283 : !
5284 : ! Method: Loop through fields on the tape
5285 : !
5286 : !-----------------------------------------------------------------------
5287 : !
5288 : integer, intent(in) :: fld ! field index
5289 : integer, intent(in) :: t ! tape index
5290 : !
5291 : ! Local workspace
5292 : !
5293 : type (dim_index_2d) :: dimind ! 2-D dimension index
5294 : integer :: c ! chunk index
5295 : integer :: fld1,fld2 ! fields to be operated on
5296 : integer :: begdim1, begdim2, begdim3 ! on-node chunk or lat start index
5297 : integer :: enddim1, enddim2, enddim3 ! on-node chunk or lat end index
5298 : character(len=field_op_len) :: optype ! field operation only sum or diff supported
5299 :
5300 0 : call t_startf ('h_field_op')
5301 0 : fld1 = tape(t)%hlist(fld)%field%op_field1_id
5302 0 : fld2 = tape(t)%hlist(fld)%field%op_field2_id
5303 0 : optype = trim(adjustl(tape(t)%hlist(fld)%field%field_op))
5304 :
5305 0 : begdim3 = tape(t)%hlist(fld)%field%begdim3
5306 0 : enddim3 = tape(t)%hlist(fld)%field%enddim3
5307 :
5308 0 : do c = begdim3, enddim3
5309 0 : dimind = tape(t)%hlist(fld)%field%get_dims(c)
5310 0 : if (trim(optype) == 'dif') then
5311 0 : tape(t)%hlist(fld)%hbuf(dimind%beg1:dimind%end1,dimind%beg2:dimind%end2,c) = &
5312 0 : tape(t)%hlist(fld1)%hbuf(dimind%beg1:dimind%end1,dimind%beg2:dimind%end2,c) - &
5313 0 : tape(t)%hlist(fld2)%hbuf(dimind%beg1:dimind%end1,dimind%beg2:dimind%end2,c)
5314 0 : else if (trim(optype) == 'sum') then
5315 0 : tape(t)%hlist(fld)%hbuf(dimind%beg1:dimind%end1,dimind%beg2:dimind%end2,c) = &
5316 0 : tape(t)%hlist(fld1)%hbuf(dimind%beg1:dimind%end1,dimind%beg2:dimind%end2,c) + &
5317 0 : tape(t)%hlist(fld2)%hbuf(dimind%beg1:dimind%end1,dimind%beg2:dimind%end2,c)
5318 : else
5319 0 : call endrun('h_field_op: ERROR: composed field operation type unknown:'//trim(optype))
5320 : end if
5321 : end do
5322 : ! Set nsteps for composed fields using value of one of the component fields
5323 0 : tape(t)%hlist(fld)%beg_nstep=tape(t)%hlist(fld1)%beg_nstep
5324 0 : tape(t)%hlist(fld)%nacs(:,:)=tape(t)%hlist(fld1)%nacs(:,:)
5325 0 : call t_stopf ('h_field_op')
5326 0 : end subroutine h_field_op
5327 :
5328 : !#######################################################################
5329 :
5330 5356032 : subroutine dump_field (fld, t, f, restart)
5331 0 : use cam_history_support, only: history_patch_t, dim_index_2d, dim_index_3d
5332 : use cam_grid_support, only: cam_grid_write_dist_array, cam_grid_dimensions
5333 : use interp_mod, only : write_interpolated
5334 :
5335 : ! Dummy arguments
5336 : integer, intent(in) :: fld ! Field index
5337 : integer, intent(in) :: t ! Tape index
5338 : integer, intent(in) :: f ! File index
5339 : logical, intent(in) :: restart
5340 : !
5341 : !-----------------------------------------------------------------------
5342 : !
5343 : ! Purpose: Write a variable to a history tape using PIO
5344 : ! For restart tapes, also write the accumulation buffer (nacs)
5345 : !
5346 : !-----------------------------------------------------------------------
5347 : ! Local variables
5348 : integer :: ierr
5349 : type(var_desc_t), pointer :: varid ! PIO ID for var
5350 : type(var_desc_t), pointer :: compid ! PIO ID for vector comp.
5351 : integer :: compind ! index of vector comp.
5352 : integer :: fdims(8) ! Field file dim sizes
5353 : integer :: frank ! Field file rank
5354 : integer :: nacsrank ! Field file rank for nacs
5355 : type(dim_index_2d) :: dimind2 ! 2-D dimension index
5356 : type(dim_index_3d) :: dimind ! 3-D dimension index
5357 : integer :: adims(3) ! Field array dim sizes
5358 : integer :: nadims ! # of used adims
5359 : integer :: fdecomp
5360 : integer :: num_patches
5361 : integer :: mdimsize ! Total # on-node elements
5362 : integer :: bdim3, edim3
5363 : integer :: ncreal ! Real output kind (double or single)
5364 : logical :: interpolate
5365 : logical :: patch_output
5366 : type(history_patch_t), pointer :: patchptr
5367 : integer :: index
5368 5356032 : real(r4), allocatable :: rtemp2(:,:)
5369 5356032 : real(r4), allocatable :: rtemp3(:,:,:)
5370 : integer :: begdim3, enddim3, ind3
5371 :
5372 5356032 : interpolate = (interpolate_output(t) .and. (.not. restart))
5373 5356032 : patch_output = (associated(tape(t)%patches) .and. (.not. restart))
5374 :
5375 : !!! Get the field's shape and decomposition
5376 :
5377 : ! Shape on disk
5378 5356032 : call tape(t)%hlist(fld)%field%get_shape(fdims, frank)
5379 :
5380 : ! Shape of array
5381 5356032 : dimind = tape(t)%hlist(fld)%field%get_dims()
5382 5356032 : call dimind%dim_sizes(adims)
5383 5356032 : if (adims(2) <= 1) then
5384 2769408 : adims(2) = adims(3)
5385 2769408 : nadims = 2
5386 : else
5387 : nadims = 3
5388 : end if
5389 5356032 : fdecomp = tape(t)%hlist(fld)%field%decomp_type
5390 :
5391 : ! num_patches will loop through the number of patches (or just one
5392 : ! for the whole grid) for this field for this tape
5393 5356032 : if (patch_output) then
5394 0 : num_patches = size(tape(t)%patches)
5395 : else
5396 : num_patches = 1
5397 : end if
5398 :
5399 10712064 : do index = 1, num_patches
5400 5356032 : varid => tape(t)%hlist(fld)%varid(index)
5401 :
5402 5356032 : if (restart) then
5403 185856 : call pio_setframe(tape(t)%Files(f), varid, int(-1,kind=PIO_OFFSET_KIND))
5404 : else
5405 5170176 : call pio_setframe(tape(t)%Files(f), varid, int(max(1,nfils(t)),kind=PIO_OFFSET_KIND))
5406 : end if
5407 10712064 : if (patch_output) then
5408 : ! We are outputting patches
5409 0 : patchptr => tape(t)%patches(index)
5410 0 : if (interpolate) then
5411 0 : call endrun('dump_field: interpolate incompatible with regional output')
5412 : end if
5413 0 : call patchptr%write_var(tape(t)%Files(f), fdecomp, adims(1:nadims), &
5414 0 : pio_double, tape(t)%hlist(fld)%hbuf, varid)
5415 : else
5416 : ! We are doing output via the field's grid
5417 5356032 : if (interpolate) then
5418 :
5419 : !Determine what the output field kind should be:
5420 0 : if (tape(t)%hlist(fld)%hwrt_prec == 8) then
5421 0 : ncreal = pio_double
5422 : else
5423 0 : ncreal = pio_real
5424 : end if
5425 :
5426 0 : mdimsize = tape(t)%hlist(fld)%field%enddim2 - tape(t)%hlist(fld)%field%begdim2 + 1
5427 0 : if (mdimsize == 0) then
5428 0 : mdimsize = tape(t)%hlist(fld)%field%numlev
5429 : end if
5430 0 : if (tape(t)%hlist(fld)%field%meridional_complement > 0) then
5431 0 : compind = tape(t)%hlist(fld)%field%meridional_complement
5432 0 : compid => tape(t)%hlist(compind)%varid(index)
5433 : ! We didn't call set frame on the meridional complement field
5434 0 : call pio_setframe(tape(t)%Files(f), compid, int(max(1,nfils(t)),kind=PIO_OFFSET_KIND))
5435 0 : call write_interpolated(tape(t)%Files(f), varid, compid, &
5436 0 : tape(t)%hlist(fld)%hbuf, tape(t)%hlist(compind)%hbuf, &
5437 0 : mdimsize, ncreal, fdecomp)
5438 0 : else if (tape(t)%hlist(fld)%field%zonal_complement <= 0) then
5439 : ! Scalar field
5440 0 : call write_interpolated(tape(t)%Files(f), varid, &
5441 0 : tape(t)%hlist(fld)%hbuf, mdimsize, ncreal, fdecomp)
5442 : end if
5443 5356032 : else if (nadims == 2) then
5444 : ! Special case for 2D field (no levels) due to hbuf structure
5445 2769408 : if ((tape(t)%hlist(fld)%hwrt_prec == 4) .and. (.not. restart)) then
5446 2663424 : call tape(t)%hlist(fld)%field%get_bounds(3, begdim3, enddim3)
5447 10653696 : allocate(rtemp2(dimind%beg1:dimind%end1, begdim3:enddim3))
5448 229008384 : rtemp2 = 0.0_r4
5449 15971328 : do ind3 = begdim3, enddim3
5450 13307904 : dimind2 = tape(t)%hlist(fld)%field%get_dims(ind3)
5451 0 : rtemp2(dimind2%beg1:dimind2%end1,ind3) = &
5452 207737856 : tape(t)%hlist(fld)%hbuf(dimind2%beg1:dimind2%end1, 1, ind3)
5453 : end do
5454 2663424 : call cam_grid_write_dist_array(tape(t)%Files(f), fdecomp, &
5455 5326848 : adims(1:nadims), fdims(1:frank), rtemp2, varid)
5456 2663424 : deallocate(rtemp2)
5457 : else
5458 105984 : call cam_grid_write_dist_array(tape(t)%Files(f), fdecomp, &
5459 0 : adims(1:nadims), fdims(1:frank), &
5460 211968 : tape(t)%hlist(fld)%hbuf(:,1,:), varid)
5461 : end if
5462 : else
5463 2586624 : if ((tape(t)%hlist(fld)%hwrt_prec == 4) .and. (.not. restart)) then
5464 2506752 : call tape(t)%hlist(fld)%field%get_bounds(3, begdim3, enddim3)
5465 0 : allocate(rtemp3(dimind%beg1:dimind%end1, &
5466 12533760 : dimind%beg2:dimind%end2, begdim3:enddim3))
5467 14828502528 : rtemp3 = 0.0_r4
5468 14985216 : do ind3 = begdim3, enddim3
5469 12478464 : dimind2 = tape(t)%hlist(fld)%field%get_dims(ind3)
5470 0 : rtemp3(dimind2%beg1:dimind2%end1, dimind2%beg2:dimind2%end2, &
5471 0 : ind3) = tape(t)%hlist(fld)%hbuf(dimind2%beg1:dimind2%end1,&
5472 13439614464 : dimind2%beg2:dimind2%end2, ind3)
5473 : end do
5474 2506752 : call cam_grid_write_dist_array(tape(t)%Files(f), fdecomp, adims, &
5475 5013504 : fdims(1:frank), rtemp3, varid)
5476 2506752 : deallocate(rtemp3)
5477 : else
5478 79872 : call cam_grid_write_dist_array(tape(t)%Files(f), fdecomp, adims, &
5479 0 : fdims(1:frank), &
5480 159744 : tape(t)%hlist(fld)%hbuf, varid)
5481 : end if
5482 : end if
5483 : end if
5484 : end do
5485 : !! write accumulation counter and variance to hist restart file
5486 5356032 : if(restart) then
5487 185856 : if (associated(tape(t)%hlist(fld)%sbuf) ) then
5488 : ! write variance data to restart file for standard deviation calc
5489 0 : if (nadims == 2) then
5490 : ! Special case for 2D field (no levels) due to sbuf structure
5491 0 : call cam_grid_write_dist_array(tape(t)%Files(f), fdecomp, &
5492 0 : adims(1:nadims), fdims(1:frank), &
5493 0 : tape(t)%hlist(fld)%sbuf(:,1,:), tape(t)%hlist(fld)%sbuf_varid)
5494 : else
5495 0 : call cam_grid_write_dist_array(tape(t)%Files(f), fdecomp, adims, &
5496 0 : fdims(1:frank), tape(t)%hlist(fld)%sbuf, &
5497 0 : tape(t)%hlist(fld)%sbuf_varid)
5498 : endif
5499 : endif
5500 : !! NACS
5501 185856 : if (size(tape(t)%hlist(fld)%nacs, 1) > 1) then
5502 10752 : if (nadims > 2) then
5503 0 : adims(2) = adims(3)
5504 0 : nadims = 2
5505 : end if
5506 10752 : call cam_grid_dimensions(fdecomp, fdims(1:2), nacsrank)
5507 10752 : call cam_grid_write_dist_array(tape(t)%Files(f), fdecomp, &
5508 0 : adims(1:nadims), fdims(1:nacsrank), &
5509 21504 : tape(t)%hlist(fld)%nacs, tape(t)%hlist(fld)%nacs_varid)
5510 : else
5511 175104 : bdim3 = tape(t)%hlist(fld)%field%begdim3
5512 175104 : edim3 = tape(t)%hlist(fld)%field%enddim3
5513 175104 : ierr = pio_put_var(tape(t)%Files(f), tape(t)%hlist(fld)%nacs_varid, &
5514 350208 : tape(t)%hlist(fld)%nacs(:, bdim3:edim3))
5515 : end if
5516 : end if
5517 :
5518 5356032 : return
5519 5356032 : end subroutine dump_field
5520 :
5521 : !#######################################################################
5522 :
5523 111360 : logical function write_inithist ()
5524 : !
5525 : !-----------------------------------------------------------------------
5526 : !
5527 : ! Purpose: Set flags that will initiate dump to IC file when OUTFLD and
5528 : ! WSHIST are called
5529 : !
5530 : !-----------------------------------------------------------------------
5531 : !
5532 5356032 : use time_manager, only: get_nstep, get_curr_date, get_step_size, is_last_step
5533 : !
5534 : ! Local workspace
5535 : !
5536 : integer :: yr, mon, day ! year, month, and day components of
5537 : ! a date
5538 : integer :: nstep ! current timestep number
5539 : integer :: ncsec ! current time of day [seconds]
5540 : integer :: dtime ! timestep size
5541 :
5542 : !-----------------------------------------------------------------------
5543 :
5544 111360 : write_inithist = .false.
5545 :
5546 111360 : if(is_initfile()) then
5547 :
5548 111360 : nstep = get_nstep()
5549 111360 : call get_curr_date(yr, mon, day, ncsec)
5550 :
5551 111360 : if (inithist == '6-HOURLY') then
5552 0 : dtime = get_step_size()
5553 0 : write_inithist = nstep /= 0 .and. mod( nstep, nint((6._r8*3600._r8)/dtime) ) == 0
5554 111360 : elseif(inithist == 'DAILY' ) then
5555 0 : write_inithist = nstep /= 0 .and. ncsec == 0
5556 111360 : elseif(inithist == 'MONTHLY' ) then
5557 0 : write_inithist = nstep /= 0 .and. ncsec == 0 .and. day == 1
5558 111360 : elseif(inithist == 'YEARLY' ) then
5559 111360 : write_inithist = nstep /= 0 .and. ncsec == 0 .and. day == 1 .and. mon == 1
5560 0 : elseif(inithist == 'CAMIOP' ) then
5561 0 : write_inithist = nstep == 0
5562 0 : elseif(inithist == 'ENDOFRUN' ) then
5563 0 : write_inithist = nstep /= 0 .and. is_last_step()
5564 : end if
5565 : end if
5566 :
5567 : return
5568 111360 : end function write_inithist
5569 :
5570 : !#######################################################################
5571 :
5572 16128 : subroutine wshist (rgnht_in)
5573 : !
5574 : !-----------------------------------------------------------------------
5575 : !
5576 : ! Purpose: Driver routine to write fields on history tape t
5577 : !
5578 : !
5579 : !-----------------------------------------------------------------------
5580 111360 : use time_manager, only: get_nstep, get_curr_date, get_curr_time, get_step_size
5581 : use time_manager, only: set_date_from_time_float
5582 : use chem_surfvals, only: chem_surfvals_get, chem_surfvals_co2_rad
5583 : use solar_irrad_data, only: sol_tsi
5584 : use sat_hist, only: sat_hist_write
5585 : use interp_mod, only: set_interp_hfile
5586 : use datetime_mod, only: datetime
5587 : use cam_pio_utils, only: cam_pio_closefile
5588 :
5589 : logical, intent(in), optional :: rgnht_in(ptapes)
5590 : !
5591 : ! Local workspace
5592 : !
5593 : character(len=8) :: cdate ! system date
5594 : character(len=8) :: ctime ! system time
5595 :
5596 : logical :: rgnht(ptapes), restart
5597 : integer t, f, fld ! tape, file, field indices
5598 : integer start ! starting index required by nf_put_vara
5599 : integer count1 ! count values required by nf_put_vara
5600 : integer startc(2) ! start values required by nf_put_vara (character)
5601 : integer countc(2) ! count values required by nf_put_vara (character)
5602 : #ifdef HDEBUG
5603 : ! integer begdim3
5604 : ! integer enddim3
5605 : #endif
5606 :
5607 : integer :: yr, mon, day ! year, month, and day components of a date
5608 : integer :: yr_mid, mon_mid, day_mid ! year, month, and day components of midpoint date
5609 : integer :: nstep ! current timestep number
5610 : integer :: ncdate(maxsplitfiles) ! current (or midpoint) date in integer format [yyyymmdd]
5611 : integer :: ncsec(maxsplitfiles) ! current (or midpoint) time of day [seconds]
5612 : integer :: ndcur ! day component of current time
5613 : integer :: nscur ! seconds component of current time
5614 : real(r8) :: time ! current (or midpoint) time
5615 : real(r8) :: tdata(2) ! time interval boundaries
5616 : character(len=max_string_len) :: fname ! Filename
5617 : character(len=max_string_len) :: fname_inst ! Filename for instantaneous tape
5618 : character(len=max_string_len) :: fname_acc ! Filename for accumulated tape
5619 : character(len=max_string_len) :: inst_filename_spec ! Filename specifier override for monthly inst. files
5620 : logical :: prev ! Label file with previous date rather than current
5621 : logical :: duplicate ! Flag for duplicate file name
5622 : integer :: ierr
5623 : #if ( defined BFB_CAM_SCAM_IOP )
5624 : integer :: tsec ! day component of current time
5625 : integer :: dtime ! seconds component of current time
5626 : #endif
5627 16128 : if(present(rgnht_in)) then
5628 1536 : rgnht=rgnht_in
5629 1536 : restart=.true.
5630 1536 : tape => restarthistory_tape
5631 : else
5632 14592 : rgnht=.false.
5633 14592 : restart=.false.
5634 14592 : tape => history_tape
5635 : end if
5636 :
5637 16128 : nstep = get_nstep()
5638 16128 : call get_curr_date(yr, mon, day, ncsec(instantaneous_file_index))
5639 16128 : ncdate(instantaneous_file_index) = yr*10000 + mon*100 + day
5640 16128 : call get_curr_time(ndcur, nscur)
5641 : !
5642 : ! Write time-varying portion of history file header
5643 : !
5644 209664 : do t=1,ptapes
5645 193536 : if (nflds(t) == 0 .or. (restart .and.(.not.rgnht(t)))) cycle
5646 : !
5647 : ! Check if this is the IC file and if it's time to write.
5648 : ! Else, use "nhtfrq" to determine if it's time to write
5649 : ! the other history files.
5650 : !
5651 77568 : if((.not. restart) .or. rgnht(t)) then
5652 77568 : if( is_initfile(file_index=t) ) then
5653 14592 : hstwr(t) = write_inithist()
5654 14592 : prev = .false.
5655 : else
5656 62976 : if (nhtfrq(t) == 0) then
5657 0 : hstwr(t) = nstep /= 0 .and. day == 1 .and. ncsec(instantaneous_file_index) == 0
5658 0 : prev = .true.
5659 : else
5660 62976 : if (nstep == 0) then
5661 3072 : if (write_nstep0) then
5662 0 : hstwr(t) = .true.
5663 : else
5664 : ! zero the buffers if nstep==0 data not written
5665 957696 : do f = 1, nflds(t)
5666 957696 : call h_zero(f, t)
5667 : end do
5668 : end if
5669 : else
5670 59904 : hstwr(t) = mod(nstep,nhtfrq(t)) == 0
5671 : endif
5672 62976 : prev = .false.
5673 : end if
5674 : end if
5675 : end if
5676 :
5677 77568 : time = ndcur + nscur/86400._r8
5678 77568 : if (is_initfile(file_index=t)) then
5679 43776 : tdata = time ! Inithist file is always instantanious data
5680 : else
5681 62976 : tdata(1) = beg_time(t)
5682 62976 : tdata(2) = time
5683 : end if
5684 :
5685 : ! Set midpoint date/datesec for accumulated file
5686 : call set_date_from_time_float((tdata(1) + tdata(2)) / 2._r8, &
5687 77568 : yr_mid, mon_mid, day_mid, ncsec(accumulated_file_index) )
5688 77568 : ncdate(accumulated_file_index) = yr_mid*10000 + mon_mid*100 + day_mid
5689 :
5690 93696 : if (hstwr(t) .or. (restart .and. rgnht(t))) then
5691 9216 : if(masterproc) then
5692 12 : if(is_initfile(file_index=t)) then
5693 0 : write(iulog,100) yr,mon,day,ncsec(init_file_index)
5694 : 100 format('WSHIST: writing time sample to Initial Conditions h-file', &
5695 : ' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6)
5696 12 : else if(is_satfile(t)) then
5697 0 : write(iulog,150) nfils(t),t,yr,mon,day,ncsec(sat_file_index)
5698 : 150 format('WSHIST: writing sat columns ',i6,' to h-file ', &
5699 : i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6)
5700 12 : else if(hstwr(t)) then
5701 18 : do f = 1, maxsplitfiles
5702 18 : if (f == instantaneous_file_index) then
5703 6 : write(iulog,200) nfils(t),'instantaneous',t,yr,mon,day,ncsec(f)
5704 : else
5705 6 : write(iulog,200) nfils(t),'accumulated',t,yr_mid,mon_mid,day_mid,ncsec(f)
5706 : end if
5707 : 200 format('WSHIST: writing time sample ',i3,' to ', a, ' h-file ', &
5708 : i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6)
5709 : end do
5710 6 : else if(restart .and. rgnht(t)) then
5711 6 : write(iulog,300) nfils(t),t,yr,mon,day,ncsec(restart_file_index)
5712 : 300 format('WSHIST: writing history restart ',i3,' to hr-file ', &
5713 : i1,' DATE=',i4.4,'/',i2.2,'/',i2.2,' NCSEC=',i6)
5714 : end if
5715 12 : write(iulog,*)
5716 : end if
5717 : !
5718 : ! Starting a new volume => define the metadata
5719 : !
5720 9216 : fname = ''
5721 9216 : fname_acc = ''
5722 9216 : fname_inst = ''
5723 9216 : if (nfils(t)==0 .or. (restart.and.rgnht(t))) then
5724 9216 : if(restart) then
5725 4608 : rhfilename_spec = '%c.cam' // trim(inst_suffix) // '.rh%t.%y-%m-%d-%s.nc'
5726 4608 : fname = interpret_filename_spec( rhfilename_spec, number=(t-1))
5727 4608 : hrestpath(t)=fname
5728 4608 : else if(is_initfile(file_index=t)) then
5729 0 : fname = interpret_filename_spec( hfilename_spec(t) )
5730 : else
5731 : fname_acc = interpret_filename_spec( hfilename_spec(t), number=(t-1), &
5732 4608 : prev=prev, flag_spec='a' )
5733 : ! If this is a monthly instantaneous file, override to default timestamp
5734 : ! unless the user input a filename specifier
5735 4608 : if (default_monthly_filename(t)) then
5736 0 : inst_filename_spec = '%c.cam' // trim(inst_suffix) // '.h%t%f.%y-%m-%d-%s.nc'
5737 : else
5738 4608 : inst_filename_spec = hfilename_spec(t)
5739 : end if
5740 : fname_inst = interpret_filename_spec( inst_filename_spec, number=(t-1), &
5741 4608 : flag_spec='i' )
5742 : end if
5743 : !
5744 : ! Check that this new filename isn't the same as a previous or current filename
5745 : !
5746 9216 : duplicate = .false.
5747 39936 : do f = 1, t
5748 39936 : if (masterproc)then
5749 40 : if (trim(fname) == trim(nhfil(f,1)) .and. trim(fname) /= '') then
5750 0 : write(iulog,*)'WSHIST: New filename same as old file = ', trim(fname)
5751 : duplicate = .true.
5752 40 : else if (trim(fname_acc) == trim(nhfil(f,accumulated_file_index)) .and. trim(fname_acc) /= '') then
5753 0 : write(iulog,*)'WSHIST: New accumulated filename same as old file = ', trim(fname_acc)
5754 : duplicate = .true.
5755 40 : else if (trim(fname_inst) == trim(nhfil(f,instantaneous_file_index)) .and. trim(fname_inst) /= '') then
5756 0 : write(iulog,*)'WSHIST: New instantaneous filename same as old file = ', trim(fname_inst)
5757 : duplicate = .true.
5758 : end if
5759 40 : if (duplicate) then
5760 0 : write(iulog,*)'Is there an error in your filename specifiers?'
5761 0 : write(iulog,*)'hfilename_spec(', t, ') = ', trim(hfilename_spec(t))
5762 0 : if ( t /= f )then
5763 0 : write(iulog,*)'hfilename_spec(', f, ') = ', trim(hfilename_spec(f))
5764 : end if
5765 0 : call endrun('WSHIST: ERROR - see atm log file for information')
5766 : end if
5767 : end if
5768 : end do
5769 9216 : if(.not. restart) then
5770 4608 : if (is_initfile(file_index=t)) then
5771 0 : nhfil(t,:) = fname
5772 0 : if(masterproc) then
5773 0 : write(iulog,*)'WSHIST: initfile nhfil(',t,')=',trim(nhfil(t,init_file_index))
5774 : end if
5775 : else
5776 4608 : nhfil(t,accumulated_file_index) = fname_acc
5777 4608 : nhfil(t,instantaneous_file_index) = fname_inst
5778 4608 : if(masterproc) then
5779 6 : write(iulog,*)'WSHIST: accumulated nhfil(',t,')=',trim(nhfil(t,accumulated_file_index))
5780 6 : write(iulog,*)'WSHIST: instantaneous nhfil(',t,')=',trim(nhfil(t,instantaneous_file_index))
5781 : end if
5782 : end if
5783 13824 : cpath(t,:) = nhfil(t,:)
5784 4608 : if ( len_trim(nfpath(t)) == 0 ) nfpath(t) = cpath(t, 1)
5785 : end if
5786 9216 : call h_define (t, restart)
5787 : end if
5788 :
5789 9216 : if(is_satfile(t)) then
5790 0 : call sat_hist_write( tape(t), nflds(t), nfils(t))
5791 : else
5792 9216 : if(restart) then
5793 : start=1
5794 : else
5795 4608 : nfils(t) = nfils(t) + 1
5796 : start = nfils(t)
5797 : end if
5798 9216 : count1 = 1
5799 : ! Setup interpolation data if history file is interpolated
5800 9216 : if (interpolate_output(t) .and. (.not. restart)) then
5801 0 : call set_interp_hfile(t, interpolate_info)
5802 : end if
5803 36864 : ierr = pio_put_var (tape(t)%Files(instantaneous_file_index),tape(t)%ndcurid,(/start/),(/count1/),(/ndcur/))
5804 36864 : ierr = pio_put_var (tape(t)%Files(instantaneous_file_index), tape(t)%nscurid,(/start/),(/count1/),(/nscur/))
5805 27648 : do f = 1, maxsplitfiles
5806 27648 : if (pio_file_is_open(tape(t)%Files(f))) then
5807 55296 : ierr = pio_put_var (tape(t)%Files(f), tape(t)%dateid,(/start/),(/count1/),(/ncdate(f)/))
5808 : end if
5809 : end do
5810 :
5811 27648 : do f = 1, maxsplitfiles
5812 27648 : if (.not. is_initfile(file_index=t) .and. f == instantaneous_file_index) then
5813 : ! Don't write the GHG/Solar forcing data to the IC file.
5814 : ! Only write GHG/Solar forcing data to the instantaneous file
5815 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%co2vmrid,(/start/), (/count1/),(/chem_surfvals_co2_rad(vmr_in=.true.)/))
5816 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%ch4vmrid,(/start/), (/count1/),(/chem_surfvals_get('CH4VMR')/))
5817 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%n2ovmrid,(/start/), (/count1/),(/chem_surfvals_get('N2OVMR')/))
5818 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%f11vmrid,(/start/), (/count1/),(/chem_surfvals_get('F11VMR')/))
5819 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%f12vmrid,(/start/), (/count1/),(/chem_surfvals_get('F12VMR')/))
5820 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%sol_tsiid,(/start/), (/count1/),(/sol_tsi/))
5821 :
5822 9216 : if (solar_parms_on) then
5823 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%f107id, (/start/), (/count1/),(/ f107 /) )
5824 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%f107aid,(/start/), (/count1/),(/ f107a /) )
5825 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%f107pid,(/start/), (/count1/),(/ f107p /) )
5826 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%kpid, (/start/), (/count1/),(/ kp /) )
5827 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%apid, (/start/), (/count1/),(/ ap /) )
5828 : endif
5829 9216 : if (solar_wind_on) then
5830 0 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%byimfid, (/start/), (/count1/),(/ byimf /) )
5831 0 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%bzimfid, (/start/), (/count1/),(/ bzimf /) )
5832 0 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%swvelid, (/start/), (/count1/),(/ swvel /) )
5833 0 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%swdenid, (/start/), (/count1/),(/ swden /) )
5834 : endif
5835 9216 : if (epot_active) then
5836 0 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%colat_crit1_id, (/start/), (/count1/),(/ epot_crit_colats(1) /) )
5837 0 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%colat_crit2_id, (/start/), (/count1/),(/ epot_crit_colats(2) /) )
5838 : endif
5839 : end if
5840 : end do
5841 27648 : do f = 1, maxsplitfiles
5842 27648 : if (pio_file_is_open(tape(t)%Files(f))) then
5843 55296 : ierr = pio_put_var (tape(t)%Files(f),tape(t)%datesecid,(/start/),(/count1/),(/ncsec(f)/))
5844 : end if
5845 : end do
5846 : #if ( defined BFB_CAM_SCAM_IOP )
5847 : dtime = get_step_size()
5848 : tsec=dtime*nstep
5849 : do f = 1, maxsplitfiles
5850 : if (pio_file_is_open(tape(t)%Files(f))) then
5851 : ierr = pio_put_var (tape(t)%Files(f),tape(t)%tsecid,(/start/),(/count1/),(/tsec/))
5852 : end if
5853 : end do
5854 : #endif
5855 36864 : ierr = pio_put_var (tape(t)%Files(instantaneous_file_index),tape(t)%nstephid,(/start/),(/count1/),(/nstep/))
5856 9216 : startc(1) = 1
5857 9216 : startc(2) = start
5858 9216 : countc(1) = 2
5859 9216 : countc(2) = 1
5860 27648 : do f = 1, maxsplitfiles
5861 18432 : if (.not. pio_file_is_open(tape(t)%Files(f))) then
5862 : cycle
5863 : end if
5864 : ! We have two files - one for accumulated and one for instantaneous fields
5865 23040 : if (f == accumulated_file_index) then
5866 4608 : if (.not. restart .and. .not. is_initfile(t)) then
5867 : ! accumulated tape - time is midpoint of time_bounds
5868 18432 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%timeid, (/start/),(/count1/),(/(tdata(1) + tdata(2)) / 2._r8/))
5869 : else
5870 : ! restart or initfile - time is current time
5871 0 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%timeid, (/start/),(/count1/),(/time/))
5872 : end if
5873 4608 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%tbndid, startc, countc, tdata)
5874 : else
5875 : ! not an accumulated history tape - time is current time
5876 36864 : ierr=pio_put_var (tape(t)%Files(f), tape(t)%timeid, (/start/),(/count1/),(/time/))
5877 : end if
5878 : end do
5879 9216 : if(.not.restart) beg_time(t) = time ! update beginning time of next interval
5880 9216 : startc(1) = 1
5881 9216 : startc(2) = start
5882 9216 : countc(1) = 8
5883 9216 : countc(2) = 1
5884 9216 : call datetime (cdate, ctime)
5885 27648 : do f = 1, maxsplitfiles
5886 27648 : if (pio_file_is_open(tape(t)%Files(f))) then
5887 27648 : ierr = pio_put_var (tape(t)%Files(f), tape(t)%date_writtenid, startc, countc, (/cdate/))
5888 27648 : ierr = pio_put_var (tape(t)%Files(f), tape(t)%time_writtenid, startc, countc, (/ctime/))
5889 : end if
5890 : end do
5891 :
5892 9216 : if(.not. restart) then
5893 : !$OMP PARALLEL DO PRIVATE (FLD)
5894 5174784 : do fld=1,nflds(t)
5895 : ! Normalize all non composed fields, composed fields are calculated next using the normalized components
5896 5174784 : if (tape(t)%hlist(fld)%avgflag /= 'I'.and..not.tape(t)%hlist(fld)%field%is_composed()) then
5897 5170176 : call h_normalize (fld, t)
5898 : end if
5899 : end do
5900 : end if
5901 :
5902 9216 : if(.not. restart) then
5903 : !$OMP PARALLEL DO PRIVATE (FLD)
5904 5174784 : do fld=1,nflds(t)
5905 : ! calculate composed fields from normalized components
5906 5174784 : if (tape(t)%hlist(fld)%field%is_composed()) then
5907 0 : call h_field_op (fld, t)
5908 : end if
5909 : end do
5910 : end if
5911 : !
5912 : ! Write field to history tape. Note that this is NOT threaded due to netcdf limitations
5913 : !
5914 9216 : call t_startf ('dump_field')
5915 5365248 : do fld=1,nflds(t)
5916 16077312 : do f = 1, maxsplitfiles
5917 10712064 : if (.not. pio_file_is_open(tape(t)%Files(f))) then
5918 : cycle
5919 : end if
5920 : ! we may have a history split, conditionally skip fields that are for the other file
5921 10526208 : if ((tape(t)%hlist(fld)%avgflag .eq. 'I') .and. f == accumulated_file_index .and. .not. restart) then
5922 : cycle
5923 10526208 : else if ((tape(t)%hlist(fld)%avgflag .ne. 'I') .and. f == instantaneous_file_index .and. .not. restart) then
5924 : cycle
5925 : end if
5926 16068096 : call dump_field(fld, t, f, restart)
5927 : end do
5928 : end do
5929 9216 : call t_stopf ('dump_field')
5930 : !
5931 : ! Calculate globals
5932 : !
5933 5365248 : do fld=1,nflds(t)
5934 5365248 : call h_global(fld, t)
5935 : end do
5936 : !
5937 : ! Zero history buffers and accumulators now that the fields have been written.
5938 : !
5939 9216 : if(restart) then
5940 190464 : do fld=1,nflds(t)
5941 190464 : if(associated(tape(t)%hlist(fld)%varid)) then
5942 185856 : deallocate(tape(t)%hlist(fld)%varid)
5943 185856 : nullify(tape(t)%hlist(fld)%varid)
5944 : end if
5945 : end do
5946 4608 : call cam_pio_closefile(tape(t)%Files(restart_file_index))
5947 : else
5948 : !$OMP PARALLEL DO PRIVATE (FLD)
5949 5174784 : do fld=1,nflds(t)
5950 5174784 : call h_zero (fld, t)
5951 : end do
5952 : end if
5953 : end if
5954 : end if
5955 :
5956 : end do
5957 :
5958 16128 : return
5959 16128 : end subroutine wshist
5960 :
5961 : !#######################################################################
5962 :
5963 0 : subroutine addfld_1d(fname, vdim_name, avgflag, units, long_name, &
5964 : gridname, flag_xyfill, sampling_seq, standard_name, fill_value, &
5965 : optype, op_f1name, op_f2name, sampled_on_subcycle)
5966 :
5967 : !
5968 : !-----------------------------------------------------------------------
5969 : !
5970 : ! Purpose: Add a field to the master field list
5971 : !
5972 : ! Method: Put input arguments of field name, units, number of levels,
5973 : ! averaging flag, and long name into a type entry in the global
5974 : ! master field list (masterlist).
5975 : !
5976 : !-----------------------------------------------------------------------
5977 :
5978 : !
5979 : ! Arguments
5980 : !
5981 : character(len=*), intent(in) :: fname ! field name (max_fieldname_len)
5982 : character(len=*), intent(in) :: vdim_name ! NetCDF dimension name (or scalar coordinate)
5983 : character(len=1), intent(in) :: avgflag ! averaging flag
5984 : character(len=*), intent(in) :: units ! units of fname (max_chars)
5985 : character(len=*), intent(in) :: long_name ! long name of field (max_chars)
5986 :
5987 : character(len=*), intent(in), optional :: gridname ! decomposition type
5988 : logical, intent(in), optional :: flag_xyfill ! non-applicable xy points flagged with fillvalue
5989 : character(len=*), intent(in), optional :: sampling_seq ! sampling sequence - if not every timestep,
5990 : ! how often field is sampled:
5991 : ! every other; only during LW/SW radiation calcs, etc.
5992 : character(len=*), intent(in), optional :: standard_name ! CF standard name (max_chars)
5993 : real(r8), intent(in), optional :: fill_value
5994 : character(len=*), intent(in), optional :: optype ! currently 'dif' or 'sum' is supported
5995 : character(len=*), intent(in), optional :: op_f1name ! first field to be operated on
5996 : character(len=*), intent(in), optional :: op_f2name ! second field which is subtracted from or added to first field
5997 : logical, intent(in), optional :: sampled_on_subcycle ! If .true., subcycle averaging is enabled
5998 : !
5999 : ! Local workspace
6000 : !
6001 4455936 : character(len=max_chars), allocatable :: dimnames(:)
6002 : integer :: index
6003 :
6004 4455936 : if (trim(vdim_name) == trim(horiz_only)) then
6005 4455936 : allocate(dimnames(0))
6006 : else
6007 0 : index = get_hist_coord_index(trim(vdim_name))
6008 0 : if (index < 1) then
6009 0 : call endrun('ADDFLD: Invalid coordinate, '//trim(vdim_name))
6010 : end if
6011 0 : allocate(dimnames(1))
6012 0 : dimnames(1) = trim(vdim_name)
6013 : end if
6014 : call addfld(fname, dimnames, avgflag, units, long_name, gridname, &
6015 : flag_xyfill, sampling_seq, standard_name, fill_value, optype, op_f1name, &
6016 31119360 : op_f2name, sampled_on_subcycle)
6017 :
6018 4472064 : end subroutine addfld_1d
6019 :
6020 12480000 : subroutine addfld_nd(fname, dimnames, avgflag, units, long_name, &
6021 : gridname, flag_xyfill, sampling_seq, standard_name, fill_value, optype, &
6022 : op_f1name, op_f2name, sampled_on_subcycle)
6023 :
6024 : !
6025 : !-----------------------------------------------------------------------
6026 : !
6027 : ! Purpose: Add a field to the master field list
6028 : !
6029 : ! Method: Put input arguments of field name, units, number of levels,
6030 : ! averaging flag, and long name into a type entry in the global
6031 : ! master field list (masterlist).
6032 : !
6033 : !-----------------------------------------------------------------------
6034 : use cam_history_support, only: fillvalue, hist_coord_find_levels
6035 : use cam_grid_support, only: cam_grid_id, cam_grid_is_zonal
6036 : use cam_grid_support, only: cam_grid_get_coord_names
6037 : use constituents, only: cnst_get_ind, cnst_get_type_byind
6038 :
6039 : !
6040 : ! Arguments
6041 : !
6042 : character(len=*), intent(in) :: fname ! field name (max_fieldname_len)
6043 : character(len=*), intent(in) :: dimnames(:) ! NetCDF dimension names (except grid dims)
6044 : character(len=1), intent(in) :: avgflag ! averaging flag
6045 : character(len=*), intent(in) :: units ! units of fname (max_chars)
6046 : character(len=*), intent(in) :: long_name ! long name of field (max_chars)
6047 :
6048 : character(len=*), intent(in), optional :: gridname ! decomposition type
6049 : logical, intent(in), optional :: flag_xyfill ! non-applicable xy points flagged with fillvalue
6050 : character(len=*), intent(in), optional :: sampling_seq ! sampling sequence - if not every timestep,
6051 : ! how often field is sampled:
6052 : ! every other; only during LW/SW radiation calcs, etc.
6053 : character(len=*), intent(in), optional :: standard_name ! CF standard name (max_chars)
6054 : real(r8), intent(in), optional :: fill_value
6055 : character(len=*), intent(in), optional :: optype ! currently 'dif' or 'sum' supported
6056 : character(len=*), intent(in), optional :: op_f1name ! first field to be operated on
6057 : character(len=*), intent(in), optional :: op_f2name ! second field which is subtracted from or added to first field
6058 : logical, intent(in), optional :: sampled_on_subcycle ! If .true., subcycle averaging is enabled
6059 :
6060 : !
6061 : ! Local workspace
6062 : !
6063 : character(len=max_fieldname_len) :: fname_tmp ! local copy of fname
6064 : character(len=max_fieldname_len) :: coord_name ! for cell_methods
6065 : character(len=128) :: errormsg
6066 : character(len=3) :: mixing_ratio
6067 : type(master_entry), pointer :: listentry
6068 : type(master_entry), pointer :: f1listentry,f2listentry
6069 :
6070 : integer :: dimcnt
6071 : integer :: idx
6072 :
6073 : character(len=*), parameter :: subname='ADDFLD_ND'
6074 :
6075 12480000 : if (htapes_defined) then
6076 0 : call endrun ('ADDFLD: Attempt to add field '//trim(fname)//' after history files set')
6077 : end if
6078 :
6079 : !
6080 : ! Ensure that new field name is not all blanks
6081 : !
6082 12480000 : if (len_trim(fname)==0) then
6083 0 : call endrun('ADDFLD: blank field name not allowed')
6084 : end if
6085 : !
6086 : ! Ensure that new field name is not longer than allowed
6087 : ! (strip "&IC" suffix if it exists)
6088 : !
6089 12480000 : fname_tmp = fname
6090 12480000 : fname_tmp = strip_suffix(fname_tmp)
6091 :
6092 12480000 : if (len_trim(fname_tmp) > fieldname_len) then
6093 0 : write(iulog,*)'ADDFLD: field name cannot be longer than ',fieldname_len,' characters long'
6094 0 : write(iulog,*)'Field name: ',fname
6095 0 : write(errormsg, *) 'Field name, "', trim(fname), '" is too long'
6096 0 : call endrun('ADDFLD: '//trim(errormsg))
6097 : end if
6098 : !
6099 : ! Ensure that new field doesn't already exist
6100 : !
6101 12480000 : listentry => get_entry_by_name(masterlinkedlist, fname)
6102 12480000 : if(associated(listentry)) then
6103 0 : call endrun ('ADDFLD: '//fname//' already on list')
6104 : end if
6105 :
6106 : ! If the field is an advected constituent determine whether its concentration
6107 : ! is based on dry or wet air.
6108 12480000 : call cnst_get_ind(fname_tmp, idx, abort=.false.)
6109 12480000 : mixing_ratio = ''
6110 12480000 : if (idx > 0) then
6111 620544 : mixing_ratio = cnst_get_type_byind(idx)
6112 : end if
6113 :
6114 : ! Add field to Master Field List arrays fieldn and iflds
6115 : !
6116 12480000 : allocate(listentry)
6117 12480000 : listentry%field%name = fname
6118 12480000 : listentry%field%long_name = long_name
6119 12480000 : listentry%field%numlev = 1 ! Will change if lev or ilev in shape
6120 12480000 : listentry%field%units = units
6121 12480000 : listentry%field%mixing_ratio = mixing_ratio
6122 12480000 : listentry%field%meridional_complement = -1
6123 12480000 : listentry%field%zonal_complement = -1
6124 12480000 : listentry%field%field_op = ''
6125 12480000 : listentry%field%op_field1_id = -1
6126 12480000 : listentry%field%op_field2_id = -1
6127 12480000 : listentry%op_field1 = ''
6128 12480000 : listentry%op_field2 = ''
6129 162240000 : listentry%htapeindx(:) = -1
6130 12480000 : listentry%act_sometape = .false.
6131 162240000 : listentry%actflag(:) = .false.
6132 :
6133 : ! Make sure we have a valid gridname
6134 12480000 : if (present(gridname)) then
6135 662016 : listentry%field%decomp_type = cam_grid_id(trim(gridname))
6136 : else
6137 11817984 : listentry%field%decomp_type = cam_grid_id('physgrid')
6138 : end if
6139 12480000 : if (listentry%field%decomp_type < 0) then
6140 0 : write(errormsg, *) 'Invalid grid name, "', trim(gridname), '" for ', &
6141 0 : trim(fname)
6142 0 : call endrun('ADDFLD: '//trim(errormsg))
6143 : end if
6144 :
6145 : !
6146 : ! Indicate sampling sequence of field (i.e., how often "outfld" is called)
6147 : ! If not every timestep (default), then give a descriptor indicating the
6148 : ! sampling pattern. Currently, the only valid value is "rad_lwsw" for sampling
6149 : ! during LW/SW radiation timesteps only
6150 : !
6151 12480000 : if (present(sampling_seq)) then
6152 92160 : listentry%field%sampling_seq = sampling_seq
6153 : else
6154 12387840 : listentry%field%sampling_seq = ' '
6155 : end if
6156 : ! Indicate if some field pre-processing occurred (e.g., zonal mean)
6157 12480000 : if (cam_grid_is_zonal(listentry%field%decomp_type)) then
6158 12288 : call cam_grid_get_coord_names(listentry%field%decomp_type, coord_name, errormsg)
6159 : ! Zonal method currently hardcoded to 'mean'.
6160 12288 : listentry%field%cell_methods = trim(coord_name)//': mean'
6161 : else
6162 12467712 : listentry%field%cell_methods = ''
6163 : end if
6164 : !
6165 : ! Whether to apply xy fillvalue: default is false
6166 : !
6167 12480000 : if (present(flag_xyfill)) then
6168 159744 : listentry%field%flag_xyfill = flag_xyfill
6169 : else
6170 12320256 : listentry%field%flag_xyfill = .false.
6171 : end if
6172 :
6173 : !
6174 : ! Allow external packages to have fillvalues different than default
6175 : !
6176 :
6177 12480000 : if(present(fill_value)) then
6178 1536 : listentry%field%fillvalue = fill_value
6179 : else
6180 12478464 : listentry%field%fillvalue = fillvalue
6181 : endif
6182 :
6183 : !
6184 : ! Whether to allow subcycle averages; default is false
6185 : !
6186 12480000 : if (present(sampled_on_subcycle)) then
6187 551424 : listentry%field%sampled_on_subcycle = sampled_on_subcycle
6188 : else
6189 11928576 : listentry%field%sampled_on_subcycle = .false.
6190 : end if
6191 :
6192 : !
6193 : ! Process shape
6194 : !
6195 :
6196 12480000 : if (associated(listentry%field%mdims)) then
6197 0 : deallocate(listentry%field%mdims)
6198 : end if
6199 12480000 : nullify(listentry%field%mdims)
6200 12480000 : dimcnt = size(dimnames)
6201 32984064 : allocate(listentry%field%mdims(dimcnt))
6202 12480000 : call lookup_hist_coord_indices(dimnames, listentry%field%mdims)
6203 12480000 : if(dimcnt > maxvarmdims) then
6204 0 : maxvarmdims = dimcnt
6205 : end if
6206 : ! Check for subcols (currently limited to first dimension)
6207 12480000 : listentry%field%is_subcol = .false.
6208 12480000 : if (size(dimnames) > 0) then
6209 8024064 : if (trim(dimnames(1)) == 'psubcols') then
6210 0 : if (listentry%field%decomp_type /= cam_grid_id('physgrid')) then
6211 0 : write(errormsg, *) "Cannot add ", trim(fname), &
6212 0 : "Subcolumn history output only allowed on physgrid"
6213 0 : call endrun("ADDFLD: "//errormsg)
6214 : end if
6215 0 : listentry%field%is_subcol = .true.
6216 : end if
6217 : end if
6218 : ! Levels
6219 12480000 : listentry%field%numlev = hist_coord_find_levels(dimnames)
6220 12480000 : if (listentry%field%numlev <= 0) then
6221 4455936 : listentry%field%numlev = 1
6222 : end if
6223 :
6224 : !
6225 : ! Dimension history info based on decomposition type (grid)
6226 : !
6227 12480000 : call set_field_dimensions(listentry%field)
6228 :
6229 : !
6230 : ! These 2 fields are used only in master field list, not runtime field list
6231 : !
6232 162240000 : listentry%avgflag(:) = avgflag
6233 162240000 : listentry%actflag(:) = .false.
6234 :
6235 162240000 : do dimcnt = 1, ptapes
6236 162240000 : call AvgflagToString(avgflag, listentry%time_op(dimcnt))
6237 : end do
6238 :
6239 12480000 : if (present(optype)) then
6240 : ! make sure optype is "sum" or "dif"
6241 0 : if (.not.(trim(optype) == 'dif' .or. trim(optype) == 'sum')) then
6242 0 : write(errormsg, '(2a)')': Fatal : optype must be "sum" or "dif" not ',trim(optype)
6243 0 : call endrun (trim(subname)//errormsg)
6244 : end if
6245 0 : listentry%field%field_op = optype
6246 0 : if (present(op_f1name).and.present(op_f2name)) then
6247 : ! Look for the field IDs
6248 0 : f1listentry => get_entry_by_name(masterlinkedlist, trim(op_f1name))
6249 0 : f2listentry => get_entry_by_name(masterlinkedlist, trim(op_f2name))
6250 0 : if (associated(f1listentry).and.associated(f2listentry)) then
6251 0 : listentry%op_field1=trim(op_f1name)
6252 0 : listentry%op_field2=trim(op_f2name)
6253 : else
6254 0 : write(errormsg, '(5a)') ': Attempt to create a composed field using (', &
6255 0 : trim(op_f1name), ', ', trim(op_f2name), &
6256 0 : ') but both fields have not been added to masterlist via addfld first'
6257 0 : call endrun (trim(subname)//errormsg)
6258 : end if
6259 : else
6260 0 : write(errormsg, *) ': Attempt to create a composed field but no component fields have been specified'
6261 0 : call endrun (trim(subname)//errormsg)
6262 : end if
6263 :
6264 : else
6265 12480000 : if (present(op_f1name)) then
6266 0 : write(errormsg, '(3a)') ': creating a composed field using component field 1:',&
6267 0 : trim(op_f1name),' but no field operation (optype=sum or dif) has been defined'
6268 0 : call endrun (trim(subname)//errormsg)
6269 : end if
6270 12480000 : if (present(op_f2name)) then
6271 0 : write(errormsg, '(3a)') ': creating a composed field using component field 2:',&
6272 0 : trim(op_f2name),' but no field operation (optype=sum or dif) has been defined'
6273 0 : call endrun (trim(subname)//errormsg)
6274 : end if
6275 : end if
6276 :
6277 :
6278 12480000 : nullify(listentry%next_entry)
6279 :
6280 12480000 : call add_entry_to_master(listentry)
6281 12480000 : return
6282 24960000 : end subroutine addfld_nd
6283 :
6284 : !#######################################################################
6285 :
6286 : ! field_part_of_vector: Determine if fname is part of a vector set
6287 : ! Optionally fill in the names of the vector set fields
6288 0 : logical function field_part_of_vector(fname, meridional_name, zonal_name)
6289 :
6290 : ! Dummy arguments
6291 : character(len=*), intent(in) :: fname
6292 : character(len=*), optional, intent(out) :: meridional_name
6293 : character(len=*), optional, intent(out) :: zonal_name
6294 :
6295 : ! Local variables
6296 : type(master_entry), pointer :: listentry
6297 :
6298 0 : listentry => get_entry_by_name(masterlinkedlist, fname)
6299 0 : if (associated(listentry)) then
6300 0 : if ( (len_trim(listentry%meridional_field) > 0) .or. &
6301 : (len_trim(listentry%zonal_field) > 0)) then
6302 0 : field_part_of_vector = .true.
6303 0 : if (present(meridional_name)) then
6304 0 : meridional_name = listentry%meridional_field
6305 : end if
6306 0 : if (present(zonal_name)) then
6307 0 : zonal_name = listentry%zonal_field
6308 : end if
6309 : else
6310 : field_part_of_vector = .false.
6311 : end if
6312 : else
6313 : field_part_of_vector = .false.
6314 : end if
6315 : if (.not. field_part_of_vector) then
6316 0 : if (present(meridional_name)) then
6317 0 : meridional_name = ''
6318 : end if
6319 0 : if (present(zonal_name)) then
6320 0 : zonal_name = ''
6321 : end if
6322 : end if
6323 :
6324 12480000 : end function field_part_of_vector
6325 :
6326 : !#######################################################################
6327 : ! composed field_info: Determine if a field is derived from a mathematical
6328 : ! operation using 2 other defined fields. Optionally,
6329 : ! retrieve names of the composing fields
6330 1112832 : subroutine composed_field_info(fname, is_composed, fname1, fname2)
6331 :
6332 : ! Dummy arguments
6333 : character(len=*), intent(in) :: fname
6334 : logical, intent(out) :: is_composed
6335 : character(len=*), optional, intent(out) :: fname1
6336 : character(len=*), optional, intent(out) :: fname2
6337 :
6338 : ! Local variables
6339 : type(master_entry), pointer :: listentry
6340 : character(len=128) :: errormsg
6341 : character(len=*), parameter :: subname='composed_field_info'
6342 :
6343 2225664 : listentry => get_entry_by_name(masterlinkedlist, fname)
6344 1112832 : if (associated(listentry)) then
6345 1112832 : if ( (len_trim(listentry%op_field1) > 0) .or. &
6346 : (len_trim(listentry%op_field2) > 0)) then
6347 0 : is_composed = .true.
6348 : else
6349 1112832 : is_composed = .false.
6350 : end if
6351 1112832 : if (is_composed) then
6352 0 : if (present(fname1)) then
6353 0 : fname1=trim(listentry%op_field1)
6354 : end if
6355 0 : if (present(fname2)) then
6356 0 : fname2=trim(listentry%op_field2)
6357 : end if
6358 : else
6359 1112832 : if (present(fname1)) then
6360 1112832 : fname1 = ''
6361 : end if
6362 1112832 : if (present(fname2)) then
6363 1112832 : fname2 = ''
6364 : end if
6365 : end if
6366 : else
6367 0 : write(errormsg, '(3a)') ': Field:',trim(fname),' not defined in masterlist'
6368 0 : call endrun (trim(subname)//errormsg)
6369 : end if
6370 :
6371 1112832 : end subroutine composed_field_info
6372 :
6373 :
6374 : ! register_vector_field: Register a pair of history field names as
6375 : ! being a vector complement set.
6376 : ! This information is used to set up interpolated history output.
6377 : ! NB: register_vector_field must be called after both fields are defined
6378 : ! with addfld
6379 62976 : subroutine register_vector_field(zonal_field_name, meridional_field_name)
6380 :
6381 : ! Dummy arguments
6382 : character(len=*), intent(in) :: zonal_field_name
6383 : character(len=*), intent(in) :: meridional_field_name
6384 :
6385 : ! Local variables
6386 : type(master_entry), pointer :: mlistentry
6387 : type(master_entry), pointer :: zlistentry
6388 : character(len=*), parameter :: subname = 'REGISTER_VECTOR_FIELD'
6389 : character(len=max_chars) :: errormsg
6390 :
6391 62976 : if (htapes_defined) then
6392 0 : write(errormsg, '(5a)') ': Attempt to register vector field (', &
6393 0 : trim(zonal_field_name), ', ', trim(meridional_field_name), &
6394 0 : ') after history files set'
6395 0 : call endrun (trim(subname)//errormsg)
6396 : end if
6397 :
6398 : ! Look for the field IDs
6399 62976 : zlistentry => get_entry_by_name(masterlinkedlist, zonal_field_name)
6400 62976 : mlistentry => get_entry_by_name(masterlinkedlist, meridional_field_name)
6401 : ! Has either of these fields been previously registered?
6402 62976 : if (associated(mlistentry)) then
6403 62976 : if (len_trim(mlistentry%meridional_field) > 0) then
6404 0 : write(errormsg, '(9a)') ': ERROR attempting to register vector ', &
6405 0 : 'field (', trim(zonal_field_name), ', ', &
6406 0 : trim(meridional_field_name), '), ', trim(meridional_field_name), &
6407 0 : ' has been registered as part of a vector field with ', &
6408 0 : trim(mlistentry%meridional_field)
6409 0 : call endrun (trim(subname)//errormsg)
6410 62976 : else if (len_trim(mlistentry%zonal_field) > 0) then
6411 0 : write(errormsg, '(9a)') ': ERROR attempting to register vector ', &
6412 0 : 'field (', trim(zonal_field_name), ', ', &
6413 0 : trim(meridional_field_name), '), ', trim(meridional_field_name), &
6414 0 : ' has been registered as part of a vector field with ', &
6415 0 : trim(mlistentry%zonal_field)
6416 0 : call endrun (trim(subname)//errormsg)
6417 : end if
6418 : end if
6419 62976 : if (associated(zlistentry)) then
6420 62976 : if (len_trim(zlistentry%meridional_field) > 0) then
6421 0 : write(errormsg, '(9a)') ': ERROR attempting to register vector ', &
6422 0 : 'field (', trim(zonal_field_name), ', ', &
6423 0 : trim(meridional_field_name), '), ', trim(zonal_field_name), &
6424 0 : ' has been registered as part of a vector field with ', &
6425 0 : trim(zlistentry%meridional_field)
6426 0 : call endrun (trim(subname)//errormsg)
6427 62976 : else if (len_trim(zlistentry%zonal_field) > 0) then
6428 0 : write(errormsg, '(9a)') ': ERROR attempting to register vector ', &
6429 0 : 'field (', trim(zonal_field_name), ', ', &
6430 0 : trim(meridional_field_name), '), ', trim(zonal_field_name), &
6431 0 : ' has been registered as part of a vector field with ', &
6432 0 : trim(zlistentry%meridional_field)
6433 0 : call endrun (trim(subname)//errormsg)
6434 : end if
6435 : end if
6436 62976 : if(associated(mlistentry) .and. associated(zlistentry)) then
6437 62976 : zlistentry%meridional_field = mlistentry%field%name
6438 62976 : zlistentry%zonal_field = ''
6439 62976 : mlistentry%meridional_field = ''
6440 62976 : mlistentry%zonal_field = zlistentry%field%name
6441 0 : else if (associated(mlistentry)) then
6442 0 : write(errormsg, '(7a)') ': ERROR attempting to register vector field (',&
6443 0 : trim(zonal_field_name), ', ', trim(meridional_field_name), &
6444 0 : '), ', trim(zonal_field_name), ' is not defined'
6445 0 : call endrun (trim(subname)//errormsg)
6446 0 : else if (associated(zlistentry)) then
6447 0 : write(errormsg, '(7a)') ': ERROR attempting to register vector field (',&
6448 0 : trim(zonal_field_name), ', ', trim(meridional_field_name), &
6449 0 : '), ', trim(meridional_field_name), ' is not defined'
6450 0 : call endrun (trim(subname)//errormsg)
6451 : else
6452 0 : write(errormsg, '(5a)') ': ERROR attempting to register vector field (',&
6453 0 : trim(zonal_field_name), ', ', trim(meridional_field_name), &
6454 0 : '), neither field is defined'
6455 0 : call endrun (trim(subname)//errormsg)
6456 : end if
6457 62976 : end subroutine register_vector_field
6458 :
6459 12480000 : subroutine add_entry_to_master( newentry)
6460 : type(master_entry), target, intent(in) :: newentry
6461 : type(master_entry), pointer :: listentry
6462 :
6463 12480000 : if(associated(masterlinkedlist)) then
6464 : listentry => masterlinkedlist
6465 50693760000 : do while(associated(listentry%next_entry))
6466 12478464 : listentry=>listentry%next_entry
6467 : end do
6468 12478464 : listentry%next_entry=>newentry
6469 : else
6470 1536 : masterlinkedlist=>newentry
6471 : end if
6472 :
6473 12480000 : end subroutine add_entry_to_master
6474 :
6475 : !#######################################################################
6476 :
6477 14592 : subroutine wrapup (rstwr, nlend)
6478 : !
6479 : !-----------------------------------------------------------------------
6480 : !
6481 : ! Purpose:
6482 : ! Close history files.
6483 : !
6484 : ! Method:
6485 : ! This routine will close any full hist. files
6486 : ! or any hist. file that has data on it when restart files are being
6487 : ! written.
6488 : ! If a partially full history file was disposed (for restart
6489 : ! purposes), then wrapup will open that unit back up and position
6490 : ! it for appending new data.
6491 : !
6492 : ! Original version: CCM2
6493 : !
6494 : !-----------------------------------------------------------------------
6495 : !
6496 : use shr_kind_mod, only: r8 => shr_kind_r8
6497 : use ioFileMod
6498 : use time_manager, only: get_nstep, get_curr_date, get_curr_time
6499 : use cam_pio_utils, only: cam_pio_openfile, cam_pio_closefile
6500 :
6501 : !
6502 : ! Input arguments
6503 : !
6504 : logical, intent(in) :: rstwr ! true => restart files are written this timestep
6505 : logical, intent(in) :: nlend ! Flag if time to end
6506 :
6507 : !
6508 : ! Local workspace
6509 : !
6510 : integer :: nstep ! current timestep number
6511 : integer :: ncsec ! time of day relative to current date [secs]
6512 : integer :: ndcur ! days component of current time
6513 : integer :: nscur ! seconds component of current time
6514 : integer :: yr, mon, day ! year, month, day components of a date
6515 :
6516 : logical :: lfill (ptapes) ! Is history file ready to dispose?
6517 : logical :: lhdisp ! true => history file is disposed
6518 : logical :: lhfill ! true => history file is full
6519 :
6520 : integer :: t ! History file number
6521 : integer :: f ! File index
6522 : integer :: fld ! Field index
6523 : real(r8) :: tday ! Model day number for printout
6524 : !-----------------------------------------------------------------------
6525 :
6526 14592 : tape => history_tape
6527 :
6528 14592 : nstep = get_nstep()
6529 14592 : call get_curr_date(yr, mon, day, ncsec)
6530 14592 : call get_curr_time(ndcur, nscur)
6531 : !
6532 : !-----------------------------------------------------------------------
6533 : ! Dispose history files.
6534 : !-----------------------------------------------------------------------
6535 : !
6536 : ! Begin loop over ptapes (the no. of declared history files - primary
6537 : ! and auxiliary). This loop disposes a history file to Mass Store
6538 : ! when appropriate.
6539 : !
6540 189696 : do t=1,ptapes
6541 175104 : if (nflds(t) == 0) cycle
6542 72960 : lfill(t) = .false.
6543 : !
6544 : ! Find out if file is full
6545 : !
6546 72960 : if (hstwr(t) .and. nfils(t) >= mfilt(t)) then
6547 4608 : lfill(t) = .true.
6548 : endif
6549 : !
6550 : ! Dispose history file if
6551 : ! 1) file is filled or
6552 : ! 2) this is the end of run and file has data on it or
6553 : ! 3) restarts are being put out and history file has data on it
6554 : !
6555 87552 : if (lfill(t) .or. (nlend .and. nfils(t) >= 1) .or. (rstwr .and. nfils(t) >= 1)) then
6556 : !
6557 : ! Dispose history file
6558 : !
6559 : !
6560 : ! Is this the 0 timestep data of a monthly run?
6561 : ! If so, just close primary unit do not dispose.
6562 : !
6563 4608 : if (masterproc) then
6564 18 : do f = 1, maxsplitfiles
6565 18 : if (pio_file_is_open(tape(t)%Files(f))) then
6566 12 : write(iulog,*)'WRAPUP: nf_close(',t,')=',trim(nhfil(t,f))
6567 : end if
6568 : end do
6569 : end if
6570 4608 : if(pio_file_is_open(tape(t)%Files(accumulated_file_index)) .or. &
6571 : pio_file_is_open(tape(t)%Files(instantaneous_file_index))) then
6572 4608 : if (nlend .or. lfill(t)) then
6573 5174784 : do fld=1,nflds(t)
6574 5174784 : if (associated(tape(t)%hlist(fld)%varid)) then
6575 5170176 : deallocate(tape(t)%hlist(fld)%varid)
6576 5170176 : nullify(tape(t)%hlist(fld)%varid)
6577 : end if
6578 : end do
6579 : end if
6580 : end if
6581 13824 : do f = 1, maxsplitfiles
6582 13824 : if (pio_file_is_open(tape(t)%Files(f))) then
6583 9216 : call cam_pio_closefile(tape(t)%Files(f))
6584 : end if
6585 : end do
6586 4608 : if (nhtfrq(t) /= 0 .or. nstep > 0) then
6587 :
6588 : !
6589 : ! Print information concerning model output.
6590 : ! Model day number = iteration number of history file data * delta-t / (seconds per day)
6591 : !
6592 4608 : tday = ndcur + nscur/86400._r8
6593 4608 : if(masterproc) then
6594 6 : if (t==1) then
6595 6 : write(iulog,*)' Primary history file'
6596 : else
6597 0 : write(iulog,*)' Auxiliary history file number ', t-1
6598 : end if
6599 6 : write(iulog,9003)nstep,nfils(t),tday
6600 6 : write(iulog,9004)
6601 : end if
6602 : !
6603 : ! Auxilary files may have been closed and saved off without being full.
6604 : ! We must reopen the files and position them for more data.
6605 : ! Must position auxiliary files if not full
6606 : !
6607 4608 : if (.not.nlend .and. .not.lfill(t)) then
6608 : ! Always open the instantaneous file
6609 0 : call cam_PIO_openfile (tape(t)%Files(instantaneous_file_index), nhfil(t,instantaneous_file_index), PIO_WRITE)
6610 0 : if (hfile_accum(t)) then
6611 : ! Conditionally open the accumulated file
6612 0 : call cam_PIO_openfile (tape(t)%Files(accumulated_file_index), nhfil(t,accumulated_file_index), PIO_WRITE)
6613 : end if
6614 0 : call h_inquire(t)
6615 : end if
6616 : endif ! if 0 timestep of montly run****
6617 : end if ! if time dispose history fiels***
6618 : end do ! do ptapes
6619 : !
6620 : ! Reset number of files on each history tape
6621 : !
6622 189696 : do t=1,ptapes
6623 175104 : if (nflds(t) == 0) cycle
6624 72960 : lhfill = hstwr(t) .and. nfils(t) >= mfilt(t)
6625 : lhdisp = lhfill .or. (nlend .and. nfils(t) >= 1) .or. &
6626 72960 : (rstwr .and. nfils(t) >= 1)
6627 87552 : if (lhfill.and.lhdisp) then
6628 4608 : nfils(t) = 0
6629 : endif
6630 : end do
6631 14592 : return
6632 : 9003 format(' Output at NSTEP = ',i10,/, &
6633 : ' Number of time samples on this file = ',i10,/, &
6634 : ' Model Day = ',f10.2)
6635 : 9004 format('---------------------------------------')
6636 14592 : end subroutine wrapup
6637 :
6638 :
6639 621283584 : integer function gen_hash_key(string)
6640 : !
6641 : !-----------------------------------------------------------------------
6642 : !
6643 : ! Purpose: Generate a hash key on the interval [0 .. tbl_hash_pri_sz-1]
6644 : ! given a character string.
6645 : !
6646 : ! Algorithm is a variant of perl's internal hashing function.
6647 : !
6648 : !-----------------------------------------------------------------------
6649 : !
6650 : implicit none
6651 : !
6652 : ! Arguments:
6653 : !
6654 : character(len=*), intent(in) :: string
6655 : !
6656 : ! Local.
6657 : !
6658 : integer :: hash
6659 : integer :: i
6660 :
6661 621283584 : hash = gen_hash_key_offset
6662 :
6663 621283584 : if ( len(string) /= 19 ) then
6664 : !
6665 : ! Process arbitrary string length.
6666 : !
6667 22366209024 : do i = 1, len(string)
6668 22366209024 : hash = ieor(hash, (ichar(string(i:i)) * tbl_gen_hash_key(iand(i-1,tbl_max_idx))))
6669 : end do
6670 : else
6671 : !
6672 : ! Special case string length = 19
6673 : !
6674 0 : hash = ieor(hash , ichar(string(1:1)) * 61)
6675 0 : hash = ieor(hash , ichar(string(2:2)) * 59)
6676 0 : hash = ieor(hash , ichar(string(3:3)) * 53)
6677 0 : hash = ieor(hash , ichar(string(4:4)) * 47)
6678 0 : hash = ieor(hash , ichar(string(5:5)) * 43)
6679 0 : hash = ieor(hash , ichar(string(6:6)) * 41)
6680 0 : hash = ieor(hash , ichar(string(7:7)) * 37)
6681 0 : hash = ieor(hash , ichar(string(8:8)) * 31)
6682 0 : hash = ieor(hash , ichar(string(9:9)) * 29)
6683 0 : hash = ieor(hash , ichar(string(10:10)) * 23)
6684 0 : hash = ieor(hash , ichar(string(11:11)) * 17)
6685 0 : hash = ieor(hash , ichar(string(12:12)) * 13)
6686 0 : hash = ieor(hash , ichar(string(13:13)) * 11)
6687 0 : hash = ieor(hash , ichar(string(14:14)) * 7)
6688 0 : hash = ieor(hash , ichar(string(15:15)) * 3)
6689 0 : hash = ieor(hash , ichar(string(16:16)) * 1)
6690 0 : hash = ieor(hash , ichar(string(17:17)) * 61)
6691 0 : hash = ieor(hash , ichar(string(18:18)) * 59)
6692 0 : hash = ieor(hash , ichar(string(19:19)) * 53)
6693 : end if
6694 :
6695 621283584 : gen_hash_key = iand(hash, tbl_hash_pri_sz-1)
6696 :
6697 : return
6698 :
6699 14592 : end function gen_hash_key
6700 :
6701 : !#######################################################################
6702 :
6703 596323584 : integer function get_masterlist_indx(fldname)
6704 : !
6705 : !-----------------------------------------------------------------------
6706 : !
6707 : ! Purpose: Return the the index of the field's name on the master file list.
6708 : !
6709 : ! If the field is not found on the masterlist, return -1.
6710 : !
6711 : !-----------------------------------------------------------------------
6712 : !
6713 : ! Arguments:
6714 : !
6715 : character(len=*), intent(in) :: fldname
6716 : !
6717 : ! Local.
6718 : !
6719 : integer :: hash_key
6720 : integer :: ff
6721 : integer :: ii
6722 : integer :: io ! Index of overflow chain in overflow table
6723 : integer :: in ! Number of entries on overflow chain
6724 :
6725 596323584 : hash_key = gen_hash_key(fldname)
6726 596323584 : ff = tbl_hash_pri(hash_key)
6727 596323584 : if ( ff < 0 ) then
6728 389338368 : io = abs(ff)
6729 389338368 : in = tbl_hash_oflow(io)
6730 733118976 : do ii = 1, in
6731 733118976 : ff = tbl_hash_oflow(io+ii)
6732 733118976 : if ( masterlist(ff)%thisentry%field%name == fldname ) exit
6733 : end do
6734 : end if
6735 :
6736 596323584 : if (ff == 0) then
6737 : ! fldname generated a hash key that doesn't have an entry in tbl_hash_pri.
6738 : ! This means that fldname isn't in the masterlist
6739 0 : call endrun ('GET_MASTERLIST_INDX: attemping to output field '//fldname//' not on master list')
6740 : end if
6741 :
6742 596323584 : if (associated(masterlist(ff)%thisentry) .and. masterlist(ff)%thisentry%field%name /= fldname ) then
6743 0 : call endrun ('GET_MASTERLIST_INDX: error finding field '//fldname//' on master list')
6744 : end if
6745 :
6746 596323584 : get_masterlist_indx = ff
6747 : return
6748 : end function get_masterlist_indx
6749 : !#######################################################################
6750 :
6751 1536 : subroutine bld_outfld_hash_tbls()
6752 : !
6753 : !-----------------------------------------------------------------------
6754 : !
6755 : ! Purpose: Build primary and overflow hash tables for outfld processing.
6756 : !
6757 : ! Steps:
6758 : ! 1) Foreach field on masterlist, find all collisions.
6759 : ! 2) Given the number of collisions, verify overflow table has sufficient
6760 : ! space.
6761 : ! 3) Build primary and overflow indices.
6762 : !
6763 : !-----------------------------------------------------------------------
6764 : !
6765 : ! Local.
6766 : !
6767 : integer :: ff
6768 : integer :: ii
6769 : integer :: itemp
6770 : integer :: ncollisions
6771 : integer :: hash_key
6772 : type(master_entry), pointer :: listentry
6773 : !
6774 : ! 1) Find all collisions.
6775 : !
6776 1536 : tbl_hash_pri = 0
6777 :
6778 1536 : ff=0
6779 12484608 : allocate(masterlist(nfmaster))
6780 1536 : listentry=>masterlinkedlist
6781 12481536 : do while(associated(listentry))
6782 12480000 : ff=ff+1
6783 12480000 : masterlist(ff)%thisentry=>listentry
6784 12480000 : listentry=>listentry%next_entry
6785 : end do
6786 1536 : if(ff /= nfmaster) then
6787 0 : write(iulog,*) 'nfmaster = ',nfmaster, ' ff=',ff
6788 0 : call endrun('mismatch in expected size of nfmaster')
6789 : end if
6790 :
6791 :
6792 12481536 : do ff = 1, nfmaster
6793 12480000 : hash_key = gen_hash_key(masterlist(ff)%thisentry%field%name)
6794 12481536 : tbl_hash_pri(hash_key) = tbl_hash_pri(hash_key) + 1
6795 : end do
6796 :
6797 : !
6798 : ! 2) Count number of collisions and define start of a individual
6799 : ! collision's chain in overflow table. A collision is defined to be any
6800 : ! location in tbl_hash_pri that has a value > 1.
6801 : !
6802 1536 : ncollisions = 0
6803 1610614272 : do ii = 0, tbl_hash_pri_sz-1
6804 1610614272 : if ( tbl_hash_pri(ii) > 1 ) then ! Define start of chain in O.F. table
6805 3294720 : itemp = tbl_hash_pri(ii)
6806 3294720 : tbl_hash_pri(ii) = -(ncollisions + 1)
6807 3294720 : ncollisions = ncollisions + itemp + 1
6808 : end if
6809 : end do
6810 :
6811 1536 : if ( ncollisions > tbl_hash_oflow_sz ) then
6812 0 : write(iulog,*) 'BLD_OUTFLD_HASH_TBLS: ncollisions > tbl_hash_oflow_sz', &
6813 0 : ncollisions, tbl_hash_oflow_sz
6814 0 : call endrun()
6815 : end if
6816 :
6817 : !
6818 : ! 3) Build primary and overflow tables.
6819 : ! i - set collisions in tbl_hash_pri to point to their respective
6820 : ! chain in the overflow table.
6821 : !
6822 1536 : tbl_hash_oflow = 0
6823 :
6824 12481536 : do ff = 1, nfmaster
6825 12480000 : hash_key = gen_hash_key(masterlist(ff)%thisentry%field%name)
6826 12481536 : if ( tbl_hash_pri(hash_key) < 0 ) then
6827 8054784 : ii = abs(tbl_hash_pri(hash_key))
6828 8054784 : tbl_hash_oflow(ii) = tbl_hash_oflow(ii) + 1
6829 8054784 : tbl_hash_oflow(ii+tbl_hash_oflow(ii)) = ff
6830 : else
6831 4425216 : tbl_hash_pri(hash_key) = ff
6832 : end if
6833 : end do
6834 :
6835 1536 : end subroutine bld_outfld_hash_tbls
6836 :
6837 : !#######################################################################
6838 :
6839 1536 : subroutine bld_htapefld_indices
6840 : !
6841 : !-----------------------------------------------------------------------
6842 : !
6843 : ! Purpose: Set history tape field indicies in masterlist for each
6844 : ! field defined on every tape.
6845 : !
6846 : ! Note: because of restart processing, the actflag field is cleared and
6847 : ! then set only for active output fields on the different history
6848 : ! tapes.
6849 : !
6850 : !-----------------------------------------------------------------------
6851 : !
6852 : ! Arguments:
6853 : !
6854 :
6855 : !
6856 : ! Local.
6857 : !
6858 : integer :: fld
6859 : integer :: t
6860 :
6861 : !
6862 : ! Initialize htapeindx to an invalid value.
6863 : !
6864 : type(master_entry), pointer :: listentry
6865 :
6866 : ! reset all the active flags to false
6867 : ! this is needed so that restarts work properly -- fvitt
6868 1536 : listentry=>masterlinkedlist
6869 12481536 : do while(associated(listentry))
6870 162240000 : listentry%actflag(:) = .false.
6871 12480000 : listentry%act_sometape = .false.
6872 12480000 : listentry=>listentry%next_entry
6873 : end do
6874 :
6875 19968 : do t = 1, ptapes
6876 2245632 : do fld = 1, nflds(t)
6877 2225664 : listentry => get_entry_by_name(masterlinkedlist, tape(t)%hlist(fld)%field%name)
6878 2225664 : if(.not.associated(listentry)) then
6879 0 : write(iulog,*) 'BLD_HTAPEFLD_INDICES: something wrong, field not found on masterlist'
6880 0 : write(iulog,*) 'BLD_HTAPEFLD_INDICES: t, f, ff = ', t, fld
6881 0 : write(iulog,*) 'BLD_HTAPEFLD_INDICES: tape%name = ', tape(t)%hlist(fld)%field%name
6882 0 : call endrun
6883 : end if
6884 2225664 : listentry%act_sometape = .true.
6885 2225664 : listentry%actflag(t) = .true.
6886 2244096 : listentry%htapeindx(t) = fld
6887 : end do
6888 : end do
6889 :
6890 : !
6891 : ! set flag indicating h-tape contents are now defined (needed by addfld)
6892 : !
6893 1536 : htapes_defined = .true.
6894 :
6895 1536 : return
6896 : end subroutine bld_htapefld_indices
6897 :
6898 : !#######################################################################
6899 :
6900 25294080 : logical function hist_fld_active(fname)
6901 : !
6902 : !------------------------------------------------------------------------
6903 : !
6904 : ! Purpose: determine if a field is active on any history file
6905 : !
6906 : !------------------------------------------------------------------------
6907 : !
6908 : ! Arguments
6909 : !
6910 : character(len=*), intent(in) :: fname ! Field name
6911 : !
6912 : ! Local variables
6913 : !
6914 : character*(max_fieldname_len) :: fname_loc ! max-char equivalent of fname
6915 : integer :: ff ! masterlist index pointer
6916 : !-----------------------------------------------------------------------
6917 :
6918 25294080 : fname_loc = fname
6919 25294080 : ff = get_masterlist_indx(fname_loc)
6920 25294080 : if ( ff < 0 ) then
6921 : hist_fld_active = .false.
6922 : else
6923 25294080 : hist_fld_active = masterlist(ff)%thisentry%act_sometape
6924 : end if
6925 :
6926 25294080 : end function hist_fld_active
6927 :
6928 : !#######################################################################
6929 :
6930 0 : function hist_fld_col_active(fname, lchnk, numcols)
6931 : use cam_history_support, only: history_patch_t
6932 :
6933 : ! Determine whether each column in a field is active on any history file.
6934 : ! The purpose of this routine is to provide information which would allow
6935 : ! a diagnostic physics parameterization to only be run on a subset of
6936 : ! columns in the case when only column or regional output is requested.
6937 : !
6938 : ! **N.B.** The field is assumed to be using the physics decomposition.
6939 :
6940 : ! Arguments
6941 : character(len=*), intent(in) :: fname ! Field name
6942 : integer, intent(in) :: lchnk ! chunk ID
6943 : integer, intent(in) :: numcols ! Size of return array
6944 :
6945 : ! Return value
6946 : logical :: hist_fld_col_active(numcols)
6947 :
6948 : ! Local variables
6949 : integer :: ffld ! masterlist index pointer
6950 : integer :: i
6951 : integer :: t ! history file (tape) index
6952 : integer :: fld ! field index
6953 : integer :: decomp
6954 0 : logical :: activeloc(numcols)
6955 : integer :: num_patches
6956 : logical :: patch_output
6957 : logical :: found
6958 : type(history_patch_t), pointer :: patchptr
6959 :
6960 0 : type (active_entry), pointer :: tape(:)
6961 :
6962 : !-----------------------------------------------------------------------
6963 :
6964 : ! Initialize to false. Then look to see if and where active.
6965 0 : hist_fld_col_active = .false.
6966 :
6967 : ! Check for name in the master list.
6968 0 : call get_field_properties(fname, found, tape_out=tape, ff_out=ffld)
6969 :
6970 : ! If not in master list then return.
6971 0 : if (.not. found) return
6972 :
6973 : ! If in master list, but not active on any file then return
6974 0 : if (.not. masterlist(ffld)%thisentry%act_sometape) return
6975 :
6976 : ! Loop over history files and check for the field/column in each one
6977 0 : do t = 1, ptapes
6978 :
6979 : ! Is the field active in this file? If not the cycle to next file.
6980 0 : if (.not. masterlist(ffld)%thisentry%actflag(t)) cycle
6981 :
6982 0 : fld = masterlist(ffld)%thisentry%htapeindx(t)
6983 0 : decomp = tape(t)%hlist(fld)%field%decomp_type
6984 0 : patch_output = associated(tape(t)%patches)
6985 :
6986 : ! Check whether this file has patch (column) output.
6987 0 : if (patch_output) then
6988 0 : num_patches = size(tape(t)%patches)
6989 :
6990 0 : do i = 1, num_patches
6991 0 : patchptr => tape(t)%patches(i)
6992 0 : activeloc = .false.
6993 0 : call patchptr%active_cols(decomp, lchnk, activeloc)
6994 0 : hist_fld_col_active = hist_fld_col_active .or. activeloc
6995 : end do
6996 : else
6997 :
6998 : ! No column output has been requested. In that case the field has
6999 : ! global output which implies all columns are active. No need to
7000 : ! check any other history files.
7001 0 : hist_fld_col_active = .true.
7002 : exit
7003 :
7004 : end if
7005 :
7006 : end do ! history files
7007 :
7008 0 : end function hist_fld_col_active
7009 :
7010 0 : subroutine cam_history_snapshot_deactivate(name)
7011 :
7012 : ! This subroutine deactivates (sets actflag to false) for all tapes
7013 :
7014 : character(len=*), intent(in) :: name
7015 :
7016 : logical :: found
7017 : integer :: ff
7018 :
7019 0 : call get_field_properties(trim(name), found, ff_out=ff, no_tape_check_in=.true.)
7020 0 : masterlist(ff)%thisentry%actflag(:) = .false.
7021 :
7022 0 : end subroutine cam_history_snapshot_deactivate
7023 :
7024 0 : subroutine cam_history_snapshot_activate(name, tape)
7025 :
7026 : ! This subroutine activates (set aftflag to true) for the requested tape number
7027 :
7028 : character(len=*), intent(in) :: name
7029 : integer, intent(in) :: tape
7030 :
7031 : logical :: found
7032 : integer :: ff
7033 :
7034 0 : call get_field_properties(trim(name), found, ff_out=ff, no_tape_check_in=.true.)
7035 0 : masterlist(ff)%thisentry%actflag(tape) = .true.
7036 :
7037 0 : end subroutine cam_history_snapshot_activate
7038 :
7039 0 : end module cam_history
|
