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, dens_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

  
  
• grdvar

  name	type	default value	comment
  ITEM	character(len=*)
  DTYPE	character(len=H_SHORT)		'linear','levels','map'
  FNAME	character(len=H_LONG)		head of file name
  SWPOINT	real(RP)		start point (south-west point) for "linear"
  DD	real(RP)		dlon,dlat for "linear"
  LNUM	integer		number of data
  LVARS	real(RP), dimension(LVARS_LIMIT)	large_number_one	values for "levels"
  STARTREC	integer
  TOTALREC	integer
  MISSVAL	real(SP)		missing value
  KNUM	integer		optional: vertical level
  YREV	character(len=*)
  FENDIAN	character(len=H_SHORT)	'big' ! option for "map"

  
  

History Output

No history output

Function/Subroutine Documentation

parentatomsetupgrads()

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

Atmos Setup.

Definition at line 193 of file mod_realinput_grads.f90.

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

Referenced by mod_realinput::parentatomsetup().

    implicit none

    integer,          intent(out) :: dims(6)
    character(len=*), 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
       write(*,*) 'xxx [realinput_grads] Not appropriate names in namelist PARAM_MKINIT_REAL_GrADS. Check!'
       call prc_mpistop
    endif
    if( io_nml ) write(io_fid_nml,nml=param_mkinit_real_grads)


    if ( len_trim(basename) == 0 ) then
       write(*,*) 'xxx [realinput_grads] "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
       write(*,*) 'xxx [realinput_grads] 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
       write(*,*) 'xxx [realinput_grads] Not appropriate names in nml_grads_grid in ', trim(basename),'. Check!'
       call prc_mpistop
    endif
    if( io_nml ) write(io_fid_nml,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)

    close( io_fid_grads_nml )

    do ielem = 1, num_item_list_atom
       item  = item_list_atom(ielem)
       !--- check data
       select case(trim(item))
       case('DENS','W','QC','QR','QI','QS','QG','MSLP','PSFC','U10','V10','T2','Q2','TOPO')
          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('QV')
          if (.not. data_available(ia_qv,1)) then
             if (.not.data_available(ia_rh,1)) then
                write(*,*) 'xxx [realinput_grads] 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
                   write(*,*) 'xxx [realinput_grads] Temperature and pressure are required to convert from RH to QV ! '
                   call prc_mpistop
                else
                   cycle ! read RH and estimate QV
                endif
             else
                write(*,*) 'xxx [realinput_grads] Not found in grads namelist! : QV and RH'
                call prc_mpistop
             endif
          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 default ! lon, lat, plev, U, V, T, HGT
          if ( .not. data_available(ielem,1) ) then
             write(*,*) 'xxx [realinput_grads] 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 342 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)	dens_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 364 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_const::const_undef, scale_atmos_hydrometeor::i_qc, scale_atmos_hydrometeor::i_qg, scale_atmos_hydrometeor::i_qi, scale_atmos_hydrometeor::i_qr, scale_atmos_hydrometeor::i_qs, scale_atmos_hydrometeor::i_qv, scale_stdio::io_fid_log, scale_stdio::io_get_available_fid(), scale_stdio::io_l, scale_process::prc_mpistop(), and scale_tracer::qa.

