mod_realinput_grads Module Reference

module REAL input GrADS More...

Functions/Subroutines
subroutine, public	parentatomsetupgrads (dims, basename)
	Atmos Setup. More...
subroutine, public	parentatomopengrads
subroutine, public	parentatominputgrads (velz_org, velx_org, vely_org, pres_org, temp_org, qtrc_org, lon_org, lat_org, cz_org, basename_num, dims, nt)
subroutine, public	parentlandsetupgrads (ldims, use_waterratio, use_file_landwater, basename)
	Land Setup. More...
subroutine, public	parentlandinputgrads (tg_org, strg_org, smds_org, lst_org, llon_org, llat_org, lz_org, topo_org, lmask_org, basename_num, ldims, use_file_landwater, nt)
subroutine, public	parentoceansetupgrads (odims, timelen, basename)
	Ocean Setup. More...
subroutine, public	parentoceanopengrads
subroutine, public	parentoceaninputgrads (tw_org, sst_org, omask_org, olon_org, olat_org, basename_num, odims, nt)
subroutine	read_namelist (grads_item, grads_fname, grads_dtype, grads_swpoint, grads_dd, grads_lnum, grads_lvars, grads_startrec, grads_totalrec, grads_knum, grads_yrev, grads_fendian, grads_missval, data_available, item_list, num_item_list, basename, io_fid_grads_nml)

Detailed Description

module REAL input GrADS

Description

read data from GrADS file for real atmospheric simulations

Author

Team SCALE

History

• 2015-05-24 (S.Nishizawa) [new] split from mod_realinput.f90

NAMELIST

• nml_grads_grid

  name	type	default value	comment
  OUTER_NX	integer	-1
  OUTER_NY	integer	-1
  OUTER_NZ	integer	-1	number of atmos layers
  OUTER_NL	integer	-1	number of land layers
  OUTER_NX_SFC	integer	-1
  OUTER_NY_SFC	integer	-1
  OUTER_NX_SST	integer	-1
  OUTER_NY_SST	integer	-1

  
  
• PARAM_MKINIT_REAL_GrADS

  name	type	default value	comment
  UPPER_QV_TYPE	character(len=H_SHORT)	"ZERO"	how qv is given at higher level than outer model

  
  

History Output

No history output

Function/Subroutine Documentation

parentatomsetupgrads()

subroutine, public mod_realinput_grads::parentatomsetupgrads	(	integer, dimension(6), intent(out)	dims,
		character(len=h_long), intent(in)	basename
	)

Atmos Setup.

Definition at line 183 of file mod_realinput_grads.f90.

References scale_stdio::io_fid_conf, scale_stdio::io_fid_log, scale_stdio::io_get_available_fid(), scale_stdio::io_l, scale_stdio::io_lnml, scale_process::prc_mpistop(), and read_namelist().

Referenced by mod_realinput::parentatomsetup().

    implicit none

    integer,          intent(out) :: dims(6)
    character(len=H_LONG), intent(in) :: basename
    

    namelist / param_mkinit_real_grads / &
        upper_qv_type

    integer             :: ielem
    integer             :: k, n

    integer             :: ierr
    !---------------------------------------------------------------------------

    if( io_l ) write(io_fid_log,*) '+++ Real Case/Atom Input File Type: GrADS format'

    !--- read namelist
    rewind(io_fid_conf)
    read(io_fid_conf,nml=param_mkinit_real_grads,iostat=ierr)

    if( ierr > 0 ) then
       if( io_l ) write(io_fid_log,*) 'xxx Not appropriate names in namelist PARAM_MKINIT_REAL_GrADS. Check!'
       call prc_mpistop
    endif
    if( io_lnml ) write(io_fid_log,nml=param_mkinit_real_grads)


    if ( len_trim(basename) == 0 ) then
       if( io_l ) write(io_fid_log,*) &
            'xxx "BASENAME_ORG" is not specified in "PARAM_MKINIT_REAL_ATMOS"!',trim(basename)
       call prc_mpistop
    endif

    !--- read namelist
    io_fid_grads_nml = io_get_available_fid()
    open( io_fid_grads_nml,       &
         file   = trim(basename), &
         form   = 'formatted',    &
         status = 'old',          &
         action = 'read',         &
         iostat = ierr            )
    if ( ierr /= 0 ) then
       if( io_l ) write(io_fid_log,*) 'xxx Input file is not found! ', trim(basename)
       call prc_mpistop
    endif

    read(io_fid_grads_nml,nml=nml_grads_grid,iostat=ierr)
    if( ierr /= 0 ) then !--- missing or fatal error
       if( io_l ) write(io_fid_log,*) 'xxx Not appropriate names in nml_grads_grid in ', trim(basename),'. Check!'
       call prc_mpistop
    endif
    if( io_lnml ) write(io_fid_log,nml=nml_grads_grid)

    ! full level
    dims(1) = outer_nz ! bottom_top
    dims(2) = outer_nx ! west_east
    dims(3) = outer_ny ! south_north
    ! half level
    dims(4) = outer_nz ! bottom_top_stag
    dims(5) = outer_nx ! west_east for 2dim data
    dims(6) = outer_ny ! south_north for 2dim data

    allocate( gdata2d( dims(2), dims(3)          ) )
    allocate( gdata3d( dims(2), dims(3), dims(1) ) )

    call read_namelist( &
         grads_item(:,1),     & ! (out)
         grads_fname(:,1),    & ! (out)
         grads_dtype(:,1),    & ! (out)
         grads_swpoint(:,1),  & ! (out)
         grads_dd(:,1),       & ! (out)
         grads_lnum(:,1),     & ! (out)
         grads_lvars(:,:,1),  & ! (out)
         grads_startrec(:,1), & ! (out)
         grads_totalrec(:,1), & ! (out)
         grads_knum(:,1),     & ! (out)
         grads_yrev(:,1),     & ! (out)
         grads_fendian(:,1),  & ! (out)
         grads_missval(:,1),  & ! (out)
         data_available(:,1), & ! (out)
         item_list_atom,      & ! (in)
         num_item_list_atom,  & ! (in)
         basename,            & ! (in)
         io_fid_grads_nml     ) ! (in)

    do ielem = 1, num_item_list_atom
       item  = item_list_atom(ielem)
       !--- check data
       select case(trim(item))
       case('QV')
          if (.not. data_available(ia_qv,1)) then
             if (.not.data_available(ia_rh,1)) then
                if( io_l ) write(io_fid_log,*) 'xxx Not found in grads namelist! : QV and RH'
                call prc_mpistop
             else ! will read RH
                cycle
             endif
          endif
       case('RH')
          if (.not. data_available(ia_qv,1))then
             if(data_available(ia_rh,1)) then
                if ((.not. data_available(ia_t,1)).or.(.not. data_available(ia_p,1))) then
                   if( io_l ) write(io_fid_log,*) 'xxx Temperature and pressure are required to convert from RH to QV ! '
                   call prc_mpistop
                else
                   cycle ! read RH and estimate QV
                endif
             else
                if( io_l ) write(io_fid_log,*) 'xxx Not found in grads namelist! : QV and RH'
                call prc_mpistop
             endif
          endif
       case('MSLP','PSFC','U10','V10','T2')
          if (.not. data_available(ielem,1)) then
             if (io_l) write(io_fid_log,*) 'warning: ',trim(item),' is not found & will be estimated.'
             cycle
          endif
       case('Q2')
          if ( .not. data_available(ia_q2,1) ) then
             if (io_l) write(io_fid_log,*) 'warning: Q2 is not found & will be estimated.'
             cycle
          endif
       case('RH2')
          if ( data_available(ia_q2,1) ) then
             cycle
          else
             if ( data_available(ia_rh2,1) ) then
                if ((.not. data_available(ia_t2,1)).or.(.not. data_available(ia_ps,1))) then
                   if (io_l) write(io_fid_log,*) 'warning: T2 and PSFC are required to convert from RH2 to Q2 !'
                   if (io_l) write(io_fid_log,*) '         Q2 will be copied from data at above level.'
                   data_available(ia_rh2,1) = .false.
                   cycle
                endif
             else
                if (io_l) write(io_fid_log,*) 'warning: Q2 and RH2 are not found, Q2 will be estimated.'
                cycle
             endif
          endif
       case('TOPO')
          if ( .not. data_available(ielem,1) ) then
             if (io_l) write(io_fid_log,*) 'warning: ',trim(item),' is not found & not used.'
             cycle
          endif
       case default ! lon, lat, plev, U, V, T, HGT
          if ( .not. data_available(ielem,1) ) then
             if( io_l ) write(io_fid_log,*) 'xxx Not found in grads namelist! : ',trim(item_list_atom(ielem))
             call prc_mpistop
          endif
       end select

    end do

    return

Here is the call graph for this function:

Here is the caller graph for this function:

parentatomopengrads()

subroutine, public mod_realinput_grads::parentatomopengrads

(

)

Definition at line 341 of file mod_realinput_grads.f90.

