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      979968 :     do while(associated(listentry))
     422      978432 :       fld=fld+1
     423      978432 :       if(masterproc) then
     424        1274 :         fldname = listentry%field%name
     425        1274 :         write(iulog,9000) fld, fldname, listentry%field%units, listentry%field%numlev, &
     426        2548 :              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      978432 :       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       82176 :       do fld=1,nflds(t)
     489       72192 :         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       72192 :         if (tape(t)%hlist(fld)%avgflag .ne. 'I') then
     494       66048 :            hfile_accum(t) = .true.
     495             :         end if
     496       72192 :         begdim1  = tape(t)%hlist(fld)%field%begdim1
     497       72192 :         enddim1  = tape(t)%hlist(fld)%field%enddim1
     498       72192 :         begdim2  = tape(t)%hlist(fld)%field%begdim2
     499       72192 :         enddim2  = tape(t)%hlist(fld)%field%enddim2
     500       72192 :         begdim3  = tape(t)%hlist(fld)%field%begdim3
     501       72192 :         enddim3  = tape(t)%hlist(fld)%field%enddim3
     502      360960 :         allocate(tape(t)%hlist(fld)%hbuf(begdim1:enddim1,begdim2:enddim2,begdim3:enddim3))
     503    56213328 :         tape(t)%hlist(fld)%hbuf = 0._r8
     504       72192 :         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       72192 :         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       72192 :         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      214272 :           allocate (tape(t)%hlist(fld)%nacs(1,begdim3:enddim3))
     542             :         end if
     543      732936 :         tape(t)%hlist(fld)%nacs(:,:) = 0
     544       72192 :         tape(t)%hlist(fld)%beg_nstep = 0
     545       72192 :         tape(t)%hlist(fld)%field%meridional_complement = -1
     546       81408 :         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     1050624 :   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     1050624 :     call cam_grid_get_array_bounds(field%decomp_type, dimbounds)
     942     1050624 :     field%begdim1  = dimbounds(1,1)
     943     1050624 :     field%enddim1  = dimbounds(1,2)
     944     1050624 :     field%begdim2  = 1
     945     1050624 :     if (associated(field%mdims)) then
     946     1004544 :       if (size(field%mdims) > 0) then
     947      640512 :         field%enddim2  = 1
     948     1281024 :         do i = 1, size(field%mdims)
     949      640512 :           msize = hist_coord_size(field%mdims(i))
     950      640512 :           if (msize <= 0) then
     951           0 :             call endrun('set_field_dimensions: mdim size must be > 0')
     952             :           end if
     953     1281024 :           field%enddim2 = field%enddim2 * msize
     954             :         end do
     955             :       else
     956      364032 :         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      364032 :         field%enddim2 = field%numlev
     963             :       end if
     964             :     else
     965       46080 :       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       46080 :       field%enddim2 = field%numlev
     972             :     end if
     973     1050624 :     field%begdim3  = dimbounds(2,1)
     974     1050624 :     field%enddim3  = dimbounds(2,2)
     975     1050624 :     field%colperchunk = cam_grid_is_block_indexed(field%decomp_type)
     976             : 
     977     1050624 :   end subroutine set_field_dimensions
     978             : 
     979        1536 :   subroutine setup_interpolation_and_define_vector_complements()
     980     1050624 :     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       81408 :     do fld = 1, nflds(t)
    1045       72192 :        call composed_field_info(tape(t)%hlist(fld)%field%name,is_composed,fname1=field1,fname2=field2)
    1046       81408 :        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     1623552 :     xyfill = 0
    1599        3072 :     allocate(is_subcol(maxnflds, ptapes))
    1600     1623552 :     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     3227136 :     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      162816 :       do fld=1,nflds(t)
    1729      144384 :         start(1)=fld
    1730      144384 :         startc(2)=fld
    1731      144384 :         ierr = pio_put_var(File, field_name_desc,startc,tape(t)%hlist(fld)%field%name)
    1732      144384 :         ierr = pio_put_var(File, decomp_type_desc,start,tape(t)%hlist(fld)%field%decomp_type)
    1733      144384 :         ierr = pio_put_var(File, numlev_desc,start,tape(t)%hlist(fld)%field%numlev)
    1734             : 
    1735      144384 :         ierr = pio_put_var(File, hwrt_prec_desc,start,tape(t)%hlist(fld)%hwrt_prec)
    1736      144384 :         call tape(t)%hlist(fld)%get_global(integral)
    1737      144384 :         ierr = pio_put_var(File, hbuf_integral_desc,start,integral)
    1738      144384 :         ierr = pio_put_var(File, beg_nstep_desc,start,tape(t)%hlist(fld)%beg_nstep)
    1739      144384 :         ierr = pio_put_var(File, sseq_desc,startc,tape(t)%hlist(fld)%field%sampling_seq)
    1740      144384 :         ierr = pio_put_var(File, cm_desc,startc,tape(t)%hlist(fld)%field%cell_methods)
    1741      144384 :         ierr = pio_put_var(File, longname_desc,startc,tape(t)%hlist(fld)%field%long_name)
    1742      144384 :         ierr = pio_put_var(File, units_desc,startc,tape(t)%hlist(fld)%field%units)
    1743      144384 :         ierr = pio_put_var(File, avgflag_desc,start, tape(t)%hlist(fld)%avgflag)
    1744             : 
    1745      144384 :         ierr = pio_put_var(File, fillval_desc,start, tape(t)%hlist(fld)%field%fillvalue)
    1746      144384 :         ierr = pio_put_var(File, meridional_complement_desc,start, tape(t)%hlist(fld)%field%meridional_complement)
    1747      144384 :         ierr = pio_put_var(File, zonal_complement_desc,start, tape(t)%hlist(fld)%field%zonal_complement)
    1748      144384 :         ierr = pio_put_var(File, field_op_desc,startc, tape(t)%hlist(fld)%field%field_op)
    1749      144384 :         ierr = pio_put_var(File, op_field1_id_desc,start, tape(t)%hlist(fld)%field%op_field1_id)
    1750      144384 :         ierr = pio_put_var(File, op_field2_id_desc,start, tape(t)%hlist(fld)%field%op_field2_id)
    1751      144384 :         ierr = pio_put_var(File, op_field1_desc,startc, tape(t)%hlist(fld)%op_field1)
    1752      144384 :         ierr = pio_put_var(File, op_field2_desc,startc, tape(t)%hlist(fld)%op_field2)
    1753      144384 :         if(associated(tape(t)%hlist(fld)%field%mdims)) then
    1754      150528 :           allmdims(1:size(tape(t)%hlist(fld)%field%mdims),fld,t) = tape(t)%hlist(fld)%field%mdims
    1755             :         else
    1756             :         end if
    1757      144384 :         if(tape(t)%hlist(fld)%field%flag_xyfill) then
    1758        1536 :            xyfill(fld,t) = 1
    1759             :         end if
    1760      162816 :         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       13824 :     do fld = 1, registeredmdims
    1796       12288 :       start(2) = fld
    1797       13824 :       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        6912 :     do f = 1, mdimcnt
    2053             :       ! Check to see if the mdim is registered
    2054        6912 :       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       92160 :       allocate(tape(t)%hlist(nflds(t)))
    2097             : 
    2098      119040 :       do fld=1,nflds(t)
    2099       72192 :         if (associated(tape(t)%hlist(fld)%field%mdims)) then
    2100           0 :           deallocate(tape(t)%hlist(fld)%field%mdims)
    2101             :         end if
    2102       72192 :         nullify(tape(t)%hlist(fld)%field%mdims)
    2103      216576 :         ierr = pio_get_var(File,fillval_desc, (/fld,t/), tape(t)%hlist(fld)%field%fillvalue)
    2104      216576 :         ierr = pio_get_var(File,meridional_complement_desc, (/fld,t/), tape(t)%hlist(fld)%field%meridional_complement)
    2105      216576 :         ierr = pio_get_var(File,zonal_complement_desc, (/fld,t/), tape(t)%hlist(fld)%field%zonal_complement)
    2106       72192 :         tape(t)%hlist(fld)%field%field_op(1:field_op_len) = ' '
    2107      288768 :         ierr = pio_get_var(File,field_op_desc, (/1,fld,t/), tape(t)%hlist(fld)%field%field_op)
    2108       72192 :         call strip_null(tape(t)%hlist(fld)%field%field_op)
    2109      216576 :         ierr = pio_get_var(File,op_field1_id_desc, (/fld,t/), tape(t)%hlist(fld)%field%op_field1_id)
    2110      216576 :         ierr = pio_get_var(File,op_field2_id_desc, (/fld,t/), tape(t)%hlist(fld)%field%op_field2_id)
    2111      216576 :         ierr = pio_get_var(File,avgflag_desc, (/fld,t/), tape(t)%hlist(fld)%avgflag)
    2112      288768 :         ierr = pio_get_var(File,longname_desc, (/1,fld,t/), tape(t)%hlist(fld)%field%long_name)
    2113      288768 :         ierr = pio_get_var(File,units_desc, (/1,fld,t/), tape(t)%hlist(fld)%field%units)
    2114       72192 :         tape(t)%hlist(fld)%field%sampling_seq(1:max_chars) = ' '
    2115      288768 :         ierr = pio_get_var(File,sseq_desc, (/1,fld,t/), tape(t)%hlist(fld)%field%sampling_seq)
    2116       72192 :         call strip_null(tape(t)%hlist(fld)%field%sampling_seq)
    2117       72192 :         tape(t)%hlist(fld)%field%cell_methods(1:max_chars) = ' '
    2118      288768 :         ierr = pio_get_var(File,cm_desc, (/1,fld,t/), tape(t)%hlist(fld)%field%cell_methods)
    2119       72192 :         call strip_null(tape(t)%hlist(fld)%field%cell_methods)
    2120       72192 :         if(xyfill(fld,t) ==1) then
    2121         768 :           tape(t)%hlist(fld)%field%flag_xyfill=.true.
    2122             :         else
    2123       71424 :           tape(t)%hlist(fld)%field%flag_xyfill=.false.
    2124             :         end if
    2125       72192 :         if(is_subcol(fld,t) ==1) then
    2126           0 :            tape(t)%hlist(fld)%field%is_subcol=.true.
    2127             :         else
    2128       72192 :            tape(t)%hlist(fld)%field%is_subcol=.false.
    2129             :         end if
    2130       72192 :         call strip_null(tmpname(fld,t))
    2131       72192 :         call strip_null(tmpf1name(fld,t))
    2132       72192 :         call strip_null(tmpf2name(fld,t))
    2133       72192 :         tape(t)%hlist(fld)%field%name = tmpname(fld,t)
    2134       72192 :         tape(t)%hlist(fld)%op_field1 = tmpf1name(fld,t)
    2135       72192 :         tape(t)%hlist(fld)%op_field2 = tmpf2name(fld,t)
    2136       72192 :         tape(t)%hlist(fld)%field%decomp_type = decomp(fld,t)
    2137       72192 :         tape(t)%hlist(fld)%field%numlev = tmpnumlev(fld,t)
    2138       72192 :         tape(t)%hlist(fld)%hwrt_prec = tmpprec(fld,t)
    2139       72192 :         tape(t)%hlist(fld)%beg_nstep = tmpbeg_nstep(fld,t)
    2140       72192 :         call tape(t)%hlist(fld)%put_global(tmpintegral(fld,t))
    2141             :         ! If the field is an advected constituent set the mixing_ratio attribute
    2142       72192 :         fname_tmp = strip_suffix(tape(t)%hlist(fld)%field%name)
    2143       72192 :         call cnst_get_ind(fname_tmp, idx, abort=.false.)
    2144       72192 :         mixing_ratio = ''
    2145       72192 :         if (idx > 0) then
    2146        4608 :            mixing_ratio = cnst_get_type_byind(idx)
    2147             :         end if
    2148       72192 :         tape(t)%hlist(fld)%field%mixing_ratio = mixing_ratio
    2149             : 
    2150      144384 :         mdimcnt = count(allmdims(:,fld,t) > 0)
    2151      514560 :         if(mdimcnt > 0) then
    2152       78336 :           allocate(tape(t)%hlist(fld)%field%mdims(mdimcnt))
    2153       52224 :           do i = 1, mdimcnt
    2154       52224 :             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       82176 :       do fld = 1, nflds(t)
    2170       72192 :         if (tape(t)%hlist(fld)%avgflag .ne. 'I') then
    2171       66048 :            hfile_accum(t) = .true.
    2172             :         end if
    2173       72192 :         call set_field_dimensions(tape(t)%hlist(fld)%field)
    2174             : 
    2175       72192 :         begdim1 = tape(t)%hlist(fld)%field%begdim1
    2176       72192 :         enddim1 = tape(t)%hlist(fld)%field%enddim1
    2177       72192 :         begdim2 = tape(t)%hlist(fld)%field%begdim2
    2178       72192 :         enddim2 = tape(t)%hlist(fld)%field%enddim2
    2179       72192 :         begdim3 = tape(t)%hlist(fld)%field%begdim3
    2180       72192 :         enddim3 = tape(t)%hlist(fld)%field%enddim3
    2181             : 
    2182      360960 :         allocate(tape(t)%hlist(fld)%hbuf(begdim1:enddim1,begdim2:enddim2,begdim3:enddim3))
    2183       72192 :         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       72192 :         if (associated(tape(t)%hlist(fld)%varid)) then
    2188           0 :           deallocate(tape(t)%hlist(fld)%varid)
    2189             :         end if
    2190       72192 :         nullify(tape(t)%hlist(fld)%varid)
    2191       72192 :         if (associated(tape(t)%hlist(fld)%nacs)) then
    2192           0 :           deallocate(tape(t)%hlist(fld)%nacs)
    2193             :         end if
    2194       72192 :         nullify(tape(t)%hlist(fld)%nacs)
    2195       72192 :         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      214272 :           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       72192 :         call h_zero(fld,t)
    2203             : 
    2204             :         ! Make sure this field's decomp is listed on the tape
    2205       72192 :         fdecomp = tape(t)%hlist(fld)%field%decomp_type
    2206       72192 :         do ffld = 1, size(gridsontape, 1)
    2207       72192 :           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      153600 :         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       67584 :           do fld=1,nflds(t)
    2424       66816 :             deallocate(tape(t)%hlist(fld)%varid)
    2425       67584 :             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   440731392 :   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   440731392 :     if(associated(listentry)) then
    2510   439752960 :       if(listentry%field%name .eq. name) then
    2511             :         entry => listentry
    2512             :       else
    2513   439310592 :         entry=>get_entry_by_name(listentry%next_entry, name)
    2514             :       end if
    2515             :     else
    2516             :       nullify(entry)
    2517             :     end if
    2518   440731392 :   end function get_entry_by_name
    2519             : 
    2520             :   !#######################################################################
    2521             : 
    2522    22442496 :   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    20146176 :     select case (avgflag)
    2531             :     case ('A')
    2532    20146176 :       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     1921536 :       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    22442496 :       call endrun(subname//': unknown avgflag = '//avgflag)
    2549             :     end select
    2550    22442496 :   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        6912 :     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       65280 :     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     5880576 :       do while(associated(listentry))
    2746     5870592 :         mastername = listentry%field%name
    2747     5870592 :         call list_index (fincl(1,t), mastername, ffld)
    2748             : 
    2749     5870592 :         fieldontape = .false.
    2750     5870592 :         if (ffld > 0) then
    2751             :           fieldontape = .true.
    2752     5870592 :         else if ((.not. empty_htapes) .or. (is_initfile(file_index=t))) then
    2753     5870592 :           call list_index (fexcl(1,t), mastername, ffld)
    2754     5870592 :           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       72192 :           nflds(t) = nflds(t) + 1
    2762       72192 :           do ffld = 1, size(gridsontape, 1)
    2763       72192 :             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     5870592 :         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       76800 :         allocate(tape(t)%hlist(nflds(t)))
    2794             :         ! Count up the number of grids output on this tape
    2795        1536 :         ffld = 0
    2796       10752 :         do fld = 1, size(gridsontape, 1)
    2797       10752 :           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       10752 :         do fld = 1, size(gridsontape, 1)
    2804       10752 :           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       81408 :       do ffld=1,nflds(t)
    2811       72192 :         nullify(tape(t)%hlist(ffld)%hbuf)
    2812       72192 :         nullify(tape(t)%hlist(ffld)%sbuf)
    2813       72192 :         nullify(tape(t)%hlist(ffld)%wbuf)
    2814       72192 :         nullify(tape(t)%hlist(ffld)%nacs)
    2815       81408 :         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     5879808 :       do while(associated(listentry))
    2822     5870592 :         mastername = listentry%field%name
    2823             : 
    2824     5870592 :         call list_index (fwrtpr(1,t), mastername, ffld)
    2825     5870592 :         if (ffld > 0) then
    2826           0 :           prec_wrt = getflag(fwrtpr(ffld,t))
    2827             :         else
    2828     5870592 :           prec_wrt = ' '
    2829             :         end if
    2830             : 
    2831     5870592 :         call list_index (fincl(1,t), mastername, ffld)
    2832             : 
    2833     5870592 :         if (ffld > 0) then
    2834           0 :           avgflag = getflag (fincl(ffld,t))
    2835           0 :           call inifld (t, listentry, avgflag,  prec_wrt)
    2836     5870592 :         else if ((.not. empty_htapes) .or. (is_initfile(file_index=t))) then
    2837     5870592 :           call list_index (fexcl(1,t), mastername, ffld)
    2838     5870592 :           if (ffld == 0 .and. listentry%actflag(t)) then
    2839       72192 :             call inifld (t, listentry, ' ', prec_wrt)
    2840             :           else
    2841     5798400 :             listentry%actflag(t) = .false.
    2842             :           end if
    2843             :         else
    2844           0 :           listentry%actflag(t) = .false.
    2845             :         end if
    2846     5870592 :         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       79872 :       do fld=nflds(t)-1,1,-1
    2865     2959872 :         do ffld=1,fld
    2866             : 
    2867     2959872 :           if (tape(t)%hlist(ffld)%field%numlev > tape(t)%hlist(ffld+1)%field%numlev) then
    2868      747264 :             tmp = tape(t)%hlist(ffld)
    2869      747264 :             tape(t)%hlist(ffld  ) = tape(t)%hlist(ffld+1)
    2870      747264 :             tape(t)%hlist(ffld+1) = tmp
    2871             :           end if
    2872             : 
    2873             :         end do
    2874             : 
    2875     2969088 :         do ffld=1,fld
    2876             : 
    2877     2889216 :            if ((tape(t)%hlist(ffld)%field%numlev == tape(t)%hlist(ffld+1)%field%numlev) .and. &
    2878       70656 :                 (tape(t)%hlist(ffld)%field%name > tape(t)%hlist(ffld+1)%field%name)) then
    2879             : 
    2880      966144 :             tmp = tape(t)%hlist(ffld)
    2881      966144 :             tape(t)%hlist(ffld  ) = tape(t)%hlist(ffld+1)
    2882      966144 :             tape(t)%hlist(ffld+1) = tmp
    2883             : 
    2884     1923072 :           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         214 :          do fld = 1, nflds(t)
    2983         212 :             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         188 :                fldname = hfile(t)%hlist(fld)%field%name
    2996         188 :                write(iulog,9000) fld, fldname, hfile(t)%hlist(fld)%field%units,  &
    2997         188 :                   hfile(t)%hlist(fld)%field%numlev, hfile(t)%hlist(fld)%avgflag, &
    2998         376 :                   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       72192 :   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       72192 :     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       72192 :     nflds(t) = nflds(t) + 1
    3051       72192 :     n = nflds(t)
    3052             :     !
    3053             :     ! Copy field info.
    3054             :     !
    3055       72192 :     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       72192 :     tape(t)%hlist(n)%field = listentry%field
    3061             : 
    3062             :     select case (prec_wrt)
    3063             :     case (' ')
    3064       72192 :       if (ndens(t) == 1) then
    3065        5376 :         tape(t)%hlist(n)%hwrt_prec = 8
    3066             :       else
    3067       66816 :         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       72192 :       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       72192 :     if (avgflag == ' ') then
    3088       72192 :       tape(t)%hlist(n)%avgflag = listentry%avgflag(t)
    3089       72192 :       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       72192 :     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       72192 :     return
    3118       72192 :   end subroutine inifld
    3119             : 
    3120             : 
    3121       18432 :   subroutine patch_init(t)
    3122       72192 :     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      470016 :   subroutine strip_null(str)
    3228             :     character(len=*), intent(inout) :: str
    3229             :     integer :: i
    3230   196224000 :     do i=1,len(str)
    3231   196224000 :       if(ichar(str(i:i))==0) str(i:i)=' '
    3232             :     end do
    3233       18432 :   end subroutine strip_null
    3234             : 
    3235    22431744 :   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    22431744 :     strip_suffix = ' '
    3254             : 
    3255   108274176 :     do n = 1,fieldname_len
    3256   108274176 :       strip_suffix(n:n) = name(n:n)
    3257   108274176 :       if(name(n+1:n+1         ) == ' '                       ) return
    3258    85876992 :       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    29352960 :   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    29352960 :     length = len (inname)
    3290             : 
    3291    29352960 :     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    29352960 :     getname = ' '
    3297   968647680 :     do i=1,fieldname_len
    3298   939294720 :       if (inname(i:i) == ':') exit
    3299   968647680 :       getname(i:i) = inname(i:i)
    3300             :     end do
    3301             : 
    3302    29352960 :     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    29352960 :   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    29352960 :     index = 0
    3522    29352960 :     do f=1,pflds
    3523             :       !
    3524             :       ! Only list items
    3525             :       !
    3526    29352960 :       listname = getname (list(f))
    3527    29352960 :       if (listname == ' ') exit
    3528    29352960 :       if (listname == name) then
    3529           0 :         index = f
    3530           0 :         exit
    3531             :       end if
    3532             :     end do
    3533             : 
    3534    29352960 :     return
    3535             :   end subroutine list_index
    3536             : 
    3537             :   !#######################################################################
    3538             : 
    3539  1337388336 :   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   668694168 :     type (active_entry), pointer :: otape(:) ! Local history_tape pointer
    3600   668694168 :     real(r8),pointer      :: hbuf(:,:)     ! history buffer
    3601   668694168 :     real(r8),pointer      :: wbuf(:)       ! area weights for field
    3602   668694168 :     real(r8),pointer      :: sbuf(:,:)     ! variance buffer
    3603   668694168 :     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   668694168 :     real(r8), allocatable :: afield(:,:)   ! Averaged field values
    3610   668694168 :     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   668694168 :     call get_field_properties(fname, found, tape_out=otape, ff_out=ff)
    3618   668694168 :     phys_decomp = cam_grid_id('physgrid')
    3619             : 
    3620             :     ! If this field is not active, return now
    3621   668694168 :     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  1330598880 :     do t = 1, ptapes
    3631  1228245120 :       if ( .not. masterlist(ff)%thisentry%actflag(t)) cycle
    3632   102353760 :       fld = masterlist(ff)%thisentry%htapeindx(t)
    3633             :       !
    3634             :       ! Update history buffer
    3635             :       !
    3636   102353760 :       flag_xyfill = otape(t)%hlist(fld)%field%flag_xyfill
    3637   102353760 :       fillvalue = otape(t)%hlist(fld)%field%fillvalue
    3638   102353760 :       avgflag = otape(t)%hlist(fld)%avgflag
    3639   102353760 :       nacs   => otape(t)%hlist(fld)%nacs(:,c)
    3640   102353760 :       hbuf => otape(t)%hlist(fld)%hbuf(:,:,c)
    3641   102353760 :       if (associated(tape(t)%hlist(fld)%wbuf)) then
    3642           0 :          wbuf => otape(t)%hlist(fld)%wbuf(:,c)
    3643             :       endif
    3644   102353760 :       if (associated(tape(t)%hlist(fld)%sbuf)) then
    3645           0 :          sbuf => otape(t)%hlist(fld)%sbuf(:,:,c)
    3646             :       endif
    3647   102353760 :       dimind = otape(t)%hlist(fld)%field%get_dims(c)
    3648             : 
    3649             :       ! See notes above about validity of avg_subcol_field
    3650   102353760 :       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   102353760 :       else if (otape(t)%hlist(fld)%field%decomp_type == phys_decomp) then
    3656   102353760 :         if (present(avg_subcol_field)) then
    3657           0 :           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   102353760 :       begdim2 = otape(t)%hlist(fld)%field%begdim2
    3670   102353760 :       enddim2 = otape(t)%hlist(fld)%field%enddim2
    3671   204707520 :       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   102353760 :       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     1495368 :         select case (avgflag)
    3746             : 
    3747             :         case ('I') ! Instantaneous
    3748             :           call hbuf_accum_inst(hbuf, field, nacs, dimind, idim,          &
    3749     1495368 :                flag_xyfill, fillvalue)
    3750             : 
    3751             :         case ('A') ! Time average
    3752             :           call hbuf_accum_add(hbuf, field, nacs, dimind, idim,           &
    3753    97880040 :                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  1228245120 :           call endrun ('OUTFLD: invalid avgflag='//avgflag)
    3783             : 
    3784             :         end select
    3785             :       end if
    3786             : 
    3787             :     end do
    3788             : 
    3789             :     return
    3790  1337388336 :   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   668694168 :     fname_loc = fname
    3829   668694168 :     ff = get_masterlist_indx(fname_loc)
    3830             : 
    3831             :     ! Set the no_tape_check to false, unless is passed in
    3832   668694168 :     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   668694168 :     found = .false.
    3840   668694168 :     if (present(tape_out)) then
    3841   668694168 :       nullify(tape_out)
    3842             :     end if
    3843   668694168 :     if (present(ff_out)) then
    3844   668694168 :       ff_out = -1
    3845             :     end if
    3846   668694168 :     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   668694168 :     if ( ff < 0 ) then
    3856   566340408 :       return
    3857             :     end if
    3858             :     !
    3859             :     !  Next, check to see whether this field is active on one or more history
    3860             :     !  tapes.
    3861             :     !
    3862   668694168 :     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   668694168 :     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   102353760 :     do t=1, ptapes
    3874   204707520 :       if (masterlist(ff)%thisentry%actflag(t)) then
    3875   102353760 :         found    =  .true.
    3876   102353760 :         if (present(tape_out)) then
    3877   102353760 :           tape_out => history_tape
    3878             :         end if
    3879   102353760 :         if (present(ff_out)) then
    3880   102353760 :           ff_out   =  ff
    3881             :         end if
    3882   102353760 :         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  1337388336 :   end subroutine get_field_properties
    3892             : 
    3893             :   !#######################################################################
    3894             : 
    3895    38353412 :   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    38353412 :     is_initfile = .false.
    3913             : 
    3914    38353412 :     if (present(file_index)) then
    3915    35745980 :       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      135936 :        do fld=1,nflds(t)
    4039      133632 :          if (f == accumulated_file_index) then
    4040             :             ! this is the accumulated file - skip instantaneous fields
    4041       66816 :             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       66816 :             if (tape(t)%hlist(fld)%avgflag /= 'I') then
    4047             :                cycle
    4048             :             end if
    4049             :          end if
    4050             : 
    4051       66816 :          if(.not. associated(tape(t)%hlist(fld)%varid)) then
    4052       66816 :            if (associated(tape(t)%patches)) then
    4053           0 :              allocate(tape(t)%hlist(fld)%varid(size(tape(t)%patches)))
    4054             :            else
    4055       66816 :              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       66816 :          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       66816 :            fldname = tape(t)%hlist(fld)%field%name
    4077       66816 :            ierr = pio_inq_varid(tape(t)%Files(f), trim(fldname), tape(t)%hlist(fld)%varid(1))
    4078       66816 :            call cam_pio_handle_error(ierr, 'H_INQUIRE: Error getting ID for '//trim(fldname))
    4079             :          end if
    4080       68352 :          if(tape(t)%hlist(fld)%field%numlev>1) then
    4081       21504 :            ierr = pio_inq_attlen(tape(t)%Files(f),tape(t)%hlist(fld)%varid(1),'mdims', mdimsize)
    4082       21504 :            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       21504 :                 tape(t)%hlist(fld)%field%mdims(1:mdimsize))
    4087       21504 :            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      145920 :   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      145920 :     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      145920 :     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      145920 :     if (tindex == 0) then
    4138       10752 :       t = ptapes
    4139       10752 :       if ( .not. is_initfile(file_index=t) ) return
    4140             :     else
    4141      135168 :       t = tindex
    4142             :     end if
    4143             : 
    4144      145920 :     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      145920 :     listentry => get_entry_by_name(masterlinkedlist, trim(name))
    4153      145920 :     if(.not.associated(listentry)) then
    4154           0 :       call endrun ('ADD_DEFAULT: field = "'//trim(name)//'" not found')
    4155             :     end if
    4156      145920 :     listentry%actflag(t) = .true.
    4157      145920 :     if (flag /= ' ') then
    4158       10752 :       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    21626880 :        do fld = 1, nflds(t)
    4641    21381120 :          if (.not. is_satfile(t) .and. .not. restart .and. .not. is_initfile(t)) then
    4642    21381120 :             if (f == accumulated_file_index) then
    4643             :                ! this is the accumulated file of a potentially split history tape - skip instantaneous fields
    4644    10690560 :                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    10690560 :                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    10690560 :          call AvgflagToString(tape(t)%hlist(fld)%avgflag, tape(t)%hlist(fld)%time_op)
    4656    10690560 :          if ((tape(t)%hlist(fld)%hwrt_prec == 8) .or. restart) then
    4657           0 :            ncreal = pio_double
    4658             :          else
    4659    10690560 :            ncreal = pio_real
    4660             :          end if
    4661             : 
    4662    10690560 :          if(associated(tape(t)%hlist(fld)%field%mdims)) then
    4663     7065600 :            mdims => tape(t)%hlist(fld)%field%mdims
    4664     7065600 :            mdimsize = size(mdims)
    4665     3624960 :          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    10690560 :          if (patch_output) then
    4674           0 :            num_patches = size(tape(t)%patches)
    4675             :          else
    4676             :            num_patches = 1
    4677             :          end if
    4678    10690560 :          if(.not.associated(tape(t)%hlist(fld)%varid)) then
    4679    32071680 :            allocate(tape(t)%hlist(fld)%varid(num_patches))
    4680             :          end if
    4681    10690560 :          fname_tmp = strip_suffix(tape(t)%hlist(fld)%field%name)
    4682             : 
    4683    10690560 :          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    10690560 :          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    10690560 :          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    10690560 :            if (.not. allocated(header_info)) then
    4705             :              ! Safety check
    4706           0 :              call endrun('h_define: header_info not allocated')
    4707             :            end if
    4708    10690560 :            grd = -1
    4709    10690560 :            do i = 1, size(header_info)
    4710    10690560 :              if (header_info(i)%get_gridid() == tape(t)%hlist(fld)%field%decomp_type) then
    4711    10690560 :                grd = i
    4712    10690560 :                exit
    4713             :              end if
    4714             :            end do
    4715    10690560 :            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    10690560 :            num_hdims = header_info(grd)%num_hdims()
    4720    21381120 :            do i = 1, num_hdims
    4721    21381120 :              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    32317440 :          do i = 1, num_patches
    4730    10690560 :            fname_tmp = strip_suffix(tape(t)%hlist(fld)%field%name)
    4731    10690560 :            varid => tape(t)%hlist(fld)%varid(i)
    4732    10690560 :            dimids_tmp = dimindex
    4733             :            ! Figure the dimension ID array for this field
    4734             :            ! We have defined the horizontal grid dimensions in dimindex
    4735    10690560 :            fdims = num_hdims
    4736    14131200 :            do j = 1, mdimsize
    4737     3440640 :              fdims = fdims + 1
    4738    14131200 :              dimids_tmp(fdims) = mdimids(mdims(j))
    4739             :            end do
    4740    10690560 :            if(.not. restart) then
    4741             :              ! Only add time dimension if this is not a restart history tape
    4742    10690560 :              fdims = fdims + 1
    4743    10690560 :              dimids_tmp(fdims) = timdim
    4744             :            end if
    4745    10690560 :            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    10690560 :            call cam_pio_def_var(tape(t)%Files(f), trim(fname_tmp), ncreal,           &
    4752    21381120 :                 dimids_tmp(1:fdims), varid)
    4753    10690560 :            if (mdimsize > 0) then
    4754     3440640 :              ierr = pio_put_att(tape(t)%Files(f), varid, 'mdims', mdims(1:mdimsize))
    4755     3440640 :              call cam_pio_handle_error(ierr, 'h_define: cannot define mdims for '//trim(fname_tmp))
    4756             :            end if
    4757    10690560 :            str = tape(t)%hlist(fld)%field%sampling_seq
    4758    10690560 :            if (len_trim(str) > 0) then
    4759     3932160 :              ierr = pio_put_att(tape(t)%Files(f), varid, 'Sampling_Sequence', trim(str))
    4760     3932160 :              call cam_pio_handle_error(ierr, 'h_define: cannot define Sampling_Sequence for '//trim(fname_tmp))
    4761             :            end if
    4762             : 
    4763    10690560 :            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    10690560 :            str = tape(t)%hlist(fld)%field%units
    4789    10690560 :            if (len_trim(str) > 0) then
    4790    10690560 :              ierr=pio_put_att (tape(t)%Files(f), varid, 'units', trim(str))
    4791             :              call cam_pio_handle_error(ierr,                                     &
    4792    10690560 :                   'h_define: cannot define units for '//trim(fname_tmp))
    4793             :            end if
    4794             : 
    4795    10690560 :            str = tape(t)%hlist(fld)%field%mixing_ratio
    4796    10690560 :            if (len_trim(str) > 0) then
    4797      368640 :              ierr=pio_put_att (tape(t)%Files(f), varid, 'mixing_ratio', trim(str))
    4798             :              call cam_pio_handle_error(ierr,                                     &
    4799      368640 :                   'h_define: cannot define mixing_ratio for '//trim(fname_tmp))
    4800             :            end if
    4801             : 
    4802    10690560 :            str = tape(t)%hlist(fld)%field%long_name
    4803    10690560 :            ierr=pio_put_att (tape(t)%Files(f), varid, 'long_name', trim(str))
    4804             :            call cam_pio_handle_error(ierr,                                       &
    4805    10690560 :                 'h_define: cannot define long_name for '//trim(fname_tmp))
    4806             : 
    4807             :            ! Assign field attributes defining valid levels and averaging info
    4808             : 
    4809    10690560 :            cell_methods = ''
    4810    10690560 :            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    10690560 :            str = tape(t)%hlist(fld)%time_op
    4821    10690560 :            if (tape(t)%hlist(fld)%avgflag == 'I') then
    4822      122880 :               str = 'point'
    4823             :            else
    4824    10567680 :               str = tape(t)%hlist(fld)%time_op
    4825             :            end if
    4826    10690560 :            cell_methods = adjustl(trim(cell_methods)//' '//'time: '//str)
    4827    10690560 :            if (len_trim(cell_methods) > 0) then
    4828    10690560 :              ierr = pio_put_att(tape(t)%Files(f), varid, 'cell_methods', trim(cell_methods))
    4829             :              call cam_pio_handle_error(ierr,                                     &
    4830    10690560 :                   'h_define: cannot define cell_methods for '//trim(fname_tmp))
    4831             :            end if
    4832    10690560 :            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    32071680 :           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    10567680 :   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    10567680 :     call t_startf ('h_normalize')
    5043             : 
    5044    10567680 :     call tape(t)%hlist(fld)%field%get_bounds(3, begdim3, enddim3)
    5045             : 
    5046             :     !
    5047             :     ! normalize by number of accumulations for averaged case
    5048             :     !
    5049    10567680 :     flag_xyfill = tape(t)%hlist(fld)%field%flag_xyfill
    5050    10567680 :     avgflag = tape(t)%hlist(fld)%avgflag
    5051             : 
    5052    53168640 :     do c = begdim3, enddim3
    5053    42600960 :       dimind = tape(t)%hlist(fld)%field%get_dims(c)
    5054             : 
    5055    42600960 :       ib = dimind%beg1
    5056    42600960 :       ie = dimind%end1
    5057    42600960 :       jb = dimind%beg2
    5058    42600960 :       je = dimind%end2
    5059             : 
    5060    42600960 :       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    42600960 :       if (avgflag == 'A' .or. avgflag == 'B' .or. avgflag == 'L') then
    5069    41610240 :         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    41114880 :         else if(tape(t)%hlist(fld)%nacs(1,c) > 0) then
    5078   427000320 :           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  6500056320 :                  / tape(t)%hlist(fld)%nacs(1,c)
    5082             :           end do
    5083             :         end if
    5084             :       end if
    5085    42600960 :       currstep=get_nstep()
    5086    42600960 :       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    53168640 :       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    10567680 :     call t_stopf ('h_normalize')
    5118             : 
    5119    10567680 :     return
    5120    10567680 :   end subroutine h_normalize
    5121             : 
    5122             :   !#######################################################################
    5123             : 
    5124    10829568 :   subroutine h_zero (fld, t)
    5125    10567680 :     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    10829568 :     call t_startf ('h_zero')
    5147             : 
    5148    10829568 :     call tape(t)%hlist(fld)%field%get_bounds(3, begdim3, enddim3)
    5149             : 
    5150    54502392 :     do c = begdim3, enddim3
    5151    43672824 :       dimind = tape(t)%hlist(fld)%field%get_dims(c)
    5152  6649015248 :       tape(t)%hlist(fld)%hbuf(dimind%beg1:dimind%end1,dimind%beg2:dimind%end2,c)=0._r8
    5153    54502392 :       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   105698496 :     tape(t)%hlist(fld)%nacs(:,:) = 0
    5158             : 
    5159             :     !Don't reset beg_nstep if this is a restart
    5160    10829568 :     if (.not. is_first_restart_step()) tape(t)%hlist(fld)%beg_nstep = get_nstep()
    5161             : 
    5162    10829568 :     call t_stopf ('h_zero')
    5163             : 
    5164    10829568 :     return
    5165    10829568 :   end subroutine h_zero
    5166             : 
    5167             :   !#######################################################################
    5168             : 
    5169    10690560 :   subroutine h_global (fld, t)
    5170             : 
    5171    10829568 :     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    10690560 :     real(r8), allocatable   :: globalarr(:) ! globalarr values for this pe
    5197             : 
    5198    10690560 :     call t_startf ('h_global')
    5199             : 
    5200             :     ! wbuf contains the area weighting for this field decomposition
    5201    10690560 :     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    10690560 :     call t_stopf ('h_global')
    5234    10690560 :   end subroutine h_global
    5235             : 
    5236           0 :   subroutine h_field_op (fld, t)
    5237    10690560 :     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    10690560 :   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    10690560 :     real(r4),            allocatable :: rtemp2(:,:)
    5328    10690560 :     real(r4),            allocatable :: rtemp3(:,:,:)
    5329             :     integer                          :: begdim3, enddim3, ind3
    5330             : 
    5331    10690560 :     interpolate = (interpolate_output(t) .and. (.not. restart))
    5332    10690560 :     patch_output = (associated(tape(t)%patches) .and. (.not. restart))
    5333             : 
    5334             :     !!! Get the field's shape and decomposition
    5335             : 
    5336             :     ! Shape on disk
    5337    10690560 :     call tape(t)%hlist(fld)%field%get_shape(fdims, frank)
    5338             : 
    5339             :     ! Shape of array
    5340    10690560 :     dimind = tape(t)%hlist(fld)%field%get_dims()
    5341    10690560 :     call dimind%dim_sizes(adims)
    5342    10690560 :     if (adims(2) <= 1) then
    5343     7249920 :       adims(2) = adims(3)
    5344     7249920 :       nadims = 2
    5345             :     else
    5346             :       nadims = 3
    5347             :     end if
    5348    10690560 :     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    10690560 :     if (patch_output) then
    5353           0 :       num_patches = size(tape(t)%patches)
    5354             :     else
    5355             :       num_patches = 1
    5356             :     end if
    5357             : 
    5358    21381120 :     do index = 1, num_patches
    5359    10690560 :       varid => tape(t)%hlist(fld)%varid(index)
    5360             : 
    5361    10690560 :       if (restart) then
    5362           0 :         call pio_setframe(tape(t)%Files(f), varid, int(-1,kind=PIO_OFFSET_KIND))
    5363             :       else
    5364    10690560 :         call pio_setframe(tape(t)%Files(f), varid, int(max(1,nfils(t)),kind=PIO_OFFSET_KIND))
    5365             :       end if
    5366    21381120 :       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    10690560 :         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    10690560 :         else if (nadims == 2) then
    5403             :           ! Special case for 2D field (no levels) due to hbuf structure
    5404     7249920 :            if ((tape(t)%hlist(fld)%hwrt_prec == 4) .and. (.not. restart)) then
    5405     7249920 :               call tape(t)%hlist(fld)%field%get_bounds(3, begdim3, enddim3)
    5406    28999680 :               allocate(rtemp2(dimind%beg1:dimind%end1, begdim3:enddim3))
    5407   504096000 :               rtemp2 = 0.0_r4
    5408    36476160 :               do ind3 = begdim3, enddim3
    5409    29226240 :                  dimind2 = tape(t)%hlist(fld)%field%get_dims(ind3)
    5410           0 :                  rtemp2(dimind2%beg1:dimind2%end1,ind3) = &
    5411   495260160 :                       tape(t)%hlist(fld)%hbuf(dimind2%beg1:dimind2%end1, 1, ind3)
    5412             :               end do
    5413     7249920 :               call cam_grid_write_dist_array(tape(t)%Files(f), fdecomp,           &
    5414    14499840 :                    adims(1:nadims), fdims(1:frank), rtemp2, varid)
    5415     7249920 :               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     3440640 :            if ((tape(t)%hlist(fld)%hwrt_prec == 4) .and. (.not. restart)) then
    5423     3440640 :               call tape(t)%hlist(fld)%field%get_bounds(3, begdim3, enddim3)
    5424           0 :               allocate(rtemp3(dimind%beg1:dimind%end1,                        &
    5425    17203200 :                    dimind%beg2:dimind%end2, begdim3:enddim3))
    5426  6147886080 :               rtemp3 = 0.0_r4
    5427    17310720 :               do ind3 = begdim3, enddim3
    5428    13870080 :                  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  6038860800 :                       dimind2%beg2:dimind2%end2, ind3)
    5432             :               end do
    5433     3440640 :               call cam_grid_write_dist_array(tape(t)%Files(f), fdecomp, adims,    &
    5434     6881280 :                    fdims(1:frank), rtemp3, varid)
    5435     3440640 :               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    10690560 :     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    10690560 :     return
    5478    10690560 :   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    10690560 :     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       67584 :                 do f = 1, nflds(t)
    5624       67584 :                   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    10813440 :              do fld=1,nflds(t)
    5841             :                 ! Normalize all non composed fields, composed fields are calculated next using the normalized components
    5842    10813440 :                 if (tape(t)%hlist(fld)%avgflag /= 'I'.and..not.tape(t)%hlist(fld)%field%is_composed()) then
    5843    10567680 :                    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    10813440 :              do fld=1,nflds(t)
    5851             :                 ! calculate composed fields from normalized components
    5852    10813440 :                 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    10813440 :           do fld=1,nflds(t)
    5862    32194560 :             do f = 1, maxsplitfiles
    5863    21381120 :                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    21381120 :                if ((tape(t)%hlist(fld)%avgflag .eq. 'I') .and. f == accumulated_file_index .and. .not. restart) then
    5868             :                   cycle
    5869    21258240 :                else if ((tape(t)%hlist(fld)%avgflag .ne. 'I') .and. f == instantaneous_file_index .and. .not. restart) then
    5870             :                   cycle
    5871             :                end if
    5872    32071680 :                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    10813440 :           do fld=1,nflds(t)
    5880    10813440 :              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    10813440 :             do fld=1,nflds(t)
    5896    10813440 :               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      364032 :     character(len=max_chars), allocatable :: dimnames(:)
    5947             :     integer                               :: index
    5948             : 
    5949      364032 :     if (trim(vdim_name) == trim(horiz_only)) then
    5950      364032 :       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     2468352 :          op_f2name)
    5962             : 
    5963      734976 :   end subroutine addfld_1d
    5964             : 
    5965      978432 :   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      978432 :     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      978432 :     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      978432 :     fname_tmp  = fname
    6034      978432 :     fname_tmp  = strip_suffix(fname_tmp)
    6035             : 
    6036      978432 :     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      978432 :     listentry => get_entry_by_name(masterlinkedlist, fname)
    6046      978432 :     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      978432 :     call cnst_get_ind(fname_tmp, idx, abort=.false.)
    6053      978432 :     mixing_ratio = ''
    6054      978432 :     if (idx > 0) then
    6055        9216 :        mixing_ratio = cnst_get_type_byind(idx)
    6056             :     end if
    6057             : 
    6058             :     ! Add field to Master Field List arrays fieldn and iflds
    6059             :     !
    6060      978432 :     allocate(listentry)
    6061      978432 :     listentry%field%name         = fname
    6062      978432 :     listentry%field%long_name    = long_name
    6063      978432 :     listentry%field%numlev       = 1        ! Will change if lev or ilev in shape
    6064      978432 :     listentry%field%units        = units
    6065      978432 :     listentry%field%mixing_ratio = mixing_ratio
    6066      978432 :     listentry%field%meridional_complement = -1
    6067      978432 :     listentry%field%zonal_complement      = -1
    6068      978432 :     listentry%field%field_op  = ''
    6069      978432 :     listentry%field%op_field1_id  = -1
    6070      978432 :     listentry%field%op_field2_id  = -1
    6071      978432 :     listentry%op_field1  = ''
    6072      978432 :     listentry%op_field2  = ''
    6073    12719616 :     listentry%htapeindx(:) = -1
    6074      978432 :     listentry%act_sometape = .false.
    6075    12719616 :     listentry%actflag(:) = .false.
    6076             : 
    6077             :     ! Make sure we have a valid gridname
    6078      978432 :     if (present(gridname)) then
    6079       69120 :       listentry%field%decomp_type = cam_grid_id(trim(gridname))
    6080             :     else
    6081      909312 :       listentry%field%decomp_type = cam_grid_id('physgrid')
    6082             :     end if
    6083      978432 :     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      978432 :     if (present(sampling_seq)) then
    6096       90624 :       listentry%field%sampling_seq = sampling_seq
    6097             :     else
    6098      887808 :       listentry%field%sampling_seq = ' '
    6099             :     end if
    6100             :     ! Indicate if some field pre-processing occurred (e.g., zonal mean)
    6101      978432 :     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      978432 :       listentry%field%cell_methods = ''
    6107             :     end if
    6108             :     !
    6109             :     ! Whether to apply xy fillvalue: default is false
    6110             :     !
    6111      978432 :     if (present(flag_xyfill)) then
    6112       24576 :       listentry%field%flag_xyfill = flag_xyfill
    6113             :     else
    6114      953856 :       listentry%field%flag_xyfill = .false.
    6115             :     end if
    6116             : 
    6117             :     !
    6118             :     !    Allow external packages to have fillvalues different than default
    6119             :     !
    6120             : 
    6121      978432 :     if(present(fill_value)) then
    6122        1536 :       listentry%field%fillvalue = fill_value
    6123             :     else
    6124      976896 :       listentry%field%fillvalue = fillvalue
    6125             :     endif
    6126             : 
    6127             :     !
    6128             :     ! Process shape
    6129             :     !
    6130             : 
    6131      978432 :     if (associated(listentry%field%mdims)) then
    6132           0 :       deallocate(listentry%field%mdims)
    6133             :     end if
    6134      978432 :     nullify(listentry%field%mdims)
    6135      978432 :     dimcnt = size(dimnames)
    6136     2571264 :     allocate(listentry%field%mdims(dimcnt))
    6137      978432 :     call lookup_hist_coord_indices(dimnames, listentry%field%mdims)
    6138      978432 :     if(dimcnt > maxvarmdims) then
    6139           0 :       maxvarmdims = dimcnt
    6140             :     end if
    6141             :     ! Check for subcols (currently limited to first dimension)
    6142      978432 :     listentry%field%is_subcol = .false.
    6143      978432 :     if (size(dimnames) > 0) then
    6144      614400 :       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      978432 :     listentry%field%numlev = hist_coord_find_levels(dimnames)
    6155      978432 :     if (listentry%field%numlev <= 0) then
    6156      364032 :       listentry%field%numlev = 1
    6157             :     end if
    6158             : 
    6159             :     !
    6160             :     ! Dimension history info based on decomposition type (grid)
    6161             :     !
    6162      978432 :     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    12719616 :     listentry%avgflag(:) = avgflag
    6168    12719616 :     listentry%actflag(:) = .false.
    6169             : 
    6170    12719616 :     do dimcnt = 1, ptapes
    6171    12719616 :       call AvgflagToString(avgflag, listentry%time_op(dimcnt))
    6172             :     end do
    6173             : 
    6174      978432 :     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      978432 :        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      978432 :        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      978432 :     nullify(listentry%next_entry)
    6214             : 
    6215      978432 :     call add_entry_to_master(listentry)
    6216      978432 :     return
    6217     1956864 :   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      978432 :   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       72192 :   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      144384 :     listentry => get_entry_by_name(masterlinkedlist, fname)
    6279       72192 :     if (associated(listentry)) then
    6280       72192 :       if ( (len_trim(listentry%op_field1) > 0) .or.                     &
    6281             :            (len_trim(listentry%op_field2) > 0)) then
    6282           0 :          is_composed = .true.
    6283             :       else
    6284       72192 :          is_composed = .false.
    6285             :       end if
    6286       72192 :       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       72192 :          if (present(fname1)) then
    6295       72192 :             fname1 = ''
    6296             :          end if
    6297       72192 :          if (present(fname2)) then
    6298       72192 :             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       72192 :  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       39936 :   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       39936 :     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       39936 :     zlistentry => get_entry_by_name(masterlinkedlist, zonal_field_name)
    6335       39936 :     mlistentry => get_entry_by_name(masterlinkedlist, meridional_field_name)
    6336             :     ! Has either of these fields been previously registered?
    6337       39936 :     if (associated(mlistentry)) then
    6338       39936 :       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       39936 :       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       39936 :     if (associated(zlistentry)) then
    6355       39936 :       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       39936 :       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       39936 :     if(associated(mlistentry) .and. associated(zlistentry)) then
    6372       39936 :       zlistentry%meridional_field = mlistentry%field%name
    6373       39936 :       zlistentry%zonal_field      = ''
    6374       39936 :       mlistentry%meridional_field = ''
    6375       39936 :       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       39936 :   end subroutine register_vector_field
    6393             : 
    6394      978432 :   subroutine add_entry_to_master( newentry)
    6395             :     type(master_entry), target, intent(in) :: newentry
    6396             :     type(master_entry), pointer :: listentry
    6397             : 
    6398      978432 :     if(associated(masterlinkedlist)) then
    6399             :       listentry => masterlinkedlist
    6400   311141376 :       do while(associated(listentry%next_entry))
    6401      976896 :         listentry=>listentry%next_entry
    6402             :       end do
    6403      976896 :       listentry%next_entry=>newentry
    6404             :     else
    6405        1536 :       masterlinkedlist=>newentry
    6406             :     end if
    6407             : 
    6408      978432 :   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    10813440 :             do fld=1,nflds(t)
    6509    10813440 :               if (associated(tape(t)%hlist(fld)%varid)) then
    6510    10690560 :                 deallocate(tape(t)%hlist(fld)%varid)
    6511    10690560 :                 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   839540376 :   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   839540376 :     hash = gen_hash_key_offset
    6597             : 
    6598   839540376 :     if ( len(string) /= 19 ) then
    6599             :       !
    6600             :       !     Process arbitrary string length.
    6601             :       !
    6602 30223453536 :       do i = 1, len(string)
    6603 30223453536 :         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   839540376 :     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   837583512 :   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   837583512 :     hash_key = gen_hash_key(fldname)
    6661   837583512 :     ff = tbl_hash_pri(hash_key)
    6662   837583512 :     if ( ff < 0 ) then
    6663    50408208 :       io = abs(ff)
    6664    50408208 :       in = tbl_hash_oflow(io)
    6665    72824784 :       do ii = 1, in
    6666    72824784 :         ff = tbl_hash_oflow(io+ii)
    6667    72824784 :         if ( masterlist(ff)%thisentry%field%name == fldname ) exit
    6668             :       end do
    6669             :     end if
    6670             : 
    6671   837583512 :     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   837583512 :     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   837583512 :     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      983040 :     allocate(masterlist(nfmaster))
    6715        1536 :     listentry=>masterlinkedlist
    6716      979968 :     do while(associated(listentry))
    6717      978432 :       ff=ff+1
    6718      978432 :       masterlist(ff)%thisentry=>listentry
    6719      978432 :       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      979968 :     do ff = 1, nfmaster
    6728      978432 :       hash_key = gen_hash_key(masterlist(ff)%thisentry%field%name)
    6729      979968 :       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       32256 :         itemp = tbl_hash_pri(ii)
    6741       32256 :         tbl_hash_pri(ii) = -(ncollisions + 1)
    6742       32256 :         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      979968 :     do ff = 1, nfmaster
    6760      978432 :       hash_key = gen_hash_key(masterlist(ff)%thisentry%field%name)
    6761      979968 :       if ( tbl_hash_pri(hash_key) < 0 ) then
    6762       64512 :         ii = abs(tbl_hash_pri(hash_key))
    6763       64512 :         tbl_hash_oflow(ii) = tbl_hash_oflow(ii) + 1
    6764       64512 :         tbl_hash_oflow(ii+tbl_hash_oflow(ii)) = ff
    6765             :       else
    6766      913920 :         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      979968 :     do while(associated(listentry))
    6805    12719616 :       listentry%actflag(:) = .false.
    6806      978432 :       listentry%act_sometape = .false.
    6807      978432 :       listentry=>listentry%next_entry
    6808             :     end do
    6809             : 
    6810       19968 :     do t = 1, ptapes
    6811      164352 :       do fld = 1, nflds(t)
    6812      144384 :         listentry => get_entry_by_name(masterlinkedlist, tape(t)%hlist(fld)%field%name)
    6813      144384 :         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      144384 :         listentry%act_sometape = .true.
    6820      144384 :         listentry%actflag(t) = .true.
    6821      162816 :         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   168889344 :   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   168889344 :     fname_loc = fname
    6854   168889344 :     ff = get_masterlist_indx(fname_loc)
    6855   168889344 :     if ( ff < 0 ) then
    6856             :       hist_fld_active = .false.
    6857             :     else
    6858   168889344 :       hist_fld_active = masterlist(ff)%thisentry%act_sometape
    6859             :     end if
    6860             : 
    6861   168889344 :   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