Referenced by mod_realinput::parentatomsetup().

    use scale_const, only: &
       undef => const_undef, &
       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_hydrometeor, only: &
       i_qv, &
       i_qc, &
       i_qr, &
       i_qi, &
       i_qs, &
       i_qg
    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) :: dens_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

    real(RP) :: RovCP
    real(RP) :: CPovR

    integer  :: lm_layer(dims(2),dims(3))

    ! data
    character(len=H_LONG) :: gfile

    real(RP) :: p_sat, qm, rhsfc, dz
    real(RP) :: lp2, lp3

    integer  :: i, j, k, iq, ielem

    logical  :: pressure_coordinates
    !---------------------------------------------------------------------------

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

    dens_org(:,:,:)   = undef ! read data or set data by build-rho-3D
    velz_org(:,:,:)   = 0.0_rp
    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)
       missval  = grads_missval(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
             pressure_coordinates = .true. ! use pressure coordinate in the input data
             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
             pressure_coordinates = .false.
             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)
                ! replace missval with UNDEF
                if( abs( pres_org(k+2,i,j) - missval ) < eps ) then
                   pres_org(k+2,i,j) = undef
                end if
             enddo
             enddo
             enddo
          endif
       case('DENS')
          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
                   dens_org(k+2,i,j) = real(gdata3D(i,j,k), kind=rp)
                   ! replace missval with UNDEF
                   if( abs( dens_org(k+2,i,j) - missval ) < eps ) then
                      dens_org(k+2,i,j) = undef
                   end if
                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)
                   ! replace missval with UNDEF
                   if( abs( velx_org(k+2,i,j) - missval ) < eps ) then
                      velx_org(k+2,i,j) = undef
                   end if
                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)
                   ! replace missval with UNDEF
                   if( abs( vely_org(k+2,i,j) - missval ) < eps ) then
                      vely_org(k+2,i,j) = undef
                   end if
                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('W')
          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)
                velz_org(1:2,i,j) = 0.0_rp
                do k = 1, knum
                   velz_org(k+2,i,j) = real(gdata3D(i,j,k), kind=rp)
                   ! replace missval with UNDEF
                   if( abs( velz_org(k+2,i,j) - missval ) < eps ) then
                      velz_org(k+2,i,j) = undef
                   end if
                enddo
             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)
                   ! replace missval with UNDEF
                   if( abs( temp_org(k+2,i,j) - missval ) < eps ) then
                      temp_org(k+2,i,j) = undef
                   end if
                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) == "levels" ) then
             if(dims(1)/=lnum)then
                write(*,*) 'xxx lnum must be same as the outer_nz for HGT! ',dims(1),lnum
                call prc_mpistop
             endif
             do j = 1, dims(3)
             do i = 1, dims(2)
                do k = 1, dims(1)
                   cz_org(k+2,i,j) = real(lvars(k), kind=rp)
                enddo
                cz_org(1,i,j) = 0.0_rp
             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)
                   cz_org(k+2,i,j) = real(gdata3D(i,j,k), kind=rp)
                   ! replace missval with UNDEF
                   if( abs( cz_org(k+2,i,j) - missval ) < eps ) then
                      cz_org(k+2,i,j) = undef
                   end if
                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,i_qv) = real(gdata3D(i,j,k), kind=rp)
                   ! replace missval with UNDEF
                   if( abs( qtrc_org(k+2,i,j,i_qv) - missval ) < eps ) then
                      qtrc_org(k+2,i,j,i_qv) = undef
                   end if
                enddo
                qtrc_org(1:2,i,j,i_qv) = qtrc_org(3,i,j,i_qv)
             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,i_qv) = qtrc_org(knum+2,i,j,i_qv)
                   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('QC')
          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,i_qc) = real(gdata3D(i,j,k), kind=rp)
                   ! replace missval with UNDEF
                   if( abs( qtrc_org(k+2,i,j,i_qc) - missval ) < eps ) then
                      qtrc_org(k+2,i,j,i_qc) = undef
                   end if
                enddo
                qtrc_org(1:2,i,j,i_qc) = qtrc_org(3,i,j,i_qc)
             enddo
             enddo
          endif
       case('QR')
          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,i_qr) = real(gdata3D(i,j,k), kind=rp)
                   ! replace missval with UNDEF
                   if( abs( qtrc_org(k+2,i,j,i_qr) - missval ) < eps ) then
                      qtrc_org(k+2,i,j,i_qr) = undef
                   end if
                enddo
                qtrc_org(1:2,i,j,i_qr) = qtrc_org(3,i,j,i_qr)
             enddo
             enddo
          endif
       case('QI')
          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,i_qi) = real(gdata3D(i,j,k), kind=rp)
                   ! replace missval with UNDEF
                   if( abs( qtrc_org(k+2,i,j,i_qi) - missval ) < eps ) then
                      qtrc_org(k+2,i,j,i_qi) = undef
                   end if
                enddo
                qtrc_org(1:2,i,j,i_qi) = qtrc_org(3,i,j,i_qi)
             enddo
             enddo
          endif
       case('QS')
          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,i_qs) = real(gdata3D(i,j,k), kind=rp)
                   ! replace missval with UNDEF
                   if( abs( qtrc_org(k+2,i,j,i_qs) - missval ) < eps ) then
                      qtrc_org(k+2,i,j,i_qs) = undef
                   end if
                enddo
                qtrc_org(1:2,i,j,i_qs) = qtrc_org(3,i,j,i_qs)
             enddo
             enddo
          endif
       case('QG')
          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,i_qg) = real(gdata3D(i,j,k), kind=rp)
                   ! replace missval with UNDEF
                   if( abs( qtrc_org(k+2,i,j,i_qg) - missval ) < eps ) then
                      qtrc_org(k+2,i,j,i_qg) = undef
                   end if
                enddo
                qtrc_org(1:2,i,j,i_qg) = qtrc_org(3,i,j,i_qg)
             enddo
             enddo
          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
                   qtrc_org(k+2,i,j,i_qv) = real(gdata3D(i,j,k), kind=rp)
                   ! replace missval with UNDEF
                   if( abs( qtrc_org(k+2,i,j,i_qv) - missval ) < eps ) then
                      qtrc_org(k+2,i,j,i_qv) = undef
                   else
                      rhprs_org(k+2,i,j) = qtrc_org(k+2,i,j,i_qv) / 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,i_qv) = qm / ( 1.0_rp + qm )            ! specific humidity
                   end if
                enddo
                qtrc_org(1:2,i,j,i_qv) = qtrc_org(3,i,j,i_qv)
             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,i_qv) = qm / ( 1.0_rp + qm )           ! specific humidity
                      qtrc_org(k+2,i,j,i_qv) = min(qtrc_org(k+2,i,j,i_qv),qtrc_org(k+1,i,j,i_qv))
                   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)
                ! replace missval with UNDEF
                if( abs( pres_org(1,i,j) - missval ) < eps ) then
                   pres_org(1,i,j) = undef
                end if
             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)
                ! replace missval with UNDEF
                if( abs( pres_org(2,i,j) - missval ) < eps ) then
                   pres_org(2,i,j) = undef
                end if
             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)
                ! replace missval with UNDEF
                if( abs( velx_org(2,i,j) - missval ) < eps ) then
                   velx_org(2,i,j) = undef
                end if
             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)
                ! replace missval with UNDEF
                if( abs( vely_org(2,i,j) - missval ) < eps ) then
                   vely_org(2,i,j) = undef
                end if
             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)
                ! replace missval with UNDEF
                if( abs( temp_org(2,i,j) - missval ) < eps ) then
                   temp_org(2,i,j) = undef
                end if
             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,i_qv) = real(gdata2D(i,j), kind=rp)
                ! replace missval with UNDEF
                if( abs( qtrc_org(2,i,j,i_qv) - missval ) < eps ) then
                   qtrc_org(2,i,j,i_qv) = undef
                end if
             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)
                qtrc_org(2,i,j,i_qv) = real(gdata2D(i,j), kind=rp)
                ! replace missval with UNDEF
                if( abs( qtrc_org(2,i,j,i_qv) - missval ) < eps ) then
                   qtrc_org(2,i,j,i_qv) = undef
                else
                   rhsfc = qtrc_org(2,i,j,i_qv) / 100.0_rp
                   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,i_qv) = qm / ( 1.0_rp + qm ) ! specific humidity
                end if
             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)
                ! replace missval with UNDEF
                if( abs( cz_org(2,i,j) - missval ) < eps ) then
                   cz_org(2,i,j) = undef
                end if
             enddo
             enddo
          endif
       end select
    enddo loop_inputatomgrads

    lm_layer(:,:) = 3

    do j = 1, dims(3)
    do i = 1, dims(2)
    do k = 3, dims(1)+2
      ! search the lowermost layer excluding UNDEF
      if( abs( pres_org(k,i,j) - undef ) < eps ) then
        lm_layer(i,j) = k + 1
      else
        exit
      end if
    end do
    end do
    end do

    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)
          dens_org(2,i,j) = pres_org(2,i,j) / ( rdry * temp_org(2,i,j) )
       end do
       end do
    else if ( data_available(ia_ps,1) ) then
       if ( data_available(ia_topo,1) ) then
          do j = 1, dims(3)
          do i = 1, dims(2)
             k = lm_layer(i,j)
             dz = cz_org(k,i,j) - cz_org(2,i,j)
             dens_org(2,i,j) = ( pres_org(k,i,j) - pres_org(2,i,j) ) * 2.0_rp / ( grav * dz ) &
                             - dens_org(k,i,j) 
             temp_org(2,i,j) = pres_org(2,i,j) / ( rdry * dens_org(2,i,j) )
          end do
          end do
       else
          do j = 1, dims(3)
          do i = 1, dims(2)
             k = lm_layer(i,j)
             dz = cz_org(k,i,j) - cz_org(2,i,j)
             temp_org(2,i,j) = temp_org(k,i,j)
             dens_org(2,i,j) = pres_org(2,i,j) / ( rdry * temp_org(2,i,j) )
          end do
          end do
       end if
    else if ( data_available(ia_topo,1) ) then
       if ( .not. data_available(ia_t2,1) ) then
          do j = 1, dims(3)
          do i = 1, dims(2)
             k = lm_layer(i,j)
             dz = cz_org(k,i,j) - cz_org(2,i,j)
             temp_org(2,i,j) = temp_org(k,i,j) + laps * dz
          end do
          end do
       end if
       do j = 1, dims(3)
       do i = 1, dims(2)
          k = lm_layer(i,j)
          dz = cz_org(k,i,j) - cz_org(2,i,j)

          dens_org(2,i,j) = ( pres_org(k,i,j) + grav * dens_org(k,i,j) * dz * 0.5_rp ) &
                          / ( rdry * temp_org(2,i,j) - grav * dz * 0.5_rp )
          pres_org(2,i,j) = dens_org(2,i,j) * rdry * temp_org(2,i,j)
       end do
       end do
    else
       do j = 1, dims(3)
       do i = 1, dims(2)
          k = lm_layer(i,j)
          temp_org(2,i,j) = temp_org(k,i,j)
          dens_org(2,i,j) = dens_org(k,i,j)
          pres_org(2,i,j) = pres_org(k,i,j)
       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)
          k = lm_layer(i,j)
          if ( pres_org(2,i,j) < pres_org(1,i,j) ) then
             lp2 = log( pres_org(2,i,j) / pres_org(1,i,j) )
          else
             lp2 = 1.0_rp
          end if
          if ( pres_org(k,i,j) < pres_org(1,i,j) ) then
             lp3 = log( pres_org(k,i,j) / pres_org(1,i,j) )
          else
             lp3 = 1.0_rp
          end if
          cz_org(2,i,j) = max( 0.0_rp, cz_org(k,i,j) * lp2 / lp3 )
       end do
       end do
    end if


    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
    if ( data_available(ia_slp,1) ) then
       do j = 1, dims(3)
       do i = 1, dims(2)
          dens_org(1,i,j) = pres_org(1,i,j) / ( rdry * temp_org(1,i,j) )
       end do
       end do
    else
       do j = 1, dims(3)
       do i = 1, dims(2)
          dens_org(1,i,j) = ( pres_org(2,i,j) + grav * dens_org(2,i,j) * cz_org(2,i,j) * 0.5_rp ) &
                          / ( rdry * temp_org(1,i,j) - grav * cz_org(2,i,j) * 0.5_rp )
          pres_org(1,i,j) = dens_org(1,i,j) * rdry * temp_org(1,i,j)
       end do
       end do
    end if

    ! check verticaly extrapolated data in outer model
    if( pressure_coordinates ) then
      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)
          dens_org(k,i,j)   = dens_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
    else
      do j = 1, dims(3)
      do i = 1, dims(2)
      do k = 3, dims(1)+2
        if( abs( velz_org(k,i,j) - undef ) < eps ) velz_org(k,i,j) = velz_org(2,i,j)
        if( abs( velx_org(k,i,j) - undef ) < eps ) velx_org(k,i,j) = velx_org(2,i,j)
        if( abs( vely_org(k,i,j) - undef ) < eps ) vely_org(k,i,j) = vely_org(2,i,j)
        if( abs( pres_org(k,i,j) - undef ) < eps ) pres_org(k,i,j) = pres_org(2,i,j)
        if( abs( dens_org(k,i,j) - undef ) < eps ) dens_org(k,i,j) = dens_org(2,i,j)
        if( abs( temp_org(k,i,j) - undef ) < eps ) temp_org(k,i,j) = temp_org(2,i,j)
        do iq = 1, qa
          if( abs( qtrc_org(k,i,j,iq) - undef ) < eps ) qtrc_org(k,i,j,iq) = 0.0_rp
        end do
      enddo
      enddo
      enddo
    end if

    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 1106 of file mod_realinput_grads.f90.

