Line data Source code
1 : module mo_flbc
2 : !---------------------------------------------------------------
3 : ! ... lower boundary module
4 : !---------------------------------------------------------------
5 :
6 : use shr_kind_mod, only : r8 => shr_kind_r8
7 : use m_types, only : time_ramp
8 : use spmd_utils, only : masterproc
9 : use cam_abortutils, only : endrun
10 : use ioFileMod, only : getfil
11 : use ppgrid, only : pcols, begchunk, endchunk, pver
12 : use time_manager, only : get_curr_date
13 : use time_utils, only : flt_date
14 : use cam_logfile, only : iulog
15 : use constituents, only : pcnst
16 :
17 : implicit none
18 :
19 : type :: flbc
20 : integer :: spc_ndx = -1
21 : real(r8), pointer :: vmr(:,:,:)
22 : character(len=16) :: species = ' '
23 : logical :: has_mean
24 : real(r8), pointer :: vmr_mean(:)
25 : end type flbc
26 :
27 : private
28 : public :: flbc_inti, flbc_set, flbc_chk, has_flbc
29 : public :: flbc_gmean_vmr
30 : public :: flbc_get_cfc11eq, flbc_has_cfc11eq
31 :
32 : save
33 :
34 : integer, parameter :: time_span = 1
35 :
36 : integer :: ntimes
37 : integer :: flbc_cnt
38 : integer :: tim_ndx(2)
39 : integer, allocatable :: dates(:)
40 : real(r8), allocatable :: times(:)
41 : logical, protected :: has_flbc(pcnst)
42 : character(len=256) :: filename
43 :
44 : type(time_ramp) :: flbc_timing
45 : integer :: ncdate, ncsec
46 :
47 : integer, parameter :: nghg = 6
48 : integer, parameter :: max_nflbc = pcnst+nghg
49 :
50 : integer, parameter :: co2_ndx = 1
51 : integer, parameter :: ch4_ndx = 2
52 : integer, parameter :: n2o_ndx = 3
53 : integer, parameter :: f11_ndx = 4
54 : integer, parameter :: f12_ndx = 5
55 : integer, parameter :: f11eq_ndx = 6
56 : character(len=8) :: ghg_names(nghg) = (/ 'CO2 ','CH4 ','N2O ','CFC11 ','CFC12 ','CFC11eq ' /)
57 : integer :: ghg_indices(nghg) = -1
58 :
59 : type(flbc) :: flbcs(max_nflbc)
60 :
61 : logical, parameter :: debug = .false.
62 : logical, protected :: flbc_has_cfc11eq = .false.
63 :
64 : contains
65 :
66 1536 : subroutine flbc_inti( flbc_file, flbc_list, flbc_timing_in, co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr )
67 : !-----------------------------------------------------------------------
68 : ! ... initialize the fixed lower bndy cond
69 : !-----------------------------------------------------------------------
70 :
71 : use string_utils, only : to_upper
72 : use constituents, only : cnst_get_ind
73 : use cam_pio_utils, only : cam_pio_openfile
74 : use pio, only : pio_get_var,pio_inq_varid,pio_inq_dimid, pio_inq_dimlen
75 : use pio, only : file_desc_t, pio_closefile, pio_nowrite
76 :
77 : implicit none
78 :
79 : !-----------------------------------------------------------------------
80 : ! ... dummy arguments
81 : !-----------------------------------------------------------------------
82 : character(len=*), intent(in) :: flbc_file
83 : character(len=*), intent(in) :: flbc_list(:)
84 : type(time_ramp), intent(in) :: flbc_timing_in
85 : real(r8), intent(in) :: co2vmr, ch4vmr, n2ovmr, f11vmr, f12vmr
86 :
87 : !-----------------------------------------------------------------------
88 : ! ... local variables
89 : !-----------------------------------------------------------------------
90 : integer :: astat
91 : integer :: m, n ! Indices
92 : integer :: t1, t2
93 : type(file_desc_t) :: ncid
94 : integer :: dimid
95 : integer :: varid
96 : integer :: yr, mon, day, wrk_date, wrk_sec
97 : real(r8) :: wrk_time
98 : character(len=8) :: time_type
99 : integer :: ierr
100 :
101 1536 : if ( len_trim( flbc_file ) == 0 .or. flbc_file.eq.'NONE') return
102 :
103 1536 : call get_curr_date( yr, mon, day, ncsec )
104 1536 : ncdate = yr*10000 + mon*100 + day
105 :
106 : !-----------------------------------------------------------------------
107 : ! ... check timing
108 : !-----------------------------------------------------------------------
109 1536 : flbc_timing = flbc_timing_in
110 1536 : time_type = to_upper(flbc_timing%type)
111 1536 : flbc_timing%type = time_type
112 : if( time_type /= 'SERIAL' .and. time_type /= 'CYCLICAL' &
113 1536 : .and. time_type /= 'FIXED' ) then
114 0 : write(iulog,*) 'flbc_inti: time type ',trim(time_type),' is not SERIAL,CYCLICAL, or FIXED'
115 0 : call endrun('flbc_inti: invalid time type ')
116 : end if
117 :
118 1536 : if ( (flbc_timing%cycle_yr>0) .and. (time_type/='CYCLICAL') ) then
119 0 : call endrun('flbc_inti: cannot specify flbc_cycle_yr if flbc_type is not CYCLICAL')
120 : endif
121 1536 : if ( ((flbc_timing%fixed_ymd>0).or.(flbc_timing%fixed_tod>0)).and.(time_type/='FIXED') ) then
122 0 : call endrun('flbc_inti: cannot specify flbc_fixed_ymd or flbc_fixed_tod if flbc_type is not FIXED')
123 : endif
124 :
125 1536 : wrk_sec = ncsec
126 1536 : if( time_type == 'SERIAL' ) then
127 1536 : wrk_date = ncdate
128 0 : else if( time_type == 'CYCLICAL' ) then
129 :
130 : ! If this is a leap-day, we have to avoid asking for a non-leap-year
131 : ! on a cyclical dataset. When this happens, just use Feb 28 instead
132 0 : if (( mon .eq. 2 ) .and. ( day.eq.29 )) then
133 0 : ncdate = yr*10000 + mon*100 + (day-1)
134 0 : write(iulog,*)'WARNING: flbc_inti using Feb 28 instead of Feb 29 for cyclical dataset'
135 : endif
136 0 : wrk_date = flbc_timing%cycle_yr*10000 + mod(ncdate,10000)
137 : else
138 0 : wrk_date = flbc_timing%fixed_ymd
139 0 : wrk_sec = flbc_timing%fixed_tod
140 : end if
141 1536 : wrk_time = flt_date( wrk_date, wrk_sec )
142 1536 : if (masterproc) write(iulog,*) 'flbc_inti: wrk_date,wrk_sec,wrk_time = ',wrk_date,wrk_sec,wrk_time
143 :
144 : !-----------------------------------------------------------------------
145 : ! ... species with fixed lbc ?
146 : !-----------------------------------------------------------------------
147 1536 : has_flbc(:) = .false.
148 1536 : flbc_cnt = 0
149 :
150 10752 : do m = 1,max_nflbc
151 :
152 10752 : if ( len_trim(flbc_list(m))==0 ) exit
153 :
154 9216 : flbc_cnt = flbc_cnt + 1
155 :
156 9216 : call cnst_get_ind (flbc_list(m), n, abort=.false.)
157 :
158 9216 : if (n > 0) then
159 0 : has_flbc(n) = .true.
160 0 : flbcs(flbc_cnt)%spc_ndx = n
161 : else ! must be one of the GHGs which is not prognosted
162 32256 : if( .not. any( ghg_names(:) == flbc_list(m) ) ) then
163 0 : call endrun('flbc_inti: flbc_list member '// trim(flbc_list(m)) //' is not allowed')
164 : endif
165 9216 : flbcs(flbc_cnt)%spc_ndx = -1
166 : endif
167 :
168 9216 : flbcs(flbc_cnt)%species = trim( flbc_list(m) )
169 :
170 64512 : where( ghg_names(:) == flbc_list(m) )
171 : ghg_indices = m
172 : endwhere
173 :
174 9216 : if( trim(flbcs(flbc_cnt)%species) == 'CFC11' ) then
175 1536 : flbcs(flbc_cnt)%species = 'CFCL3'
176 7680 : elseif( trim(flbcs(flbc_cnt)%species) == 'CFC12' ) then
177 1536 : flbcs(flbc_cnt)%species = 'CF2CL2'
178 : endif
179 :
180 10752 : if ( trim(flbc_list(m)) .eq. trim(ghg_names(f11eq_ndx)) ) then
181 1536 : flbc_has_cfc11eq = .true.
182 : endif
183 :
184 : enddo
185 :
186 : ! check that user has not set vmr namelist values...
187 1536 : if ( ghg_indices(co2_ndx) > 0 .and. co2vmr>1.e-6_r8) then
188 0 : call endrun('flbc_inti: cannot specify both co2vmr and CO2 in flbc_file')
189 : endif
190 1536 : if ( ghg_indices(ch4_ndx) > 0 .and. ch4vmr > 0._r8) then
191 0 : call endrun('flbc_inti: cannot specify both ch4vmr and CH4 in flbc_file')
192 : endif
193 1536 : if ( ghg_indices(n2o_ndx) > 0 .and. n2ovmr > 0._r8) then
194 0 : call endrun('flbc_inti: cannot specify both n2ovmr and N2O in flbc_file')
195 : endif
196 1536 : if ( ghg_indices(f11_ndx) > 0 .and. f11vmr > 0._r8) then
197 0 : call endrun('flbc_inti: cannot specify both f11vmr and CFC11 in flbc_file')
198 : endif
199 1536 : if ( ghg_indices(f12_ndx) > 0 .and. f12vmr > 0._r8) then
200 0 : call endrun('flbc_inti: cannot specify both f12vmr and CFC12 in flbc_file')
201 : endif
202 :
203 1536 : if( flbc_cnt == 0 ) then
204 : return
205 : end if
206 :
207 1536 : if(masterproc) then
208 2 : write(iulog,*) ' '
209 2 : if( flbc_cnt > 0 ) then
210 2 : write(iulog,*) 'flbc_inti: Species with specified lower boundary values'
211 14 : do n = 1,flbc_cnt
212 14 : write(iulog,*) trim(flbcs(n)%species)
213 : enddo
214 : else
215 0 : write(iulog,*) 'There are no species with specified lower boundary values'
216 : end if
217 2 : write(iulog,*) ' '
218 :
219 : !-----------------------------------------------------------------------
220 : ! ... diagnostics
221 : !-----------------------------------------------------------------------
222 2 : write(iulog,*) ' '
223 2 : write(iulog,*) 'flbc_inti: diagnostics'
224 2 : write(iulog,*) ' '
225 2 : write(iulog,*) 'lower bndy timing specs'
226 2 : write(iulog,*) 'type = ',flbc_timing%type
227 2 : if( time_type == 'CYCLICAL' ) then
228 0 : write(iulog,*) 'cycle year = ',flbc_timing%cycle_yr
229 : else
230 2 : write(iulog,*) 'fixed date = ',flbc_timing%fixed_ymd
231 2 : write(iulog,*) 'fixed time = ',flbc_timing%fixed_tod
232 : end if
233 2 : write(iulog,*) ' '
234 2 : write(iulog,*) 'there are ',flbc_cnt,' species with specified lower bndy values'
235 2 : write(iulog,*) ' '
236 : end if
237 : !-----------------------------------------------------------------------
238 : ! ... get timing information, allocate arrays, and read in dates
239 : !-----------------------------------------------------------------------
240 1536 : call getfil ( flbc_file, filename, 0)
241 1536 : call cam_pio_openfile (ncid, trim(filename), PIO_NOWRITE)
242 1536 : ierr = pio_inq_dimid( ncid, 'time', dimid )
243 1536 : ierr = pio_inq_dimlen( ncid, dimid, ntimes )
244 :
245 4608 : allocate( dates(ntimes),stat=astat )
246 1536 : if( astat/= 0 ) then
247 0 : write(iulog,*) 'flbc_inti: failed to allocate dates array; error = ',astat
248 0 : call endrun
249 : end if
250 4608 : allocate( times(ntimes),stat=astat )
251 1536 : if( astat/= 0 ) then
252 0 : write(iulog,*) 'flbc_inti: failed to allocate times array; error = ',astat
253 0 : call endrun
254 : end if
255 :
256 1536 : ierr = pio_inq_varid( ncid, 'date', varid )
257 1536 : ierr = pio_get_var( ncid, varid, dates )
258 :
259 4887552 : do n = 1,ntimes
260 4887552 : times(n) = flt_date( dates(n), 0 )
261 : end do
262 1536 : if( time_type /= 'CYCLICAL' ) then
263 1536 : if( wrk_time < times(1) .or. wrk_time > times(ntimes) ) then
264 0 : write(iulog,*) 'flbc_inti: time out of bounds for dataset = ',trim(filename)
265 0 : call endrun
266 : end if
267 4220928 : do n = 2,ntimes
268 4220928 : if( wrk_time <= times(n) ) then
269 : exit
270 : end if
271 : end do
272 1536 : tim_ndx(1) = n - 1
273 : else
274 0 : yr = flbc_timing%cycle_yr
275 0 : do n = 1,ntimes
276 0 : if( yr == dates(n)/10000 ) then
277 : exit
278 : end if
279 : end do
280 0 : if( n >= ntimes ) then
281 0 : write(iulog,*) 'flbc_inti: time out of bounds for dataset = ',trim(filename)
282 0 : call endrun
283 : end if
284 0 : tim_ndx(1) = n
285 : end if
286 0 : select case( time_type )
287 : case( 'FIXED' )
288 0 : tim_ndx(2) = n
289 : case( 'CYCLICAL' )
290 0 : do n = tim_ndx(1),ntimes
291 0 : if( yr /= dates(n)/10000 ) then
292 : exit
293 : end if
294 : end do
295 0 : tim_ndx(2) = n - 1
296 0 : if( (tim_ndx(2) - tim_ndx(1)) < 2 ) then
297 0 : write(iulog,*) 'flbc_inti: cyclical lb conds require at least two time points'
298 0 : call endrun
299 : end if
300 : case( 'SERIAL' )
301 1536 : tim_ndx(2) = min( ntimes,tim_ndx(1) + time_span )
302 : end select
303 1536 : t1 = tim_ndx(1)
304 1536 : t2 = tim_ndx(2)
305 :
306 : if( masterproc .and. debug ) then
307 : write(iulog,*) ' '
308 : write(iulog,*) 'flbc time cnt = ',ntimes
309 : write(iulog,*) 'flbc times'
310 : write(iulog,'(10i10)') dates(:)
311 : write(iulog,'(1p,5g15.7)') times(:)
312 : write(iulog,*) 'flbc time indicies = ',tim_ndx(:)
313 : write(iulog,'(10i10)') dates(tim_ndx(1):tim_ndx(2))
314 : write(iulog,*) ' '
315 : endif
316 :
317 10752 : do m = 1,flbc_cnt
318 : !-----------------------------------------------------------------------
319 : ! ... allocate array
320 : !-----------------------------------------------------------------------
321 36864 : allocate( flbcs(m)%vmr(pcols,begchunk:endchunk,t1:t2),stat=astat )
322 9216 : if( astat/= 0 ) then
323 0 : write(iulog,*) 'flbc_inti: failed to allocate lbc vmr; error = ',astat
324 0 : call endrun
325 : end if
326 9216 : flbcs(m)%has_mean = file_has_gmean(ncid,flbcs(m)%species)
327 9216 : if ( flbcs(m)%has_mean) then
328 0 : allocate( flbcs(m)%vmr_mean(t1:t2),stat=astat )
329 0 : if( astat/= 0 ) then
330 0 : write(iulog,*) 'flbc_inti: failed to allocate lbc vmr_mean; error = ',astat
331 0 : call endrun
332 : end if
333 : endif
334 : !-----------------------------------------------------------------------
335 : ! ... readin the flbc vmr
336 : !-----------------------------------------------------------------------
337 10752 : call flbc_get( ncid, flbcs(m), .true., read_gmean=flbcs(m)%has_mean )
338 : end do
339 :
340 : !-----------------------------------------------------------------------
341 : ! ... close the file
342 : !-----------------------------------------------------------------------
343 1536 : call pio_closefile( ncid )
344 :
345 3072 : end subroutine flbc_inti
346 :
347 372480 : subroutine flbc_chk( )
348 1536 : use cam_pio_utils, only : cam_pio_openfile
349 : use pio, only : file_desc_t, pio_closefile, pio_nowrite
350 : !-----------------------------------------------------------------------
351 : ! ... check serial case for time span
352 : !-----------------------------------------------------------------------
353 :
354 : implicit none
355 :
356 : !-----------------------------------------------------------------------
357 : ! ... dummy arguments
358 : !-----------------------------------------------------------------------
359 :
360 : !-----------------------------------------------------------------------
361 : ! ... local variables
362 : !-----------------------------------------------------------------------
363 : integer :: m
364 : integer :: t1, t2, tcnt
365 : integer :: astat
366 : type(file_desc_t) :: ncid
367 : real(r8) :: wrk_time
368 : integer :: yr, mon, day
369 :
370 372480 : call get_curr_date( yr, mon, day, ncsec )
371 372480 : ncdate = yr*10000 + mon*100 + day
372 :
373 372480 : if( flbc_cnt > 0 .and. flbc_timing%type == 'SERIAL' ) then
374 372480 : wrk_time = flt_date( ncdate, ncsec )
375 372480 : if( wrk_time > times(tim_ndx(2)) ) then
376 0 : tcnt = tim_ndx(2) - tim_ndx(1)
377 0 : tim_ndx(1) = tim_ndx(2)
378 0 : tim_ndx(2) = min( ntimes,tim_ndx(1) + time_span )
379 0 : t1 = tim_ndx(1)
380 0 : t2 = tim_ndx(2)
381 : !!$ if( tcnt /= (t2 - t1) ) then
382 : !-----------------------------------------------------------------------
383 : ! ... allocate array
384 : !-----------------------------------------------------------------------
385 0 : do m = 1,flbc_cnt
386 0 : if( associated( flbcs(m)%vmr ) ) then
387 0 : deallocate( flbcs(m)%vmr,stat=astat )
388 : if( astat/= 0 ) then
389 : write(iulog,*) 'flbc_chk: failed to deallocate flbc vmr; error = ',astat
390 : call endrun
391 : end if
392 : end if
393 0 : allocate( flbcs(m)%vmr(pcols,begchunk:endchunk,t1:t2),stat=astat )
394 0 : if( astat/= 0 ) then
395 0 : write(iulog,*) 'flbc_chk: failed to allocate flbc vmr; error = ',astat
396 0 : call endrun
397 : end if
398 :
399 0 : if (flbcs(m)%has_mean) then
400 0 : if( associated( flbcs(m)%vmr_mean ) ) then
401 0 : deallocate( flbcs(m)%vmr_mean,stat=astat )
402 : if( astat/= 0 ) then
403 : write(iulog,*) 'flbc_chk: failed to deallocate flbc vmr; error = ',astat
404 : call endrun
405 : end if
406 : end if
407 0 : allocate( flbcs(m)%vmr_mean(t1:t2),stat=astat )
408 0 : if( astat/= 0 ) then
409 0 : write(iulog,*) 'flbc_chk: failed to allocate flbc vmr; error = ',astat
410 0 : call endrun
411 : end if
412 :
413 : endif
414 : end do
415 : !!$ end if
416 :
417 0 : call cam_pio_openfile (ncid, trim(filename), PIO_NOWRITE)
418 : !-----------------------------------------------------------------------
419 : ! ... readin the lb concentrations
420 : !-----------------------------------------------------------------------
421 0 : do m = 1,flbc_cnt
422 0 : call flbc_get( ncid, flbcs(m), .true., read_gmean=flbcs(m)%has_mean )
423 : end do
424 :
425 : !-----------------------------------------------------------------------
426 : ! ... close the file
427 : !-----------------------------------------------------------------------
428 0 : call pio_closefile( ncid )
429 :
430 : end if
431 : end if
432 :
433 744960 : end subroutine flbc_chk
434 :
435 : ! checks for global mean in input file
436 9216 : function file_has_gmean(ncid,species)
437 372480 : use pio, only : file_desc_t, pio_inq_varid, pio_noerr, pio_seterrorhandling, &
438 : pio_bcast_error, pio_internal_error
439 : implicit none
440 :
441 : type(file_desc_t), intent(inout) :: ncid
442 : character(*), intent(in) :: species
443 : logical :: file_has_gmean
444 :
445 : integer :: varid, ierr
446 :
447 : ! Allow pio to return the potential error and handle it locally
448 9216 : call pio_seterrorhandling(ncid, PIO_BCAST_ERROR)
449 9216 : ierr = pio_inq_varid( ncid, trim(species)//'_LBC_mean', varid)
450 9216 : call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR)
451 :
452 :
453 9216 : file_has_gmean = (ierr==PIO_NOERR)
454 :
455 9216 : endfunction file_has_gmean
456 :
457 9216 : subroutine flbc_get( ncid, lbcs, initial, read_gmean )
458 : !-----------------------------------------------------------------------
459 : ! ... read lower bndy values
460 : !-----------------------------------------------------------------------
461 : use mo_constants, only : d2r, pi
462 : use phys_grid, only: get_ncols_p, get_rlat_all_p, get_rlon_all_p
463 : use pio, only: file_desc_t, pio_get_var, pio_inq_varndims
464 : use pio, only: pio_max_name, pio_inq_varid, pio_inq_dimlen, pio_inq_dimid
465 : use pio, only: pio_seterrorhandling, PIO_BCAST_ERROR, PIO_INTERNAL_ERROR, PIO_NOERR
466 : use interpolate_data, only : interp_type, lininterp_init, lininterp_finish, lininterp
467 :
468 : implicit none
469 :
470 : !-----------------------------------------------------------------------
471 : ! ... dummy arguments
472 : !-----------------------------------------------------------------------
473 : type(file_desc_t), intent(inout) :: ncid
474 : logical, intent(in) :: initial
475 : type(flbc), intent(inout) :: lbcs
476 :
477 : logical, intent(in), optional :: read_gmean
478 :
479 : !-----------------------------------------------------------------------
480 : ! ... local variables
481 : !-----------------------------------------------------------------------
482 : integer :: j, m ! Indices
483 : integer :: t1, t2, tcnt
484 : integer :: ierr
485 : integer :: vid, nlat, nlon
486 : integer :: dimid_lat, dimid_lon
487 9216 : real(r8), allocatable :: lat(:)
488 9216 : real(r8), allocatable :: lon(:)
489 9216 : real(r8), allocatable :: wrk(:,:,:), wrk_zonal(:,:)
490 : character(len=pio_max_name) :: varname
491 9216 : real(r8), allocatable :: locl_vmr(:,:,:)
492 : integer :: ndims, t, c, ncols
493 : type(interp_type) :: lon_wgts, lat_wgts
494 : real(r8) :: to_lats(pcols), to_lons(pcols)
495 : real(r8), parameter :: twopi=2._r8*pi, zero=0._r8
496 :
497 9216 : t1 = tim_ndx(1)
498 9216 : t2 = tim_ndx(2)
499 9216 : tcnt = t2 - t1 + 1
500 36864 : allocate( locl_vmr(pcols,begchunk:endchunk,tcnt), stat=ierr )
501 9216 : if( ierr /= 0 ) then
502 0 : write(iulog,*) 'srf_emis_get: locl_emis allocation error = ',ierr
503 0 : call endrun
504 : end if
505 :
506 1290816 : locl_vmr(:,:,:) = 0._r8
507 :
508 9216 : initialization : if( initial ) then
509 : !-----------------------------------------------------------------------
510 : ! ... get grid dimensions from file
511 : !-----------------------------------------------------------------------
512 : ! latitudes
513 : !-----------------------------------------------------------------------
514 9216 : ierr = pio_inq_dimid( ncid, 'lat', dimid_lat )
515 9216 : ierr = pio_inq_dimlen( ncid, dimid_lat, nlat )
516 27648 : allocate( lat(nlat),stat=ierr )
517 9216 : if( ierr /= 0 ) then
518 0 : write(iulog,*) 'flbc_get: lat allocation error = ',ierr
519 0 : call endrun
520 : end if
521 9216 : ierr = pio_inq_varid( ncid, 'lat', vid )
522 9216 : ierr = pio_get_var( ncid, vid, lat )
523 3336192 : lat(:nlat) = lat(:nlat) * d2r
524 :
525 : !-----------------------------------------------------------------------
526 : ! longitudes
527 : !-----------------------------------------------------------------------
528 9216 : call pio_seterrorhandling( ncid, PIO_BCAST_ERROR )
529 9216 : ierr = pio_inq_dimid( ncid, 'lon', dimid_lon )
530 9216 : call pio_seterrorhandling( ncid, PIO_INTERNAL_ERROR )
531 9216 : if (ierr == PIO_NOERR ) then
532 9216 : ierr = pio_inq_dimlen( ncid, dimid_lon, nlon )
533 27648 : allocate( lon(nlon),stat=ierr )
534 9216 : if( ierr /= 0 ) then
535 0 : write(iulog,*) 'flbc_get: lon allocation error = ',ierr
536 0 : call endrun
537 : end if
538 9216 : ierr = pio_inq_varid( ncid, 'lon', vid )
539 9216 : ierr = pio_get_var( ncid, vid, lon )
540 2672640 : lon(:nlon) = lon(:nlon) * d2r
541 : endif
542 : end if initialization
543 :
544 : !-----------------------------------------------------------------------
545 : ! ... read data
546 : !-----------------------------------------------------------------------
547 9216 : varname = trim(lbcs%species) // '_LBC'
548 9216 : ierr = pio_inq_varid( ncid, trim(varname), vid )
549 9216 : ierr = pio_inq_varndims (ncid, vid, ndims)
550 :
551 9216 : if (ndims==2) then
552 36864 : allocate( wrk_zonal(nlat,tcnt), stat=ierr )
553 9216 : if( ierr /= 0 ) then
554 0 : write(iulog,*) 'flbc_get: wrk_zonal allocation error = ',ierr
555 0 : call endrun
556 : end if
557 : else
558 0 : allocate( wrk(nlon,nlat,tcnt), stat=ierr )
559 0 : if( ierr /= 0 ) then
560 0 : write(iulog,*) 'flbc_get: wrk allocation error = ',ierr
561 0 : call endrun
562 : end if
563 : endif
564 :
565 9216 : if (ndims==2) then
566 : ierr = pio_get_var( ncid, vid, (/ 1, t1/), &
567 46080 : (/ nlat, tcnt /), wrk_zonal )
568 : else
569 : ierr = pio_get_var( ncid, vid, (/ 1, 1, t1/), &
570 0 : (/ nlon, nlat, tcnt /), wrk )
571 : endif
572 :
573 46368 : do c=begchunk,endchunk
574 37152 : ncols = get_ncols_p(c)
575 37152 : call get_rlat_all_p(c, pcols, to_lats)
576 37152 : call get_rlon_all_p(c, pcols, to_lons)
577 :
578 37152 : call lininterp_init(lat, nlat, to_lats, ncols, 1, lat_wgts)
579 37152 : if (ndims==2) then
580 111456 : do m = 1,tcnt
581 111456 : call lininterp(wrk_zonal(:,m), nlat, locl_vmr(:,c,m), ncols, lat_wgts)
582 : end do
583 : else
584 0 : call lininterp_init(lon, nlon, to_lons, ncols, 2, lon_wgts, zero, twopi)
585 :
586 0 : do m = 1,tcnt
587 0 : call lininterp(wrk(:,:,m), nlon, nlat, locl_vmr(:,c,m), ncols, lon_wgts, lat_wgts)
588 : end do
589 :
590 :
591 0 : call lininterp_finish(lon_wgts)
592 : end if
593 46368 : call lininterp_finish(lat_wgts)
594 :
595 : end do
596 :
597 9216 : if (ndims==2) then
598 9216 : deallocate( wrk_zonal,stat=ierr )
599 9216 : if( ierr /= 0 ) then
600 0 : write(iulog,*) 'flbc_get: Failed to deallocate wrk_zonal, ierr = ',ierr
601 0 : call endrun
602 : end if
603 : else
604 0 : deallocate(wrk, stat=ierr)
605 0 : if( ierr /= 0 ) then
606 0 : write(iulog,*) 'flbc_get: Failed to deallocate wrk, ierr = ',ierr
607 0 : call endrun
608 : end if
609 : end if
610 9216 : if (read_gmean) then
611 0 : varname = trim(lbcs%species) // '_LBC_mean'
612 0 : ierr = pio_inq_varid( ncid, trim(varname), vid )
613 0 : ierr = pio_get_var( ncid, vid, (/t1/), (/tcnt/), lbcs%vmr_mean(t1:t2) )
614 : endif
615 :
616 :
617 27648 : do m = t1,t2
618 1290816 : lbcs%vmr(:,:,m) = locl_vmr(:,:,m-t1+1)
619 : enddo
620 :
621 9216 : deallocate(locl_vmr, stat=ierr )
622 9216 : if( ierr /= 0 ) then
623 0 : write(iulog,*) 'flbc_get: Failed to deallocate locl_vmr; ierr = ',ierr
624 0 : call endrun
625 : end if
626 :
627 9216 : end subroutine flbc_get
628 :
629 0 : subroutine flbc_set( vmr, ncol, lchnk, map )
630 : !--------------------------------------------------------
631 : ! ... set the lower bndy values
632 : !--------------------------------------------------------
633 :
634 : implicit none
635 :
636 : !--------------------------------------------------------
637 : ! ... dummy arguments
638 : !--------------------------------------------------------
639 : integer, intent(in) :: ncol
640 : integer, intent(in) :: lchnk
641 : integer, intent(in) :: map(:)
642 : real(r8), intent(inout) :: vmr(:,:,:) ! lower bndy concentrations( mol/mol )
643 :
644 : !--------------------------------------------------------
645 : ! ... local variables
646 : !--------------------------------------------------------
647 : integer :: m, n
648 : integer :: last, next
649 : real(r8) :: dels
650 :
651 0 : if( flbc_cnt < 1 ) then
652 0 : return
653 : end if
654 :
655 0 : call get_dels( dels, last, next )
656 :
657 0 : do m = 1,flbc_cnt
658 0 : if ( flbcs(m)%spc_ndx > 0 ) then
659 0 : n = map( flbcs(m)%spc_ndx )
660 : ! If the GHG happens to be an advected specie, but not a chemical specie
661 : ! (e.g., CO2 when the carbon cycle is on in standard CAM), then n=0 and
662 : ! we need to skip setting the LBC.
663 0 : if (n > 0) then
664 0 : vmr(:ncol,pver,n) = flbcs(m)%vmr(:ncol,lchnk,last) &
665 0 : + dels * (flbcs(m)%vmr(:ncol,lchnk,next) - flbcs(m)%vmr(:ncol,lchnk,last))
666 : end if
667 : endif
668 : end do
669 :
670 9216 : end subroutine flbc_set
671 :
672 0 : subroutine flbc_get_cfc11eq( lbc_vmr, ncol, lchnk )
673 :
674 : !--------------------------------------------------------
675 : ! return the lower of cfclleq
676 : !--------------------------------------------------------
677 :
678 : !--------------------------------------------------------
679 : ! dummy arguments
680 : !--------------------------------------------------------
681 : integer, intent(in) :: ncol
682 : integer, intent(in) :: lchnk
683 : real(r8), intent(out) :: lbc_vmr(:) ! lower bndy concentrations( mol/mol )
684 :
685 : !--------------------------------------------------------
686 : ! ... local variables
687 : !--------------------------------------------------------
688 : integer :: m, last, next
689 : real(r8) :: dels
690 :
691 0 : lbc_vmr(:) = 0._r8
692 :
693 0 : if (flbc_has_cfc11eq) then
694 0 : call get_dels( dels, last, next )
695 0 : m = ghg_indices(f11eq_ndx)
696 0 : lbc_vmr(:ncol) = flbcs(m)%vmr(:ncol,lchnk,last) &
697 0 : + dels * (flbcs(m)%vmr(:ncol,lchnk,next) - flbcs(m)%vmr(:ncol,lchnk,last))
698 : endif
699 :
700 0 : end subroutine flbc_get_cfc11eq
701 :
702 372480 : subroutine get_dels( dels, last, next )
703 :
704 : use intp_util, only: findplb
705 :
706 : implicit none
707 :
708 : real(r8), intent(out) :: dels
709 : integer, intent(out) :: last
710 : integer, intent(out) :: next
711 :
712 : !--------------------------------------------------------
713 : ! ... local variables
714 : !--------------------------------------------------------
715 : integer :: wrk_date, wrk_sec
716 : integer :: tcnt, n
717 : real(r8) :: wrk_time
718 :
719 : !--------------------------------------------------------
720 : ! ... setup the time interpolation
721 : !--------------------------------------------------------
722 372480 : wrk_sec = ncsec
723 372480 : select case( flbc_timing%type )
724 : case( 'SERIAL' )
725 372480 : wrk_date = ncdate
726 : case( 'CYCLICAL' )
727 0 : wrk_date = flbc_timing%cycle_yr*10000 + mod( ncdate,10000 )
728 : case( 'FIXED' )
729 0 : wrk_date = flbc_timing%fixed_ymd
730 372480 : wrk_sec = flbc_timing%fixed_tod
731 : end select
732 :
733 372480 : wrk_time = flt_date( wrk_date, wrk_sec )
734 :
735 : !--------------------------------------------------------
736 : ! ... set time interpolation factor
737 : !--------------------------------------------------------
738 372480 : if( flbc_timing%type /= 'CYCLICAL' ) then
739 372480 : do n = tim_ndx(1)+1,tim_ndx(2)
740 372480 : if( wrk_time <= times(n) ) then
741 372480 : last = n - 1
742 372480 : next = n
743 372480 : exit
744 : end if
745 : end do
746 372480 : if( n > ntimes ) then
747 0 : write(iulog,*) 'flbc_set: interp time is out of bounds'
748 0 : call endrun
749 : end if
750 372480 : dels = (wrk_time - times(last))/(times(next) - times(last))
751 : ! write(iulog,*) ' '
752 : ! write(iulog,*) 'flbc_set: last,next,dels,ncdate,ncsec = ',last,next,dels,ncdate,ncsec
753 : else
754 0 : tcnt = tim_ndx(2) - tim_ndx(1) + 1
755 0 : call findplb( times(tim_ndx(1)), tcnt, wrk_time, n )
756 0 : if( n < tcnt ) then
757 0 : last = tim_ndx(1) + n - 1
758 0 : next = last + 1
759 0 : dels = (wrk_time - times(last))/(times(next) - times(last))
760 : else
761 0 : next = tim_ndx(1)
762 0 : last = tim_ndx(2)
763 0 : dels = wrk_time - times(last)
764 0 : if( dels < 0._r8 ) then
765 0 : dels = 365._r8 + dels
766 : end if
767 0 : dels = dels/(365._r8 + times(next) - times(last))
768 : end if
769 : ! write(iulog,*) ' '
770 : ! write(iulog,*) 'flbc_set: last,next,dels,ncdate,ncsec = ',last,next,dels,ncdate,ncsec
771 : end if
772 :
773 372480 : dels = max( min( 1._r8,dels ),0._r8 )
774 :
775 372480 : end subroutine get_dels
776 :
777 744960 : subroutine flbc_gmean_vmr(co2vmr,ch4vmr,n2ovmr,f11vmr,f12vmr)
778 :
779 : implicit none
780 :
781 : real(r8), intent(inout) :: co2vmr
782 : real(r8), intent(inout) :: ch4vmr
783 : real(r8), intent(inout) :: n2ovmr
784 : real(r8), intent(inout) :: f11vmr
785 : real(r8), intent(inout) :: f12vmr
786 :
787 : integer :: last, next
788 : real(r8) :: dels
789 :
790 372480 : if( flbc_cnt < 1 ) return
791 :
792 372480 : call get_dels( dels, last, next )
793 :
794 372480 : if (ghg_indices(co2_ndx)>0) &
795 372480 : co2vmr = global_mean_vmr(flbcs(ghg_indices(co2_ndx)), dels, last, next )
796 372480 : if (ghg_indices(ch4_ndx)>0) &
797 372480 : ch4vmr = global_mean_vmr(flbcs(ghg_indices(ch4_ndx)), dels, last, next )
798 372480 : if (ghg_indices(n2o_ndx)>0) &
799 372480 : n2ovmr = global_mean_vmr(flbcs(ghg_indices(n2o_ndx)), dels, last, next )
800 372480 : if (ghg_indices(f11_ndx)>0) then
801 372480 : f11vmr = global_mean_vmr(flbcs(ghg_indices(f11_ndx)), dels, last, next )
802 0 : elseif (ghg_indices(f11eq_ndx)>0) then
803 0 : f11vmr = global_mean_vmr(flbcs(ghg_indices(f11eq_ndx)), dels, last, next )
804 : endif
805 372480 : if (ghg_indices(f12_ndx)>0) &
806 372480 : f12vmr = global_mean_vmr(flbcs(ghg_indices(f12_ndx)), dels, last, next )
807 :
808 : end subroutine flbc_gmean_vmr
809 :
810 1862400 : function global_mean_vmr( flbcs, dels, last, next )
811 : use gmean_mod, only: gmean
812 : use phys_grid, only: get_ncols_p
813 :
814 : implicit none
815 :
816 : type(flbc), intent(in) :: flbcs
817 : real(r8), intent(in) :: dels
818 : integer, intent(in) :: last
819 : integer, intent(in) :: next
820 : real(r8) :: global_mean_vmr
821 3724800 : real(r8) :: vmr_arr(pcols,begchunk:endchunk)
822 :
823 : integer :: lchnk, ncol !, n
824 :
825 1862400 : if (flbcs%has_mean) then
826 0 : global_mean_vmr = flbcs%vmr_mean(last) &
827 0 : + dels * (flbcs%vmr_mean(next) - flbcs%vmr_mean(last))
828 : else
829 9370200 : do lchnk = begchunk, endchunk
830 7507800 : ncol = get_ncols_p(lchnk)
831 7507800 : vmr_arr(:ncol,lchnk) = flbcs%vmr(:ncol,lchnk,last) &
832 134733000 : + dels * (flbcs%vmr(:ncol,lchnk,next) - flbcs%vmr(:ncol,lchnk,last))
833 : enddo
834 1862400 : call gmean (vmr_arr, global_mean_vmr)
835 : endif
836 :
837 1862400 : endfunction global_mean_vmr
838 :
839 1862400 : end module mo_flbc
|
