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