References scale_stdio::io_fid_log, and scale_stdio::io_l.

Referenced by mod_realinput::parentatomsetup().

    implicit none

    if( io_l ) write(io_fid_log,*) '+++ ScaleLib/IO[realinput]/Categ[AtomOpenGrADS]'

    return

Here is the caller graph for this function:

parentatominputgrads()

subroutine, public mod_realinput_grads::parentatominputgrads	(	real(rp), dimension(:,:,:), intent(out)	velz_org,
		real(rp), dimension(:,:,:), intent(out)	velx_org,
		real(rp), dimension(:,:,:), intent(out)	vely_org,
		real(rp), dimension(:,:,:), intent(out)	pres_org,
		real(rp), dimension(:,:,:), intent(out)	temp_org,
		real(rp), dimension(:,:,:,:), intent(out)	qtrc_org,
		real(rp), dimension(:,:), intent(out)	lon_org,
		real(rp), dimension(:,:), intent(out)	lat_org,
		real(rp), dimension(:,:,:), intent(out)	cz_org,
		character(len=*), intent(in)	basename_num,
		integer, dimension(6), intent(in)	dims,
		integer, intent(in)	nt
	)

Definition at line 362 of file mod_realinput_grads.f90.

References scale_const::const_cpdry, scale_const::const_d2r, scale_const::const_eps, scale_const::const_epsvap, scale_const::const_grav, scale_const::const_laps, scale_const::const_pre00, scale_const::const_rdry, scale_stdio::io_fid_log, scale_stdio::io_get_available_fid(), scale_stdio::io_l, dc_log::log(), and scale_process::prc_mpistop().

