LCOV - code coverage report
Current view: | top level - control - cam_history.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 2061 | 3086 | 66.8 %
Date: | 2024-12-17 17:57:11 |  | Functions: | 45 | 64 | 70.3 %

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

Generated by: LCOV version 1.14