forked from ESCOMP/CTSM
-
Notifications
You must be signed in to change notification settings - Fork 0
/
histFileMod.F90
5609 lines (4950 loc) · 243 KB
/
histFileMod.F90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
module histFileMod
#include "shr_assert.h"
!-----------------------------------------------------------------------
! !DESCRIPTION:
! Module containing methods to for CLM history file handling.
!
! !USES:
use shr_kind_mod , only : r8 => shr_kind_r8
use shr_log_mod , only : errMsg => shr_log_errMsg
use shr_sys_mod , only : shr_sys_flush
use spmdMod , only : masterproc
use abortutils , only : endrun
use clm_varctl , only : iulog, use_vertsoilc, use_fates, compname
use clm_varcon , only : spval, ispval, dzsoi_decomp
use clm_varcon , only : grlnd, nameg, namel, namec, namep, nameCohort
use decompMod , only : get_proc_bounds, get_proc_global, bounds_type
use GetGlobalValuesMod , only : GetGlobalIndexArray
use GridcellType , only : grc
use LandunitType , only : lun
use ColumnType , only : col
use PatchType , only : patch
use EDTypesMod , only : nclmax
use EDTypesMod , only : nlevleaf
use FatesInterfaceTypesMod , only : nlevsclass, nlevage, nlevcoage
use FatesInterfaceTypesMod , only : nlevheight
use EDTypesMod , only : nfsc
use FatesLitterMod , only : ncwd
use PRTGenericMod , only : num_elements_fates => num_elements
use FatesInterfaceTypesMod , only : numpft_fates => numpft
use ncdio_pio
!
implicit none
save
private
!
! !PUBLIC TYPES:
!
! Constants
!
integer , public, parameter :: max_tapes = 10 ! max number of history tapes
integer , public, parameter :: max_flds = 2500 ! max number of history fields
integer , public, parameter :: max_namlen = 64 ! maximum number of characters for field name
integer , public, parameter :: scale_type_strlen = 32 ! maximum number of characters for scale types
integer , private, parameter :: avgflag_strlen = 3 ! maximum number of characters for avgflag
integer , private, parameter :: hist_dim_name_length = 16 ! lenngth of character strings in dimension names
! Possible ways to treat multi-layer snow fields at times when no snow is present in a
! given layer. Note that the public parameters are the only ones that can be used by
! calls to hist_addfld2d; the private parameters are just used internally by the
! histFile implementation.
integer , private, parameter :: no_snow_MIN = 1 ! minimum valid value for this flag
integer , public , parameter :: no_snow_normal = 1 ! normal treatment, which should be used for most fields (use spval when snow layer not present)
integer , public , parameter :: no_snow_zero = 2 ! average in a 0 value for times when the snow layer isn't present
integer , private, parameter :: no_snow_MAX = 2 ! maximum valid value for this flag
integer , private, parameter :: no_snow_unset = no_snow_MIN - 1 ! flag specifying that field is NOT a multi-layer snow field
!
! Counters
!
! ntapes gives the index of the max history file requested. There can be "holes" in the
! numbering - e.g., we can have h0, h1 and h3 tapes, but no h2 tape (because there are
! no fields on the h2 tape). In this case, ntapes will be 4 (for h0, h1, h2 and h3,
! since h3 is the last requested file), not 3 (the number of files actually produced).
integer , private :: ntapes = 0 ! index of max history file requested
!
! Namelist
!
integer :: ni ! implicit index below
logical, public :: &
hist_empty_htapes = .false. ! namelist: flag indicates no default history fields
integer, public :: &
hist_ndens(max_tapes) = 2 ! namelist: output density of netcdf history files
integer, public :: &
hist_mfilt(max_tapes) = (/ 1, (30, ni=2, max_tapes)/) ! namelist: number of time samples per tape
logical, public :: &
hist_dov2xy(max_tapes) = (/.true.,(.true.,ni=2,max_tapes)/) ! namelist: true=> do grid averaging
integer, public :: &
hist_nhtfrq(max_tapes) = (/0, (-24, ni=2,max_tapes)/) ! namelist: history write freq(0=monthly)
character(len=avgflag_strlen), public :: &
hist_avgflag_pertape(max_tapes) = (/(' ',ni=1,max_tapes)/) ! namelist: per tape averaging flag
character(len=max_namlen), public :: &
hist_type1d_pertape(max_tapes) = (/(' ',ni=1,max_tapes)/) ! namelist: per tape type1d
character(len=max_namlen+2), public :: &
fincl(max_flds,max_tapes) ! namelist-equivalence list of fields to add
character(len=max_namlen+2), public :: &
hist_fincl1(max_flds) = ' ' ! namelist: list of fields to add
character(len=max_namlen+2), public :: &
hist_fincl2(max_flds) = ' ' ! namelist: list of fields to add
character(len=max_namlen+2), public :: &
hist_fincl3(max_flds) = ' ' ! namelist: list of fields to add
character(len=max_namlen+2), public :: &
hist_fincl4(max_flds) = ' ' ! namelist: list of fields to add
character(len=max_namlen+2), public :: &
hist_fincl5(max_flds) = ' ' ! namelist: list of fields to add
character(len=max_namlen+2), public :: &
hist_fincl6(max_flds) = ' ' ! namelist: list of fields to add
character(len=max_namlen+2), public :: &
hist_fincl7(max_flds) = ' ' ! namelist: list of fields to add
character(len=max_namlen+2), public :: &
hist_fincl8(max_flds) = ' ' ! namelist: list of fields to add
character(len=max_namlen+2), public :: &
hist_fincl9(max_flds) = ' ' ! namelist: list of fields to add
character(len=max_namlen+2), public :: &
hist_fincl10(max_flds) = ' ' ! namelist: list of fields to add
character(len=max_namlen+2), public :: &
fexcl(max_flds,max_tapes) ! namelist-equivalence list of fields to remove
character(len=max_namlen+2), public :: &
hist_fexcl1(max_flds) = ' ' ! namelist: list of fields to remove
character(len=max_namlen+2), public :: &
hist_fexcl2(max_flds) = ' ' ! namelist: list of fields to remove
character(len=max_namlen+2), public :: &
hist_fexcl3(max_flds) = ' ' ! namelist: list of fields to remove
character(len=max_namlen+2), public :: &
hist_fexcl4(max_flds) = ' ' ! namelist: list of fields to remove
character(len=max_namlen+2), public :: &
hist_fexcl5(max_flds) = ' ' ! namelist: list of fields to remove
character(len=max_namlen+2), public :: &
hist_fexcl6(max_flds) = ' ' ! namelist: list of fields to remove
character(len=max_namlen+2), public :: &
hist_fexcl7(max_flds) = ' ' ! namelist: list of fields to remove
character(len=max_namlen+2), public :: &
hist_fexcl8(max_flds) = ' ' ! namelist: list of fields to remove
character(len=max_namlen+2), public :: &
hist_fexcl9(max_flds) = ' ' ! namelist: list of fields to remove
character(len=max_namlen+2), public :: &
hist_fexcl10(max_flds) = ' ' ! namelist: list of fields to remove
logical, private :: if_disphist(max_tapes) ! restart, true => save history file
!
! !PUBLIC MEMBER FUNCTIONS:
public :: hist_addfld1d ! Add a 1d single-level field to the master field list
public :: hist_addfld2d ! Add a 2d multi-level field to the master field list
public :: hist_addfld_decomp ! Add a 2d multi-level field to the master field list
public :: hist_add_subscript ! Add a 2d subscript dimension
public :: hist_printflds ! Print summary of master field list
public :: hist_htapes_build ! Initialize history file handler for initial or continue run
public :: hist_update_hbuf ! Updates history buffer for all fields and tapes
public :: hist_htapes_wrapup ! Write history tape(s)
public :: hist_restart_ncd ! Read/write history file restart data
public :: htapes_fieldlist ! Define the contents of each history file based on namelist
!
! !PRIVATE MEMBER FUNCTIONS:
private :: is_mapping_upto_subgrid ! Is this field being mapped up to a higher subgrid level?
private :: masterlist_make_active ! Add a field to a history file default "on" list
private :: masterlist_addfld ! Add a field to the master field list
private :: masterlist_change_timeavg ! Override default history tape contents for specific tape
private :: htape_addfld ! Add a field to the active list for a history tape
private :: htape_create ! Define contents of history file t
private :: htape_add_ltype_metadata ! Add global metadata defining landunit types
private :: htape_add_ctype_metadata ! Add global metadata defining column types
private :: htape_add_natpft_metadata ! Add global metadata defining natpft types
private :: htape_add_cft_metadata ! Add global metadata defining cft types
private :: htape_timeconst ! Write time constant values to history tape
private :: htape_timeconst3D ! Write time constant 3D values to primary history tape
private :: hfields_normalize ! Normalize history file fields by number of accumulations
private :: hfields_zero ! Zero out accumulation and hsitory buffers for a tape
private :: hfields_write ! Write a variable to a history tape
private :: hfields_1dinfo ! Define/output 1d subgrid info if appropriate
private :: hist_update_hbuf_field_1d ! Updates history buffer for specific field and tape
private :: hist_update_hbuf_field_2d ! Updates history buffer for specific field and tape
private :: hist_set_snow_field_2d ! Set values in history field dimensioned by levsno
private :: list_index ! Find index of field in exclude list
private :: set_hist_filename ! Determine history dataset filenames
private :: getname ! Retrieve name portion of input "inname"
private :: getflag ! Retrieve flag
private :: pointer_index ! Track data pointer indices
private :: max_nFields ! The max number of fields on any tape
private :: avgflag_valid ! Whether a given avgflag is a valid option
private :: add_landunit_mask_metadata ! Add landunit_mask metadata for the given history field
!
! !PRIVATE TYPES:
! Constants
!
integer, parameter :: max_length_filename = 199 ! max length of a filename. on most linux systems this
! is 255. But this can't be increased until all hard
! coded values throughout the i/o stack are updated.
integer, parameter :: max_chars = 199 ! max chars for char variables
integer, parameter :: max_subs = 100 ! max number of subscripts
integer :: num_subs = 0 ! actual number of subscripts
character(len=32) :: subs_name(max_subs) ! name of subscript
integer :: subs_dim(max_subs) ! dimension of subscript
!
type field_info
character(len=max_namlen) :: name ! field name
character(len=max_chars) :: long_name ! long name
character(len=max_chars) :: units ! units
character(len=hist_dim_name_length) :: type1d ! pointer to first dimension type from data type (nameg, etc)
character(len=hist_dim_name_length) :: type1d_out ! hbuf first dimension type from data type (nameg, etc)
character(len=hist_dim_name_length) :: type2d ! hbuf second dimension type ["levgrnd","levlak","numrad","ltype","natpft","cft","glc_nec","elevclas","subname(n)"]
integer :: beg1d ! on-node 1d clm pointer start index
integer :: end1d ! on-node 1d clm pointer end index
integer :: num1d ! size of clm pointer first dimension (all nodes)
integer :: beg1d_out ! on-node 1d hbuf pointer start index
integer :: end1d_out ! on-node 1d hbuf pointer end index
integer :: num1d_out ! size of hbuf first dimension (all nodes)
integer :: numdims ! the actual number of dimensions, this allows
! for 2D arrays, where the second dimension is allowed
! to be 1
integer :: num2d ! size of hbuf second dimension (e.g. number of vertical levels)
integer :: hpindex ! history pointer index
character(len=scale_type_strlen) :: p2c_scale_type ! scale factor when averaging patch to column
character(len=scale_type_strlen) :: c2l_scale_type ! scale factor when averaging column to landunit
character(len=scale_type_strlen) :: l2g_scale_type ! scale factor when averaging landunit to gridcell
integer :: no_snow_behavior ! for multi-layer snow fields, flag saying how to treat times when a given snow layer is absent
end type field_info
type, abstract :: entry_base
type (field_info) :: field ! field information
contains
procedure(copy_entry_interface), deferred :: copy
end type entry_base
abstract interface
subroutine copy_entry_interface(this, other)
! set this = other
import :: entry_base
class(entry_base), intent(out) :: this
class(entry_base), intent(in) :: other
end subroutine copy_entry_interface
end interface
type, extends(entry_base) :: master_entry
logical :: actflag(max_tapes) ! active/inactive flag
character(len=avgflag_strlen) :: avgflag(max_tapes) ! time averaging flag
contains
procedure :: copy => copy_master_entry
end type master_entry
type, extends(entry_base) :: history_entry
character(len=avgflag_strlen) :: avgflag ! time averaging flag ("X","A","M","I","SUM")
real(r8), pointer :: hbuf(:,:) ! history buffer (dimensions: dim1d x num2d)
integer , pointer :: nacs(:,:) ! accumulation counter (dimensions: dim1d x num2d)
contains
procedure :: copy => copy_history_entry
end type history_entry
type history_tape
integer :: nflds ! number of active fields on tape
integer :: ntimes ! current number of time samples on tape
integer :: mfilt ! maximum number of time samples per tape
integer :: nhtfrq ! number of time samples per tape
integer :: ncprec ! netcdf output precision
logical :: dov2xy ! true => do xy average for all fields
logical :: is_endhist ! true => current time step is end of history interval
real(r8) :: begtime ! time at beginning of history averaging interval
type (history_entry) :: hlist(max_flds) ! array of active history tape entries
end type history_tape
type clmpoint_rs ! Pointer to real scalar data (1D)
real(r8), pointer :: ptr(:)
end type clmpoint_rs
type clmpoint_ra ! Pointer to real array data (2D)
real(r8), pointer :: ptr(:,:)
end type clmpoint_ra
! Pointers into datatype arrays
integer, parameter :: max_mapflds = 2500 ! Maximum number of fields to track
type (clmpoint_rs) :: clmptr_rs(max_mapflds) ! Real scalar data (1D)
type (clmpoint_ra) :: clmptr_ra(max_mapflds) ! Real array data (2D)
!
! Master list: an array of master_entry entities
!
type (master_entry) :: masterlist(max_flds) ! master field list
!
! Whether each history tape is in use in this run. If history_tape_in_use(i) is false,
! then data in tape(i) is undefined and should not be referenced.
!
logical :: history_tape_in_use(max_tapes) ! whether each history tape is in use in this run
!
! History tape: an array of history_tape entities (only active fields)
!
type (history_tape) :: tape(max_tapes) ! array history tapes
!
! Namelist input
!
! Counters
!
integer :: nfmaster = 0 ! number of fields in master field list
!
! Other variables
!
character(len=max_length_filename) :: locfnh(max_tapes) ! local history file names
character(len=max_length_filename) :: locfnhr(max_tapes) ! local history restart file names
logical :: htapes_defined = .false. ! flag indicates history contents have been defined
!
! NetCDF Id's
!
type(file_desc_t), target :: nfid(max_tapes) ! file ids
type(file_desc_t), target :: ncid_hist(max_tapes) ! file ids for history restart files
integer :: time_dimid ! time dimension id
integer :: hist_interval_dimid ! time bounds dimension id
integer :: strlen_dimid ! string dimension id
!
! Time Constant variable names and filename
!
character(len=max_chars) :: TimeConst3DVars_Filename = ' '
!
! time_period_freq variable
!
character(len=max_chars) :: time_period_freq = ' '
character(len=max_chars) :: TimeConst3DVars = ' '
character(len=*), parameter, private :: sourcefile = &
__FILE__
!-----------------------------------------------------------------------
contains
!-----------------------------------------------------------------------
subroutine hist_printflds()
!
! !DESCRIPTION:
! Print summary of master field list.
!
! !USES:
use clm_varctl, only: hist_master_list_file
use fileutils, only: getavu, relavu
!
! !ARGUMENTS:
!
! !LOCAL VARIABLES:
integer, parameter :: ncol = 5 ! number of table columns
integer nf, i, j ! do-loop counters
integer master_list_file ! file unit number
integer width_col(ncol) ! widths of table columns
integer width_col_sum ! widths of columns summed, including spaces
character(len=3) str_width_col(ncol) ! string version of width_col
character(len=3) str_w_col_sum ! string version of width_col_sum
character(len=99) fmt_txt ! format statement
character(len=*),parameter :: subname = 'CLM_hist_printflds'
!-----------------------------------------------------------------------
if (masterproc) then
write(iulog,*) trim(subname),' : number of master fields = ',nfmaster
write(iulog,*)' ******* MASTER FIELD LIST *******'
do nf = 1,nfmaster
write(iulog,9000)nf, masterlist(nf)%field%name, masterlist(nf)%field%units
9000 format (i5,1x,a32,1x,a16)
end do
call shr_sys_flush(iulog)
end if
! Print master field list in separate text file when namelist
! variable requests it. Text file is formatted in the .rst
! (reStructuredText) format for easy introduction of the file to
! the CTSM's web-based documentation.
! First sort the list to be in alphabetical order
call sort_hist_list(1, nfmaster, masterlist)
if (masterproc .and. hist_master_list_file) then
! Hardwired table column widths to fit the table on a computer
! screen. Some strings will be truncated as a result of the
! current choices (4, 35, 94, 65, 7). In sphinx (ie the web-based
! documentation), text that has not been truncated will wrap
! around in the available space.
width_col(1) = 4 ! column that shows the variable number, nf
width_col(2) = 35 ! variable name column
width_col(3) = 94 ! long description column
width_col(4) = 65 ! units column
width_col(5) = 7 ! active (T or F) column
width_col_sum = sum(width_col) + ncol - 1 ! sum of widths & blank spaces
! Convert integer widths to strings for use in format statements
! These write statements are not outputting to files
do i = 1, ncol
write(str_width_col(i),'(i0)') width_col(i)
end do
write(str_w_col_sum,'(i0)') width_col_sum
! Open master_list_file
master_list_file = getavu() ! get next available file unit number
open(unit = master_list_file, file = 'master_list_file.rst', &
status = 'new', action = 'write', form = 'formatted')
! File title
fmt_txt = '(a)'
write(master_list_file,fmt_txt) '==================='
write(master_list_file,fmt_txt) 'CTSM History Fields'
write(master_list_file,fmt_txt) '==================='
write(master_list_file,*)
! Table header
! Concatenate strings needed in format statement
do i = 1, ncol
fmt_txt = '('//str_width_col(i)//'a,x)'
write(master_list_file,fmt_txt,advance='no') ('=', j=1,width_col(i))
end do
write(master_list_file,*) ! next write statement will now appear in new line
! Table title
fmt_txt = '(a)'
write(master_list_file,fmt_txt) 'CTSM History Fields'
! Sub-header
! Concatenate strings needed in format statement
fmt_txt = '('//str_w_col_sum//'a)'
write(master_list_file,fmt_txt) ('-', i=1, width_col_sum)
! Concatenate strings needed in format statement
fmt_txt = '(a'//str_width_col(1)//',x,a'//str_width_col(2)//',x,a'//str_width_col(3)//',x,a'//str_width_col(4)//',x,a'//str_width_col(5)//')'
write(master_list_file,fmt_txt) '#', 'Variable Name', &
'Long Description', 'Units', 'Active?'
! End header, same as header
! Concatenate strings needed in format statement
do i = 1, ncol
fmt_txt = '('//str_width_col(i)//'a,x)'
write(master_list_file,fmt_txt,advance='no') ('=', j=1,width_col(i))
end do
write(master_list_file,*) ! next write statement will now appear in new line
! Main table
! Concatenate strings needed in format statement
fmt_txt = '(i'//str_width_col(1)//',x,a'//str_width_col(2)//',x,a'//str_width_col(3)//',x,a'//str_width_col(4)//',l'//str_width_col(5)//')'
do nf = 1,nfmaster
write(master_list_file,fmt_txt) nf, &
masterlist(nf)%field%name, &
masterlist(nf)%field%long_name, &
masterlist(nf)%field%units, &
masterlist(nf)%actflag(1)
end do
! Table footer, same as header
! Concatenate strings needed in format statement
do i = 1, ncol
fmt_txt = '('//str_width_col(i)//'a,x)'
write(master_list_file,fmt_txt,advance='no') ('=', j=1,width_col(i))
end do
call shr_sys_flush(master_list_file)
close(unit = master_list_file)
call relavu(master_list_file) ! close and release file unit number
end if
end subroutine hist_printflds
!-----------------------------------------------------------------------
subroutine masterlist_addfld (fname, numdims, type1d, type1d_out, &
type2d, num2d, units, avgflag, long_name, hpindex, &
p2c_scale_type, c2l_scale_type, l2g_scale_type, &
no_snow_behavior)
!
! !DESCRIPTION:
! Add a field to the master field list. Put input arguments of
! field name, units, number of levels, averaging flag, and long name
! into a type entry in the global master field list (masterlist).
!
! The optional argument no_snow_behavior should be given when this is a multi-layer
! snow field, and should be absent otherwise. It should take on one of the no_snow_*
! parameters defined above
!
! !ARGUMENTS:
character(len=*), intent(in) :: fname ! field name
integer , intent(in) :: numdims ! number of dimensions
character(len=*), intent(in) :: type1d ! 1d data type
character(len=*), intent(in) :: type1d_out ! 1d output type
character(len=*), intent(in) :: type2d ! 2d output type
integer , intent(in) :: num2d ! size of second dimension (e.g. number of vertical levels)
character(len=*), intent(in) :: units ! units of field
character(len=*), intent(in) :: avgflag ! time averaging flag
character(len=*), intent(in) :: long_name ! long name of field
integer , intent(in) :: hpindex ! data type index for history buffer output
character(len=*), intent(in) :: p2c_scale_type ! scale type for subgrid averaging of pfts to column
character(len=*), intent(in) :: c2l_scale_type ! scale type for subgrid averaging of columns to landunits
character(len=*), intent(in) :: l2g_scale_type ! scale type for subgrid averaging of landunits to gridcells
integer, intent(in), optional :: no_snow_behavior ! if a multi-layer snow field, behavior to use for absent snow layers
!
! !LOCAL VARIABLES:
integer :: n ! loop index
integer :: f ! masterlist index
integer :: numa ! total number of atm cells across all processors
integer :: numg ! total number of gridcells across all processors
integer :: numl ! total number of landunits across all processors
integer :: numc ! total number of columns across all processors
integer :: nump ! total number of pfts across all processors
type(bounds_type) :: bounds
character(len=*),parameter :: subname = 'masterlist_addfld'
!------------------------------------------------------------------------
if (.not. avgflag_valid(avgflag, blank_valid=.true.)) then
write(iulog,*) trim(subname),' ERROR: unknown averaging flag=', avgflag
call endrun(msg=errMsg(sourcefile, __LINE__))
end if
! Determine bounds
call get_proc_bounds(bounds)
call get_proc_global(ng=numg, nl=numl, nc=numc, np=nump)
! Ensure that new field is not all blanks
if (fname == ' ') then
write(iulog,*) trim(subname),' ERROR: blank field name not allowed'
call endrun(msg=errMsg(sourcefile, __LINE__))
end if
! Ensure that new field name isn't too long
if (len_trim(fname) > max_namlen ) then
write(iulog,*) trim(subname),' ERROR: field name too long: ', trim(fname)
call endrun(msg=errMsg(sourcefile, __LINE__))
end if
! Ensure that new field doesn't already exist
do n = 1,nfmaster
if (masterlist(n)%field%name == fname) then
write(iulog,*) trim(subname),' ERROR:', fname, ' already on list'
call endrun(msg=errMsg(sourcefile, __LINE__))
end if
end do
! Increase number of fields on master field list
nfmaster = nfmaster + 1
f = nfmaster
! Check number of fields in master list against maximum number for master list
if (nfmaster > max_flds) then
write(iulog,*) trim(subname),' ERROR: too many fields for primary history file ', &
'-- max_flds,nfmaster=', max_flds, nfmaster
call endrun(msg=errMsg(sourcefile, __LINE__))
end if
! Add field to master list
masterlist(f)%field%name = fname
masterlist(f)%field%long_name = long_name
masterlist(f)%field%units = units
masterlist(f)%field%type1d = type1d
masterlist(f)%field%type1d_out = type1d_out
masterlist(f)%field%type2d = type2d
masterlist(f)%field%numdims = numdims
masterlist(f)%field%num2d = num2d
masterlist(f)%field%hpindex = hpindex
masterlist(f)%field%p2c_scale_type = p2c_scale_type
masterlist(f)%field%c2l_scale_type = c2l_scale_type
masterlist(f)%field%l2g_scale_type = l2g_scale_type
select case (type1d)
case (grlnd)
masterlist(f)%field%beg1d = bounds%begg
masterlist(f)%field%end1d = bounds%endg
masterlist(f)%field%num1d = numg
case (nameg)
masterlist(f)%field%beg1d = bounds%begg
masterlist(f)%field%end1d = bounds%endg
masterlist(f)%field%num1d = numg
case (namel)
masterlist(f)%field%beg1d = bounds%begl
masterlist(f)%field%end1d = bounds%endl
masterlist(f)%field%num1d = numl
case (namec)
masterlist(f)%field%beg1d = bounds%begc
masterlist(f)%field%end1d = bounds%endc
masterlist(f)%field%num1d = numc
case (namep)
masterlist(f)%field%beg1d = bounds%begp
masterlist(f)%field%end1d = bounds%endp
masterlist(f)%field%num1d = nump
case default
write(iulog,*) trim(subname),' ERROR: unknown 1d output type= ',type1d
call endrun(msg=errMsg(sourcefile, __LINE__))
end select
if (present(no_snow_behavior)) then
masterlist(f)%field%no_snow_behavior = no_snow_behavior
else
masterlist(f)%field%no_snow_behavior = no_snow_unset
end if
! The following two fields are used only in master field list,
! NOT in the runtime active field list
! ALL FIELDS IN THE MASTER LIST ARE INITIALIZED WITH THE ACTIVE
! FLAG SET TO FALSE
masterlist(f)%avgflag(:) = avgflag
masterlist(f)%actflag(:) = .false.
end subroutine masterlist_addfld
!-----------------------------------------------------------------------
subroutine hist_htapes_build ()
!
! !DESCRIPTION:
! Initialize history file for initial or continuation run. For example,
! on an initial run, this routine initializes ``ntapes'' history files.
! On a restart run, this routine only initializes history files declared
! beyond what existed on the previous run. Files which already existed on
! the previous run have already been initialized (i.e. named and opened)
! in routine restart\_history. Loop over tapes and fields per tape setting
! appropriate variables and calling appropriate routines
!
! !USES:
use clm_time_manager, only: get_prev_time
use clm_varcon , only: secspday
!
! !ARGUMENTS:
!
! !LOCAL VARIABLES:
integer :: i ! index
integer :: ier ! error code
integer :: t, f ! tape, field indices
integer :: day, sec ! day and seconds from base date
character(len=*),parameter :: subname = 'hist_htapes_build'
!-----------------------------------------------------------------------
if (masterproc) then
write(iulog,*) trim(subname),' Initializing ', trim(compname), ' history files'
write(iulog,'(72a1)') ("-",i=1,60)
call shr_sys_flush(iulog)
endif
! Define field list information for all history files.
! Update ntapes to reflect number of active history files
! Note - branch runs can have additional auxiliary history files
! declared).
call htapes_fieldlist()
! Determine if gridcell (xy) averaging is done for all fields on tape
do t=1,ntapes
tape(t)%dov2xy = hist_dov2xy(t)
if (masterproc) then
write(iulog,*)trim(subname),' hist tape = ',t,&
' written with dov2xy= ',tape(t)%dov2xy
end if
end do
! Set number of time samples in each history file and
! Note - the following entries will be overwritten by history restart
! Note - with netcdf, only 1 (ncd_double) and 2 (ncd_float) are allowed
do t=1,ntapes
tape(t)%ntimes = 0
tape(t)%dov2xy = hist_dov2xy(t)
tape(t)%nhtfrq = hist_nhtfrq(t)
tape(t)%mfilt = hist_mfilt(t)
if (hist_ndens(t) == 1) then
tape(t)%ncprec = ncd_double
else
tape(t)%ncprec = ncd_float
endif
end do
! Set time of beginning of current averaging interval
! First etermine elapased time since reference date
call get_prev_time(day, sec)
do t=1,ntapes
tape(t)%begtime = day + sec/secspday
end do
if (masterproc) then
write(iulog,*) trim(subname),' Successfully initialized ', trim(compname), ' history files'
write(iulog,'(72a1)') ("-",i=1,60)
call shr_sys_flush(iulog)
endif
end subroutine hist_htapes_build
!-----------------------------------------------------------------------
subroutine masterlist_make_active (name, tape_index, avgflag)
!
! !DESCRIPTION:
! Add a field to the default ``on'' list for a given history file.
! Also change the default time averaging flag if requested.
!
! !ARGUMENTS:
character(len=*), intent(in) :: name ! field name
integer, intent(in) :: tape_index ! history tape index
character(len=*), intent(in), optional :: avgflag ! time averaging flag
!
! !LOCAL VARIABLES:
integer :: f ! field index
logical :: found ! flag indicates field found in masterlist
character(len=*),parameter :: subname = 'masterlist_make_active'
!-----------------------------------------------------------------------
! Check validity of input arguments
if (tape_index > max_tapes) then
write(iulog,*) trim(subname),' ERROR: tape index=', tape_index, ' is too big'
call endrun(msg=errMsg(sourcefile, __LINE__))
end if
if (present(avgflag)) then
if (.not. avgflag_valid(avgflag, blank_valid=.true.)) then
write(iulog,*) trim(subname),' ERROR: unknown averaging flag=', avgflag
call endrun(msg=errMsg(sourcefile, __LINE__))
endif
end if
! Look through master list for input field name.
! When found, set active flag for that tape to true.
! Also reset averaging flag if told to use other than default.
found = .false.
do f = 1,nfmaster
if (trim(name) == trim(masterlist(f)%field%name)) then
masterlist(f)%actflag(tape_index) = .true.
if (present(avgflag)) then
if (avgflag/= ' ') masterlist(f)%avgflag(tape_index) = avgflag
end if
found = .true.
exit
end if
end do
if (.not. found) then
write(iulog,*) trim(subname),' ERROR: field=', name, ' not found'
call endrun(msg=errMsg(sourcefile, __LINE__))
end if
end subroutine masterlist_make_active
!-----------------------------------------------------------------------
subroutine masterlist_change_timeavg (t)
!
! !DESCRIPTION:
! Override default history tape contents for a specific tape.
! Copy the flag into the master field list.
!
! !ARGUMENTS:
integer, intent(in) :: t ! history tape index
!
! !LOCAL VARIABLES:
integer :: f ! field index
character(len=avgflag_strlen) :: avgflag ! local equiv of hist_avgflag_pertape(t)
character(len=*),parameter :: subname = 'masterlist_change_timeavg'
!-----------------------------------------------------------------------
avgflag = hist_avgflag_pertape(t)
if (.not. avgflag_valid(avgflag, blank_valid = .false.)) then
write(iulog,*) trim(subname),' ERROR: unknown avgflag=',avgflag
call endrun(msg=errMsg(sourcefile, __LINE__))
end if
do f = 1,nfmaster
masterlist(f)%avgflag(t) = avgflag
end do
end subroutine masterlist_change_timeavg
!-----------------------------------------------------------------------
subroutine htapes_fieldlist()
!
! !DESCRIPTION:
! Define the contents of each history file based on namelist
! input for initial or branch run, and restart data if a restart run.
! Use arrays fincl and fexcl to modify default history tape contents.
! Then sort the result alphanumerically.
!
! !ARGUMENTS:
!
! !LOCAL VARIABLES:
integer :: t, f ! tape, field indices
integer :: ff ! index into include, exclude and fprec list
character(len=max_namlen) :: name ! field name portion of fincl (i.e. no avgflag separator)
character(len=max_namlen) :: mastername ! name from masterlist field
character(len=avgflag_strlen) :: avgflag ! averaging flag
character(len=1) :: prec_acc ! history buffer precision flag
character(len=1) :: prec_wrt ! history buffer write precision flag
character(len=*),parameter :: subname = 'htapes_fieldlist'
!-----------------------------------------------------------------------
! Override averaging flag for all fields on a particular tape
! if namelist input so specifies
do t=1,max_tapes
if (hist_avgflag_pertape(t) /= ' ') then
call masterlist_change_timeavg (t)
end if
end do
fincl(:,1) = hist_fincl1(:)
fincl(:,2) = hist_fincl2(:)
fincl(:,3) = hist_fincl3(:)
fincl(:,4) = hist_fincl4(:)
fincl(:,5) = hist_fincl5(:)
fincl(:,6) = hist_fincl6(:)
fincl(:,7) = hist_fincl7(:)
fincl(:,8) = hist_fincl8(:)
fincl(:,9) = hist_fincl9(:)
fincl(:,10) = hist_fincl10(:)
fexcl(:,1) = hist_fexcl1(:)
fexcl(:,2) = hist_fexcl2(:)
fexcl(:,3) = hist_fexcl3(:)
fexcl(:,4) = hist_fexcl4(:)
fexcl(:,5) = hist_fexcl5(:)
fexcl(:,6) = hist_fexcl6(:)
fexcl(:,7) = hist_fexcl7(:)
fexcl(:,8) = hist_fexcl8(:)
fexcl(:,9) = hist_fexcl9(:)
fexcl(:,10) = hist_fexcl10(:)
! First ensure contents of fincl and fexcl are valid names
do t = 1,max_tapes
f = 1
do while (f < max_flds .and. fincl(f,t) /= ' ')
name = getname (fincl(f,t))
do ff = 1,nfmaster
mastername = masterlist(ff)%field%name
if (name == mastername) exit
end do
if (name /= mastername) then
write(iulog,*) trim(subname),' ERROR: ', trim(name), ' in fincl(', f, ') ',&
'for history tape ',t,' not found'
call endrun(msg=errMsg(sourcefile, __LINE__))
end if
f = f + 1
end do
f = 1
do while (f < max_flds .and. fexcl(f,t) /= ' ')
do ff = 1,nfmaster
mastername = masterlist(ff)%field%name
if (fexcl(f,t) == mastername) exit
end do
if (fexcl(f,t) /= mastername) then
write(iulog,*) trim(subname),' ERROR: ', fexcl(f,t), ' in fexcl(', f, ') ', &
'for history tape ',t,' not found'
call endrun(msg=errMsg(sourcefile, __LINE__))
end if
f = f + 1
end do
end do
history_tape_in_use(:) = .false.
tape(:)%nflds = 0
do t = 1,max_tapes
! Loop through the masterlist set of field names and determine if any of those
! are in the FINCL or FEXCL arrays
! The call to list_index determines the index in the FINCL or FEXCL arrays
! that the masterlist field corresponds to
! Add the field to the tape if specified via namelist (FINCL[1-max_tapes]),
! or if it is on by default and was not excluded via namelist (FEXCL[1-max_tapes]).
do f = 1,nfmaster
mastername = masterlist(f)%field%name
call list_index (fincl(1,t), mastername, ff)
if (ff > 0) then
! if field is in include list, ff > 0 and htape_addfld
! will not be called for field
avgflag = getflag (fincl(ff,t))
call htape_addfld (t, f, avgflag)
else if (.not. hist_empty_htapes) then
! find index of field in exclude list
call list_index (fexcl(1,t), mastername, ff)
! if field is in exclude list, ff > 0 and htape_addfld
! will not be called for field
! if field is not in exclude list, ff =0 and htape_addfld
! will be called for field (note that htape_addfld will be
! called below only if field is not in exclude list OR in
! include list
if (ff == 0 .and. masterlist(f)%actflag(t)) then
call htape_addfld (t, f, ' ')
end if
end if
end do
! Specification of tape contents now complete.
! Sort each list of active entries
call sort_hist_list(t, tape(t)%nflds, tape(t)%hlist)
if (masterproc) then
if (tape(t)%nflds > 0) then
write(iulog,*) trim(subname),' : Included fields tape ',t,'=',tape(t)%nflds
end if
do f = 1,tape(t)%nflds
write(iulog,*) f,' ',tape(t)%hlist(f)%field%name, &
tape(t)%hlist(f)%field%num2d,' ',tape(t)%hlist(f)%avgflag
end do
call shr_sys_flush(iulog)
end if
end do
! Determine index of max active history tape, and whether each tape is in use
ntapes = 0
do t = max_tapes,1,-1
if (tape(t)%nflds > 0) then
ntapes = t
exit
end if
end do
do t = 1, ntapes
if (tape(t)%nflds > 0) then
history_tape_in_use(t) = .true.
end if
end do
! Change 1d output per tape output flag if requested - only for history
! tapes where 2d xy averaging is not enabled
do t = 1,ntapes
if (hist_type1d_pertape(t) /= ' ' .and. (.not. hist_dov2xy(t))) then
select case (trim(hist_type1d_pertape(t)))
case ('PFTS','COLS', 'LAND', 'GRID')
if ( masterproc ) &
write(iulog,*)'history tape ',t,' will have 1d output type of ',hist_type1d_pertape(t)
case default
write(iulog,*) trim(subname),' ERROR: unknown namelist type1d per tape=',hist_type1d_pertape(t)
call endrun(msg=errMsg(sourcefile, __LINE__))
end select
end if
end do
if (masterproc) then
write(iulog,*) 'There will be a total of ',ntapes,' history tapes'
do t=1,ntapes
write(iulog,*)
if (hist_nhtfrq(t) == 0) then
write(iulog,*)'History tape ',t,' write frequency is MONTHLY'
else
write(iulog,*)'History tape ',t,' write frequency = ',hist_nhtfrq(t)
endif
if (hist_dov2xy(t)) then
write(iulog,*)'All fields on history tape ',t,' are grid averaged'
else
write(iulog,*)'All fields on history tape ',t,' are not grid averaged'
end if
write(iulog,*)'Number of time samples on history tape ',t,' is ',hist_mfilt(t)
write(iulog,*)'Output precision on history tape ',t,'=',hist_ndens(t)
if (.not. history_tape_in_use(t)) then
write(iulog,*) 'History tape ',t,' does not have any fields,'
write(iulog,*) 'so it will not be written!'
end if
write(iulog,*)
end do
call shr_sys_flush(iulog)
end if
! Set flag indicating h-tape contents are now defined (needed by masterlist_addfld)
htapes_defined = .true.
end subroutine htapes_fieldlist
!-----------------------------------------------------------------------
subroutine copy_master_entry(this, other)
! set this = other
class(master_entry), intent(out) :: this
class(entry_base), intent(in) :: other
select type(this)
type is (master_entry)
select type(other)
type is (master_entry)
this = other
class default
call endrun('Unexpected type of "other" in copy_master_entry')
end select
class default
call endrun('Unexpected type of "this" in copy_master_entry')
end select
end subroutine copy_master_entry
!-----------------------------------------------------------------------
subroutine copy_history_entry(this, other)
! set this = other
class(history_entry), intent(out) :: this
class(entry_base), intent(in) :: other
select type(this)
type is (history_entry)
select type(other)
type is (history_entry)
this = other
class default
call endrun('Unexpected type of "other" in copy_history_entry')
end select
class default
call endrun('Unexpected type of "this" in copy_history_entry')
end select
end subroutine copy_history_entry
!-----------------------------------------------------------------------