Referenced by mod_realinput::parentatomsetup().

    use scale_const, only: &
         d2r => const_d2r,   &
         eps => const_eps,   &
         epsvap => const_epsvap, &
         grav => const_grav, &
         laps => const_laps, &
         p00 => const_pre00, &
         rdry => const_rdry, &
         cpdry => const_cpdry
    use scale_atmos_saturation, only: &
         psat => atmos_saturation_psat_liq
    implicit none


    real(RP),         intent(out) :: velz_org(:,:,:)
    real(RP),         intent(out) :: velx_org(:,:,:)
    real(RP),         intent(out) :: vely_org(:,:,:)
    real(RP),         intent(out) :: pres_org(:,:,:)
    real(RP),         intent(out) :: temp_org(:,:,:)
    real(RP),         intent(out) :: qtrc_org(:,:,:,:)
    real(RP),         intent(out) :: lon_org(:,:)
    real(RP),         intent(out) :: lat_org(:,:)
    real(RP),         intent(out) :: cz_org(:,:,:)
    character(len=*), intent(in)  :: basename_num
    integer,          intent(in)  :: dims(6)
    integer,          intent(in)  :: nt

    real(RP) :: rhprs_org(dims(1)+2,dims(2),dims(3))
    real(RP) :: pott(dims(2),dims(3))

    real(RP) :: rovcp
    real(RP) :: cpovr

    ! data
    character(len=H_LONG) :: gfile

    integer  :: qa_outer = 1
    real(RP) :: p_sat, qm, rhsfc

    integer  :: i, j, k, ielem

    !---------------------------------------------------------------------------

    if( io_l ) write(io_fid_log,*) '+++ ScaleLib/IO[realinput]/Categ[AtomInputGrADS]'

    qtrc_org = 0.0_rp

    !--- read grads data
    loop_inputatomgrads : do ielem = 1, num_item_list_atom

       if ( .not. data_available(ielem,1) ) cycle

       item     = grads_item(ielem,1)
       dtype    = grads_dtype(ielem,1)
       fname    = grads_fname(ielem,1)
       lnum     = grads_lnum(ielem,1)

       if ( dims(1) < grads_knum(ielem,1) ) then
          write(*,*) 'xxx "knum" must be less than or equal to outer_nz. knum:',knum,'> outer_nz:',dims(1),trim(item)
          call prc_mpistop
       else if ( grads_knum(ielem,1) > 0 )then
          knum = grads_knum(ielem,1)  ! not missing
       else
          knum = dims(1)
       endif

       select case (trim(dtype))
       case("linear")
          swpoint = grads_swpoint(ielem,1)
          dd      = grads_dd(ielem,1)
          if( (abs(swpoint-large_number_one)<eps).or.(abs(dd-large_number_one)<eps) )then
             write(*,*) 'xxx "swpoint" is required in grads namelist! ',swpoint
             write(*,*) 'xxx "dd"      is required in grads namelist! ',dd
             call prc_mpistop
          endif
       case("levels")
          if ( lnum < 0 )then
             write(*,*) 'xxx "lnum" is required in grads namelist for levels data! '
             call prc_mpistop
          endif
          do k=1, lnum
             lvars(k)=grads_lvars(k,ielem,1)
          enddo
          if(abs(lvars(1)-large_number_one)<eps)then
             write(*,*) 'xxx "lvars" must be specified in grads namelist for levels data! '
             call prc_mpistop
          endif
       case("map")
          startrec = grads_startrec(ielem,1)
          totalrec = grads_totalrec(ielem,1)
          fendian  = grads_fendian(ielem,1)
          yrev     = grads_yrev(ielem,1)
          if( (startrec<0).or.(totalrec<0) )then
             write(*,*) 'xxx "startrec" is required in grads namelist! ',startrec
             write(*,*) 'xxx "totalrec" is required in grads namelist! ',totalrec
             call prc_mpistop
          endif
          ! get file_id
          if(io_fid_grads_data < 0)then
             io_fid_grads_data = io_get_available_fid()
          endif
          gfile=trim(fname)//trim(basename_num)//'.grd'
          if( len_trim(fname)==0 )then
             write(*,*) 'xxx "fname" is required in grads namelist for map data! ',trim(fname)
             call prc_mpistop
          endif
       end select

       ! read data
       select case (trim(item))
       case("lon")
          if ( trim(dtype) == "linear" ) then
             do j = 1, dims(3)
             do i = 1, dims(2)
                lon_org(i,j) = real(swpoint+real(i-1)*dd, kind=RP) * d2r
             enddo
             enddo
          else if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,dims(2),dims(3),1,1,item,startrec,totalrec,yrev,gdata2d)
             lon_org(:,:) = real(gdata2D(:,:), kind=RP) * d2r
          endif
       case("lat")
          if ( trim(dtype) == "linear" ) then
             do j = 1, dims(3)
             do i = 1, dims(2)
                lat_org(i,j) = real(swpoint+real(j-1)*dd, kind=RP) * d2r
             enddo
             enddo
          else if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,dims(2),dims(3),1,1,item,startrec,totalrec,yrev,gdata2d)
             lat_org(:,:) = real(gdata2D(:,:), kind=RP) * d2r
          endif
       case("plev")
          if(dims(1)/=knum)then
             write(*,*) 'xxx "knum" must be equal to outer_nz for plev. knum:',knum,'> outer_nz:',dims(1)
             call prc_mpistop
          endif
          if ( trim(dtype) == "levels" ) then
             if(dims(1)/=lnum)then
                write(*,*) 'xxx lnum must be same as the outer_nz for plev! ',dims(1),lnum
                call prc_mpistop
             endif
             do j = 1, dims(3)
             do i = 1, dims(2)
             do k = 1, dims(1)
                pres_org(k+2,i,j) = real(lvars(k), kind=rp)
             enddo
             enddo
             enddo
          else if ( trim(dtype) == "map" ) then
             call read_grads_file_3d(io_fid_grads_data,gfile,dims(2),dims(3),dims(1),nt,item,startrec,totalrec,yrev,gdata3d)
             do j = 1, dims(3)
             do i = 1, dims(2)
             do k = 1, dims(1)
                pres_org(k+2,i,j) = real(gdata3D(i,j,k), kind=rp)
             enddo
             enddo
             enddo
          endif
       case('U')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_3d(io_fid_grads_data,gfile,dims(2),dims(3),knum,nt,item,startrec,totalrec,yrev,gdata3d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                velx_org(1:2,i,j) = 0.0_rp
                do k = 1, knum
                   velx_org(k+2,i,j) = real(gdata3D(i,j,k), kind=rp)
                enddo
                if(dims(1)>knum)then
                   do k = knum+1, dims(1)
                      velx_org(k+2,i,j) = velx_org(knum+2,i,j)
                   enddo
                endif
             enddo
             enddo
          endif
       case('V')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_3d(io_fid_grads_data,gfile,dims(2),dims(3),knum,nt,item,startrec,totalrec,yrev,gdata3d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                vely_org(1:2,i,j) = 0.0_rp
                do k = 1, knum
                   vely_org(k+2,i,j) = real(gdata3D(i,j,k), kind=rp)
                enddo
                if(dims(1)>knum)then
                   do k = knum+1, dims(1)
                      vely_org(k+2,i,j) = vely_org(knum+2,i,j)
                   enddo
                endif
             enddo
             enddo
          endif
       case('T')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_3d(io_fid_grads_data,gfile,dims(2),dims(3),knum,nt,item,startrec,totalrec,yrev,gdata3d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                do k = 1, knum
                   temp_org(k+2,i,j) = real(gdata3D(i,j,k), kind=rp)
                enddo
                if(dims(1)>knum)then
                   do k = knum+1, dims(1)
                      temp_org(k+2,i,j) = temp_org(knum+2,i,j)
                   enddo
                endif
             enddo
             enddo
          endif
       case('HGT')
          if(dims(1)/=knum)then
             write(*,*) 'xxx The number of levels for HGT must be same as plevs! knum:',knum,'> outer_nz:',dims(1)
             call prc_mpistop
          endif
          if ( trim(dtype) == "map" ) then
             call read_grads_file_3d(io_fid_grads_data,gfile,dims(2),dims(3),dims(1),nt,item,startrec,totalrec,yrev,gdata3d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                do k = 1, dims(1)
                   cz_org(k+2,i,j) = real(gdata3D(i,j,k), kind=rp)
                enddo
                cz_org(1,i,j) = 0.0_rp
             enddo
             enddo
          endif
       case('QV')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_3d(io_fid_grads_data,gfile,dims(2),dims(3),knum,nt,item,startrec,totalrec,yrev,gdata3d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                do k = 1, knum
                   qtrc_org(k+2,i,j,qa_outer) = real(gdata3D(i,j,k), kind=rp)
                enddo
                qtrc_org(1:2,i,j,qa_outer) = qtrc_org(3,i,j,qa_outer)
             enddo
             enddo
             if( dims(1)>knum ) then
                select case ( upper_qv_type )
                case ("COPY")
                   do j = 1, dims(3)
                   do i = 1, dims(2)
                   do k = knum+1, dims(1)
                      qtrc_org(k+2,i,j,qa_outer) = qtrc_org(knum+2,i,j,qa_outer)
                   enddo
                   enddo
                   enddo
                case ("ZERO")
                   ! do nothing
                case default
                   write(*,*) 'xxx upper_qv_type in PARAM_MKINIT_REAL_GrADS is invalid! ', upper_qv_type
                   call prc_mpistop
                end select
             endif
          endif
       case('RH')
          if (data_available(ia_qv,1)) cycle  ! use QV
          if ( trim(dtype) == "map" ) then
             call read_grads_file_3d(io_fid_grads_data,gfile,dims(2),dims(3),knum,nt,item,startrec,totalrec,yrev,gdata3d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                do k = 1, knum
                   rhprs_org(k+2,i,j) = real(gdata3D(i,j,k), kind=RP) / 100.0_rp  ! relative humidity
                   call psat( p_sat, temp_org(k+2,i,j) )                          ! satulation pressure
                   qm = epsvap * rhprs_org(k+2,i,j) * p_sat &
                        / ( pres_org(k+2,i,j) - rhprs_org(k+2,i,j) * p_sat )      ! mixing ratio
                   qtrc_org(k+2,i,j,qa_outer) = qm / ( 1.0_rp + qm )              ! specific humidity
                enddo
                qtrc_org(1:2,i,j,qa_outer) = qtrc_org(3,i,j,qa_outer)
             enddo
             enddo
             if( dims(3)>knum ) then
                select case ( upper_qv_type )
                case ("COPY")
                   do j = 1, dims(3)
                   do i = 1, dims(2)
                   do k = knum+1, dims(1)
                      rhprs_org(k+2,i,j) = rhprs_org(knum+2,i,j)              ! relative humidity
                      call psat( p_sat, temp_org(k+2,i,j) )                   ! satulated specific humidity
                      qm = epsvap * rhprs_org(k+2,i,j) * p_sat &
                         / ( pres_org(k+2,i,j) - rhprs_org(k+2,i,j) * p_sat ) ! mixing ratio
                      qtrc_org(k+2,i,j,qa_outer) = qm / ( 1.0_rp + qm )       ! specific humidity
                      qtrc_org(k+2,i,j,qa_outer) = min(qtrc_org(k+2,i,j,qa_outer),qtrc_org(k+1,i,j,qa_outer))
                   enddo
                   enddo
                   enddo
                case ("ZERO")
                   ! do nothing
                case default
                   write(*,*) 'xxx upper_qv_type in PARAM_MKINIT_REAL_GrADS is invalid! ', upper_qv_type
                   call prc_mpistop
                end select
             endif
          endif
       case('MSLP')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,dims(2),dims(3),1,nt,item,startrec,totalrec,yrev,gdata2d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                pres_org(1,i,j) = real(gdata2D(i,j), kind=rp)
             enddo
             enddo
          endif
       case('PSFC')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,dims(2),dims(3),1,nt,item,startrec,totalrec,yrev,gdata2d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                pres_org(2,i,j) = real(gdata2D(i,j), kind=rp)
             enddo
             enddo
          endif
       case('U10')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,dims(2),dims(3),1,nt,item,startrec,totalrec,yrev,gdata2d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                velx_org(2,i,j) = real(gdata2D(i,j), kind=rp)
             enddo
             enddo
          endif
       case('V10')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,dims(2),dims(3),1,nt,item,startrec,totalrec,yrev,gdata2d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                vely_org(2,i,j) = real(gdata2D(i,j), kind=rp)
             enddo
             enddo
          endif
       case('T2')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,dims(2),dims(3),1,nt,item,startrec,totalrec,yrev,gdata2d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                temp_org(2,i,j) = real(gdata2D(i,j), kind=rp)
             enddo
             enddo
          endif
       case('Q2')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,dims(2),dims(3),1,nt,item,startrec,totalrec,yrev,gdata2d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                qtrc_org(2,i,j,qa_outer) = real(gdata2D(i,j), kind=rp)
             enddo
             enddo
          endif
       case('RH2')
          if (data_available(ia_q2,1)) cycle  ! use QV
          if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,dims(2),dims(3),1,nt,item,startrec,totalrec,yrev,gdata2d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                rhsfc = real(gdata2D(i,j), kind=RP) / 100.0_rp   ! relative humidity
                call psat( p_sat, temp_org(2,i,j) )                         ! satulation pressure
                qm = epsvap * rhsfc * p_sat &
                   / ( pres_org(2,i,j) - rhsfc * p_sat )           ! mixing ratio
                qtrc_org(2,i,j,qa_outer) = qm / ( 1.0_rp + qm )             ! specific humidity
             enddo
             enddo
          endif
       case('TOPO')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,dims(2),dims(3),1,nt,item,startrec,totalrec,yrev,gdata2d)
             do j = 1, dims(3)
             do i = 1, dims(2)
                cz_org(2,i,j) = real(gdata2D(i,j), kind=rp)
             enddo
             enddo
          endif
       end select
    enddo loop_inputatomgrads


    rovcp = rdry / cpdry
    cpovr = cpdry / rdry

    if ( data_available(ia_t2,1) .and. data_available(ia_ps,1) ) then
       do j = 1, dims(3)
       do i = 1, dims(2)
          pott(i,j) = temp_org(2,i,j) * (p00/pres_org(2,i,j))**rovcp
       end do
       end do
    else
       do j = 1, dims(3)
       do i = 1, dims(2)
          pott(i,j) = temp_org(3,i,j) * (p00/pres_org(3,i,j))**rovcp
       end do
       end do
    end if

    if ( .not. data_available(ia_t2,1) ) then
       if ( data_available(ia_ps,1) ) then
          do j = 1, dims(3)
          do i = 1, dims(2)
             temp_org(2,i,j) = pott(i,j) * (pres_org(2,i,j)/p00)**rovcp
          end do
          end do
       else
          if ( data_available(ia_topo,1) ) then
             do j = 1, dims(3)
             do i = 1, dims(2)
                temp_org(2,i,j) = temp_org(3,i,j) &
                                + laps * (cz_org(3,i,j)-cz_org(2,i,j))
             end do
             end do
          else
             do j = 1, dims(3)
             do i = 1, dims(2)
                temp_org(2,i,j) = temp_org(3,i,j)
             end do
             end do
          end if
       end if
    end if

    if ( .not. data_available(ia_ps,1) ) then
       do j = 1, dims(3)
       do i = 1, dims(2)
          pres_org(2,i,j) = p00 * (temp_org(2,i,j)/pott(i,j))**cpovr
       end do
       end do
    end if

    if ( data_available(ia_slp,1) ) then
       do j = 1, dims(3)
       do i = 1, dims(2)
          temp_org(1,i,j) = pott(i,j) * (pres_org(1,i,j)/p00)**rovcp
       end do
       end do
    else
       if ( data_available(ia_t2,1) .and. data_available(ia_topo,1) ) then
          do j = 1, dims(3)
          do i = 1, dims(2)
             temp_org(1,i,j) = temp_org(2,i,j) + laps * cz_org(2,i,j)
          end do
          end do
       else
          do j = 1, dims(3)
          do i = 1, dims(2)
             temp_org(1,i,j) = temp_org(3,i,j) + laps * cz_org(3,i,j)
          end do
          end do
       end if
       do j = 1, dims(3)
       do i = 1, dims(2)
          pres_org(1,i,j) = p00 * (temp_org(1,i,j)/pott(i,j))**cpovr
       end do
       end do
    end if

    if ( .not. data_available(ia_topo,1) ) then
       ! guess surface height (elevation)
       do j = 1, dims(3)
       do i = 1, dims(2)
          cz_org(2,i,j) = max( 0.0_rp, &
                               cz_org(3,i,j) &
                               * ( log(pres_org(2,i,j)/pres_org(1,i,j)) ) &
                               / ( log(pres_org(3,i,j)/pres_org(1,i,j)) ) )
       end do
       end do
    end if

    velz_org = 0.0_rp


    ! check verticaly extrapolated data in outer model
    do j = 1, dims(3)
    do i = 1, dims(2)
    do k = 3, dims(1)+2

       if( pres_org(k,i,j)>pres_org(2,i,j) )then ! if Pressure is larger than Surface pressure
          !velz_org(k,i,j)=velz_org(2,i,j)
          velx_org(k,i,j)=velx_org(2,i,j)
          vely_org(k,i,j)=vely_org(2,i,j)
          temp_org(k,i,j)=temp_org(2,i,j)
          qtrc_org(k,i,j,:)=qtrc_org(2,i,j,:)
          cz_org(k,i,j)=cz_org(2,i,j)
      end if

    enddo
    enddo
    enddo


    !do it = 1, nt
    !   k=1 ; j=int(dims(3)/2) ; i=int(dims(2)/2) ; iq = 1
    !   write(*,*) "read 3D grads data",i,j,k
    !   write(*,*) "lon_org    ",lon_org   (i,j)/D2R
    !   write(*,*) "lat_org    ",lat_org   (i,j)/D2R
    !   write(*,*) "pres_org   ",pres_org  (k,i,j)
    !   write(*,*) "usfc_org   ",usfc_org  (i,j)
    !   write(*,*) "vsfc_org   ",vsfc_org  (i,j)
    !   write(*,*) "tsfc_org   ",tsfc_org  (i,j)
    !   write(*,*) "qsfc_org   ",qsfc_org  (i,j,iq)
    !   write(*,*) "rhsfc_org  ",rhsfc_org (i,j)
    !   write(*,*) "velx_org   ",velx_org  (k,i,j)
    !   write(*,*) "vely_org   ",vely_org  (k,i,j)
    !   write(*,*) "temp_org   ",temp_org  (k,i,j)
    !   write(*,*) "hgt_org    ",hgt_org   (k,i,j)
    !   write(*,*) "qtrc_org   ",qtrc_org  (k,i,j,iq)
    !   write(*,*) "rhprs_org  ",rhprs_org (k,i,j)
    !enddo

    return

Here is the call graph for this function:

Here is the caller graph for this function:

parentlandsetupgrads()

subroutine, public mod_realinput_grads::parentlandsetupgrads	(	integer, dimension(3), intent(out)	ldims,
		logical, intent(out)	use_waterratio,
		logical, intent(in)	use_file_landwater,
		character(len=*), intent(in)	basename
	)

Land Setup.

Definition at line 876 of file mod_realinput_grads.f90.

References scale_stdio::io_fid_log, scale_stdio::io_get_available_fid(), scale_stdio::io_l, scale_stdio::io_lnml, scale_process::prc_mpistop(), and read_namelist().

Referenced by mod_realinput::parentatomsetup().

    implicit none

    integer,          intent(out) :: ldims(3)
    logical,          intent(out) :: use_waterratio
    logical,          intent(in)  :: use_file_landwater ! use landwater data from files
    character(len=*), intent(in)  :: basename

    integer             :: ielem
    integer             :: k, n

    integer             :: ierr
    !---------------------------------------------------------------------------

    if( io_l ) write(io_fid_log,*) '+++ Real Case/Land Input File Type: GrADS format'

    !--- initialization
    use_waterratio = .false.

    if ( len_trim(basename) == 0 ) then
       if( io_l ) write(io_fid_log,*) &
            'xxx "BASEMAAME" is not specified in "PARAM_MKINIT_REAL_ATOMS"!',trim(basename)
       call prc_mpistop
    endif

    !--- read namelist
    io_fid_grads_nml = io_get_available_fid()
    open( io_fid_grads_nml,       &
         file   = trim(basename), &
         form   = 'formatted',    &
         status = 'old',          &
         action = 'read',         &
         iostat = ierr            )
    if ( ierr /= 0 ) then
       if( io_l ) write(io_fid_log,*) 'xxx Input file is not found! ', trim(basename)
       call prc_mpistop
    endif

    read(io_fid_grads_nml,nml=nml_grads_grid,iostat=ierr)
    if( ierr /= 0 ) then !--- missing or fatal error
       if( io_l ) write(io_fid_log,*) 'xxx Not appropriate names in nml_grads_grid in ', trim(basename),'. Check!'
       call prc_mpistop
    endif
    if( io_lnml ) write(io_fid_log,nml=nml_grads_grid)

    ! land
    ldims(1) = outer_nl ! soil_layers_stag
    if(outer_nx_sfc > 0)then
       ldims(2) = outer_nx_sfc
    else
       ldims(2) = outer_nx
       outer_nx_sfc = outer_nx
    endif
    if(outer_ny_sfc > 0)then
       ldims(3) = outer_ny_sfc
    else
       ldims(3) = outer_ny
       outer_ny_sfc = outer_ny
    endif

    allocate( gland2d( ldims(2), ldims(3)           ) )
    allocate( gland3d( ldims(2), ldims(3), ldims(1) ) )

    call read_namelist( &
         grads_item(:,2),     & ! (out)
         grads_fname(:,2),    & ! (out)
         grads_dtype(:,2),    & ! (out)
         grads_swpoint(:,2),  & ! (out)
         grads_dd(:,2),       & ! (out)
         grads_lnum(:,2),     & ! (out)
         grads_lvars(:,:,2),  & ! (out)
         grads_startrec(:,2), & ! (out)
         grads_totalrec(:,2), & ! (out)
         grads_knum(:,2),     & ! (out)
         grads_yrev(:,2),     & ! (out)
         grads_fendian(:,2),  & ! (out)
         grads_missval(:,2),  & ! (out)
         data_available(:,2), & ! (out)
         item_list_land,      & ! (in)
         num_item_list_land,  & ! (in)
         basename,            & ! (in)
         io_fid_grads_nml     ) ! (in)

    do ielem = 1, num_item_list_land
       item  = item_list_land(ielem)
       !--- check data
       select case(trim(item))
       case('TOPO','lsmask')
          if ( .not. data_available(ielem,2) ) then
             if (io_l) write(io_fid_log,*) 'warning: ',trim(item),' is not found & not used.'
             cycle
          endif
       case('lon', 'lat', 'lon_sfc', 'lat_sfc')
          cycle
       case('SMOISVC', 'SMOISDS')
          if ( use_file_landwater ) then
             if (.not. data_available(il_smoisvc,2) .and. .not. data_available(il_smoisds,2)) then
                if( io_l ) write(io_fid_log,*) 'xxx Not found in grads namelist! : ',trim(item_list_land(ielem))
                call prc_mpistop
             end if
             use_waterratio =  data_available(il_smoisds,2)
          else
             cycle
          end if
       case default ! llev, SKINT, STEMP
          if ( .not. data_available(ielem,2) ) then
             if( io_l ) write(io_fid_log,*) 'xxx Not found in grads namelist! : ',trim(item_list_land(ielem))
             call prc_mpistop
          endif
       end select

    end do

    return

Here is the call graph for this function:

Here is the caller graph for this function:

parentlandinputgrads()

subroutine, public mod_realinput_grads::parentlandinputgrads	(	real(rp), dimension (:,:,:), intent(out)	tg_org,
		real(rp), dimension (:,:,:), intent(out)	strg_org,
		real(rp), dimension (:,:,:), intent(out)	smds_org,
		real(rp), dimension (:,:), intent(out)	lst_org,
		real(rp), dimension (:,:), intent(out)	llon_org,
		real(rp), dimension (:,:), intent(out)	llat_org,
		real(rp), dimension (:), intent(out)	lz_org,
		real(rp), dimension(:,:), intent(out)	topo_org,
		real(rp), dimension(:,:), intent(out)	lmask_org,
		character(len=*), intent(in)	basename_num,
		integer, dimension(3), intent(in)	ldims,
		logical, intent(in)	use_file_landwater,
		integer, intent(in)	nt
	)

grads data

Definition at line 1005 of file mod_realinput_grads.f90.

References scale_const::const_d2r, scale_const::const_eps, scale_const::const_tem00, scale_const::const_undef, scale_stdio::io_fid_log, scale_stdio::io_get_available_fid(), scale_stdio::io_l, and scale_process::prc_mpistop().

Referenced by mod_realinput::parentatomsetup().

    use scale_const, only: &
       undef => const_undef, &
       d2r   => const_d2r,   &
       tem00 => const_tem00, &
       eps   => const_eps
    implicit none

    real(RP), intent(out) :: tg_org    (:,:,:)
    real(RP), intent(out) :: strg_org  (:,:,:)
    real(RP), intent(out) :: smds_org  (:,:,:)
    real(RP), intent(out) :: lst_org   (:,:)
    real(RP), intent(out) :: llon_org  (:,:)
    real(RP), intent(out) :: llat_org  (:,:)
    real(RP), intent(out) :: lz_org    (:)
    real(RP), intent(out) :: topo_org(:,:)
    real(RP), intent(out) :: lmask_org(:,:)

    character(len=*), intent(in) :: basename_num
    integer,          intent(in) :: ldims(3)
    logical,          intent(in) :: use_file_landwater   ! use land water data from files
    integer,          intent(in) :: nt
    ! ----------------------------------------------------------------

    character(len=H_LONG) :: gfile

    real(RP) :: qvsat, qm

    integer :: i, j, k, ielem, n
    integer :: ierr

    !---------------------------------------------------------------------------

    if( io_l ) write(io_fid_log,*) '+++ ScaleLib/IO[realinput]/Categ[LandInputGrADS]'


    loop_inputlandgrads : do ielem = 1, num_item_list_land

       item  = item_list_land(ielem)

       dtype    = grads_dtype(ielem,2)
       fname    = grads_fname(ielem,2)
       lnum     = grads_lnum(ielem,2)
       missval  = grads_missval(ielem,2)

       if ( grads_knum(ielem,2) > 0 )then
          knum = grads_knum(ielem,2)
       else
          knum = ldims(1)
       endif

       select case (trim(dtype))
       case("linear")
          swpoint = grads_swpoint(ielem,2)
          dd      = grads_dd(ielem,2)
          if( (abs(swpoint-large_number_one)<eps).or.(abs(dd-large_number_one)<eps) )then
             write(*,*) 'xxx "swpoint" is required in grads namelist! ',swpoint
             write(*,*) 'xxx "dd"      is required in grads namelist! ',dd
             call prc_mpistop
          endif
       case("levels")
          if ( lnum < 0 )then
             write(*,*) 'xxx "lnum" in grads namelist is required for levels data! '
             call prc_mpistop
          endif
          do k=1, lnum
             lvars(k)=grads_lvars(k,ielem,2)
          enddo
          if(abs(lvars(1)-large_number_one)<eps)then
             write(*,*) 'xxx "lvars" must be specified in grads namelist for levels data!',(lvars(k),k=1,lnum)
             call prc_mpistop
          endif
       case("map")
          startrec = grads_startrec(ielem,2)
          totalrec = grads_totalrec(ielem,2)
          fendian  = grads_fendian(ielem,2)
          yrev     = grads_yrev(ielem,2)
          if( (startrec<0).or.(totalrec<0) )then
             write(*,*) 'xxx "startrec" is required in grads namelist! ',startrec
             write(*,*) 'xxx "totalrec" is required in grads namelist! ',totalrec
             call prc_mpistop
          endif
          ! get file_io
          if(io_fid_grads_data < 0)then
             io_fid_grads_data = io_get_available_fid()
          endif
          gfile=trim(fname)//trim(basename_num)//'.grd'
          if( len_trim(fname)==0 )then
             write(*,*) 'xxx "fname" is required in grads namelist for map data! ',trim(fname)
             call prc_mpistop
          endif
       end select

       ! read data
       select case (trim(item))
       case("lsmask")
          if ( data_available(il_lsmask,2) ) then
             if ( trim(dtype) == "map" ) then
                call read_grads_file_2d(io_fid_grads_data,gfile,ldims(2),ldims(3),1,1,item,startrec,totalrec,yrev,gland2d)
                lmask_org(:,:) = real(gland2D(:,:), kind=rp)
             endif
          else
             lmask_org = undef
          end if
       case("lon")
          if ( .not. data_available(il_lon_sfc,2) ) then
             if ( ldims(2).ne.outer_nx .or. ldims(3).ne.outer_ny ) then
                write(*,*) 'xxx namelist of "lon_sfc" is not found in grads namelist!'
                write(*,*) 'xxx dimension is different: outer_nx and outer_nx_sfc! ', outer_nx, ldims(2)
                write(*,*) '                          : outer_ny and outer_ny_sfc! ', outer_ny, ldims(3)
                call prc_mpistop
             end if
             if ( trim(dtype) == "linear" ) then
                do j = 1, ldims(3)
                do i = 1, ldims(2)
                   llon_org(i,j) = real(swpoint+real(i-1)*dd, kind=RP) * d2r
                enddo
                enddo
             else if ( trim(dtype) == "map" ) then
                call read_grads_file_2d(io_fid_grads_data,gfile,ldims(2),ldims(3),1,1,item,startrec,totalrec,yrev,gland2d)
                llon_org(:,:) = real(gland2D(:,:), kind=RP) * d2r
             endif
          end if
       case("lon_sfc")
          if ( .not. data_available(il_lon_sfc,2) ) cycle
          if ( trim(dtype) == "linear" ) then
             do j = 1, ldims(3)
             do i = 1, ldims(2)
                llon_org(i,j) = real(swpoint+real(i-1)*dd, kind=RP) * d2r
             enddo
             enddo
          else if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,ldims(2),ldims(3),1,1,item,startrec,totalrec,yrev,gland2d)
             llon_org(:,:) = real(gland2D(:,:), kind=RP) * d2r
          endif
       case("lat")
          if ( .not. data_available(il_lat_sfc,2) ) then
             if ( ldims(2).ne.outer_nx .or. ldims(3).ne.outer_ny ) then
                write(*,*) 'xxx namelist of "lat_sfc" is not found in grads namelist!'
                write(*,*) 'xxx dimension is different: outer_nx and outer_nx_sfc! ', outer_nx, ldims(2)
                write(*,*) '                          : outer_ny and outer_ny_sfc! ', outer_nx, ldims(3)
                call prc_mpistop
             end if
             if ( trim(dtype) == "linear" ) then
                do j = 1, ldims(3)
                do i = 1, ldims(2)
                   llat_org(i,j) = real(swpoint+real(j-1)*dd, kind=RP) * d2r
                enddo
                enddo
             else if ( trim(dtype) == "map" ) then
                call read_grads_file_2d(io_fid_grads_data,gfile,ldims(2),ldims(3),1,1,item,startrec,totalrec,yrev,gland2d)
                llat_org(:,:) = real(gland2D(:,:), kind=RP) * d2r
             endif
          end if
       case("lat_sfc")
          if ( .not. data_available(il_lat_sfc,2) ) cycle
          if ( trim(dtype) == "linear" ) then
             do j = 1, ldims(3)
             do i = 1, ldims(2)
                llat_org(i,j) = real(swpoint+real(j-1)*dd, kind=RP) * d2r
             enddo
             enddo
          else if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,ldims(2),ldims(3),1,1,item,startrec,totalrec,yrev,gland2d)
             llat_org(:,:) = real(gland2D(:,:), kind=RP) * d2r
          endif
       case("llev")
          if(ldims(1)/=knum)then
             write(*,*) 'xxx "knum" must be equal to outer_nl for llev. knum:',knum,'> outer_nl:',ldims(1)
             call prc_mpistop
          endif
          if ( trim(dtype) == "levels" ) then
             if(ldims(1)/=lnum)then
                write(*,*) 'xxx lnum must be same as the outer_nl for llev! ',ldims(1),lnum
                call prc_mpistop
             endif
             do k = 1, ldims(1)
                lz_org(k) = real(lvars(k), kind=rp)
             enddo
!          else if ( trim(dtype) == "map" ) then
!             call read_grads_file_3d(io_fid_grads_data,gfile,ldims(2),ldims(3),ldims(1),nt,item,startrec,totalrec,yrev,gland)
!             do j = 1, ldims(3)
!             do i = 1, ldims(2)
!             do k = 1, ldims(1)
!                lz_org(k,i,j) = real(gland(i,j,k), kind=RP)
!             enddo
!             enddo
!             enddo
          endif
       case('STEMP')
          if(ldims(1)/=knum)then
             write(*,*) 'xxx The number of levels for STEMP must be same as llevs! ',ldims(1),knum
             call prc_mpistop
          endif
          if ( trim(dtype) == "map" ) then
             call read_grads_file_3d(io_fid_grads_data,gfile,ldims(2),ldims(3),ldims(1),nt,item,startrec,totalrec,yrev,gland3d)
             do j = 1, ldims(3)
             do i = 1, ldims(2)
             do k = 1, ldims(1)
                if ( abs(gland3d(i,j,k)-missval) < eps ) then
                   tg_org(k,i,j) = undef
                else
                   tg_org(k,i,j) = real(gland3D(i,j,k), kind=rp)
                end if
             enddo
             enddo
             enddo
          endif
       case('SMOISVC')
          if ( use_file_landwater ) then
             if(ldims(1)/=knum)then
                write(*,*) 'xxx The number of levels for SMOISVC must be same as llevs! ',ldims(1),knum
                call prc_mpistop
             endif
             if ( trim(dtype) == "map" ) then
                call read_grads_file_3d(io_fid_grads_data,gfile,ldims(2),ldims(3),ldims(1),nt,item,startrec,totalrec,yrev,gland3d)
                do j = 1, ldims(3)
                do i = 1, ldims(2)
                do k = 1, ldims(1)
                   if ( abs(gland3d(i,j,k)-missval) < eps ) then
                      strg_org(k,i,j) = undef
                   else
                      strg_org(k,i,j) = real(gland3D(i,j,k), kind=rp)
                   end if
                enddo
                enddo
                enddo
             endif
          endif
       case('SMOISDS')
          if ( use_file_landwater ) then
             if(ldims(1)/=knum)then
                write(*,*) 'xxx The number of levels for SMOISDS must be same as llevs! ',ldims(1),knum
                call prc_mpistop
             endif
             if ( trim(dtype) == "map" ) then
                call read_grads_file_3d(io_fid_grads_data,gfile,ldims(2),ldims(3),ldims(1),nt,item,startrec,totalrec,yrev,gland3d)
                do j = 1, ldims(3)
                do i = 1, ldims(2)
                do k = 1, ldims(1)
                   if ( abs(gland3d(i,j,k)-missval) < eps ) then
                      smds_org(k,i,j) = undef
                   else
                      smds_org(k,i,j) = real(gland3D(i,j,k), kind=rp)
                   end if
                enddo
                enddo
                enddo
             endif
          endif
       case('SKINT')
          if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,ldims(2),ldims(3),1,nt,item,startrec,totalrec,yrev,gland2d)
             do j = 1, ldims(3)
             do i = 1, ldims(2)
                if ( abs(gland2d(i,j)-missval) < eps ) then
                   lst_org(i,j) = undef
                else
                   lst_org(i,j) = real(gland2D(i,j), kind=rp)
                end if
             enddo
             enddo
          endif
       case('TOPO')
          if ( data_available(il_topo,2) ) then
             if ( trim(dtype) == "map" ) then
                call read_grads_file_2d(io_fid_grads_data,gfile,ldims(2),ldims(3),1,nt,item,startrec,totalrec,yrev,gland2d)
                do j = 1, ldims(3)
                do i = 1, ldims(2)
                   if ( abs(gland2d(i,j)-missval) < eps ) then
                      topo_org(i,j) = undef
                   else
                      topo_org(i,j) = real(gland2D(i,j), kind=rp)
                   end if
                enddo
                enddo
             endif
          else
             topo_org = undef
          endif
       end select
    enddo loop_inputlandgrads

    !do it = 1, nt
    !   i=int(ldims(2)/2) ; j=int(ldims(3)/2)
    !   write(*,*) "read 2D grads data",ldims(2),ldims(3),i,j,it
    !   write(*,*) "lon_org    ",lon_org  (i,j)
    !   write(*,*) "lat_org    ",lat_org  (i,j)
    !   write(*,*) "lst_org  ",lst_org(i,j)
    !   do k=1,dims(7)
    !      write(*,*) "tg_org    ",tg_org   (k,i,j)," k= ",k
    !      write(*,*) "strg_org  ",strg_org (k,i,j)," k= ",k
    !   enddo
    !enddo

    return

Here is the call graph for this function:

Here is the caller graph for this function:

parentoceansetupgrads()

subroutine, public mod_realinput_grads::parentoceansetupgrads	(	integer, dimension(2), intent(out)	odims,
		integer, intent(out)	timelen,
		character(len=*), intent(in)	basename
	)

Ocean Setup.

Definition at line 1309 of file mod_realinput_grads.f90.

References scale_stdio::io_fid_log, scale_stdio::io_get_available_fid(), scale_stdio::io_l, scale_stdio::io_lnml, scale_process::prc_mpistop(), and read_namelist().

Referenced by mod_realinput::parentatomsetup().

    implicit none

    integer,          intent(out) :: odims(2)
    integer,          intent(out) :: timelen
    character(len=*), intent(in)  :: basename

    character(len=H_LONG) :: grads_ctl
    integer             :: ielem
    integer             :: n

    integer             :: ierr
    !---------------------------------------------------------------------------

    if( io_l ) write(io_fid_log,*) '+++ Real Case/Ocean Input File Type: GrADS format'

    !--- read namelist

    if ( len_trim(basename) == 0 ) then
       grads_ctl = "namelist.grads_boundary"
    else
       grads_ctl = basename
    endif

    !--- read namelist
    io_fid_grads_nml = io_get_available_fid()
    open( io_fid_grads_nml,                    &
         file   = trim(grads_ctl), &
         form   = 'formatted',                   &
         status = 'old',                         &
         action = 'read',                        &
         iostat = ierr                           )
    if ( ierr /= 0 ) then
       if( io_l ) write(io_fid_log,*) 'xxx Input file is not found! ', trim(grads_ctl)
       call prc_mpistop
    endif

    read(io_fid_grads_nml,nml=nml_grads_grid,iostat=ierr)
    if( ierr /= 0 ) then !--- missing or fatal error
       if( io_l ) write(io_fid_log,*) 'xxx Not appropriate names in nml_grads_grid in ', trim(grads_ctl),'. Check!'
       call prc_mpistop
    endif
    if( io_lnml ) write(io_fid_log,nml=nml_grads_grid)

    timelen = 0        ! will be replaced later

    ! sst
    if(outer_nx_sst > 0)then
       odims(1) = outer_nx_sst
    else if (outer_nx_sfc > 0) then
       odims(1) = outer_nx_sfc
       outer_nx_sst = outer_nx_sfc
    else
       odims(1) = outer_nx
       outer_nx_sst = outer_nx
    endif
    if(outer_ny_sst > 0)then
       odims(2) = outer_ny_sst
    else if(outer_ny_sfc > 0)then
       odims(2) = outer_ny_sfc
       outer_ny_sst = outer_ny_sfc
    else
       odims(2) = outer_ny
       outer_ny_sst = outer_ny
    endif

    allocate( gsst2d( odims(1), odims(2)        ) )


    call read_namelist( &
         grads_item(:,3),     & ! (out)
         grads_fname(:,3),    & ! (out)
         grads_dtype(:,3),    & ! (out)
         grads_swpoint(:,3),  & ! (out)
         grads_dd(:,3),       & ! (out)
         grads_lnum(:,3),     & ! (out)
         grads_lvars(:,:,3),  & ! (out)
         grads_startrec(:,3), & ! (out)
         grads_totalrec(:,3), & ! (out)
         grads_knum(:,3),     & ! (out)
         grads_yrev(:,3),     & ! (out)
         grads_fendian(:,3),  & ! (out)
         grads_missval(:,3),  & ! (out)
         data_available(:,3), & ! (out)
         item_list_ocean,     & ! (in)
         num_item_list_ocean, & ! (in)
         grads_ctl,           & ! (in)
         io_fid_grads_nml     ) ! (in)

    do ielem = 1, num_item_list_ocean
       item  = item_list_ocean(ielem)
       !--- check data
       select case(trim(item))
       case('lsmask')
          if ( .not. data_available(ielem,3) ) then
             if (io_l) write(io_fid_log,*) 'warning: ',trim(item),' is not found & not used.'
             cycle
          endif
       case('lon', 'lat', 'lon_sfc', 'lat_sfc', 'lon_sst', 'lat_sst')
          cycle
       case('SST')
          if (.not. data_available(io_sst,3) .and. .not. data_available(io_skint,3) ) then
             if (io_l) write(io_fid_log,*) 'xxx SST and SKINT are found in grads namelist!'
             call prc_mpistop
          endif
          if (.not. data_available(io_sst,3)) then
             if (io_l) write(io_fid_log,*) 'warning: SST is found in grads namelist. SKINT is used in place of SST.'
             cycle
          endif
       case('SKINT')
          cycle
       case default !
          if ( .not. data_available(ielem,3) ) then
             if( io_l ) write(io_fid_log,*) 'xxx Not found in grads namelist! : ',trim(item_list_ocean(ielem))
             call prc_mpistop
          endif
       end select

    end do

    return

Here is the call graph for this function:

Here is the caller graph for this function:

parentoceanopengrads()

subroutine, public mod_realinput_grads::parentoceanopengrads

(

)

Definition at line 1433 of file mod_realinput_grads.f90.

References scale_stdio::io_fid_log, and scale_stdio::io_l.

Referenced by mod_realinput::parentatomsetup().

    implicit none

    if( io_l ) write(io_fid_log,*) '+++ ScaleLib/IO[realinput]/Categ[OceanOpenGrADS]'

    return

Here is the caller graph for this function:

parentoceaninputgrads()

subroutine, public mod_realinput_grads::parentoceaninputgrads	(	real(rp), dimension (:,:), intent(out)	tw_org,
		real(rp), dimension (:,:), intent(out)	sst_org,
		real(rp), dimension(:,:), intent(out)	omask_org,
		real(rp), dimension (:,:), intent(out)	olon_org,
		real(rp), dimension (:,:), intent(out)	olat_org,
		character(len=*), intent(in)	basename_num,
		integer, dimension(2), intent(in)	odims,
		integer, intent(in)	nt
	)

grads data

Definition at line 1450 of file mod_realinput_grads.f90.

References scale_const::const_d2r, scale_const::const_eps, scale_const::const_tem00, scale_const::const_undef, scale_stdio::io_fid_log, scale_stdio::io_get_available_fid(), scale_stdio::io_l, and scale_process::prc_mpistop().

Referenced by mod_realinput::parentatomsetup().

    use scale_const, only: &
       undef => const_undef, &
       d2r   => const_d2r,   &
       tem00 => const_tem00, &
       eps   => const_eps
    implicit none

    real(RP), intent(out) :: tw_org   (:,:)
    real(RP), intent(out) :: sst_org  (:,:)
    real(RP), intent(out) :: omask_org(:,:)
    real(RP), intent(out) :: olon_org (:,:)
    real(RP), intent(out) :: olat_org (:,:)

    character(len=*), intent(in) :: basename_num
    integer,          intent(in) :: odims(2)
    integer,          intent(in) :: nt
    ! ----------------------------------------------------------------

    character(len=H_LONG) :: gfile

    real(RP) :: qvsat, qm

    integer :: i, j, ielem, n
    integer :: ierr

    !---------------------------------------------------------------------------

    if( io_l ) write(io_fid_log,*) '+++ ScaleLib/IO[realinput]/Categ[OceanInputGrADS]'


    loop_inputoceangrads : do ielem = 1, num_item_list_ocean

       item  = item_list_ocean(ielem)

       dtype    = grads_dtype(ielem,3)
       fname    = grads_fname(ielem,3)
       lnum     = grads_lnum(ielem,3)
       missval  = grads_missval(ielem,3)

       select case (trim(dtype))
       case("linear")
          swpoint = grads_swpoint(ielem,3)
          dd      = grads_dd(ielem,3)
          if( (abs(swpoint-large_number_one)<eps).or.(abs(dd-large_number_one)<eps) )then
             write(*,*) 'xxx "swpoint" is required in grads namelist! ',swpoint
             write(*,*) 'xxx "dd"      is required in grads namelist! ',dd
             call prc_mpistop
          endif
       case("levels")
          write(*,*) 'xxx "lnum" in grads namelist is invalid for ocean data'
          call prc_mpistop
       case("map")
          startrec = grads_startrec(ielem,3)
          totalrec = grads_totalrec(ielem,3)
          fendian  = grads_fendian(ielem,3)
          yrev     = grads_yrev(ielem,3)
          if( (startrec<0).or.(totalrec<0) )then
             write(*,*) 'xxx "startrec" is required in grads namelist! ',startrec
             write(*,*) 'xxx "totalrec" is required in grads namelist! ',totalrec
             call prc_mpistop
          endif
          ! get file_io
          if(io_fid_grads_data < 0)then
             io_fid_grads_data = io_get_available_fid()
          endif
          gfile=trim(fname)//trim(basename_num)//'.grd'
          if( len_trim(fname)==0 )then
             write(*,*) 'xxx "fname" is required in grads namelist for map data! ',trim(fname)
             call prc_mpistop
          endif
       end select

       ! read data
       select case (trim(item))
       case("lsmask")
          if ( data_available(io_lsmask,3) ) then
             if ( trim(dtype) == "map" ) then
                call read_grads_file_2d(io_fid_grads_data,gfile,odims(1),odims(2),1,1,item,startrec,totalrec,yrev,gsst2d)
                omask_org(:,:) = real(gsst2D(:,:), kind=rp)
             endif
          else
             omask_org = undef
          end if
       case("lon")
          if ( .not. data_available(io_lon_sst,3) .and. .not. data_available(io_lon_sfc,3) ) then
             if ( odims(1).ne.outer_nx .or. odims(2).ne.outer_ny ) then
                write(*,*) 'xxx namelist of "lon_sst" is not found in grads namelist!'
                write(*,*) 'xxx dimension is different: outer_nx and outer_nx_sst! ', outer_nx, odims(1)
                write(*,*) '                          : outer_ny and outer_ny_sst! ', outer_ny, odims(2)
                call prc_mpistop
             end if
             if ( trim(dtype) == "linear" ) then
                do j = 1, odims(2)
                do i = 1, odims(1)
                   olon_org(i,j) = real(swpoint+real(i-1)*dd, kind=RP) * d2r
                enddo
                enddo
             else if ( trim(dtype) == "map" ) then
                call read_grads_file_2d(io_fid_grads_data,gfile,odims(1),odims(2),1,1,item,startrec,totalrec,yrev,gsst2d)
                olon_org(:,:) = real(gsst2D(:,:), kind=RP) * d2r
             endif
          end if
       case("lon_sfc")
          if ( .not. data_available(io_lon_sst,3) .and. data_available(io_lon_sfc,3) ) then
             if ( odims(1).ne.outer_nx_sfc .or. odims(2).ne.outer_ny_sfc ) then
                write(*,*) 'xxx namelist of "lon_sst" is not found in grads namelist!'
                write(*,*) 'xxx dimension is different: outer_nx_sfc and outer_nx_sst! ', outer_nx_sfc, odims(1)
                write(*,*) '                          : outer_ny_sfc and outer_ny_sst! ', outer_ny_sfc, odims(2)
                call prc_mpistop
             end if
             if ( trim(dtype) == "linear" ) then
                do j = 1, odims(2)
                do i = 1, odims(1)
                   olon_org(i,j) = real(swpoint+real(i-1)*dd, kind=RP) * d2r
                enddo
                enddo
             else if ( trim(dtype) == "map" ) then
                call read_grads_file_2d(io_fid_grads_data,gfile,odims(1),odims(2),1,1,item,startrec,totalrec,yrev,gsst2d)
                olon_org(:,:) = real(gsst2D(:,:), kind=RP) * d2r
             endif
          end if
       case("lon_sst")
          if ( .not. data_available(io_lon_sst,3) ) cycle
          if ( trim(dtype) == "linear" ) then
             do j = 1, odims(2)
             do i = 1, odims(1)
                olon_org(i,j) = real(swpoint+real(i-1)*dd, kind=RP) * d2r
             enddo
             enddo
          else if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,odims(1),odims(2),1,1,item,startrec,totalrec,yrev,gsst2d)
             olon_org(:,:) = real(gsst2D(:,:), kind=RP) * d2r
          endif
       case("lat")
          if ( .not. data_available(io_lat_sfc,3) .and. .not. data_available(io_lat_sst,3) ) then
             if ( odims(1).ne.outer_nx .or. odims(2).ne.outer_ny ) then
                write(*,*) 'xxx namelist of "lat_sst" is not found in grads namelist!'
                write(*,*) 'xxx dimension is different: outer_nx and outer_nx_sst! ', outer_nx, odims(1)
                write(*,*) '                          : outer_ny and outer_ny_sst! ', outer_ny, odims(2)
                call prc_mpistop
             end if
             if ( trim(dtype) == "linear" ) then
                do j = 1, odims(2)
                do i = 1, odims(1)
                   olat_org(i,j) = real(swpoint+real(j-1)*dd, kind=RP) * d2r
                enddo
                enddo
             else if ( trim(dtype) == "map" ) then
                call read_grads_file_2d(io_fid_grads_data,gfile,odims(1),odims(2),1,1,item,startrec,totalrec,yrev,gsst2d)
                olat_org(:,:) = real(gsst2D(:,:), kind=RP) * d2r
             endif
          end if
       case("lat_sfc")
          if ( .not. data_available(io_lat_sst,3) .and. data_available(io_lat_sfc,3) ) then
             if ( odims(1).ne.outer_nx .or. odims(1).ne.outer_ny ) then
                write(*,*) 'xxx namelist of "lat_sst" is not found in grads namelist!'
                write(*,*) 'xxx dimension is different: outer_nx_sfc and outer_nx_sst! ', outer_nx_sfc, odims(1)
                write(*,*) '                          : outer_ny_sfc and outer_ny_sst! ', outer_ny_sfc, odims(2)
                call prc_mpistop
             end if
             if ( trim(dtype) == "linear" ) then
                do j = 1, odims(2)
                do i = 1, odims(1)
                   olat_org(i,j) = real(swpoint+real(j-1)*dd, kind=RP) * d2r
                enddo
                enddo
             else if ( trim(dtype) == "map" ) then
                call read_grads_file_2d(io_fid_grads_data,gfile,odims(1),odims(2),1,1,item,startrec,totalrec,yrev,gsst2d)
                olat_org(:,:) = real(gsst2D(:,:), kind=RP) * d2r
             endif
          end if
       case("lat_sst")
          if ( .not. data_available(io_lat_sst,3) ) cycle
          if ( trim(dtype) == "linear" ) then
             do j = 1, odims(2)
             do i = 1, odims(1)
                olat_org(i,j) = real(swpoint+real(j-1)*dd, kind=RP) * d2r
             enddo
             enddo
          else if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,odims(1),odims(2),1,1,item,startrec,totalrec,yrev,gsst2d)
             olat_org(:,:) = real(gsst2D(:,:), kind=RP) * d2r
          endif
       case('SKINT')
          if ( .not. data_available(io_sst,3) ) then
             if ( odims(1).ne.outer_nx_sfc .or. odims(2).ne.outer_ny_sfc ) then
                write(*,*) 'xxx dimsntion is different: outer_nx_sst/outer_nx_sfc and outer_nx_sst! ', odims(1), outer_nx_sfc
                write(*,*) '                          : outer_ny_sst/outer_ny_sfc and outer_ny_sst! ', odims(2), outer_ny_sfc
                call prc_mpistop
             end if
             if ( trim(dtype) == "map" ) then
                call read_grads_file_2d(io_fid_grads_data,gfile,odims(1),odims(2),1,nt,item,startrec,totalrec,yrev,gsst2d)
                do j = 1, odims(2)
                do i = 1, odims(1)
                   if ( abs(gsst2d(i,j)-missval) < eps ) then
                      sst_org(i,j) = undef
                   else
                      sst_org(i,j) = real(gsst2D(i,j), kind=rp)
                   end if
                enddo
                enddo
             end if
          endif
       case('SST')
          if ( .not. data_available(io_sst,3) ) cycle
          if ( trim(dtype) == "map" ) then
             call read_grads_file_2d(io_fid_grads_data,gfile,odims(1),odims(2),1,nt,item,startrec,totalrec,yrev,gsst2d)
             do j = 1, odims(2)
             do i = 1, odims(1)
                if ( abs(gsst2d(i,j)-missval) < eps ) then
                   sst_org(i,j) = undef
                else
                   sst_org(i,j) = real(gsst2D(i,j), kind=rp)
                end if
             enddo
             enddo
          end if
       end select
    enddo loop_inputoceangrads

    tw_org = sst_org

    !do it = 1, nt
    !   i=int(dims(8)/2) ; j=int(dims(9)/2)
    !   write(*,*) "read 2D grads data",dims(8),dims(9),i,j,it
    !   write(*,*) "lon_org    ",lon_org  (i,j)
    !   write(*,*) "lat_org    ",lat_org  (i,j)
    !   write(*,*) "sst_org    ",sst_org  (i,j)
    !   write(*,*) "lst_org  ",lst_org(i,j)
    !   do k=1,dims(7)
    !      write(*,*) "tg_org    ",tg_org   (k,i,j)," k= ",k
    !      write(*,*) "strg_org  ",strg_org (k,i,j)," k= ",k
    !   enddo
    !enddo

    return

