!--------------------------------------------------------------------------- ! ! WRF Parallel I/O ! Author: Wei Huang huangwei@ucar.edu ! Date: June 01, 2014 ! !--------------------------------------------------------------------------- !$Id$ !--------------------------------------------------------------------------- module pio_routines use pio_kinds use pio use module_domain use wrf_data_pio implicit none include 'mpif.h' integer(i4) :: nprocs, myrank integer :: ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte CONTAINS subroutine allocHandle(DataHandle,DH,Status) implicit none include 'wrf_status_codes.h' integer ,intent(out) :: DataHandle type(wrf_data_handle),pointer :: DH integer ,intent(out) :: Status integer :: i, n integer :: stat do i=1,WrfDataHandleMax if(WrfDataHandles(i)%Free) then DH => WrfDataHandles(i) DataHandle = i do n = 1, MaxVars DH%vartype(n) = NOT_LAND_SOIL_VAR end do exit endif if(i==WrfDataHandleMax) then Status = WRF_WARN_TOO_MANY_FILES write(msg,*) 'Warning TOO MANY FILES in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) write(msg,*) 'Did you call ext_pio_ioinit?' call wrf_debug ( WARN , TRIM(msg)) return endif enddo DH%Free =.false. DH%Write =.false. DH%first_operation = .TRUE. DH%CurrentVariable = 0 Status = WRF_NO_ERR end subroutine allocHandle subroutine deallocHandle(DataHandle, Status) implicit none include 'wrf_status_codes.h' integer ,intent(in) :: DataHandle integer ,intent(out) :: Status type(wrf_data_handle),pointer :: DH integer :: i integer :: stat IF ( DataHandle .GE. 1 .AND. DataHandle .LE. WrfDataHandleMax ) THEN if(.NOT. WrfDataHandles(DataHandle)%Free) then DH => WrfDataHandles(DataHandle) DH%Free =.TRUE. endif !deallocate(DH%iosystem) ENDIF Status = WRF_NO_ERR end subroutine deallocHandle subroutine GetDH(DataHandle,DH,Status) implicit none include 'wrf_status_codes.h' integer ,intent(in) :: DataHandle type(wrf_data_handle) ,pointer :: DH integer ,intent(out) :: Status if(DataHandle < 1 .or. DataHandle > WrfDataHandleMax) then Status = WRF_WARN_BAD_DATA_HANDLE return endif DH => WrfDataHandles(DataHandle) if(DH%Free) then Status = WRF_WARN_BAD_DATA_HANDLE return endif Status = WRF_NO_ERR return end subroutine GetDH subroutine DateCheck(Date,Status) implicit none include 'wrf_status_codes.h' character*(*) ,intent(in) :: Date integer ,intent(out) :: Status if(len(Date) /= DateStrLen) then Status = WRF_WARN_DATESTR_BAD_LENGTH else Status = WRF_NO_ERR endif return end subroutine DateCheck subroutine GetName(Element,Var,Name,Status) implicit none include 'wrf_status_codes.h' character*(*) ,intent(in) :: Element character*(*) ,intent(in) :: Var character*(*) ,intent(out) :: Name integer ,intent(out) :: Status character (VarNameLen) :: VarName character (1) :: c integer :: i integer, parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') VarName = Var Name = 'MD___'//trim(Element)//VarName do i=1,len(Name) c=Name(i:i) if('A'<=c .and. c <='Z') Name(i:i)=achar(iachar(c)+upper_to_lower) if(c=='-'.or.c==':') Name(i:i)='_' enddo Status = WRF_NO_ERR return end subroutine GetName subroutine GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) implicit none include 'wrf_status_codes.h' character (*) ,intent(in) :: IO integer ,intent(in) :: DataHandle character*(*) ,intent(in) :: DateStr integer ,intent(out) :: TimeIndex integer ,intent(out) :: Status type(wrf_data_handle) ,pointer :: DH integer :: VStart(2) integer :: VCount(2) integer :: stat integer :: i character(len=DateStrLen) :: tmpdatestr(1) if(len(Datestr) == DateStrLen) then tmpdatestr = DateStr else write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ write(unit=0, fmt='(3a)') 'IO: <', trim(IO), '>' write(unit=0, fmt='(a,i3)') 'DataHandle = ', DataHandle write(unit=0, fmt='(3a)') 'DateStr: <', trim(DateStr), '>' write(unit=0, fmt='(a,i6,a,i6)') 'DateStrLen = ', DateStrLen, & ' did not equal len(DateStr): ', len(DateStr) Status = WRF_WARN_DATESTR_ERROR write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) return end if DH => WrfDataHandles(DataHandle) call DateCheck(DateStr,Status) if(Status /= WRF_NO_ERR) then Status = WRF_WARN_DATESTR_ERROR write(msg,*) 'Warning DATE STRING ERROR in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) return endif if(IO == 'write') then TimeIndex = DH%TimeIndex if(TimeIndex <= 0) then TimeIndex = 1 elseif(DateStr == DH%Times(TimeIndex)) then Status = WRF_NO_ERR return else TimeIndex = TimeIndex + 1 if(TimeIndex > MaxTimes) then Status = WRF_WARN_TIME_EOF write(msg,*) 'Warning TIME EOF in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) return endif endif DH%TimeIndex = TimeIndex DH%Times(TimeIndex) = DateStr VStart(1) = 1 VStart(2) = TimeIndex VCount(1) = DateStrLen VCount(2) = 1 !write(unit=0, fmt='(3a,i6)') 'DateStr: <', trim(DateStr), '>, TimeIndex =', TimeIndex stat = pio_put_var(DH%file_handle, DH%vtime, VStart, VCount, tmpdatestr) call netcdf_err(stat,Status) if(Status /= WRF_NO_ERR) then write(msg,*) 'NetCDF error in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) return endif !call pio_advanceframe(DH%vtime) else do i=1,MaxTimes if(DH%Times(i)==DateStr) then Status = WRF_NO_ERR TimeIndex = i exit endif if(i==MaxTimes) then Status = WRF_WARN_TIME_NF write(msg,*) 'Warning TIME ',DateStr,' NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) return endif enddo endif return end subroutine GetTimeIndex subroutine GetDim(MemoryOrder,NDim,Status) implicit none include 'wrf_status_codes.h' character*(*) ,intent(in) :: MemoryOrder integer ,intent(out) :: NDim integer ,intent(out) :: Status character*3 :: MemOrd call LowerCase(MemoryOrder,MemOrd) select case (MemOrd) case ('xyz','xzy','yxz','yzx','zxy','zyx','xsz','xez','ysz','yez') NDim = 3 case ('xy','yx','xs','xe','ys','ye') NDim = 2 case ('z','c') NDim = 1 case ('0') ! NDim=0 for scalars. TBH: 20060502 NDim = 0 case default print *, 'memory order = ',MemOrd,' ',MemoryOrder Status = WRF_WARN_BAD_MEMORYORDER return end select Status = WRF_NO_ERR return end subroutine GetDim subroutine GetIndices(NDim,Start,End,i1,i2,j1,j2,k1,k2) implicit none include 'wrf_status_codes.h' integer ,intent(in) :: NDim integer ,dimension(*),intent(in) :: Start,End integer ,intent(out) :: i1,i2,j1,j2,k1,k2 i1=1 i2=1 j1=1 j2=1 k1=1 k2=1 if(NDim == 0) return ! NDim=0 for scalars. TBH: 20060502 i1 = Start(1) i2 = End (1) if(NDim == 1) return j1 = Start(2) j2 = End (2) if(NDim == 2) return k1 = Start(3) k2 = End (3) return end subroutine GetIndices logical function ZeroLengthHorzDim(MemoryOrder,Vector,Status) implicit none include 'wrf_status_codes.h' character*(*) ,intent(in) :: MemoryOrder integer,dimension(*) ,intent(in) :: Vector integer ,intent(out) :: Status integer :: NDim integer,dimension(NVarDims) :: temp character*3 :: MemOrd logical zero_length call GetDim(MemoryOrder,NDim,Status) temp(1:NDim) = Vector(1:NDim) call LowerCase(MemoryOrder,MemOrd) zero_length = .false. select case (MemOrd) case ('xsz','xez','ysz','yez','xs','xe','ys','ye','z','c') continue case ('0') continue ! NDim=0 for scalars. TBH: 20060502 case ('xzy','yzx') zero_length = temp(1) .lt. 1 .or. temp(3) .lt. 1 case ('xy','yx','xyz','yxz') zero_length = temp(1) .lt. 1 .or. temp(2) .lt. 1 case ('zxy','zyx') zero_length = temp(2) .lt. 1 .or. temp(3) .lt. 1 case default Status = WRF_WARN_BAD_MEMORYORDER ZeroLengthHorzDim = .true. return end select Status = WRF_NO_ERR ZeroLengthHorzDim = zero_length return end function ZeroLengthHorzDim subroutine ExtOrder(MemoryOrder,Vector,Status) implicit none include 'wrf_status_codes.h' character*(*) ,intent(in) :: MemoryOrder integer,dimension(*) ,intent(inout) :: Vector integer ,intent(out) :: Status integer :: NDim integer,dimension(NVarDims) :: temp character*3 :: MemOrd call GetDim(MemoryOrder,NDim,Status) temp(1:NDim) = Vector(1:NDim) call LowerCase(MemoryOrder,MemOrd) select case (MemOrd) case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') continue case ('0') continue ! NDim=0 for scalars. TBH: 20060502 case ('xzy') Vector(2) = temp(3) Vector(3) = temp(2) case ('yxz') Vector(1) = temp(2) Vector(2) = temp(1) case ('yzx') Vector(1) = temp(3) Vector(2) = temp(1) Vector(3) = temp(2) case ('zxy') Vector(1) = temp(2) Vector(2) = temp(3) Vector(3) = temp(1) case ('zyx') Vector(1) = temp(3) Vector(3) = temp(1) case ('yx') Vector(1) = temp(2) Vector(2) = temp(1) case default Status = WRF_WARN_BAD_MEMORYORDER return end select Status = WRF_NO_ERR return end subroutine ExtOrder subroutine ExtOrderStr(MemoryOrder,Vector,ROVector,Status) implicit none include 'wrf_status_codes.h' character*(*) ,intent(in) :: MemoryOrder character*(*),dimension(*) ,intent(in) :: Vector character(80),dimension(NVarDims),intent(out) :: ROVector integer ,intent(out) :: Status integer :: NDim character*3 :: MemOrd call GetDim(MemoryOrder,NDim,Status) ROVector(1:NDim) = Vector(1:NDim) call LowerCase(MemoryOrder,MemOrd) select case (MemOrd) case ('xyz','xsz','xez','ysz','yez','xy','xs','xe','ys','ye','z','c') continue case ('0') continue ! NDim=0 for scalars. TBH: 20060502 case ('xzy') ROVector(2) = Vector(3) ROVector(3) = Vector(2) case ('yxz') ROVector(1) = Vector(2) ROVector(2) = Vector(1) case ('yzx') ROVector(1) = Vector(3) ROVector(2) = Vector(1) ROVector(3) = Vector(2) case ('zxy') ROVector(1) = Vector(2) ROVector(2) = Vector(3) ROVector(3) = Vector(1) case ('zyx') ROVector(1) = Vector(3) ROVector(3) = Vector(1) case ('yx') ROVector(1) = Vector(2) ROVector(2) = Vector(1) case default Status = WRF_WARN_BAD_MEMORYORDER return end select Status = WRF_NO_ERR return end subroutine ExtOrderStr subroutine LowerCase(MemoryOrder,MemOrd) implicit none include 'wrf_status_codes.h' character*(*) ,intent(in) :: MemoryOrder character*(*) ,intent(out) :: MemOrd character*1 :: c integer ,parameter :: upper_to_lower =IACHAR('a')-IACHAR('A') integer :: i,N MemOrd = ' ' N = len(MemoryOrder) MemOrd(1:N) = MemoryOrder(1:N) do i=1,N c = MemoryOrder(i:i) if('A'<=c .and. c <='Z') MemOrd(i:i)=achar(iachar(c)+upper_to_lower) enddo return end subroutine LowerCase subroutine UpperCase(MemoryOrder,MemOrd) implicit none include 'wrf_status_codes.h' character*(*) ,intent(in) :: MemoryOrder character*(*) ,intent(out) :: MemOrd character*1 :: c integer ,parameter :: lower_to_upper =IACHAR('A')-IACHAR('a') integer :: i,N MemOrd = ' ' N = len(MemoryOrder) MemOrd(1:N) = MemoryOrder(1:N) do i=1,N c = MemoryOrder(i:i) if('a'<=c .and. c <='z') MemOrd(i:i)=achar(iachar(c)+lower_to_upper) enddo return end subroutine UpperCase subroutine netcdf_err(err,Status) implicit none include 'wrf_status_codes.h' integer ,intent(in) :: err integer ,intent(out) :: Status character(len=80) :: errmsg integer :: stat if(err == PIO_NOERR)then Status = WRF_NO_ERR else write(msg,*) 'NetCDF error: ', 'from PIO' call wrf_debug ( WARN , TRIM(msg)) Status = WRF_WARN_NETCDF endif return end subroutine netcdf_err subroutine find_iodesc(DH,MemoryOrder,Stagger,FieldTYpe,whole) implicit none type(wrf_data_handle), pointer :: DH character*(*), intent(in) :: MemoryOrder character*(*), intent(in) :: Stagger integer, intent(in) :: FieldType logical, intent(out) :: whole character*3 :: MemOrd character*1 :: Stag integer ,parameter :: MaxUpperCase=IACHAR('Z') whole = .false. call LowerCase(MemoryOrder,MemOrd) call LowerCase(Stagger,Stag) select case (MemOrd) case ('xzy') select case (FieldType) case (WRF_REAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_u_real case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_v_real case ('z') if(LAND_CAT_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_land_real else if(SOIL_CAT_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_real else if(SOIL_LAYERS_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_layers_real else if(MDL_CPL_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_mdl_cpl_real else if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_real else DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_w_real endif case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_real end select case (WRF_DOUBLE) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_u_double case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_v_double case ('z') if(LAND_CAT_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_land_double else if(SOIL_CAT_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_double else if(SOIL_LAYERS_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_layers_double else if(MDL_CPL_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_mdl_cpl_double else if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_double else DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_w_double endif case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_double end select case (WRF_INTEGER) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_v_int case ('z') if(LAND_CAT_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_land_int else if(SOIL_CAT_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_int else if(SOIL_LAYERS_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_layers_int else if(MDL_CPL_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_mdl_cpl_int else if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_int else DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_w_int endif case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_int end select case (WRF_LOGICAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_v_int case ('z') if(LAND_CAT_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_land_int else if(SOIL_CAT_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_int else if(SOIL_LAYERS_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_soil_layers_int else if(MDL_CPL_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_mdl_cpl_int else if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_int else DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_w_int endif case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_int end select case default write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) whole = .true. return end select case ('xy') select case (FieldType) case (WRF_REAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_u_real case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_v_real case default DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_m_real end select case (WRF_DOUBLE) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_u_double case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_v_double case default DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_m_double end select case (WRF_INTEGER) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_v_int case default DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_m_int end select case (WRF_LOGICAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_v_int case default DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_m_int end select case default write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) whole = .true. return end select case ('xsz') DH%vartype(DH%CurrentVariable) = BDY_VAR select case (FieldType) case (WRF_REAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_u_real case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_v_real case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_w_real case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_m_real end select case (WRF_DOUBLE) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_u_double case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_v_double case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_w_double case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_m_double end select case (WRF_INTEGER) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_v_int case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_w_int case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_m_int end select case (WRF_LOGICAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_v_int case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_w_int case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xsz_m_int end select case default write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) whole = .true. return end select case ('xez') DH%vartype(DH%CurrentVariable) = BDY_VAR select case (FieldType) case (WRF_REAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_u_real case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_v_real case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_w_real case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_m_real end select case (WRF_DOUBLE) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_u_double case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_v_double case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_w_double case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_m_double end select case (WRF_INTEGER) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_v_int case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_w_int case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_m_int end select case (WRF_LOGICAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_v_int case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_w_int case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_xez_m_int end select case default write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) whole = .true. return end select case ('ysz') DH%vartype(DH%CurrentVariable) = BDY_VAR select case (FieldType) case (WRF_REAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_u_real case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_v_real case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_w_real case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_m_real end select case (WRF_DOUBLE) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_u_double case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_v_double case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_w_double case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_m_double end select case (WRF_INTEGER) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_v_int case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_w_int case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_m_int end select case (WRF_LOGICAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_v_int case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_w_int case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ysz_m_int end select case default write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) whole = .true. return end select case ('yez') DH%vartype(DH%CurrentVariable) = BDY_VAR select case (FieldType) case (WRF_REAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_u_real case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_v_real case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_w_real case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_m_real end select case (WRF_DOUBLE) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_u_double case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_v_double case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_w_double case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_m_double end select case (WRF_INTEGER) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_v_int case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_w_int case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_m_int end select case (WRF_LOGICAL) select case (Stag) case ('x') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_u_int case ('y') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_v_int case ('z') DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_w_int case default DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_yez_m_int end select case default write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) whole = .true. return end select case ('xs') DH%vartype(DH%CurrentVariable) = BDY_VAR select case (FieldType) case (WRF_REAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xs_m_real case (WRF_DOUBLE) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xs_m_double case (WRF_INTEGER) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xs_m_int case (WRF_LOGICAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xs_m_int case default write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) whole = .true. return end select case ('xe') DH%vartype(DH%CurrentVariable) = BDY_VAR select case (FieldType) case (WRF_REAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xe_m_real case (WRF_DOUBLE) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xe_m_double case (WRF_INTEGER) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xe_m_int case (WRF_LOGICAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_xe_m_int case default write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) whole = .true. return end select case ('ys') DH%vartype(DH%CurrentVariable) = BDY_VAR select case (FieldType) case (WRF_REAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ys_m_real case (WRF_DOUBLE) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ys_m_double case (WRF_INTEGER) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ys_m_int case (WRF_LOGICAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ys_m_int case default write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) whole = .true. return end select case ('ye') DH%vartype(DH%CurrentVariable) = BDY_VAR select case (FieldType) case (WRF_REAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ye_m_real case (WRF_DOUBLE) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ye_m_double case (WRF_INTEGER) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ye_m_int case (WRF_LOGICAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc2d_ye_m_int case default write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) whole = .true. return end select case ('xyz') select case (Stag) case ('z') if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then select case (FieldType) case (WRF_REAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_real case (WRF_DOUBLE) DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_double case (WRF_INTEGER) DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_int case (WRF_LOGICAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_ensemble_int case default write(msg,*) 'Warning DO NOT KNOW HOW TO HANDLE this FieldType in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_real end select else write(msg,*) 'Warning DO NOT KNOW HOW TO HANDLE THIS VAR KIND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_w_double end if case default write(msg,*) 'Warning DO NOT KNOW HOW TO HANDLE THIS STAG in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) DH%ioVar(DH%CurrentVariable) = DH%iodesc3d_m_real end select !case ('z','c') ! whole = .true. case default whole = .true. if(ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable)) then whole = .false. end if #if 0 select case (FieldType) case (WRF_REAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc1d_real case (WRF_DOUBLE) DH%ioVar(DH%CurrentVariable) = DH%iodesc1d_double case (WRF_INTEGER) DH%ioVar(DH%CurrentVariable) = DH%iodesc1d_int case (WRF_LOGICAL) DH%ioVar(DH%CurrentVariable) = DH%iodesc1d_int case default write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) return end select #endif end select end subroutine find_iodesc logical function is_boundary(MemoryOrder) implicit none character*(*), intent(in) :: MemoryOrder logical :: isbdy character*3 :: MemOrd isbdy = .false. call LowerCase(MemoryOrder,MemOrd) select case (MemOrd) case ('xsz', 'xez', 'ysz', 'yez') isbdy = .true. case ('xs', 'xe', 'ys', 'ye') isbdy = .true. case default isbdy = .false. end select is_boundary = isbdy end function is_boundary subroutine FieldIO(IO,DataHandle,DateStr,Dimens,Starts,Counts,Length,MemoryOrder, & Stagger,FieldType,Field,Status) implicit none include 'wrf_status_codes.h' character (*) ,intent(in) :: IO integer ,intent(in) :: DataHandle character*(*) ,intent(in) :: DateStr integer,dimension(NVarDims),intent(inout) :: Dimens integer,dimension(NVarDims),intent(inout) :: Starts integer,dimension(NVarDims),intent(inout) :: Counts integer,dimension(NVarDims),intent(in) :: Length character*(*) ,intent(in) :: MemoryOrder character*(*) ,intent(in) :: Stagger integer ,intent(in) :: FieldType integer,dimension(*) ,intent(inout) :: Field integer ,intent(out) :: Status integer :: TimeIndex logical :: whole, isbdy integer :: NDim integer :: fldsize, datasize integer :: n type(wrf_data_handle) ,pointer :: DH integer(KIND=PIO_OFFSET) :: pioidx DH => WrfDataHandles(DataHandle) call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) if(Status /= WRF_NO_ERR) then write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) write(msg,*) ' Bad time index for DateStr = ',DateStr call wrf_debug ( WARN , TRIM(msg)) return endif call GetDim(MemoryOrder,NDim,Status) fldsize = 1 datasize = 1 do n = 1, NDim fldsize = fldsize * Length(n) datasize = datasize * Counts(n) end do Starts(NDim+1) = TimeIndex Counts(NDim+1) = 1 call find_iodesc(DH,MemoryOrder,Stagger,FieldTYpe,whole) isbdy = is_boundary(MemoryOrder) !isbdy = BDY_VAR == DH%vartype(DH%CurrentVariable) pioidx = TimeIndex call pio_setframe(DH%descVar(DH%CurrentVariable), pioidx) !DH%descVar(DH%CurrentVariable)%rec = TimeIndex !write(unit=0, fmt='(3a,i6)') 'File: ', __FILE__, ', line: ', __LINE__ !write(unit=0, fmt='(3a,l8)') 'IO = ', trim(IO), ', whole = ', whole !write(unit=0, fmt='(4a)') 'MemoryOrder = ', trim(MemoryOrder), ', Stagger = ', trim(Stagger) !write(unit=0, fmt='(a,i4,a,i3)') 'DH%vartype(', DH%CurrentVariable, ') = ', DH%vartype(DH%CurrentVariable) !if(whole .and. (ENSEMBLE_VAR == DH%vartype(DH%CurrentVariable))) then ! whole = .false. !end if select case (FieldType) case (WRF_REAL) if(isbdy .and. (IO == 'read')) then Dimens(NDim+1) = TimeIndex call read_bdy_RealFieldIO(DH,NDim,Dimens,Starts,Counts,Field,Status) else call ext_pio_RealFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Field,Status) endif case (WRF_DOUBLE) if(isbdy .and. (IO == 'read')) then Dimens(NDim+1) = TimeIndex call read_bdy_DoubleFieldIO(DH,NDim,Dimens,Starts,Counts,Field,Status) else call ext_pio_DoubleFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Field,Status) endif case (WRF_INTEGER) call ext_pio_IntFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Field,Status) case (WRF_LOGICAL) call ext_pio_LogicalFieldIO(whole,IO,DH,Starts,Counts,fldsize,datasize,Field,Status) case default Status = WRF_WARN_DATA_TYPE_NOT_FOUND write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) return end select return end subroutine FieldIO subroutine FieldBDY(IO,DataHandle,DateStr,NDim,Domains, & MemoryStart,MemoryEnd,PatchStart,PatchEnd, & FieldType,Field,Status) implicit none include 'wrf_status_codes.h' character (*) ,intent(in) :: IO integer ,intent(in) :: DataHandle,NDim character*(*) ,intent(in) :: DateStr integer,dimension(*) ,intent(inout) :: Domains integer,dimension(*) ,intent(in) :: MemoryStart, MemoryEnd integer,dimension(*) ,intent(in) :: PatchStart, PatchEnd integer ,intent(in) :: FieldType integer,dimension(*) ,intent(inout) :: Field integer ,intent(out) :: Status integer :: TimeIndex type(wrf_data_handle) ,pointer :: DH integer(KIND=PIO_OFFSET) :: pioidx DH => WrfDataHandles(DataHandle) call GetTimeIndex(IO,DataHandle,DateStr,TimeIndex,Status) if(Status /= WRF_NO_ERR) then write(msg,*) 'Warning in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) write(msg,*) ' Bad time index for DateStr = ',DateStr call wrf_debug ( WARN , TRIM(msg)) return endif pioidx = TimeIndex call pio_setframe(DH%descVar(DH%CurrentVariable), pioidx) !DH%descVar(DH%CurrentVariable)%rec = TimeIndex Domains(NDim+1) = TimeIndex select case (FieldType) case (WRF_REAL) call read_bdy_RealFieldIO(DH,NDim,Domains,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Field,Status) case (WRF_DOUBLE) call read_bdy_DoubleFieldIO(DH,NDim,Domains,MemoryStart,MemoryEnd,PatchStart,PatchEnd,Field,Status) case default Status = WRF_WARN_DATA_TYPE_NOT_FOUND write(msg,*) 'Warning DATA TYPE NOT FOUND in ',__FILE__,', line', __LINE__ call wrf_debug ( WARN , TRIM(msg)) return end select return end subroutine FieldBDY ! Returns .TRUE. iff it is OK to write time-independent domain metadata to the ! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is ! returned. LOGICAL FUNCTION ncd_ok_to_put_dom_ti( DataHandle ) implicit none include 'wrf_status_codes.h' INTEGER, INTENT(IN) :: DataHandle CHARACTER*80 :: fname INTEGER :: filestate INTEGER :: Status LOGICAL :: dryrun, retval call ext_pio_inquire_filename( DataHandle, fname, filestate, Status ) IF ( Status /= WRF_NO_ERR ) THEN write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & ', line', __LINE__ call wrf_debug ( WARN , TRIM(msg) ) retval = .FALSE. ELSE dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) retval = dryrun ENDIF ncd_ok_to_put_dom_ti = retval RETURN END FUNCTION ncd_ok_to_put_dom_ti ! Returns .TRUE. iff it is OK to read time-independent domain metadata from the ! file referenced by DataHandle. If DataHandle is invalid, .FALSE. is ! returned. LOGICAL FUNCTION ncd_ok_to_get_dom_ti( DataHandle ) implicit none include 'wrf_status_codes.h' INTEGER, INTENT(IN) :: DataHandle CHARACTER*80 :: fname INTEGER :: filestate INTEGER :: Status LOGICAL :: dryrun, retval call ext_pio_inquire_filename( DataHandle, fname, filestate, Status ) IF ( Status /= WRF_NO_ERR ) THEN write(msg,*) 'Warning Status = ',Status,' in ',__FILE__, & ', line', __LINE__ call wrf_debug ( WARN , TRIM(msg) ) retval = .FALSE. ELSE dryrun = ( filestate .EQ. WRF_FILE_OPENED_NOT_COMMITTED ) retval = .NOT. dryrun ENDIF ncd_ok_to_get_dom_ti = retval RETURN END FUNCTION ncd_ok_to_get_dom_ti subroutine initialize_pio(grid, DH) implicit none type(domain) :: grid type(wrf_data_handle), pointer :: DH integer :: ierr integer(i4) :: communicator, pioprocs, piostart, piostride, pioshift communicator = grid%communicator if(.not. associated(DH%iosystem)) then allocate(DH%iosystem) end if DH%Write = 0 !call pio_setdebuglevel(1) call mpi_comm_size(communicator, nprocs, ierr) call mpi_comm_rank(communicator, myrank, ierr) if(grid%pioprocs > nprocs) then !Force pioprocs to be nprocs. pioprocs = nprocs else if(grid%pioprocs < 1) then !Force pioprocs to be 1. pioprocs = 1 else pioprocs = grid%pioprocs endif piostride = nprocs / grid%pioprocs if((grid%pioprocs * piostride) < nprocs) then !We expect that: nprocs = piostride * grid%pioprocs piostride = piostride + 1 endif if(piostride /= grid%piostride) then !We expect that user's piostride equals what we calculated here. !If not, override it. write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ write(unit=0, fmt='(a,i6)') 'Calculated piostride = ', piostride, & 'User provided piostride = ', grid%piostride endif if(grid%pioshift < 0) then !pioshift can from 0, but can not less than 0, usually, we if(grid%piostride > 1) then pioshift = 1 else pioshift = 0 endif write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ write(unit=0, fmt='(a,i6)') 'PIO has forced pioshift to: ', pioshift else if(grid%pioshift >= grid%piostride) then !pioshift can not large then piostride write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ write(unit=0, fmt='(a,i6)') 'User provided a pioshift of: ', grid%pioshift if(grid%piostride > 1) then pioshift = 1 else pioshift = 0 endif write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ write(unit=0, fmt='(a,i6)') 'PIO has forced pioshift to: ', pioshift else pioshift = grid%pioshift endif if(grid%piostart < 0) then !Force piostart from 0 write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ write(unit=0, fmt='(a,i6)') 'User provided a piostart of: ', grid%piostart write(unit=0, fmt='(a,i6)') 'PIO has forced piosstart to: ', 0 piostart = 0 else piostart = grid%piostart endif !write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ !write(unit=0, fmt='(2(a,i6))') 'nprocs = ', nprocs, ', myrank = ', myrank !write(unit=0, fmt='(4(a,i6))') 'pioprocs = ', pioprocs, & ! ', piostride = ', piostride, & ! ', piostart = ', piostart, & ! ', pioshift = ', pioshift !call PIO_init to initiate iosystem !call PIO_init(my_rank, MPI_COMM_WORLD, 4, 0, 4, PIO_rearr_box, iosystem, 1) !call PIO_init(myrank, MPI_COMM_WORLD, pioprocs, & call PIO_init(myrank, communicator, pioprocs, & piostart, piostride, & PIO_rearr_box, DH%iosystem, pioshift) DH%nprocs = nprocs DH%myrank = myrank DH%piostart = piostart DH%pioshift = pioshift DH%pioprocs = pioprocs DH%piostride = piostride call get_ijk_from_grid(grid, & ids, ide, jds, jde, kds, kde, & ims, ime, jms, jme, kms, kme, & its, ite, jts, jte, kts, kte) end subroutine initialize_pio subroutine define_pio_iodesc(grid, DH) implicit none type(domain) :: grid type(wrf_data_handle), pointer :: DH integer(i4) :: communicator, myrank integer(i4) :: iostat integer(kind=PIO_Offset), & dimension((ime - ims + 1) * (jme - jms + 1) * (kme - kms + 1)) & :: compdof_3d integer(kind=PIO_Offset), & dimension((ime - ims + 1) * (jme - jms + 1) * grid%num_land_cat) & :: compdof_3d_land integer(kind=PIO_Offset), & dimension((ime - ims + 1) * (jme - jms + 1) * grid%num_soil_cat) & :: compdof_3d_soil integer(kind=PIO_Offset), & dimension((ime - ims + 1) * (jme - jms + 1) * grid%num_soil_layers) & :: compdof_3d_soil_layers integer(kind=PIO_Offset), & dimension((ime - ims + 1) * (jme - jms + 1) * grid%num_ext_model_couple_dom) & :: compdof_3d_mdl_cpl integer(kind=PIO_Offset), & dimension((ime - ims + 1) * (jme - jms + 1) * grid%ensdim) & :: compdof_3d_ensemble integer(kind=PIO_Offset), & dimension((jme - jms + 1) * (kme - kms + 1) * grid%spec_bdy_width ) & :: compdof_3d_xsz, compdof_3d_xez integer(kind=PIO_Offset), & dimension((ime - ims + 1) * (kme - kms + 1) * grid%spec_bdy_width ) & :: compdof_3d_ysz, compdof_3d_yez integer(kind=PIO_Offset), & dimension((jme - jms + 1) * grid%spec_bdy_width ) & :: compdof_2d_xs, compdof_2d_xe integer(kind=PIO_Offset), & dimension((ime - ims + 1) * grid%spec_bdy_width ) & :: compdof_2d_ys, compdof_2d_ye integer(kind=PIO_Offset), & dimension((ime - ims + 1) * (jme - jms + 1)) & :: compdof_2d integer :: dims3d(3), dims2d(2), dims2di(3) integer :: dims3d_xb(3), dims2d_xb(2) integer :: dims3d_yb(3), dims2d_yb(2) integer :: dims3d_land(3), dims3d_soil(3), dims3d_soil_layers(3) integer :: dims3d_mdl_cpl(3) integer :: dims3d_ensemble(3) integer :: lite, ljte, lkte integer :: i, j, k, n, npos DH%first_operation = .false. communicator = grid%communicator myrank = DH%myrank !--For MASS variables dims3d(1) = ide - 1 dims3d(2) = jde - 1 dims3d(3) = kde - 1 lite = ite ljte = jte lkte = kte if(lite > dims3d(1)) lite = dims3d(1) if(ljte > dims3d(2)) ljte = dims3d(2) if(lkte > dims3d(3)) lkte = dims3d(3) dims3d_land(1) = dims3d(1) dims3d_land(2) = dims3d(2) dims3d_land(3) = grid%num_land_cat dims3d_soil(1) = dims3d(1) dims3d_soil(2) = dims3d(2) dims3d_soil(3) = grid%num_soil_cat dims3d_soil_layers(1) = dims3d(1) dims3d_soil_layers(2) = dims3d(2) dims3d_soil_layers(3) = grid%num_soil_layers dims3d_mdl_cpl(1) = dims3d(1) dims3d_mdl_cpl(2) = dims3d(2) dims3d_mdl_cpl(3) = grid%num_ext_model_couple_dom dims3d_ensemble(1) = dims3d(1) dims3d_ensemble(2) = dims3d(2) dims3d_ensemble(3) = grid%ensdim dims2d(1) = dims3d(1) dims2d(2) = dims3d(2) dims2di(1) = dims3d(1) dims2di(2) = dims3d(2) dims2di(3) = 1 dims3d_xb(1) = dims3d(2) dims3d_xb(2) = dims3d(3) dims3d_xb(3) = grid%spec_bdy_width dims3d_yb(1) = dims3d(1) dims3d_yb(2) = dims3d(3) dims3d_yb(3) = grid%spec_bdy_width dims2d_xb(1) = dims2d(2) dims2d_xb(2) = grid%spec_bdy_width dims2d_yb(1) = dims2d(1) dims2d_yb(2) = grid%spec_bdy_width !write(unit=0, fmt='(3a,i6)') 'file: ', __FILE__, ', line: ', __LINE__ !write(unit=0, fmt='(a, 6i6)') 'dims2d = ', dims2d !write(unit=0, fmt='(a, 6i6)') 'dims3d = ', dims3d !write(unit=0, fmt='(a, 6i6)') 'dims3d_land = ', dims3d_land !write(unit=0, fmt='(a, 6i6)') 'dims3d_soil = ', dims3d_soil !write(unit=0, fmt='(a, 6i6)') 'grid%num_land_cat = ', grid%num_land_cat !write(unit=0, fmt='(a, 6i6)') 'grid%num_soil_cat = ', grid%num_soil_cat !write(unit=0, fmt='(a, 6i6)') 'grid%num_soil_layers = ', grid%num_soil_layers !write(unit=0, fmt='(a, 6i6)') 'grid%num_ext_model_couple_dom = ', grid%num_ext_model_couple_dom !write(unit=0, fmt='(a, 6i6)') 'grid%spec_bdy_width = ', grid%spec_bdy_width do j = jms, jme do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) compdof_2d(npos) = 0 enddo do k = kms, kme do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) compdof_3d(npos) = 0 enddo enddo do k = 1, dims3d_land(3) do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_land(3) * (j - jms)) compdof_3d_land(npos) = 0 enddo enddo do k = 1, dims3d_soil(3) do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_soil(3) * (j - jms)) compdof_3d_soil(npos) = 0 enddo enddo do k = 1, dims3d_soil_layers(3) do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_soil_layers(3) * (j - jms)) compdof_3d_soil_layers(npos) = 0 enddo enddo do k = 1, dims3d_mdl_cpl(3) do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_mdl_cpl(3) * (j - jms)) compdof_3d_mdl_cpl(npos) = 0 enddo enddo enddo do n = 1, grid%spec_bdy_width do i = ims, ime npos = i - ims + 1 + (ime - ims + 1) * (n - 1) compdof_2d_ys(npos) = 0 compdof_2d_ye(npos) = 0 enddo do j = jms, jme npos = j - jms + 1 + (jme - jms + 1) * (n - 1) compdof_2d_xs(npos) = 0 compdof_2d_xe(npos) = 0 enddo do k = kms, kme do i = ims, ime npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_ysz(npos) = 0 compdof_3d_yez(npos) = 0 enddo enddo do k = kms, kme do j = jms, jme npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xsz(npos) = 0 compdof_3d_xez(npos) = 0 enddo enddo enddo do j = jts, ljte do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) compdof_2d(npos) = i + dims2d(1) * (j - 1) end do do k = kts, lkte do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) compdof_3d(npos) = i + dims3d(1) * (j - 1 + dims3d(2) * (k - 1)) enddo enddo do k = 1, dims3d_land(3) do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_land(3) * (j - jms)) compdof_3d_land(npos) = i + dims3d_land(1) * (j - 1 + dims3d_land(2) * (k - 1)) enddo enddo do k = 1, dims3d_soil(3) do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_soil(3) * (j - jms)) compdof_3d_soil(npos) = i + dims3d_soil(1) * (j - 1 + dims3d_soil(2) * (k - 1)) enddo enddo do k = 1, dims3d_soil_layers(3) do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_soil_layers(3) * (j - jms)) compdof_3d_soil_layers(npos) = i + dims3d_soil_layers(1) * (j - 1 + dims3d_soil_layers(2) * (k - 1)) enddo enddo do k = 1, dims3d_mdl_cpl(3) do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (k - 1 + dims3d_mdl_cpl(3) * (j - jms)) compdof_3d_mdl_cpl(npos) = i + dims3d_mdl_cpl(1) * (j - 1 + dims3d_mdl_cpl(2) * (k - 1)) enddo enddo enddo do k = 1, dims3d_ensemble(3) do j = jms, jme do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (j - jms + (jme - jms + 1) * (k - 1)) compdof_3d_ensemble(npos) = 0 enddo enddo do j = jts, ljte do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (j - jms + (jme - jms + 1) * (k - 1)) compdof_3d_ensemble(npos) = i + dims3d_ensemble(1) * (j - 1 + dims3d_ensemble(2) * (k - 1)) enddo enddo enddo !write(unit=0, fmt='(3a,i6)') 'File: ', __FILE__, ', line: ', __LINE__ !write(unit=0, fmt='(4x,a,i6)') 'npos = ', npos !write(unit=0, fmt='(4x,a,i16)') 'compdof_3d_ensemble(npos) = ', compdof_3d_ensemble(npos) if(1 == its) then do n = 1, grid%spec_bdy_width do j = jts, ljte npos = j - jms + 1 + (jme - jms + 1) * (n - 1) compdof_2d_xs(npos) = j + dims2d_xb(1) * (n - 1) enddo enddo endif if(1 == jts) then do n = 1, grid%spec_bdy_width do i = its, lite npos = i - ims + 1 + (ime - ims + 1) * (n - 1) compdof_2d_ys(npos) = i + dims2d_yb(1) * (n - 1) enddo enddo endif if(dims2d(1) == lite) then do n = 1, grid%spec_bdy_width do j = jts, ljte npos = j - jms + 1 + (jme - jms + 1) * (n - 1) compdof_2d_xe(npos) = j + dims2d_xb(1) * (n - 1) enddo enddo endif if(dims2d(2) == ljte) then do n = 1, grid%spec_bdy_width do i = its, lite npos = i - ims + 1 + (ime - ims + 1) * (n - 1) compdof_2d_ye(npos) = i + dims2d_yb(1) * (n - 1) enddo enddo endif if(1 == its) then do n = 1, grid%spec_bdy_width do k = kts, lkte do j = jts, ljte npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xsz(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) enddo enddo enddo endif if(1 == jts) then do n = 1, grid%spec_bdy_width do k = kts, lkte do i = its, lite npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_ysz(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) enddo enddo enddo endif if(dims2d(1) == lite) then do n = 1, grid%spec_bdy_width do k = kts, lkte do j = jts, ljte npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xez(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) enddo enddo enddo endif if(dims2d(2) == ljte) then do n = 1, grid%spec_bdy_width do k = kts, lkte do i = its, lite npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_yez(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) enddo enddo enddo endif !--call init_decomp in order to setup the IO decomposition with PIO !call pio_setdebuglevel(1) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d, compdof_3d, DH%iodesc3d_m_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d, compdof_3d, DH%iodesc3d_m_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d, compdof_3d, DH%iodesc3d_m_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_land, compdof_3d_land, DH%iodesc3d_land_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_land, compdof_3d_land, DH%iodesc3d_land_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_land, compdof_3d_land, DH%iodesc3d_land_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_soil, compdof_3d_soil, DH%iodesc3d_soil_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_soil, compdof_3d_soil, DH%iodesc3d_soil_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_soil, compdof_3d_soil, DH%iodesc3d_soil_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_soil_layers, compdof_3d_soil_layers, DH%iodesc3d_soil_layers_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_soil_layers, compdof_3d_soil_layers, DH%iodesc3d_soil_layers_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_soil_layers, compdof_3d_soil_layers, DH%iodesc3d_soil_layers_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_mdl_cpl, compdof_3d_mdl_cpl, DH%iodesc3d_mdl_cpl_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_mdl_cpl, compdof_3d_mdl_cpl, DH%iodesc3d_mdl_cpl_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_mdl_cpl, compdof_3d_mdl_cpl, DH%iodesc3d_mdl_cpl_double) !call pio_setdebuglevel(1) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_ensemble, compdof_3d_ensemble, DH%iodesc3d_ensemble_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_ensemble, compdof_3d_ensemble, DH%iodesc3d_ensemble_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_ensemble, compdof_3d_ensemble, DH%iodesc3d_ensemble_double) !call pio_setdebuglevel(0) #ifndef INTSPECIAL call PIO_initdecomp(DH%iosystem, PIO_int, dims2d, compdof_2d, DH%iodesc2d_m_int) #else call PIO_initdecomp(DH%iosystem, PIO_int, dims2di, compdof_2d, DH%iodesc2d_m_int) #endif call PIO_initdecomp(DH%iosystem, PIO_real, dims2d, compdof_2d, DH%iodesc2d_m_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims2d, compdof_2d, DH%iodesc2d_m_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_m_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_m_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_m_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_m_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_m_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_m_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_m_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_m_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_m_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_m_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_m_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_m_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims2d_xb, compdof_2d_xs, DH%iodesc2d_xs_m_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims2d_xb, compdof_2d_xs, DH%iodesc2d_xs_m_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims2d_xb, compdof_2d_xs, DH%iodesc2d_xs_m_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims2d_xb, compdof_2d_xe, DH%iodesc2d_xe_m_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims2d_xb, compdof_2d_xe, DH%iodesc2d_xe_m_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims2d_xb, compdof_2d_xe, DH%iodesc2d_xe_m_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims2d_yb, compdof_2d_ys, DH%iodesc2d_ys_m_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims2d_yb, compdof_2d_ys, DH%iodesc2d_ys_m_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims2d_yb, compdof_2d_ys, DH%iodesc2d_ys_m_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims2d_yb, compdof_2d_ye, DH%iodesc2d_ye_m_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims2d_yb, compdof_2d_ye, DH%iodesc2d_ye_m_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims2d_yb, compdof_2d_ye, DH%iodesc2d_ye_m_double) !--For X-STAG variables dims3d(1) = ide dims3d(2) = jde - 1 dims3d(3) = kde - 1 lite = ite ljte = jte lkte = kte if(lite > dims3d(1)) lite = dims3d(1) if(ljte > dims3d(2)) ljte = dims3d(2) if(lkte > dims3d(3)) lkte = dims3d(3) dims2d(1) = dims3d(1) dims2d(2) = dims3d(2) dims3d_xb(1) = dims3d(2) dims3d_xb(2) = dims3d(3) dims3d_xb(3) = grid%spec_bdy_width dims3d_yb(1) = dims3d(1) dims3d_yb(2) = dims3d(3) dims3d_yb(3) = grid%spec_bdy_width !compdof_3d = 0 !compdof_2d = 0 do j = jms, jme do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) compdof_2d(npos) = 0 enddo do k = kms, kme do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) compdof_3d(npos) = 0 enddo enddo enddo do n = 1, grid%spec_bdy_width do k = kms, kme do i = ims, ime npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_ysz(npos) = 0 compdof_3d_yez(npos) = 0 enddo enddo do k = kms, kme do j = jms, jme npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xsz(npos) = 0 compdof_3d_xez(npos) = 0 enddo enddo enddo do j = jts, ljte do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) compdof_2d(npos) = i + dims2d(1) * (j - 1) end do do k = kts, lkte do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) compdof_3d(npos) = i + dims3d(1) * (j - 1 + dims3d(2) * (k - 1)) enddo enddo enddo if(1 == its) then do n = 1, grid%spec_bdy_width do k = kts, lkte do j = jts, ljte npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xsz(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) enddo enddo enddo endif if(1 == jts) then do n = 1, grid%spec_bdy_width do k = kts, lkte do i = its, lite npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_ysz(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) enddo enddo enddo endif if(dims3d(1) == lite) then do n = 1, grid%spec_bdy_width do k = kts, lkte do j = jts, ljte npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xez(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) enddo enddo enddo endif if(dims3d(2) == ljte) then do n = 1, grid%spec_bdy_width do k = kts, lkte do i = its, lite npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_yez(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) enddo enddo enddo endif !--call init_decomp in order to setup the IO decomposition with PIO call PIO_initdecomp(DH%iosystem, PIO_double, dims3d, compdof_3d, DH%iodesc3d_u_double) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d, compdof_3d, DH%iodesc3d_u_real) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d, compdof_3d, DH%iodesc3d_u_int) call PIO_initdecomp(DH%iosystem, PIO_double, dims2d, compdof_2d, DH%iodesc2d_u_double) call PIO_initdecomp(DH%iosystem, PIO_real, dims2d, compdof_2d, DH%iodesc2d_u_real) call PIO_initdecomp(DH%iosystem, PIO_int, dims2d, compdof_2d, DH%iodesc2d_u_int) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_u_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_u_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_u_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_u_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_u_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_u_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_u_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_u_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_u_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_u_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_u_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_u_double) !--For Y-STAG variables dims3d(1) = ide - 1 dims3d(2) = jde dims3d(3) = kde - 1 lite = ite ljte = jte lkte = kte if(lite > dims3d(1)) lite = dims3d(1) if(ljte > dims3d(2)) ljte = dims3d(2) if(lkte > dims3d(3)) lkte = dims3d(3) dims2d(1) = dims3d(1) dims2d(2) = dims3d(2) dims3d_xb(1) = dims3d(2) dims3d_xb(2) = dims3d(3) dims3d_xb(3) = grid%spec_bdy_width dims3d_yb(1) = dims3d(1) dims3d_yb(2) = dims3d(3) dims3d_yb(3) = grid%spec_bdy_width !compdof_3d = 0 !compdof_2d = 0 do j = jms, jme do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) compdof_2d(npos) = 0 enddo do k = kms, kme do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) compdof_3d(npos) = 0 enddo enddo enddo do n = 1, grid%spec_bdy_width do k = kms, kme do i = ims, ime npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_ysz(npos) = 0 compdof_3d_yez(npos) = 0 enddo enddo do k = kms, kme do j = jms, jme npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xsz(npos) = 0 compdof_3d_xez(npos) = 0 enddo enddo enddo do j = jts, ljte do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (j - jms) compdof_2d(npos) = i + dims2d(1) * (j - 1) end do do k = kts, lkte do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) compdof_3d(npos) = i + dims3d(1) * (j - 1 + dims3d(2) * (k - 1)) enddo enddo enddo if(1 == its) then do n = 1, grid%spec_bdy_width do k = kts, lkte do j = jts, ljte npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xsz(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) enddo enddo enddo endif if(1 == jts) then do n = 1, grid%spec_bdy_width do k = kts, lkte do i = its, lite npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_ysz(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) enddo enddo enddo endif if(dims3d(1) == lite) then do n = 1, grid%spec_bdy_width do k = kts, lkte do j = jts, ljte npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xez(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) enddo enddo enddo endif if(dims3d(2) == ljte) then do n = 1, grid%spec_bdy_width do k = kts, lkte do i = its, lite npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_yez(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) enddo enddo enddo endif !--call init_decomp in order to setup the IO decomposition with PIO call PIO_initdecomp(DH%iosystem, PIO_double, dims3d, compdof_3d, DH%iodesc3d_v_double) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d, compdof_3d, DH%iodesc3d_v_real) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d, compdof_3d, DH%iodesc3d_v_int) call PIO_initdecomp(DH%iosystem, PIO_double, dims2d, compdof_2d, DH%iodesc2d_v_double) call PIO_initdecomp(DH%iosystem, PIO_real, dims2d, compdof_2d, DH%iodesc2d_v_real) call PIO_initdecomp(DH%iosystem, PIO_int, dims2d, compdof_2d, DH%iodesc2d_v_int) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_v_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_v_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_v_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_v_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_v_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_v_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_v_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_v_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_v_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_v_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_v_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_v_double) !--For Z-STAG variables dims3d(1) = ide - 1 dims3d(2) = jde - 1 dims3d(3) = kde dims2d(1) = dims3d(1) dims2d(2) = dims3d(2) dims3d_xb(1) = dims3d(2) dims3d_xb(2) = dims3d(3) dims3d_xb(3) = grid%spec_bdy_width dims3d_yb(1) = dims3d(1) dims3d_yb(2) = dims3d(3) dims3d_yb(3) = grid%spec_bdy_width lite = ite ljte = jte lkte = kte if(lite > dims3d(1)) lite = dims3d(1) if(ljte > dims3d(2)) ljte = dims3d(2) if(lkte > dims3d(3)) lkte = dims3d(3) !compdof_3d = 0 do j = jms, jme do k = kms, kme do i = ims, ime npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) compdof_3d(npos) = 0 enddo enddo enddo do n = 1, grid%spec_bdy_width do k = kms, kme do i = ims, ime npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_ysz(npos) = 0 compdof_3d_yez(npos) = 0 enddo enddo do k = kms, kme do j = jms, jme npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xsz(npos) = 0 compdof_3d_xez(npos) = 0 enddo enddo enddo do j = jts, ljte do k = kts, lkte do i = its, lite npos = (i - ims + 1) + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (j - jms)) compdof_3d(npos) = i + dims3d(1) * (j - 1 + dims3d(2) * (k - 1)) enddo enddo enddo if(1 == its) then do n = 1, grid%spec_bdy_width do k = kts, lkte do j = jts, ljte npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xsz(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) enddo enddo enddo endif if(1 == jts) then do n = 1, grid%spec_bdy_width do k = kts, lkte do i = its, lite npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_ysz(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) enddo enddo enddo endif if(dims3d(1) == lite) then do n = 1, grid%spec_bdy_width do k = kts, lkte do j = jts, ljte npos = j - jms + 1 + (jme - jms + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_xez(npos) = j + dims3d_xb(1) * (k - 1 + dims3d_xb(2) * (n - 1)) enddo enddo enddo endif if(dims3d(2) == ljte) then do n = 1, grid%spec_bdy_width do k = kts, lkte do i = its, lite npos = i - ims + 1 + (ime - ims + 1) * (k - kms + (kme - kms + 1) * (n - 1)) compdof_3d_yez(npos) = i + dims3d_yb(1) * (k - 1 + dims3d_yb(2) * (n - 1)) enddo enddo enddo endif !--call init_decomp in order to setup the IO decomposition with PIO call PIO_initdecomp(DH%iosystem, PIO_double, dims3d, compdof_3d, DH%iodesc3d_w_double) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d, compdof_3d, DH%iodesc3d_w_real) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d, compdof_3d, DH%iodesc3d_w_int) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_w_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_w_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xsz, DH%iodesc3d_xsz_w_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_w_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_w_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_xb, compdof_3d_xez, DH%iodesc3d_xez_w_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_w_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_w_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_ysz, DH%iodesc3d_ysz_w_double) call PIO_initdecomp(DH%iosystem, PIO_int, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_w_int) call PIO_initdecomp(DH%iosystem, PIO_real, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_w_real) call PIO_initdecomp(DH%iosystem, PIO_double, dims3d_yb, compdof_3d_yez, DH%iodesc3d_yez_w_double) end subroutine define_pio_iodesc subroutine reorder (MemoryOrder,MemO) implicit none include 'wrf_status_codes.h' character*(*) ,intent(in) :: MemoryOrder character*3 ,intent(out) :: MemO character*3 :: MemOrd integer :: N,i,i1,i2,i3 MemO = MemoryOrder N = len_trim(MemoryOrder) if(N == 1) return call lowercase(MemoryOrder,MemOrd) ! never invert the boundary codes select case ( MemOrd ) case ( 'xsz','xez','ysz','yez' ) return case default continue end select i1 = 1 i3 = 1 do i=2,N if(ichar(MemOrd(i:i)) < ichar(MemOrd(i1:i1))) I1 = i if(ichar(MemOrd(i:i)) > ichar(MemOrd(i3:i3))) I3 = i enddo if(N == 2) then i2=i3 else i2 = 6-i1-i3 endif MemO(1:1) = MemoryOrder(i1:i1) MemO(2:2) = MemoryOrder(i2:i2) if(N == 3) MemO(3:3) = MemoryOrder(i3:i3) if(MemOrd(i1:i1) == 's' .or. MemOrd(i1:i1) == 'e') then MemO(1:N-1) = MemO(2:N) MemO(N:N ) = MemoryOrder(i1:i1) endif return end subroutine reorder end module pio_routines