LCOV - code coverage report
Current view: | top level - chemistry/utils - mo_flbc.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 0 | 331 | 0.0 %
Date: | 2025-01-13 21:54:50 |  | Functions: | 0 | 10 | 0.0 %

              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           0 :   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           0 :     if ( len_trim( flbc_file ) == 0 .or. flbc_file.eq.'NONE') return
         102             :
         103           0 :     call get_curr_date( yr, mon, day, ncsec )
         104           0 :     ncdate = yr*10000 + mon*100 + day
         105             :
         106             :     !-----------------------------------------------------------------------
         107             :     !   ... check timing
         108             :     !-----------------------------------------------------------------------
         109           0 :     flbc_timing = flbc_timing_in
         110           0 :     time_type = to_upper(flbc_timing%type)
         111           0 :     flbc_timing%type = time_type
         112             :     if( time_type /= 'SERIAL' .and. time_type /= 'CYCLICAL' &
         113           0 :          .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           0 :     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           0 :     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           0 :     wrk_sec  = ncsec
         126           0 :     if( time_type == 'SERIAL' ) then
         127           0 :        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           0 :     wrk_time = flt_date( wrk_date, wrk_sec )
         142           0 :     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           0 :     has_flbc(:) = .false.
         148           0 :     flbc_cnt = 0
         149             :
         150           0 :     do m = 1,max_nflbc
         151             :
         152           0 :        if ( len_trim(flbc_list(m))==0 ) exit
         153             :
         154           0 :        flbc_cnt = flbc_cnt + 1
         155             :
         156           0 :        call cnst_get_ind (flbc_list(m), n, abort=.false.)
         157             :
         158           0 :        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           0 :           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           0 :           flbcs(flbc_cnt)%spc_ndx = -1
         166             :        endif
         167             :
         168           0 :        flbcs(flbc_cnt)%species = trim( flbc_list(m) )
         169             :
         170           0 :        where( ghg_names(:) == flbc_list(m) )
         171             :           ghg_indices = m
         172             :        endwhere
         173             :
         174           0 :        if( trim(flbcs(flbc_cnt)%species) == 'CFC11' ) then
         175           0 :           flbcs(flbc_cnt)%species = 'CFCL3'
         176           0 :        elseif( trim(flbcs(flbc_cnt)%species) == 'CFC12' ) then
         177           0 :           flbcs(flbc_cnt)%species = 'CF2CL2'
         178             :        endif
         179             :
         180           0 :        if ( trim(flbc_list(m)) .eq. trim(ghg_names(f11eq_ndx)) ) then
         181           0 :           flbc_has_cfc11eq = .true.
         182             :        endif
         183             :
         184             :     enddo
         185             :
         186             :     ! check that user has not set vmr namelist values...
         187           0 :     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           0 :     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           0 :     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           0 :     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           0 :     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           0 :     if( flbc_cnt == 0 ) then
         204             :        return
         205             :     end if
         206             :
         207           0 :     if(masterproc) then
         208           0 :        write(iulog,*) ' '
         209           0 :        if( flbc_cnt > 0 ) then
         210           0 :           write(iulog,*) 'flbc_inti: Species with specified lower boundary values'
         211           0 :           do n = 1,flbc_cnt
         212           0 :              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           0 :        write(iulog,*) ' '
         218             :
         219             :        !-----------------------------------------------------------------------
         220             :        !        ... diagnostics
         221             :        !-----------------------------------------------------------------------
         222           0 :        write(iulog,*) ' '
         223           0 :        write(iulog,*) 'flbc_inti: diagnostics'
         224           0 :        write(iulog,*) ' '
         225           0 :        write(iulog,*) 'lower bndy timing specs'
         226           0 :        write(iulog,*) 'type = ',flbc_timing%type
         227           0 :        if( time_type == 'CYCLICAL' ) then
         228           0 :           write(iulog,*) 'cycle year = ',flbc_timing%cycle_yr
         229             :        else
         230           0 :           write(iulog,*) 'fixed date = ',flbc_timing%fixed_ymd
         231           0 :           write(iulog,*) 'fixed time = ',flbc_timing%fixed_tod
         232             :        end if
         233           0 :        write(iulog,*) ' '
         234           0 :        write(iulog,*) 'there are ',flbc_cnt,' species with specified lower bndy values'
         235           0 :        write(iulog,*) ' '
         236             :     end if
         237             :     !-----------------------------------------------------------------------
         238             :     !   ... get timing information, allocate arrays, and read in dates
         239             :     !-----------------------------------------------------------------------
         240           0 :     call getfil ( flbc_file, filename, 0)
         241           0 :     call cam_pio_openfile (ncid, trim(filename), PIO_NOWRITE)
         242           0 :     ierr = pio_inq_dimid( ncid, 'time', dimid )
         243           0 :     ierr = pio_inq_dimlen( ncid, dimid, ntimes )
         244             :
         245           0 :     allocate( dates(ntimes),stat=astat )
         246           0 :     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           0 :     allocate( times(ntimes),stat=astat )
         251           0 :     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           0 :     ierr = pio_inq_varid( ncid, 'date', varid )
         257           0 :     ierr = pio_get_var( ncid, varid, dates )
         258             :
         259           0 :     do n = 1,ntimes
         260           0 :        times(n) = flt_date( dates(n), 0 )
         261             :     end do
         262           0 :     if( time_type /= 'CYCLICAL' ) then
         263           0 :        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           0 :        do n = 2,ntimes
         268           0 :           if( wrk_time <= times(n) ) then
         269             :              exit
         270             :           end if
         271             :        end do
         272           0 :        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           0 :        tim_ndx(2) = min( ntimes,tim_ndx(1) + time_span )
         302             :     end select
         303           0 :     t1 = tim_ndx(1)
         304           0 :     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           0 :     do m = 1,flbc_cnt
         318             :        !-----------------------------------------------------------------------
         319             :        !        ... allocate array
         320             :        !-----------------------------------------------------------------------
         321           0 :        allocate( flbcs(m)%vmr(pcols,begchunk:endchunk,t1:t2),stat=astat )
         322           0 :        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           0 :        flbcs(m)%has_mean = file_has_gmean(ncid,flbcs(m)%species)
         327           0 :        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           0 :        call flbc_get( ncid, flbcs(m), .true., read_gmean=flbcs(m)%has_mean )
         338             :     end do
         339             :
         340             :     !-----------------------------------------------------------------------
         341             :     !   ... close the file
         342             :     !-----------------------------------------------------------------------
         343           0 :     call pio_closefile( ncid )
         344             :
         345           0 :   end subroutine flbc_inti
         346             :
         347           0 :   subroutine flbc_chk( )
         348           0 :     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           0 :     call get_curr_date( yr, mon, day, ncsec )
         371           0 :     ncdate = yr*10000 + mon*100 + day
         372             :
         373           0 :     if( flbc_cnt > 0 .and. flbc_timing%type == 'SERIAL' ) then
         374           0 :        wrk_time = flt_date( ncdate, ncsec )
         375           0 :        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           0 :   end subroutine flbc_chk
         434             :
         435             :   ! checks for global mean in input file
         436           0 :   function file_has_gmean(ncid,species)
         437           0 :     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           0 :     call pio_seterrorhandling(ncid, PIO_BCAST_ERROR)
         449           0 :     ierr = pio_inq_varid( ncid, trim(species)//'_LBC_mean', varid)
         450           0 :     call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR)
         451             :
         452             :
         453           0 :     file_has_gmean = (ierr==PIO_NOERR)
         454             :
         455           0 :   endfunction file_has_gmean
         456             :
         457           0 :   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           0 :     real(r8), allocatable           :: lat(:)
         488           0 :     real(r8), allocatable           :: lon(:)
         489           0 :     real(r8), allocatable           :: wrk(:,:,:), wrk_zonal(:,:)
         490             :     character(len=pio_max_name)  :: varname
         491           0 :     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           0 :     t1 = tim_ndx(1)
         498           0 :     t2 = tim_ndx(2)
         499           0 :     tcnt = t2 - t1 + 1
         500           0 :     allocate( locl_vmr(pcols,begchunk:endchunk,tcnt), stat=ierr )
         501           0 :     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           0 :     locl_vmr(:,:,:) = 0._r8
         507             :
         508           0 :     initialization : if( initial ) then
         509             :        !-----------------------------------------------------------------------
         510             :        !       ... get grid dimensions from file
         511             :        !-----------------------------------------------------------------------
         512             :        !           latitudes
         513             :        !-----------------------------------------------------------------------
         514           0 :        ierr = pio_inq_dimid( ncid, 'lat', dimid_lat )
         515           0 :        ierr = pio_inq_dimlen( ncid, dimid_lat, nlat )
         516           0 :        allocate( lat(nlat),stat=ierr )
         517           0 :        if( ierr /= 0 ) then
         518           0 :           write(iulog,*) 'flbc_get: lat allocation error = ',ierr
         519           0 :           call endrun
         520             :        end if
         521           0 :        ierr = pio_inq_varid( ncid, 'lat', vid )
         522           0 :        ierr = pio_get_var( ncid, vid, lat )
         523           0 :        lat(:nlat) = lat(:nlat) * d2r
         524             :
         525             :        !-----------------------------------------------------------------------
         526             :        !           longitudes
         527             :        !-----------------------------------------------------------------------
         528           0 :        call pio_seterrorhandling( ncid, PIO_BCAST_ERROR )
         529           0 :        ierr = pio_inq_dimid( ncid, 'lon', dimid_lon )
         530           0 :        call pio_seterrorhandling( ncid, PIO_INTERNAL_ERROR )
         531           0 :        if (ierr == PIO_NOERR ) then
         532           0 :           ierr = pio_inq_dimlen( ncid, dimid_lon, nlon )
         533           0 :           allocate( lon(nlon),stat=ierr )
         534           0 :           if( ierr /= 0 ) then
         535           0 :              write(iulog,*) 'flbc_get: lon allocation error = ',ierr
         536           0 :              call endrun
         537             :           end if
         538           0 :           ierr = pio_inq_varid( ncid, 'lon', vid )
         539           0 :           ierr = pio_get_var( ncid, vid, lon )
         540           0 :           lon(:nlon) = lon(:nlon) * d2r
         541             :        endif
         542             :     end if initialization
         543             :
         544             :     !-----------------------------------------------------------------------
         545             :     !       ... read data
         546             :     !-----------------------------------------------------------------------
         547           0 :     varname = trim(lbcs%species) // '_LBC'
         548           0 :     ierr = pio_inq_varid( ncid, trim(varname), vid )
         549           0 :     ierr = pio_inq_varndims (ncid, vid, ndims)
         550             :
         551           0 :     if (ndims==2) then
         552           0 :        allocate( wrk_zonal(nlat,tcnt), stat=ierr )
         553           0 :        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           0 :     if (ndims==2) then
         566             :        ierr = pio_get_var( ncid, vid, (/ 1, t1/), &
         567           0 :             (/ 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           0 :     do c=begchunk,endchunk
         574           0 :        ncols = get_ncols_p(c)
         575           0 :        call get_rlat_all_p(c, pcols, to_lats)
         576           0 :        call get_rlon_all_p(c, pcols, to_lons)
         577             :
         578           0 :        call lininterp_init(lat, nlat, to_lats, ncols, 1, lat_wgts)
         579           0 :        if (ndims==2) then
         580           0 :          do m = 1,tcnt
         581           0 :              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           0 :        call lininterp_finish(lat_wgts)
         594             :
         595             :     end do
         596             :
         597           0 :     if (ndims==2) then
         598           0 :        deallocate( wrk_zonal,stat=ierr )
         599           0 :        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           0 :     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           0 :     do m = t1,t2
         618           0 :        lbcs%vmr(:,:,m) = locl_vmr(:,:,m-t1+1)
         619             :     enddo
         620             :
         621           0 :     deallocate(locl_vmr, stat=ierr )
         622           0 :     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           0 :   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           0 :   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           0 :   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           0 :     wrk_sec  = ncsec
         723           0 :     select case( flbc_timing%type )
         724             :     case( 'SERIAL' )
         725           0 :        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           0 :        wrk_sec  = flbc_timing%fixed_tod
         731             :     end select
         732             :
         733           0 :     wrk_time = flt_date( wrk_date, wrk_sec )
         734             :
         735             :     !--------------------------------------------------------
         736             :     !   ... set time interpolation factor
         737             :     !--------------------------------------------------------
         738           0 :     if( flbc_timing%type /= 'CYCLICAL' ) then
         739           0 :        do n = tim_ndx(1)+1,tim_ndx(2)
         740           0 :           if( wrk_time <= times(n) ) then
         741           0 :              last = n - 1
         742           0 :              next = n
         743           0 :              exit
         744             :           end if
         745             :        end do
         746           0 :        if( n > ntimes ) then
         747           0 :           write(iulog,*) 'flbc_set: interp time is out of bounds'
         748           0 :           call endrun
         749             :        end if
         750           0 :        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           0 :     dels = max( min( 1._r8,dels ),0._r8 )
         774             :
         775           0 :   end subroutine get_dels
         776             :
         777           0 :   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           0 :      if( flbc_cnt < 1 ) return
         791             :
         792           0 :      call get_dels( dels, last, next )
         793             :
         794           0 :      if (ghg_indices(co2_ndx)>0) &
         795           0 :           co2vmr = global_mean_vmr(flbcs(ghg_indices(co2_ndx)), dels, last, next )
         796           0 :      if (ghg_indices(ch4_ndx)>0) &
         797           0 :           ch4vmr = global_mean_vmr(flbcs(ghg_indices(ch4_ndx)), dels, last, next )
         798           0 :      if (ghg_indices(n2o_ndx)>0) &
         799           0 :           n2ovmr = global_mean_vmr(flbcs(ghg_indices(n2o_ndx)), dels, last, next )
         800           0 :      if (ghg_indices(f11_ndx)>0) then
         801           0 :           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           0 :      if (ghg_indices(f12_ndx)>0) &
         806           0 :           f12vmr = global_mean_vmr(flbcs(ghg_indices(f12_ndx)), dels, last, next )
         807             :
         808             :   end subroutine flbc_gmean_vmr
         809             :
         810           0 :   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           0 :     real(r8) :: vmr_arr(pcols,begchunk:endchunk)
         822             :
         823             :     integer  :: lchnk, ncol !, n
         824             :
         825           0 :     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           0 :        do lchnk = begchunk, endchunk
         830           0 :           ncol = get_ncols_p(lchnk)
         831           0 :           vmr_arr(:ncol,lchnk) = flbcs%vmr(:ncol,lchnk,last) &
         832           0 :                + dels * (flbcs%vmr(:ncol,lchnk,next) - flbcs%vmr(:ncol,lchnk,last))
         833             :        enddo
         834           0 :        call gmean (vmr_arr, global_mean_vmr)
         835             :     endif
         836             :
         837           0 :   endfunction global_mean_vmr
         838             :
         839           0 : end module mo_flbc

Generated by: LCOV version 1.14