Here is the call graph for this function:

Here is the caller graph for this function:

read_namelist()

subroutine mod_realinput_grads::read_namelist	(	character(len=h_short), dimension (:), intent(out)	grads_item,
		character(len=h_long), dimension (:), intent(out)	grads_fname,
		character(len=h_long), dimension (:), intent(out)	grads_dtype,
		real(rp), dimension (:), intent(out)	grads_swpoint,
		real(rp), dimension (:), intent(out)	grads_dd,
		integer, dimension (:), intent(out)	grads_lnum,
		real(rp), dimension (:,:), intent(out)	grads_lvars,
		integer, dimension(:), intent(out)	grads_startrec,
		integer, dimension(:), intent(out)	grads_totalrec,
		integer, dimension (:), intent(out)	grads_knum,
		character(len=h_short), dimension (:), intent(out)	grads_yrev,
		character(len=h_short), dimension (:), intent(out)	grads_fendian,
		real(sp), dimension (:), intent(out)	grads_missval,
		logical, dimension(:), intent(out)	data_available,
		character(len=h_short), dimension (:), intent(in)	item_list,
		integer, intent(in)	num_item_list,
		character(len=*), intent(in)	basename,
		integer, intent(in)	io_fid_grads_nml
	)

Definition at line 1708 of file mod_realinput_grads.f90.