References scale_stdio::io_fid_log, scale_stdio::io_fid_nml, scale_stdio::io_get_available_fid(), scale_stdio::io_l, scale_stdio::io_nml, 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
       write(*,*) 'xxx [realinput_grads] "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
       write(*,*) 'xxx [realinput_grads] 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
       write(*,*) 'xxx [realinput_grads] Not appropriate names in nml_grads_grid in ', trim(basename),'. Check!'
       call prc_mpistop
    endif
    if( io_nml ) write(io_fid_nml,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)

    close( io_fid_grads_nml )

    do ielem = 1, num_item_list_land
       item  = item_list_land(ielem)
       !--- check data
       select case(trim(item))
       case('TOPO','TOPO_sfc', '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
                write(*,*) 'xxx [realinput_grads] 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
             write(*,*) 'xxx [realinput_grads] 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 1236 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 ( .not. data_available(il_topo_sfc,2) ) then
             if ( ldims(2)==outer_nx .or. ldims(3)==outer_ny ) 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
                end if
             else
                topo_org = undef
             endif
          end if
       case('TOPO_sfc')
          if ( data_available(il_topo_sfc,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 if ( .not. data_available(il_topo,2) ) then
             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 1559 of file mod_realinput_grads.f90.

References scale_stdio::io_fid_log, scale_stdio::io_fid_nml, scale_stdio::io_get_available_fid(), scale_stdio::io_l, scale_stdio::io_nml, 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
       write(*,*) 'xxx [realinput_grads] 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
       write(*,*) 'xxx [realinput_grads] Not appropriate names in nml_grads_grid in ', trim(grads_ctl),'. Check!'
       call prc_mpistop
    endif
    if( io_nml ) write(io_fid_nml,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)

    close( io_fid_grads_nml )

    do ielem = 1, num_item_list_ocean
       item  = item_list_ocean(ielem)
       !--- check data
       select case(trim(item))
       case('lsmask','lsmask_sst')
          if ( .not. data_available(io_lsmask,3) .and. .not. data_available(io_lsmask_sst,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
             write(*,*) 'xxx [realinput_grads] 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
             write(*,*) 'xxx [realinput_grads/ParentOceanSetupGrADS] 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 1686 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 1703 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 ( .not. data_available(io_lsmask_sst,3) .and. data_available(io_lsmask,3) ) then
             if ( odims(1)==outer_nx_sfc .and. odims(2)==outer_ny_sfc ) 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
          end if
       case("lsmask_sst")
          if ( data_available(io_lsmask_sst,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 if ( .not. data_available(io_lsmask,3) ) then
             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_sfc .or. odims(2).ne.outer_ny_sfc ) 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=*), 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 1972 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=*),       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
             write(*,*) 'xxx [realinput_grads/read_namelist] 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
       write(*,*) 'xxx [realinput_grads/read_namelist] namelist file is not open! ', trim(basename)
       call prc_mpistop
    endif

    if ( grads_vars_nmax > grads_vars_limit ) then
       write(*,*) 'xxx [realinput_grads/read_namelist] 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: