LCOV - code coverage report
Current view: | top level - physics/cam - subcol_tstcp.F90 (source / functions) |  |  | Hit | Total | Coverage
Test: | coverage.info |  | Lines: | 0 | 148 | 0.0 %
Date: | 2025-01-13 21:54:50 |  | Functions: | 0 | 7 | 0.0 %

              Line data    Source code
           1             : module subcol_tstcp
           2             :    !---------------------------------------------------------------------------
           3             :    ! Purpose:
           4             :    !
           5             :    ! Implement the various TestCopy schemes
           6             :    !  sub-column schemes
           7             :    !
           8             :    !---------------------------------------------------------------------------
           9             :
          10             :    use shr_kind_mod,    only: r8=>shr_kind_r8
          11             :    use physics_types,   only: physics_state, physics_tend, physics_ptend
          12             :    use ppgrid,          only: pcols, psubcols, pver, pverp
          13             :    use constituents,    only: pcnst
          14             :    use cam_abortutils,  only: endrun
          15             :    use spmd_utils,      only: masterproc
          16             :    use cam_logfile,     only: iulog
          17             :
          18             :    implicit none
          19             :
          20             :    private
          21             :    save
          22             :
          23             :    public :: subcol_gen_tstcp
          24             :    public :: subcol_register_tstcp
          25             :    public :: subcol_readnl_tstcp
          26             :    public :: subcol_field_avg_tstcp
          27             :    public :: subcol_ptend_avg_tstcp
          28             :
          29             :    interface subcol_field_avg_tstcp
          30             :       module procedure subcol_field_avg_tstcp_1dr
          31             :       module procedure subcol_field_avg_tstcp_1di
          32             :       module procedure subcol_field_avg_tstcp_2dr
          33             :    end interface
          34             :
          35             :    logical :: subcol_tstcp_noAvg   ! if set, bypasses averaging and assigns back the first subcolumn to grid
          36             :
          37             :    logical :: subcol_tstcp_filter  ! if set, sets up a filter which yields BFB results
          38             :                                    ! (doesn't really excercise the filter arithmetic)
          39             :
          40             :    logical :: subcol_tstcp_weight  ! if set, sets up a weight which yields BFB results
          41             :                                    ! (doesn't really excercise the weight arithmetic)
          42             :
          43             :    logical :: subcol_tstcp_perturb ! if set, turns on the perturbation test which changes the state temperatures
          44             :                                    ! to make sure subcolumns differ
          45             :
          46             :    logical :: subcol_tstcp_restart ! if set, sets up weights so that they are more adequately tested in restart,
          47             :                                    ! but will not be BFB with non-subcolumnized run
          48             :
          49             :    integer :: tstcpy_scol_idx      ! pbuf index for subcolumn-only test field
          50             :
          51             : contains
          52             :
          53           0 :    subroutine subcol_register_tstcp()
          54             :       use physics_buffer,  only: pbuf_add_field, dtype_i4, col_type_subcol
          55             :       use phys_control,    only: phys_getopts
          56             :
          57             :       ! A subcolumn-only test field
          58             :       ! pbuf is global so it will show up in restart file
          59             :       call pbuf_add_field('TSTCPY_SCOL','global', dtype_i4,                 &
          60           0 :            (/pcols,pver/), tstcpy_scol_idx, col_type_subcol)
          61             :
          62           0 :    end subroutine subcol_register_tstcp
          63             :
          64           0 :    subroutine subcol_readnl_tstcp(nlfile)
          65           0 :       use namelist_utils,  only: find_group_name
          66             :       use units,           only: getunit, freeunit
          67             :       use spmd_utils,      only: masterproc, mpi_logical, masterprocid, mpicom
          68             :
          69             :       character(len=*), intent(in) :: nlfile  ! filepath for file containing namelist input
          70             :
          71             :       ! Local variables
          72             :       integer :: unitn, ierr
          73             :
          74             :       namelist /subcol_tstcp_nl/ subcol_tstcp_noAvg, subcol_tstcp_filter, subcol_tstcp_weight, subcol_tstcp_perturb, &
          75             :                                  subcol_tstcp_restart
          76             :
          77             :       !-----------------------------------------------------------------------------
          78             :
          79           0 :       if (masterproc) then
          80           0 :          unitn = getunit()
          81           0 :          open( unitn, file=trim(nlfile), status='old' )
          82           0 :          call find_group_name(unitn, 'subcol_tstcp_nl', status=ierr)
          83           0 :          if (ierr == 0) then
          84           0 :             read(unitn, subcol_tstcp_nl, iostat=ierr)
          85           0 :             if (ierr /= 0) then
          86           0 :                call endrun('subcol_readnl_tstcp: ERROR reading namelist')
          87             :             end if
          88             :          end if
          89           0 :          close(unitn)
          90           0 :          call freeunit(unitn)
          91             :       end if
          92             :
          93             : #ifdef SPMD
          94             :       ! Broadcast namelist variables
          95           0 :       call mpi_bcast(subcol_tstcp_noAvg,   1, mpi_logical, masterprocid, mpicom, ierr)
          96           0 :       call mpi_bcast(subcol_tstcp_filter,  1, mpi_logical, masterprocid, mpicom, ierr)
          97           0 :       call mpi_bcast(subcol_tstcp_weight,  1, mpi_logical, masterprocid, mpicom, ierr)
          98           0 :       call mpi_bcast(subcol_tstcp_perturb, 1, mpi_logical, masterprocid, mpicom, ierr)
          99           0 :       call mpi_bcast(subcol_tstcp_restart, 1, mpi_logical, masterprocid, mpicom, ierr)
         100             : #endif
         101           0 :    end subroutine subcol_readnl_tstcp
         102             :
         103           0 :    subroutine subcol_gen_tstcp(state, tend, state_sc, tend_sc, pbuf)
         104             :
         105             :       use subcol_utils,    only: subcol_set_subcols, subcol_set_weight, subcol_set_filter
         106             :       use subcol_pack_mod, only: subcol_get_nsubcol
         107             :       use physics_buffer,  only: physics_buffer_desc, pbuf_get_field, col_type_subcol
         108             :       use phys_grid,       only: get_gcol_p
         109             :       use time_manager,    only: is_first_step, is_first_restart_step
         110             :
         111             :
         112             :       !-----------------------------------
         113             :       ! sub-column generator
         114             :       !-----------------------------------
         115             :       type(physics_state), intent(inout) :: state
         116             :       type(physics_tend),  intent(inout) :: tend
         117             :       type(physics_state), intent(inout) :: state_sc        ! sub-column state
         118             :       type(physics_tend),  intent(inout) :: tend_sc         ! sub-column tend
         119             :       type(physics_buffer_desc), pointer :: pbuf(:)
         120             :
         121             :
         122             :       !
         123             :       ! Local variables
         124             :       !
         125             :       integer            :: i, j, k, ngrdcol, indx, indx1, indx2
         126             :       integer            :: nsubcol(pcols)
         127           0 :       real(r8)           :: weight(state_sc%psetcols)
         128           0 :       integer            :: filter(state_sc%psetcols)
         129           0 :       integer, pointer   :: test_field(:,:)
         130             :       character(len=128) :: errmsg
         131             :
         132           0 :       ngrdcol    = state%ngrdcol
         133             :
         134             :       !----------------------
         135             :       ! Set the number of subcolumns on the 0th time step -- current implementation does not allow
         136             :       ! number of subcolumns to vary within a run.  Cannot be done in init as ngrdcol is not known
         137             :       ! at init
         138             :       !----------------------
         139             :       ! Test differing number of subcolumns by setting columns > 45 degrees to
         140             :       ! have 1 subcolumn, columns < -45 to 2 subcolumns and others to 3 subcols
         141           0 :       if (is_first_step()) then
         142           0 :          nsubcol = 0
         143           0 :          do i = 1, ngrdcol
         144           0 :             if (state%lat(i) > 0.7854_r8) then
         145           0 :                nsubcol(i) = 1
         146           0 :             else if (state%lat(i) < -0.7854_r8) then
         147           0 :                nsubcol(i) = 2
         148             :             else
         149           0 :                nsubcol(i) = psubcols
         150             :             end if
         151             :          end do
         152             :
         153             :          ! Set up the weights once and do not modify - this will test the restart ability to correctly retrieve them
         154           0 :          if(subcol_tstcp_restart) then
         155           0 :            weight=0._r8
         156           0 :            indx=1
         157           0 :            do i=1,ngrdcol
         158           0 :               weight(indx:indx+nsubcol(i)-1)=1._r8/nsubcol(i)
         159           0 :               if (state%lon(i) < -0.5236_r8) then
         160           0 :                 if (nsubcol(i) >= 3) then
         161           0 :                   weight(indx) = 2*1._r8/nsubcol(i)
         162           0 :                   weight(indx+1) = 1._r8 - weight(indx)
         163           0 :                   weight(indx+2:indx+nsubcol(i)-1)=0._r8
         164             :                 end if
         165             :               end if
         166           0 :               indx = indx+nsubcol(i)
         167             :            end do
         168           0 :            call subcol_set_weight(state%lchnk, weight)
         169             :          end if
         170             :       else
         171           0 :          call subcol_get_nsubcol(state%lchnk, nsubcol)
         172             :          ! Since this is a test generator, check for nsubcol correctness.
         173           0 :          do i = 1, pcols
         174           0 :             if (i > ngrdcol) then
         175           0 :                if (nsubcol(i) /= 0) then
         176           0 :                   write(errmsg, *) 'subcol_gen_tstcp: Bad value for nsubcol(',&
         177           0 :                        i,') = ',nsubcol(i),', /= 0'
         178           0 :                   call endrun(errmsg)
         179             :                end if
         180           0 :             else if (state%lat(i) > 0.7854_r8) then
         181           0 :                if (nsubcol(i) /= 1) then
         182           0 :                   write(errmsg, *) 'subcol_gen_tstcp: Bad value for nsubcol(',&
         183           0 :                        i,') = ',nsubcol(i),', /= 1'
         184           0 :                   call endrun(errmsg)
         185             :                end if
         186           0 :             else if (state%lat(i) < -0.7854_r8) then
         187           0 :                if (nsubcol(i) /= 2) then
         188           0 :                   write(errmsg, *) 'subcol_gen_tstcp: Bad value for nsubcol(',&
         189           0 :                        i,') = ',nsubcol(i),', /= 2'
         190           0 :                   call endrun(errmsg)
         191             :                end if
         192             :             else
         193           0 :                if (nsubcol(i) /= psubcols) then
         194           0 :                   write(errmsg, *) 'subcol_gen_tstcp: Bad value for nsubcol(',&
         195           0 :                        i,') = ',nsubcol(i),', /=',psubcols
         196           0 :                   call endrun(errmsg)
         197             :                end if
         198             :             end if
         199             :          end do
         200             :       end if
         201             :
         202           0 :       call subcol_set_subcols(state, tend, nsubcol, state_sc, tend_sc)
         203             :
         204             :       ! For perturb case, adjust Temperature up and down one degree
         205           0 :       if (subcol_tstcp_perturb) then
         206           0 :         indx=1
         207           0 :         do i=1,ngrdcol
         208           0 :           if (nsubcol(i) >= 2) then
         209           0 :             state_sc%t(indx,:) = state_sc%t(indx,:)+1
         210           0 :             state_sc%t(indx+1,:) = state_sc%t(indx+1,:)-1
         211             :           end if
         212           0 :           indx=indx+nsubcol(i)
         213             :         end do
         214             :       end if
         215             :
         216             :       ! Set weight to 1 for first column, 0 for all others -- will be BFB with noUniAv case
         217           0 :       if(subcol_tstcp_filter .and. subcol_tstcp_weight) then
         218           0 :         weight=1._r8
         219             :         ! Initialize to 1 - will match doAv_noUni, init to 0 - will match noUniAv
         220           0 :         filter=1
         221           0 :         indx=1
         222           0 :         do i=1,ngrdcol
         223           0 :            weight(indx) = 1.0_r8
         224           0 :            filter(indx) = 1
         225           0 :            indx = indx+nsubcol(i)
         226             :         end do
         227           0 :         call subcol_set_weight(state%lchnk, weight)
         228           0 :         call subcol_set_filter(state%lchnk, filter)
         229             :       ! Set weight to 1 for first column, 0 for all others -- will be BFB with noUniAv case
         230           0 :       else if(subcol_tstcp_weight) then
         231           0 :         weight=0._r8
         232           0 :         indx=1
         233           0 :         do i=1,ngrdcol
         234           0 :            weight(indx) = 1.0_r8
         235           0 :            indx = indx+nsubcol(i)
         236             :         end do
         237           0 :         call subcol_set_weight(state%lchnk, weight)
         238             :
         239             :       ! Set filter to 1 for first column, 0 for all others -- will be BFB with noUniAv case
         240           0 :       else if(subcol_tstcp_filter) then
         241           0 :         filter=0
         242           0 :         indx=1
         243           0 :         do i=1,ngrdcol
         244           0 :            filter(indx) = 1
         245           0 :            indx = indx+nsubcol(i)
         246             :         end do
         247           0 :         call subcol_set_filter(state%lchnk, filter)
         248             :       end if
         249             :
         250             :
         251           0 :       if (is_first_restart_step()) then
         252             :          ! Test values for the test pbuf
         253             :          call pbuf_get_field(pbuf, tstcpy_scol_idx, test_field,               &
         254           0 :               col_type=col_type_subcol, copy_if_needed=.false.)
         255           0 :          indx = 1
         256           0 :          do i=1,ngrdcol
         257           0 :             do indx1 = 1, nsubcol(i)
         258           0 :                do k = 1, pver
         259           0 :                   indx2 = (get_gcol_p(state%lchnk, i) * 10000)
         260           0 :                   indx2 = k + (100 * (indx1 + indx2))
         261           0 :                   if(test_field(indx, k) /= indx2) then
         262           0 :                      write(iulog, *) 'TSTCPY_SCOL check(',indx,',',k,         &
         263           0 :                           '): expected',indx2,', found',test_field(indx, k)
         264           0 :                      call endrun("Restart check for TSTCPY_SCOL failed")
         265             :                   end if
         266             :                end do
         267           0 :                indx = indx + 1
         268             :             end do
         269             :          end do
         270             :          ! Unused subcolumn space is not initialized so no check
         271           0 :       else if (is_first_step()) then
         272             :          ! Set values for the test pbuf
         273             :          call pbuf_get_field(pbuf, tstcpy_scol_idx, test_field,               &
         274           0 :               col_type=col_type_subcol, copy_if_needed=.false.)
         275           0 :          test_field = -1
         276           0 :          indx = 1
         277           0 :          do i=1,ngrdcol
         278           0 :             do indx1 = 1, nsubcol(i)
         279           0 :                do k = 1, pver
         280           0 :                   indx2 = (get_gcol_p(state%lchnk, i) * 10000)
         281           0 :                   indx2 = k + (100 * (indx1 + indx2))
         282           0 :                   test_field(indx, k) = indx2
         283             :                end do
         284           0 :                indx = indx + 1
         285             :             end do
         286             :          end do
         287             :       end if
         288             :
         289           0 : end subroutine subcol_gen_tstcp
         290             :
         291           0 : subroutine subcol_field_avg_tstcp_1dr (field_sc, ngrdcol, lchnk, field)
         292           0 :       use physics_buffer,   only: physics_buffer_desc
         293             :       use subcol_utils,     only: subcol_field_get_firstsubcol, subcol_field_avg_shr, is_filter_set, is_weight_set
         294             :
         295             :       !-----------------------------------
         296             :       ! Average the subcolumns dimension (pcols*psubcols) to the grid dimension (pcols)
         297             :       !-----------------------------------
         298             :
         299             :       real(r8), intent(in)                        :: field_sc(:)   ! intent in
         300             :       integer,  intent(in)                        :: ngrdcol       ! # grid cols
         301             :       integer,  intent(in)                        :: lchnk         ! chunk index
         302             :       real(r8), intent(out)                       :: field(:)
         303             :
         304             :       !
         305             :       ! Local variables
         306             :       !
         307             :       real(r8),pointer :: weight(:)
         308             :       integer, pointer :: filter(:)
         309             :
         310             :
         311             :       ! Unless specialized averaging is needed, most subcolumn schemes will be handled here
         312           0 :       if (subcol_tstcp_noAvg) then
         313           0 :          call subcol_field_get_firstsubcol(field_sc, .true., ngrdcol, lchnk, field)
         314             :       else
         315           0 :          call subcol_field_avg_shr(field_sc, ngrdcol, lchnk, field, is_filter_set(), is_weight_set())
         316             :       end if
         317             :
         318           0 : end subroutine subcol_field_avg_tstcp_1dr
         319             :
         320           0 : subroutine subcol_field_avg_tstcp_1di (field_sc, ngrdcol, lchnk, field)
         321           0 :       use physics_buffer,   only: physics_buffer_desc
         322             :       use subcol_utils,     only: subcol_field_get_firstsubcol, subcol_field_avg_shr, is_filter_set, is_weight_set
         323             :
         324             :       !-----------------------------------
         325             :       ! Average the subcolumns dimension (pcols*psubcols) to the grid dimension (pcols)
         326             :       !-----------------------------------
         327             :
         328             :       integer, intent(in)                         :: field_sc(:)   ! intent in
         329             :       integer, intent(in)                         :: ngrdcol       ! # grid cols
         330             :       integer, intent(in)                         :: lchnk         ! chunk index
         331             :       integer, intent(out)                        :: field(:)
         332             :
         333             :       !
         334             :       ! Local variables
         335             :       !
         336             :       real(r8),pointer :: weight(:)
         337             :       integer, pointer :: filter(:)
         338             :
         339             :
         340             :       ! Unless specialized averaging is needed, most subcolumn schemes will be handled here
         341           0 :       if (subcol_tstcp_noAvg) then
         342           0 :          call subcol_field_get_firstsubcol(field_sc, .true., ngrdcol, lchnk, field)
         343             :       else
         344           0 :          call subcol_field_avg_shr(field_sc, ngrdcol, lchnk, field, is_filter_set(), is_weight_set())
         345             :       end if
         346             :
         347           0 : end subroutine subcol_field_avg_tstcp_1di
         348             :
         349           0 : subroutine subcol_field_avg_tstcp_2dr (field_sc, ngrdcol, lchnk, field)
         350           0 :       use physics_buffer,   only: physics_buffer_desc
         351             :       use subcol_utils,     only: subcol_field_get_firstsubcol, subcol_field_avg_shr, is_filter_set, is_weight_set
         352             :
         353             :       !-----------------------------------
         354             :       ! Average the subcolumns dimension (pcols*psubcols) to the grid dimension (pcols)
         355             :       !-----------------------------------
         356             :
         357             :       real(r8), intent(in)                        :: field_sc(:,:)   ! intent in
         358             :       integer,  intent(in)                        :: ngrdcol       ! # grid cols
         359             :       integer,  intent(in)                        :: lchnk         ! chunk index
         360             :       real(r8), intent(out)                       :: field(:,:)
         361             :
         362             :       ! Unless specialized averaging is needed, most subcolumn schemes will be handled here
         363           0 :       if (subcol_tstcp_noAvg) then
         364           0 :          call subcol_field_get_firstsubcol(field_sc, .true., ngrdcol, lchnk, field)
         365             :       else
         366           0 :          call subcol_field_avg_shr(field_sc, ngrdcol, lchnk, field, is_filter_set(), is_weight_set())
         367             :       end if
         368             :
         369           0 : end subroutine subcol_field_avg_tstcp_2dr
         370             :
         371           0 : subroutine subcol_ptend_avg_tstcp (ptend_sc, ngrdcol, lchnk, ptend)
         372           0 :       use physics_buffer,   only: physics_buffer_desc
         373             :       use subcol_utils,     only: subcol_ptend_get_firstsubcol, subcol_ptend_avg_shr, subcol_get_weight, subcol_get_filter, &
         374             :                                   is_filter_set, is_weight_set
         375             :
         376             :       !-----------------------------------
         377             :       ! Average the subcolumns dimension (pcols*psubcols) to the grid dimension (pcols)
         378             :       !-----------------------------------
         379             :
         380             :       type(physics_ptend), intent(in)             :: ptend_sc        ! intent in
         381             :       integer,  intent(in)                        :: ngrdcol       ! # grid cols
         382             :       integer,  intent(in)                        :: lchnk         ! chunk index
         383             :       type(physics_ptend), intent(inout)          :: ptend
         384             :
         385           0 :       if (subcol_tstcp_noAvg) then
         386           0 :          call subcol_ptend_get_firstsubcol(ptend_sc, .true., ngrdcol, lchnk, ptend)
         387             :       else
         388           0 :          call subcol_ptend_avg_shr(ptend_sc, ngrdcol, lchnk, ptend, is_filter_set(), is_weight_set())
         389             :       end if
         390             :
         391           0 : end subroutine subcol_ptend_avg_tstcp
         392             : end module subcol_tstcp

Generated by: LCOV version 1.14