References scale_stdio::io_fid_log, scale_stdio::io_l, and scale_process::prc_mpistop().

Referenced by parentatomsetupgrads(), parentlandsetupgrads(), and parentoceansetupgrads().

    implicit none
    character(len=H_SHORT), intent(out) :: grads_item    (:)
    character(len=H_LONG),  intent(out) :: grads_fname   (:)
    character(len=H_LONG),  intent(out) :: grads_dtype   (:)
    real(RP),               intent(out) :: grads_swpoint (:)
    real(RP),               intent(out) :: grads_dd      (:)
    integer,                intent(out) :: grads_lnum    (:)
    real(RP),               intent(out) :: grads_lvars   (:,:)
    integer,                intent(out) :: grads_startrec(:)
    integer,                intent(out) :: grads_totalrec(:)
    integer,                intent(out) :: grads_knum    (:)
    character(len=H_SHORT), intent(out) :: grads_yrev    (:)
    character(len=H_SHORT), intent(out) :: grads_fendian (:)
    real(SP),               intent(out) :: grads_missval (:)
    logical,                intent(out) :: data_available(:)
    character(len=H_SHORT), intent(in)  :: item_list     (:)
    integer,                intent(in)  :: num_item_list
    character(len=*),       intent(in)  :: basename
    integer,                intent(in)  :: io_fid_grads_nml

    integer :: grads_vars_nmax
    integer :: k, n, ielem, ierr

    namelist /grdvar/ &
         item,      &  ! necessary
         dtype,     &  ! necessary
         fname,     &  ! necessary except for linear data
         swpoint,   &  ! for linear data
         dd,        &  ! for linear data
         lnum,      &  ! for levels data
         lvars,     &  ! for levels data
         startrec,  &  ! for map data
         totalrec,  &  ! for map data
         missval,   &  ! option
         knum,      &  ! option
         yrev,      &  ! option
         fendian       ! option

    ! listup variables
    if ( io_fid_grads_nml > 0 ) then
       rewind( io_fid_grads_nml )
       grads_vars_nmax = 0
       do n = 1, grads_vars_limit
          read(io_fid_grads_nml, nml=grdvar, iostat=ierr)
          if( ierr > 0 )then
             if( io_l ) write(io_fid_log,*) 'xxx Not appropriate names in grdvar in ', trim(basename),'. Check!'
             call prc_mpistop
          else if( ierr < 0 )then
             exit
          endif
          grads_vars_nmax = grads_vars_nmax + 1
       enddo
    else
       if( io_l ) write(io_fid_log,*) 'xxx namelist file is not open! ', trim(basename)
       call prc_mpistop
    endif

    if ( grads_vars_nmax > grads_vars_limit ) then
       if( io_l ) write(io_fid_log,*) &
            'xxx The number of grads vars exceeds grads_vars_limit! ',grads_vars_nmax,' >', grads_vars_limit
       call prc_mpistop
    endif


    ! check data availability
    data_available(:) = .false.
    do ielem = 1, num_item_list
       if ( io_fid_grads_nml > 0 ) rewind( io_fid_grads_nml )
       do n = 1, grads_vars_nmax

          ! set default
          item     = ''
          dtype    = ''
          fname    = ''
          swpoint  = large_number_one
          dd       = large_number_one
          lnum     = -99
          lvars    = large_number_one
          startrec = -99
          totalrec = -99
          knum     = -99
          yrev     = 'off'
          fendian  = 'big'
          missval  = large_number_one

          ! read namelist
          if ( io_fid_grads_nml > 0 ) then
             read(io_fid_grads_nml, nml=grdvar, iostat=ierr)
             if( ierr /= 0 ) exit
          endif

          if(item == item_list(ielem))then
             grads_item(ielem) = item
             grads_fname(ielem) = fname
             grads_dtype(ielem) = dtype
             grads_swpoint(ielem) = swpoint
             grads_dd(ielem) = dd
             grads_lnum(ielem) = lnum
             do k = 1, lvars_limit
                grads_lvars(k,ielem) = lvars(k)
             enddo
             grads_startrec(ielem) = startrec
             grads_totalrec(ielem) = totalrec
             grads_knum(ielem) = knum
             grads_yrev(ielem) = yrev
             grads_fendian(ielem) = fendian
             grads_missval(ielem) = missval
             data_available(ielem) = .true.

             exit
          endif
       enddo ! n
       if( io_l ) write(io_fid_log,*) 'GrADS data availability ',trim(item_list(ielem)),data_available(ielem)
    enddo ! ielem

Here is the call graph for this function:

Here is the caller graph for this function: