! +-======-+ ! Copyright (c) 2003-2007 United States Government as represented by ! the Admistrator of the National Aeronautics and Space Administration. ! All Rights Reserved. ! ! THIS OPEN SOURCE AGREEMENT ("AGREEMENT") DEFINES THE RIGHTS OF USE, ! REPRODUCTION, DISTRIBUTION, MODIFICATION AND REDISTRIBUTION OF CERTAIN ! COMPUTER SOFTWARE ORIGINALLY RELEASED BY THE UNITED STATES GOVERNMENT AS ! REPRESENTED BY THE GOVERNMENT AGENCY LISTED BELOW ("GOVERNMENT AGENCY"). ! THE UNITED STATES GOVERNMENT, AS REPRESENTED BY GOVERNMENT AGENCY, IS AN ! INTENDED THIRD-PARTY BENEFICIARY OF ALL SUBSEQUENT DISTRIBUTIONS OR ! REDISTRIBUTIONS OF THE SUBJECT SOFTWARE. ANYONE WHO USES, REPRODUCES, ! DISTRIBUTES, MODIFIES OR REDISTRIBUTES THE SUBJECT SOFTWARE, AS DEFINED ! HEREIN, OR ANY PART THEREOF, IS, BY THAT ACTION, ACCEPTING IN FULL THE ! RESPONSIBILITIES AND OBLIGATIONS CONTAINED IN THIS AGREEMENT. ! ! Government Agency: National Aeronautics and Space Administration ! Government Agency Original Software Designation: GSC-15354-1 ! Government Agency Original Software Title: GEOS-5 GCM Modeling Software ! User Registration Requested. Please Visit http://opensource.gsfc.nasa.gov ! Government Agency Point of Contact for Original Software: ! Dale Hithon, SRA Assistant, (301) 286-2691 ! ! +-======-+ ! $Id: MAPL_IO.P90,v 1.56.2.10.2.7 2016-05-17 18:09:33 bmauer Exp $ #include "MAPL_ErrLog.h" #define DEALOC_(A) if(associated(A))then;if(MAPL_ShmInitialized)then;call MAPL_SyncSharedMemory(rc=STATUS);call MAPL_DeAllocNodeArray(A,rc=STATUS);else;deallocate(A,stat=STATUS);endif;VERIFY_(STATUS);NULLIFY(A);endif !BOP ! !MODULE: MAPL_IO -- A Module to do I/O (ASCII+binary) until ESMF fully supports it ! !INTERFACE: module MAPL_IOMod use ESMF use MAPL_BaseMod use MAPL_CommsMod use MAPL_SortMod use MAPL_ShmemMod use netcdf use, intrinsic :: ISO_C_BINDING use, intrinsic :: iso_fortran_env implicit none private type NCIO_Var character(len=ESMF_MAXSTR) :: Name integer :: VarId integer :: ndims ! total number of dimensions integer, allocatable :: dimids(:) ! this is the number of the NCIO_Dim dimension (it might not be the same as the acutal dimid returned by netcdf) character(len=ESMF_MAXSTR) :: long_name character(len=ESMF_MAXSTR) :: units integer :: spatialDims ! number of non-time dimensions integer :: ncDataType end type NCIO_Var type NCIO_Dim character(len=ESMF_MAXSTR) :: Name integer :: len integer :: dimid ! this is the actual dimid returned by netcdf integer :: varid integer :: dimType integer :: ncDataType logical :: hasVar real(ESMF_KIND_R4), allocatable :: dimPtrR4(:) real(ESMF_KIND_R8), allocatable :: dimPtrR8(:) integer, allocatable :: dimPtrI4(:) character(len=ESMF_MAXSTR) :: units character(len=ESMF_MAXSTR) :: long_name character(len=ESMF_MAXSTR) :: standard_name character(len=ESMF_MAXSTR) :: coordinate character(len=ESMF_MAXSTR) :: formulaTerms character(len=ESMF_MAXSTR) :: positive end type NCIO_Dim type MAPL_NCIO character(len=ESMF_MAXSTR) :: name character(len=ESMF_MAXPATHLEN) :: filename integer :: ncid integer :: nVars ! number of variables on file integer :: nDimVars ! number of dimension variables integer :: nDims ! number of dimensions defined on file integer :: gridType integer :: date integer :: time integer :: time_increment = -999 type (NCIO_Var), allocatable :: vars(:) type (NCIO_Dim), allocatable :: dims(:) logical :: isOpen = .false. logical :: fparallel end type MAPL_NCIO integer, public, parameter :: MAPL_NCIODimLon = 0 integer, public, parameter :: MAPL_NCIODimLat = 1 integer, public, parameter :: MAPL_NCIODimLev = 2 integer, public, parameter :: MAPL_NCIODimEdge = 3 integer, public, parameter :: MAPL_NCIODimTime = 4 integer, public, parameter :: MAPL_NCIODimTile = 5 integer, public, parameter :: MAPL_NCIODimSubTile = 6 integer, public, parameter :: MAPL_NCIODimExtraDim =7 integer, public, parameter :: MAPL_NCIODimUnknown = 8 integer, parameter :: MAPL_NCIOGridUnknown = 0 integer, parameter :: MAPL_NCIOGridLL = 1 integer, parameter :: MAPL_NCIOGridCS = 2 integer, parameter :: MAPL_NCIOGridTile = 3 ! public types public MAPL_NCIO ! public routines public MAPL_NCIOOpen public MAPL_NCIOClose public MAPL_NCIOCreateFile public MAPL_NCIOChangeRes public MAPL_NCIOSet public MAPL_NCIOAddVar public MAPL_NCIOAddDim public MAPL_NCIOVarGetDims public MAPL_NCIOGetDimSizes public MAPL_NCIOGetFileType public MAPL_NCIOGetVarid public MAPL_NCIOGetVarName public MAPL_NCIOParseTimeUnits ! public routines public GETFILEUNIT public GETFILE public FREE_FILE public READ_PARALLEL public WRITE_PARALLEL public MAPL_VarRead public MAPL_VarWrite public MAPL_Skip public MAPL_Backspace public MAPL_Rewind public MAPL_ClimUpdate public MAPL_DestroyFile public ArrDescr public ArrDescrSet public MAPL_TileMaskGet public MAPL_VarReadNCPar public MAPL_VarWriteNCPar public MAPL_MemFileInquire ! Interfaces: ! ----------- interface WRITE_PARALLEL module procedure WRITE_PARALLEL_I4_0 module procedure WRITE_PARALLEL_I4_1 module procedure WRITE_PARALLEL_R4_0 module procedure WRITE_PARALLEL_R4_1 module procedure WRITE_PARALLEL_R8_0 module procedure WRITE_PARALLEL_R8_1 module procedure WRITE_PARALLEL_STRING_0 end interface interface READ_PARALLEL module procedure READ_PARALLEL_STRING_0 module procedure READ_PARALLEL_I4_0 module procedure READ_PARALLEL_I4_1 module procedure READ_PARALLEL_I4_2 module procedure READ_PARALLEL_R4_0 module procedure READ_PARALLEL_R4_1 module procedure READ_PARALLEL_R4_2 module procedure READ_PARALLEL_R8_0 module procedure READ_PARALLEL_R8_1 module procedure READ_PARALLEL_R8_2 end interface ! ----------------------------------------- interface MAPL_VarRead module procedure MAPL_StateVarRead module procedure MAPL_BundleRead module procedure MAPL_FieldRead module procedure MAPL_VarRead_R4_1D module procedure MAPL_VarReadNCpar_R4_1d module procedure MAPL_VarRead_R4_2D module procedure MAPL_VarReadNCpar_R4_2d module procedure MAPL_VarRead_R4_3d module procedure MAPL_VarReadNCpar_R4_3d module procedure MAPL_VarRead_R4_4D module procedure MAPL_VarRead_R8_1D module procedure MAPL_VarReadNCpar_R8_1d module procedure MAPL_VarRead_R8_2D module procedure MAPL_VarReadNCpar_R8_2d module procedure MAPL_VarRead_R8_3D module procedure MAPL_VarReadNCpar_R8_3d module procedure MAPL_VarRead_R8_4D end interface interface MAPL_VarReadNCPar module procedure MAPL_StateVarReadNCPar module procedure MAPL_BundleReadNCPar module procedure MAPL_ArrayReadNCpar_1d module procedure MAPL_ArrayReadNCpar_2d module procedure MAPL_ArrayReadNCpar_3d end interface interface MAPL_VarWriteNCPar module procedure MAPL_StateVarWriteNCPar module procedure MAPL_BundleWriteNCPar end interface interface MAPL_VarWrite module procedure MAPL_StateVarWrite module procedure MAPL_BundleWrite module procedure MAPL_FieldWrite module procedure MAPL_VarWrite_I4_1D module procedure MAPL_VarWrite_R4_1D module procedure MAPL_VarWriteNCpar_R4_1d module procedure MAPL_VarWrite_R4_2d module procedure MAPL_VarWriteNCpar_R4_2d module procedure MAPL_VarWrite_R4_3D module procedure MAPL_VarWriteNCpar_R4_3d module procedure MAPL_VarWrite_R4_4D module procedure MAPL_VarWrite_R8_1D module procedure MAPL_VarWriteNCpar_R8_1d module procedure MAPL_VarWrite_R8_2D module procedure MAPL_VarWriteNCpar_R8_2d module procedure MAPL_VarWrite_R8_3D module procedure MAPL_VarWriteNCpar_R8_3d module procedure MAPL_VarWrite_R8_4D end interface interface ArrayScatterShm module procedure ArrayScatterShmR4D1 end interface ArrayScatterShm interface MAPL_MemFileInquire module procedure InqFileMem end interface include "mpif.h" include "netcdf.inc" ! Global vars: ! ------------ integer, parameter :: STD_OUT_UNIT_NUMBER = 6 integer, parameter :: LAST_UNIT = 999 integer, parameter :: UNDEF = 999 logical, save :: TAKEN(LAST_UNIT)=.FALSE. logical, save :: MTAKEN(LAST_UNIT)=.FALSE. character(len=ESMF_MAXSTR), save :: mname(LAST_UNIT) integer, parameter :: not_allocated = 0 integer, parameter :: r4_2 = 1 integer, parameter :: r4_1 = 2 integer, parameter :: r8_2 = 3 integer, parameter :: r8_1 = 4 integer, parameter :: i4_2 = 5 integer, parameter :: i4_1 = 6 type PTR integer :: allocated=not_allocated real(kind=ESMF_KIND_R4) , pointer :: r4_2(:,:) => null() real(kind=ESMF_KIND_R4) , pointer :: r4_1(:) => null() real(kind=ESMF_KIND_R4) :: r4_0 real(kind=ESMF_KIND_R8) , pointer :: r8_2(:,:) => null() real(kind=ESMF_KIND_R8) , pointer :: r8_1(:) => null() real(kind=ESMF_KIND_R8) :: r8_0 integer(kind=ESMF_KIND_I4), pointer :: I4_2(:,:) => null() integer(kind=ESMF_KIND_I4), pointer :: I4_1(:) => null() integer(kind=ESMF_KIND_I4) :: I4_0 end type PTR type memunit integer :: prevrec = 0 type (PTR), pointer :: Records(:)=>null() end type MEMUNIT type (memunit), target, save :: MEM_UNITS(LAST_UNIT) type (memunit), pointer :: munit type(PTR), pointer :: REC(:) type ArrDescr integer(kind=MPI_OFFSET_KIND) :: offset character(len=MPI_MAX_INFO_VAL) :: romio_cb_read,cb_buffer_size,romio_cb_write integer :: Xcomm, Ycomm integer :: readers_comm, IOscattercomm integer :: writers_comm, IOgathercomm integer, pointer :: i1(:), in(:), j1(:), jn(:) integer :: im_world, jm_world, lm_world type (ESMF_Grid) :: grid logical :: tile integer :: num_readers = 1 integer :: num_writers = 1 end type ArrDescr !#define TIME_MPIIO #ifdef TIME_MPIIO real(kind=ESMF_KIND_R8), save :: peak_ioread_bandwidth=0 real(kind=ESMF_KIND_R8), save :: mean_ioread_bandwidth=0 real(kind=ESMF_KIND_R8), save :: ioread_counter=0 real(kind=ESMF_KIND_R8), save :: peak_iowrite_bandwidth=0 real(kind=ESMF_KIND_R8), save :: mean_iowrite_bandwidth=0 real(kind=ESMF_KIND_R8), save :: iowrite_counter=0 #endif contains subroutine ArrDescrSet(ArrDes, offset, & readers_comm, ioscattercomm, & writers_comm, iogathercomm, & i1, in, j1, jn, im_world, jm_world, lm_world) type(ArrDescr), intent(INOUT) :: ArrDes integer(kind=MPI_OFFSET_KIND), & optional, intent(IN ) :: offset integer, optional, intent(IN ) :: readers_comm, ioscattercomm integer, optional, intent(IN ) :: writers_comm, iogathercomm integer, optional, pointer :: i1(:), in(:), j1(:), jn(:) integer, optional, intent(IN ) :: im_world, jm_world, lm_world if(present(offset )) ArrDes%offset = offset if(present(readers_comm )) ArrDes%readers_comm = readers_comm if(present(ioscattercomm)) ArrDes%ioscattercomm = ioscattercomm if(present(writers_comm )) ArrDes%writers_comm = writers_comm if(present(iogathercomm )) ArrDes%iogathercomm = iogathercomm if(present(i1 )) ArrDes%i1 => i1 if(present(in )) ArrDes%in => in if(present(j1 )) ArrDes%j1 => j1 if(present(jn )) ArrDes%jn => jn if(present(im_world)) ArrDes%im_world = im_world if(present(jm_world)) ArrDes%jm_world = jm_world if(present(lm_world)) ArrDes%lm_world = lm_world end subroutine ArrDescrSet INTEGER FUNCTION GETFILEMEM(name, RC ) IMPLICIT NONE character(LEN=*), intent(in ) :: Name integer , intent( out), OPTIONAL :: RC integer :: i logical :: found found = .false. do i = 3, last_unit if(name==Mname(i)) then found = .true. exit end if end do if (.not. found) then do i = 3,last_unit if(.not.MTAKEN(i)) then found = .true. exit endif enddo end if if (.not. found) then if(present(rc)) rc = 1 return endif mname(i) = name mtaken(i) = .true. getfilemem = -i if(present(rc)) rc = 0 return end function getfilemem LOGICAL FUNCTION INQFILEMEM(name) IMPLICIT NONE character(LEN=*), intent(in ) :: Name integer :: i logical :: found found = .false. do i = 3, last_unit if(name==Mname(i)) then found = .true. exit end if end do InqFileMem = found return end FUNCTION INQFILEMEM INTEGER FUNCTION GETFILEUNIT(name, RC ) IMPLICIT NONE character(LEN=*), intent(in ) :: Name integer , intent( out), OPTIONAL :: RC integer :: i logical :: found found = .false. do i = 2, last_unit if(name==Mname(i)) then found = .true. exit end if end do if (.not. found) then do i = 2,last_unit if(.not.MTAKEN(i)) then found = .true. exit endif enddo end if if (.not. found) then if(present(rc)) rc = 1 return endif mname(i) = name mtaken(i) = .true. getfileunit = i if(present(rc)) rc = 0 return end function getfileunit !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! INTEGER FUNCTION GETFILE( NAME, DO_OPEN, FORM, ALL_PES, & BLOCKSIZE, NUMBUFFERS, RC ) IMPLICIT NONE character(LEN=*), intent(in ) :: Name integer , intent(in ), OPTIONAL :: DO_OPEN character(LEN=*), intent(in ), OPTIONAL :: Form logical , intent(in ), OPTIONAL :: ALL_PES integer , intent(in ), OPTIONAL :: BLOCKSIZE integer , intent(in ), OPTIONAL :: NUMBUFFERS integer , intent( out), OPTIONAL :: RC INTEGER I integer :: DO_OPEN_ logical :: ALL_PES_ character(len=ESMF_MAXSTR) :: Iam="GETFILE" integer :: status LOGICAL FILEOPEN, UNITOPEN, FOUND if(INDEX(NAME,'*') /= 0) then getfile = getfilemem(name,rc=status) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) endif if (NAME == "stdout" .or. NAME== "STDOUT") then GETFILE = STD_OUT_UNIT_NUMBER RETURN_(ESMF_SUCCESS) end if if (.not. present(DO_OPEN)) then DO_OPEN_ = 1 else DO_OPEN_ = DO_OPEN end if ALL_PES_ = .false. if (present(ALL_PES)) then ALL_PES_ = ALL_PES end if if (.not. MAPL_AM_I_ROOT() .and. .not. ALL_PES_) then GETFILE = UNDEF RETURN_(ESMF_SUCCESS) end if ! Check if the file is already open INQUIRE ( FILE=NAME, NUMBER=GETFILE, OPENED=FILEOPEN ) ! If the file isnt already open THEN IF ( .NOT. FILEOPEN ) THEN I = 20 FOUND = .FALSE. DO WHILE ( I.LE.LAST_UNIT .AND. .NOT.FOUND ) IF ( .NOT. TAKEN(I) ) THEN TAKEN(I) = .TRUE. INQUIRE ( UNIT=I, OPENED=UNITOPEN ) IF ( .NOT. UNITOPEN ) THEN status = 0 if ( DO_OPEN_ .NE. 0 ) then call MAPL_open(UNIT=i,FILE=Name,FORM=FORM, & BLOCKSIZE= BLOCKSIZE, NUMBUFFERS=NUMBUFFERS, RC=STATUS) endif if ( status /= 0 ) then write (0,*) 'ERROR opening "',trim(Name),'" using GETFILE' write (0,*) ' IOSTAT = ',status RETURN_(ESMF_FAILURE) endif GETFILE = I FOUND = .TRUE. ENDIF ENDIF I = I + 1 ENDDO ! ! IF there are no available logical units THEN ! Write an error message ! Return Error status ! ENDIF there are no available logical units ! IF ( .NOT. FOUND ) THEN WRITE (0,*) ' COULD NOT FIND ANY AVAILABLE UNITS ' RETURN_(ESMF_FAILURE) ENDIF ENDIF ! the file isnt already open RETURN_(ESMF_SUCCESS) END FUNCTION GETFILE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! SUBROUTINE FREE_FILE(UNIT, RC) implicit none integer , intent(out), OPTIONAL :: RC character(len=ESMF_MAXSTR) :: Iam="FREE_FILE" integer :: status integer :: UNIT logical :: ALL_OPEN_ if(UNIT < 0) then ASSERT_(-UNIT<=LAST_UNIT) ASSERT_(MTAKEN(-UNIT)) MEM_units(-unit)%PREVREC=0 ELSE if (UNIT == STD_OUT_UNIT_NUMBER) return if (UNIT /= UNDEF) then close(UNIT) IF (UNIT.LT.1 .OR. UNIT.GT.LAST_UNIT) THEN WRITE (0,*) ' BAD UNIT NUMBER ZFILCLR UNIT = ', UNIT RETURN_(ESMF_FAILURE) ELSE TAKEN(UNIT) = .FALSE. MTAKEN(UNIT) = .FALSE. ENDIF end if END IF RETURN_(ESMF_SUCCESS) END SUBROUTINE FREE_FILE !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MAPL_Destroyfile(unit, RC ) IMPLICIT NONE integer , intent(in ) :: unit integer , intent( out), OPTIONAL :: RC integer :: i,k if (unit < 0) then i = -unit if (associated(mem_units(i)%records)) then do k=1,size(mem_units(i)%records) call dealloc_(mem_units(i)%records(k)) end do deallocate(mem_units(i)%records) end if mtaken(i) = .false. end if if(present(rc)) rc = 0 return end subroutine MAPL_Destroyfile !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! subroutine MAPL_OPEN(UNIT,FILE,FORM,BLOCKSIZE, NUMBUFFERS, RC) implicit none integer , optional, intent(out) :: RC integer , intent(in) :: UNIT character(LEN=*), intent(in) :: FILE character(LEN=*), optional, intent(in) :: FORM integer, optional, intent(in) :: BLOCKSIZE, NUMBUFFERS character(len=ESMF_MAXSTR) :: Iam="MAPL_OPEN" integer :: status character(LEN=ESMF_MAXSTR) :: usableFORM if(MAPL_AM_I_ROOT()) then if(.not.present(BLOCKSIZE) .and. .not.present(NUMBUFFERS)) then print *, "NOT using buffer I/O for file: ", trim(file) else print *, "Using buffer I/O for file: ", trim(file) endif endif if (present(FORM)) then usableFORM = FORM else usableFORM = "unformatted" end if open(UNIT,FILE=FILE,FORM=usableFORM,IOSTAT=STATUS) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) end subroutine MAPL_OPEN !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !--WRITES ------------------ !--------------------------- #define RANK_ 0 #define VARTYPE_ 1 #include "write_parallel.H" !--------------------------- #define RANK_ 1 #define VARTYPE_ 1 #include "write_parallel.H" !--------------------------- #define RANK_ 0 #define VARTYPE_ 3 #include "write_parallel.H" !--------------------------- #define RANK_ 1 #define VARTYPE_ 3 #include "write_parallel.H" !--------------------------- #define RANK_ 0 #define VARTYPE_ 4 #include "write_parallel.H" !--------------------------- #define RANK_ 1 #define VARTYPE_ 4 #include "write_parallel.H" !--------------------------- #define RANK_ 0 #define VARTYPE_ 0 #include "write_parallel.H" !-READS -------------------- ! Rank 0 !--------------------------- #define RANK_ 0 #define VARTYPE_ 0 #include "read_parallel.H" !--------------------------- #define RANK_ 0 #define VARTYPE_ 1 #include "read_parallel.H" !--------------------------- #define RANK_ 0 #define VARTYPE_ 3 #include "read_parallel.H" !--------------------------- #define RANK_ 0 #define VARTYPE_ 4 #include "read_parallel.H" ! Rank 1 !--------------------------- #define RANK_ 1 #define VARTYPE_ 1 #include "read_parallel.H" !--------------------------- #define RANK_ 1 #define VARTYPE_ 3 #include "read_parallel.H" !--------------------------- #define RANK_ 1 #define VARTYPE_ 4 #include "read_parallel.H" ! Rank 2 !--------------------------- #define RANK_ 2 #define VARTYPE_ 1 #include "read_parallel.H" !--------------------------- #define RANK_ 2 #define VARTYPE_ 3 #include "read_parallel.H" !--------------------------- #define RANK_ 2 #define VARTYPE_ 4 #include "read_parallel.H" !--------------------------- ! Read routines !--------------------------- subroutine MAPL_StateVarRead(UNIT, STATE, NAME, arrdes, bootstrapable, RC) integer , intent(IN ) :: UNIT type (ESMF_State) , intent(INOUT) :: STATE character(len=*), optional, intent(IN ) :: NAME type(ArrDescr), optional, intent(INOUT) :: ARRDES logical, optional, intent(IN ) :: bootstrapable integer, optional, intent( OUT) :: RC ! Local vars type (ESMF_FieldBundle) :: bundle type (ESMF_Field) :: field type (ESMF_Grid) :: grid integer :: status integer :: I, N character(len=ESMF_MAXSTR) :: IAm='MAPL_StateVarRead' integer :: J, ITEMCOUNT type (ESMF_StateItem_Flag), pointer :: ITEMTYPES(:) character(len=ESMF_MAXSTR ), pointer :: ITEMNAMES(:) logical, pointer :: DOIT(:) integer :: DIMS integer, pointer :: MASK(:) => null() type (ESMF_Array) :: array integer :: rank, varid, ind logical :: skipReading integer :: RST integer :: dna logical :: ignoreEOF logical :: bootstrapable_ character(len=ESMF_MAXSTR) :: FieldName integer, allocatable :: orderlist(:) integer :: jj character(len=ESMF_MAXSTR) :: attrName character(len=ESMF_MAXSTR), allocatable :: currList(:) integer :: natt call ESMF_StateGet(STATE,ITEMCOUNT=ITEMCOUNT,RC=STATUS) VERIFY_(STATUS) ASSERT_(ITEMCOUNT>0) allocate(ITEMNAMES(ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) allocate(ITEMTYPES(ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) allocate( DOIT(ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) call ESMF_StateGet(STATE,ITEMNAMELIST=ITEMNAMES,& ITEMTYPELIST=ITEMTYPES,RC=STATUS) VERIFY_(STATUS) if(present(NAME)) then DOIT = ITEMNAMES==NAME ASSERT_(count(DOIT)/=0) else DOIT = .true. endif attrName = MAPL_StateItemOrderList call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, RC=STATUS) VERIFY_(STATUS) ASSERT_(natt > 0) allocate(orderlist(natt), stat=status) VERIFY_(STATUS) allocate(currList(natt), stat=status) VERIFY_(STATUS) ! get the current list call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, rc=status) VERIFY_(STATUS) orderList = -1 ! not found do i = 1, natt ! search loop do jj = 1, ITEMCOUNT if (itemNames(jj) == currList(i)) then orderList(i) = jj exit end if end do end do deallocate(currList) if (present(bootstrapable)) then bootstrapable_ = bootstrapable else bootstrapable_ = .false. end if do JJ = 1, natt I = ORDERLIST(JJ) if (DOIT(I)) then #ifdef TIME_MPIIO call write_parallel(itemnames(i)) #endif if (ITEMTYPES(I) == ESMF_StateItem_FieldBundle) then call ESMF_StateGet(state, itemnames(i), bundle, rc=status) VERIFY_(STATUS) skipReading = .false. call ESMF_AttributeGet(bundle, name='RESTART', value=RST, rc=status) if (STATUS /= ESMF_SUCCESS) then RST = MAPL_RestartOptional end if skipReading = (RST == MAPL_RestartSkip) if (skipReading) cycle if (RST == MAPL_RestartRequired) then bootstrapable_ = .true. end if call MAPL_BundleRead(unit, bundle, arrdes=arrdes, & bootstrapable=bootstrapable_, rc=status) VERIFY_(STATUS) else if (ITEMTYPES(I) == ESMF_StateItem_Field) then call ESMF_StateGet(state, itemnames(i), field, rc=status) VERIFY_(STATUS) skipReading = .false. call ESMF_AttributeGet(field, name='RESTART', value=RST, rc=status) if (STATUS /= ESMF_SUCCESS) then RST = MAPL_RestartOptional end if skipReading = (RST == MAPL_RestartSkip) if (skipReading) cycle call ESMF_AttributeGet(field, name='doNotAllocate', value=dna, rc=status) if (STATUS == ESMF_SUCCESS) then skipReading = (dna /= 0) end if if (skipReading) cycle ignoreEOF = .false. if (bootstrapable_ .and. (RST == MAPL_RestartOptional)) then ignoreEOF = .true. end if if(.not.associated(MASK)) then call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) VERIFY_(STATUS) if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call ESMF_FieldGet (field, grid=grid, rc=status) VERIFY_(STATUS) call MAPL_TileMaskGet(grid, mask, rc=status) VERIFY_(STATUS) !@ else !@ allocate(Mask(1)) endif endif call MAPL_FieldRead(unit, field, arrdes=arrdes, HomePE=Mask, ignoreEOF=ignoreEOF, rc=status) VERIFY_(STATUS) !ALT else !ALT ASSERT_(.false.) end if end if end do deallocate(orderlist) deallocate(ITEMNAMES) deallocate(ITEMTYPES) deallocate( DOIT) if(associated(MASK)) then DEALOC_(MASK) end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_StateVarRead !--------------------------- subroutine MAPL_BundleRead(UNIT,BUNDLE, ARRDES, BOOTSTRAPABLE, RC) integer , intent(IN ) :: UNIT type (ESMF_FieldBundle) , intent(INOUT) :: BUNDLE type(ArrDescr), optional , intent(INOUT) :: ARRDES logical, optional , intent(IN ) :: BOOTSTRAPABLE integer, optional , intent( OUT) :: RC integer :: status integer :: J, N, varid, fieldCount, ind character(len=ESMF_MAXSTR) :: IAm='MAPL_BundleRead' type (ESMF_Field) :: field character(len=ESMF_MAXSTR),allocatable :: nameList(:) character(len=ESMF_MAXSTR) :: FieldName, BundleName integer :: RST logical :: ignoreEOF logical :: skipReading logical :: bootstrapable_ call ESMF_FieldBundleGet(bundle, fieldCount=N, name=BundleName, rc=STATUS) VERIFY_(STATUS) allocate(namelist(N), stat=status) VERIFY_(STATUS) call ESMF_FieldBundleGet(bundle, fieldNameList=nameList, fieldCount=FieldCount, rc=STATUS) VERIFY_(STATUS) ASSERT_(N==fieldCount) if (present(bootstrapable)) then bootstrapable_ = bootstrapable else bootstrapable_ = .false. end if do J = 1, N call MAPL_FieldBundleGet(bundle, fieldIndex=J, field=field, rc=status) VERIFY_(STATUS) call ESMF_AttributeGet(field, name='RESTART', value=RST, rc=status) if (STATUS /= ESMF_SUCCESS) then RST = MAPL_RestartOptional end if skipReading = (RST == MAPL_RestartSkip) if (skipReading) cycle ignoreEOF=.false. if (bootstrapable_ .and. (RST == MAPL_RestartOptional)) then ignoreEOF = .true. end if call MAPL_FieldRead(unit, field, arrdes=ARRDES, ignoreEOF=ignoreEOF, rc=status) VERIFY_(STATUS) end do RETURN_(ESMF_SUCCESS) end subroutine MAPL_BundleRead subroutine MAPL_FieldReadNCPar(ncioObj,name,FIELD, ARRDES, HomePE, RC) type(MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name type (ESMF_Field) , intent(INOUT) :: field type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, target, optional , intent(IN ) :: HomePE(:) integer, optional , intent( OUT) :: RC ! Local vars type (ESMF_Array) :: array type (ESMF_DELayout) :: layout type (ESMF_Grid) :: GRID integer :: rank integer :: status real(KIND=ESMF_KIND_R4), pointer, dimension(:) :: var_1d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:) :: var_2d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:,:) :: var_3d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:,:,:) :: var_4d real(KIND=ESMF_KIND_R8), pointer, dimension(:) :: vr8_1d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:) :: vr8_2d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:,:) :: vr8_3d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:,:,:) :: vr8_4d type(ESMF_TypeKind_Flag) :: tk character(len=ESMF_MAXSTR) :: FORMATTED integer :: count integer :: dims integer :: J, K integer, pointer :: mask(:) character(len=ESMF_MAXSTR) :: IAm='MAPL_FieldReadNCPar' type (ESMF_DistGrid) :: distGrid integer :: stat call ESMF_FieldGet(field, grid=grid, rc=status) VERIFY_(STATUS) call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) VERIFY_(STATUS) if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then if(present(HomePE)) then mask => HomePE else call MAPL_TileMaskGet(grid, mask, rc=status) VERIFY_(STATUS) endif end if call ESMF_FieldGet(field, Array=array, rc=status) VERIFY_(STATUS) call ESMF_ArrayGet(array, typekind=tk, rank=rank, rc=status) VERIFY_(STATUS) if (rank == 1) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_1d, rc=status) VERIFY_(STATUS) if (associated(var_1d)) then if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call MAPL_VarRead(ncioObj, name, var_1d, layout=layout, arrdes=arrdes, mask=mask, rc=status) VERIFY_(STATUS) else if (DIMS == MAPL_DimsVertOnly .or. DIMS==MAPL_DimsNone) then call MAPL_VarRead(ncioObj, name, var_1d, layout=layout, arrdes=arrdes, rc=status) VERIFY_(STATUS) else RETURN_(ESMF_FAILURE) endif end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_1d, rc=status) VERIFY_(STATUS) if (associated(vr8_1d)) then if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call MAPL_VarRead(ncioObj, name, var_1d, layout=layout, arrdes=arrdes, mask=mask, rc=status) VERIFY_(STATUS) else if (DIMS == MAPL_DimsVertOnly .or. DIMS==MAPL_DimsNone) then call MAPL_VarRead(ncioObj, name, vr8_1d, layout=layout, arrdes=arrdes, rc=status) VERIFY_(STATUS) else RETURN_(ESMF_FAILURE) endif end if end if else if (rank == 2) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_2d, rc=status) VERIFY_(STATUS) if (associated(var_2d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(var_2d,2) call MAPL_VarRead(ncioObj, name, var_2d(:,J), layout=layout, arrdes=arrdes, mask=mask, offset1=j, rc=status) VERIFY_(STATUS) end do else if (DIMS == MAPL_DimsTileTile) then do j=1,size(var_2d,2) call MAPL_VarRead(ncioObj, name, var_2d(:,J), layout=layout, arrdes=arrdes, mask=mask, offset1=j, rc=status) VERIFY_(STATUS) enddo else call MAPL_VarRead(ncioObj, name, var_2d, arrdes=arrdes, rc=status) VERIFY_(STATUS) end if end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_2d, rc=status) VERIFY_(STATUS) if (associated(vr8_2d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(vr8_2d,2) call MAPL_VarRead(ncioObj, name, vr8_2d(:,J), layout=layout, arrdes=arrdes, mask=mask, offset1=j, rc=status) end do else if (DIMS == MAPL_DimsTileTile) then do j=1,size(var_2d,2) call MAPL_VarRead(ncioObj, name, vr8_2d(:,J), layout=layout, arrdes=arrdes, mask=mask, offset1=j, rc=status) VERIFY_(STATUS) enddo else call MAPL_VarRead(ncioObj, name, vr8_2d, arrdes=arrdes, rc=status) VERIFY_(STATUS) end if end if endif else if (rank == 3) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_3d, rc=status) VERIFY_(STATUS) if (associated(var_3d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(var_3d,2) do K = 1,size(var_3d,3) call MAPL_VarRead(ncioObj, name, var_3d(:,J,K), layout=layout, arrdes=arrdes, mask=mask, offset1=j, offset2=k, rc=status) end do end do else call MAPL_VarRead(ncioObj, name, var_3d, arrdes=arrdes, rc=status) end if end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_3d, rc=status) VERIFY_(STATUS) if (associated(vr8_3d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(vr8_3d,2) do K = 1,size(vr8_3d,3) call MAPL_VarRead(ncioObj, name, vr8_3d(:,J,K), layout=layout, arrdes=arrdes, mask=mask, offset1=j, offset2=k, rc=status) end do end do else call MAPL_VarRead(ncioObj, name, vr8_3d, arrdes=arrdes, rc=status) end if end if endif else print *, "ERROR: unsupported RANK" RETURN_(ESMF_FAILURE) endif VERIFY_(STATUS) if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then if(.not.present(HomePE)) then DEALOC_(mask) end if end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_FieldReadNCPar subroutine MAPL_FieldRead(UNIT,FIELD, ARRDES, HomePE, ignoreEOF, RC) integer , intent(IN ) :: UNIT type (ESMF_Field) , intent(INOUT) :: field type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, target, optional , intent(IN ) :: HomePE(:) logical, optional , intent(IN ) :: ignoreEOF integer, optional , intent( OUT) :: RC ! Local vars type (ESMF_Array) :: array type (ESMF_DELayout) :: layout type (ESMF_Grid) :: GRID integer :: rank integer :: status real(KIND=ESMF_KIND_R4), pointer, dimension(:) :: var_1d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:) :: var_2d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:,:) :: var_3d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:,:,:) :: var_4d real(KIND=ESMF_KIND_R8), pointer, dimension(:) :: vr8_1d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:) :: vr8_2d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:,:) :: vr8_3d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:,:,:) :: vr8_4d type(ESMF_TypeKind_Flag) :: tk character(len=ESMF_MAXSTR) :: FORMATTED integer :: count integer :: dims integer :: J, K integer, pointer :: mask(:) character(len=ESMF_MAXSTR) :: IAm='MAPL_FieldRead' type (ESMF_DistGrid) :: distGrid integer :: stat logical :: ignoreEOF_ if (unit < 0 .or. present(arrdes)) then FORMATTED = "NO" else inquire(unit=UNIT, formatted=FORMATTED) end if if (present(ignoreEOF)) then ignoreEOF_ = ignoreEOF else ignoreEOF_ = .false. end if call ESMF_FieldGet(field, grid=grid, rc=status) VERIFY_(STATUS) call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) if (ignoreEOF_ .and. (unit > 0)) then ! test for end-of-file by ! making a blank read followed by backspace if (MAPL_am_i_root(layout)) then read (UNIT, IOSTAT=status) end if call MAPL_CommsBcast(layout, status, n=1, ROOT=MAPL_Root, rc=stat) VERIFY_(STAT) if (status == IOSTAT_END) then RETURN_(ESMF_SUCCESS) end if VERIFY_(STATUS) call MAPL_Backspace(UNIT, layout, rc=status) VERIFY_(STATUS) end if call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) VERIFY_(STATUS) if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then if(present(HomePE)) then mask => HomePE else call MAPL_TileMaskGet(grid, mask, rc=status) VERIFY_(STATUS) endif end if call ESMF_FieldGet(field, Array=array, rc=status) VERIFY_(STATUS) call ESMF_ArrayGet(array, typekind=tk, rank=rank, rc=status) VERIFY_(STATUS) if (rank == 1) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_1d, rc=status) VERIFY_(STATUS) if (associated(var_1d)) then if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call MAPL_VarRead(unit, grid, var_1d, arrdes=arrdes, mask=mask, rc=status) VERIFY_(STATUS) else if (DIMS == MAPL_DimsVertOnly .or. DIMS==MAPL_DimsNone) then call READ_PARALLEL(layout, var_1d, unit, arrdes=arrdes, rc=status) else RETURN_(ESMF_FAILURE) endif end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_1d, rc=status) VERIFY_(STATUS) if (associated(vr8_1d)) then if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call MAPL_VarRead(unit, grid, vr8_1d, arrdes=arrdes, mask=mask, rc=status) else if (DIMS == MAPL_DimsVertOnly .or. DIMS==MAPL_DimsNone) then call READ_PARALLEL(layout, vr8_1d, unit, arrdes=arrdes, rc=status) else RETURN_(ESMF_FAILURE) endif end if end if else if (rank == 2) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_2d, rc=status) VERIFY_(STATUS) if (associated(var_2d)) then !ALT: temp kludge if (FORMATTED=="YES") THEN call READ_PARALLEL(layout, & var_2d(lbound(var_2d,1),:), unit, rc=status) else if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(var_2d,2) call MAPL_VarRead(unit, grid, var_2d(:,J), arrdes=arrdes, mask=mask, rc=status) end do else if (DIMS == MAPL_DimsTileTile) then call MAPL_VarRead(unit, grid, var_2d, arrdes=arrdes, mask=mask, rc=status) else call MAPL_VarRead(unit, grid, var_2d, arrdes=arrdes, rc=status) end if end if end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_2d, rc=status) VERIFY_(STATUS) if (associated(vr8_2d)) then !ALT: temp kludge if (FORMATTED=="YES") THEN call READ_PARALLEL(layout, & vr8_2d(lbound(vr8_2d,1),:), unit, rc=status) else if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(vr8_2d,2) call MAPL_VarRead(unit, grid, vr8_2d(:,J), arrdes=arrdes, mask=mask, rc=status) end do else if (DIMS == MAPL_DimsTileTile) then call MAPL_VarRead(unit, grid, vr8_2d, arrdes=arrdes, mask=mask, rc=status) else call MAPL_VarRead(unit, grid, vr8_2d, arrdes=arrdes, rc=status) end if end if end if endif else if (rank == 3) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_3d, rc=status) VERIFY_(STATUS) if (associated(var_3d)) then !ALT: temp kludge if (FORMATTED=="YES") THEN call READ_PARALLEL(layout, & var_3d(lbound(var_3d,1),lbound(var_3d,2),:), unit) else if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(var_3d,2) do K = 1,size(var_3d,3) call MAPL_VarRead(unit, grid, var_3d(:,J,K), arrdes=arrdes, mask=mask, rc=status) end do end do else call MAPL_VarRead(unit, grid, var_3d, arrdes=arrdes, rc=status) end if endif end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_3d, rc=status) VERIFY_(STATUS) if (associated(vr8_3d)) then !ALT: temp kludge if (FORMATTED=="YES") THEN call READ_PARALLEL(layout, & vr8_3d(lbound(vr8_3d,1),lbound(vr8_3d,2),:), unit) else if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(vr8_3d,2) do K = 1,size(vr8_3d,3) call MAPL_VarRead(unit, grid, vr8_3d(:,J,K), arrdes=arrdes, mask=mask, rc=status) end do end do else call MAPL_VarRead(unit, grid, vr8_3d, arrdes=arrdes, rc=status) end if endif end if endif else if (rank == 4) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_4d, rc=status) VERIFY_(STATUS) call MAPL_VarRead(unit, grid, var_4d, rc=status) else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_4d, rc=status) VERIFY_(STATUS) call MAPL_VarRead(unit, grid, vr8_4d, rc=status) end if else print *, "ERROR: unsupported RANK" RETURN_(ESMF_FAILURE) endif VERIFY_(STATUS) if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then if(.not.present(HomePE)) then DEALOC_(mask) end if end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_FieldRead !--------------------------- subroutine MAPL_VarRead_R4_1d(UNIT, GRID, A, MASK, arrdes, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R4) , intent( OUT) :: A(:) integer, optional , intent(IN ) :: MASK(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables real(kind=ESMF_KIND_R4), pointer :: VAR(:) integer :: IM_WORLD integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) type (ESMF_DELayout) :: layout type (ESMF_DistGrid) :: distgrid character(len=ESMF_MAXSTR) :: IAm='MAPL_VarRead_R4_1d' integer, allocatable :: msk(:), sendcounts(:), displs(:) integer, allocatable :: idx(:) integer :: nrdrs, mype, npes, recvcount integer :: mypeRd integer :: Rsize, first, last integer(KIND=MPI_OFFSET_KIND) :: offset integer(KIND=MPI_OFFSET_KIND) :: loffset integer :: i, k, n, i1, in real(kind=ESMF_KIND_R4) :: dummy integer :: group, newgroup integer :: thiscomm integer :: nactive integer :: ntransl integer, allocatable :: pes(:) integer, allocatable :: r2g(:) integer, allocatable :: rpes(:) integer, allocatable :: activeranks(:) integer, allocatable :: activesendcounts(:) integer :: numread, mpistatus(MPI_STATUS_SIZE) integer :: cnt logical :: amIRoot if(present(arrdes)) then ASSERT_(present(mask)) IM_WORLD = arrdes%im_world call mpi_comm_size(arrdes%ioscattercomm,npes ,status) VERIFY_(STATUS) if(arrdes%readers_comm /= MPI_COMM_NULL) then call mpi_comm_rank(arrdes%readers_comm,mypeRd ,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%readers_comm,nrdrs,status) VERIFY_(STATUS) else mypeRd = -1 endif call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) call MAPL_CommsBcast(layout, nrdrs, 1, 0, rc = status) Rsize = im_world/nrdrs + 1 first = mypeRd*Rsize + 1 if(mypeRd >= mod(im_world,nrdrs)) then Rsize = Rsize - 1 first = first - (mypeRd-mod(im_world,nrdrs)) endif last = first + Rsize - 1 #ifdef DEBUG_MPIIO if (mypeRd <= nrdrs-1) write(*,'(5i)') mypeRd, IM_WORLD, first, last, Rsize #endif allocate(VAR(Rsize), stat=status) VERIFY_(STATUS) allocate(msk(Rsize), stat=status) VERIFY_(STATUS) allocate (sendcounts(0:npes-1), stat=status) VERIFY_(STATUS) allocate (r2g(0:nrdrs-1), stat=status) VERIFY_(STATUS) if(arrdes%readers_comm /= MPI_COMM_NULL) then if(arrdes%offset<=0) then offset = 4 else offset = arrdes%offset endif loffset = offset + (first-1)*4 cnt = Rsize call MPI_FILE_READ_AT_ALL(UNIT, loffset, VAR, cnt, MPI_REAL, mpistatus, STATUS) VERIFY_(STATUS) call MPI_GET_COUNT( mpistatus, MPI_REAL, numread, STATUS ) VERIFY_(STATUS) ASSERT_(cnt == numread) #ifdef DEBUG_MPIIO write(*,'(3i,1f)') IM_WORLD, loffset, numread, VAR(1) #endif ASSERT_( (lbound(mask,1) <= first) ) ASSERT_( (ubound(mask,1) >= last ) ) msk = mask(first:last) allocate(idx(Rsize), stat=status) VERIFY_(STATUS) do i=1,Rsize idx(i) = i enddo msk = mask(first:last) call MAPL_Sort(msk,idx) msk = mask(first:last) call MAPL_Sort(msk,var) arrdes%offset = offset + IM_WORLD*4 + 8 endif call mpi_comm_rank(arrdes%ioscattercomm,mype ,status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%ioscattercomm, GROUP, STATUS) VERIFY_(STATUS) #if 1 if (arrdes%readers_comm /= MPI_COMM_NULL) then allocate(rpes(0:nrdrs-1), stat=status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%readers_comm, NEWGROUP, STATUS) VERIFY_(STATUS) do n=0,nrdrs-1 rpes(n) = n end do call MPI_Group_translate_ranks(newgroup, nrdrs, rpes, group, r2g, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) deallocate(rpes) end if call MAPL_CommsBcast(layout, r2g, nrdrs, 0, rc = status) #else do n=0,nrdrs-1 r2g(n) = (npes/nrdrs)*n end do #endif offset = 1 do n=0,nrdrs-1 Rsize = im_world/nrdrs + 1 first = n*Rsize + 1 if(n >= mod(im_world,nrdrs)) then Rsize = Rsize - 1 first = first - (n-mod(im_world,nrdrs)) endif last = first + Rsize - 1 sendcounts = 0 do i=first,last sendcounts(mask(i)) = sendcounts(mask(i)) + 1 enddo ! Reader "n" must be included in the mpi group + evevybody that need the data nactive = count(sendcounts > 0) if (sendcounts(r2g(n)) == 0) then nactive = nactive + 1 end if allocate (activeranks(0:nactive-1), activesendcounts(0:nactive-1), stat=status) VERIFY_(STATUS) allocate(pes(0:nactive-1), stat=status) VERIFY_(STATUS) allocate (displs(0:nactive), stat=status) VERIFY_(STATUS) k = 0 do i=0, npes-1 if (sendcounts(i) > 0) then pes(k) = i k = k+1 end if enddo if (k /= nactive) then k = k+1 ASSERT_(k == nactive) ASSERT_(sendcounts(r2g(n)) == 0) pes(nactive-1) = r2g(n) end if call MPI_GROUP_INCL (GROUP, nactive, PES, newgroup, STATUS) VERIFY_(STATUS) call MPI_COMM_CREATE(arrdes%ioscattercomm, newgroup, thiscomm, STATUS) VERIFY_(STATUS) call MPI_Group_translate_ranks(group, nactive, pes, newgroup, activeranks, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) if (thiscomm /= MPI_COMM_NULL) then activesendcounts = 0 do i=0,nactive-1 activesendcounts(activeranks(i)) = sendcounts(pes(i)) if (pes(i) == r2g(n)) ntransl = activeranks(i) end do displs(0) = 0 do i=1,nactive displs(i) = displs(i-1) + activesendcounts(i-1) enddo if(n==mypeRd) then do i=0,nactive-1 if(activesendcounts(i)>0) then i1 = displs(i ) + 1 in = displs(i+1) call MAPL_Sort(idx(i1:in),var(i1:in)) endif end do endif recvcount = sendcounts(mype) if (recvcount == 0) then call MPI_SCATTERV( var, activesendcounts, displs, MPI_REAL, & dummy, recvcount, MPI_REAL, & ntransl, thiscomm, status ) else call MPI_SCATTERV( var, activesendcounts, displs, MPI_REAL, & a(offset), recvcount, MPI_REAL, & ntransl, thiscomm, status ) endif VERIFY_(STATUS) call MPI_Comm_Free(thiscomm, status) VERIFY_(STATUS) offset = offset + recvcount end if deallocate (displs) deallocate(pes) deallocate (activesendcounts, activeranks) enddo call MPI_Barrier(arrdes%ioscattercomm, status) VERIFY_(STATUS) call MPI_GROUP_FREE (GROUP, STATUS) VERIFY_(STATUS) deallocate(var,msk) deallocate (r2g) deallocate(sendcounts) if(arrdes%readers_comm /= MPI_COMM_NULL) then deallocate(idx) end if elseif(unit < 0) then ASSERT_(-UNIT<=LAST_UNIT) munit => MEM_units(-unit) munit%prevrec = munit%prevrec + 1 ASSERT_(associated(munit%Records(munit%prevrec)%R4_1)) ASSERT_(size(A)==size(munit%Records(munit%prevrec)%R4_1)) A = munit%Records(munit%prevrec)%R4_1 else call MAPL_GridGet(grid, globalCellCountPerDim=DIMS, RC=STATUS) VERIFY_(STATUS) call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) amIRoot = MAPL_am_i_root(layout) IM_WORLD = DIMS(1) if (.not. MAPL_ShmInitialized) then if (amIRoot) then allocate(VAR(IM_WORLD), stat=status) VERIFY_(STATUS) else allocate(VAR(0), stat=status) VERIFY_(STATUS) end if else call MAPL_AllocNodeArray(var,(/IM_WORLD/),rc=STATUS) VERIFY_(STATUS) end if if (amIRoot) then read (UNIT, IOSTAT=status) VAR VERIFY_(STATUS) end if if (.not. MAPL_ShmInitialized) then call ArrayScatter(A, VAR, grid, mask=mask, rc=status) VERIFY_(STATUS) deallocate(VAR) else call ArrayScatterShm(A, VAR, grid, mask=mask, rc=status) VERIFY_(STATUS) call MAPL_DeAllocNodeArray(VAR,rc=STATUS) VERIFY_(STATUS) end if end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarRead_R4_1d !--------------------------- subroutine MAPL_VarRead_R4_2d(UNIT, GRID, A, MASK, arrdes, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R4) , intent( OUT) :: A(:,:) integer, optional , intent(IN ) :: MASK(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables real(kind=ESMF_KIND_R4), allocatable :: VAR(:,:) real(kind=ESMF_KIND_R4), pointer :: VAR1d(:) integer :: IM_WORLD integer :: JM_WORLD integer :: status integer :: gridRank integer :: DIMS(ESMF_MAXGRIDDIM) type (ESMF_DELayout) :: layout type (ESMF_DistGrid) :: distGRID character(len=ESMF_MAXSTR) :: IAm='MAPL_VarRead_R4_2d' real(kind=ESMF_KIND_R4), allocatable :: buf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x integer(kind=MPI_OFFSET_KIND) :: offset integer :: jsize, jprev, num_io_rows integer, allocatable :: sendcounts(:), displs(:) real(kind=ESMF_KIND_R8) :: itime_beg, itime_end, bwidth integer :: numread, mpistatus(MPI_STATUS_SIZE) integer :: cnt logical :: am_i_root #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) VERIFY_(STATUS) itime_beg = MPI_Wtime(STATUS) VERIFY_(STATUS) #endif if(present(arrdes)) then if(present(mask)) then JM_WORLD = size(A,2) ! arrdes%offset = 0 do j=1,jm_world call MAPL_VarRead(Unit, Grid, a(:,j), mask, arrdes, rc=status) arrdes%offset = arrdes%offset - 8 enddo arrdes%offset = arrdes%offset + 8 else ndes_x = size(arrdes%in) IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%ioscattercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%ioscattercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (sendcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 sendcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + sendcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize), stat=status) VERIFY_(STATUS) allocate(buf(IM_WORLD*jsize), stat=status) VERIFY_(STATUS) if(arrdes%offset<=0) then offset = 4 else offset = arrdes%offset endif offset = offset + (arrdes%j1(myrow+1)-1)*IM_WORLD*4 cnt = IM_WORLD*jsize call MPI_FILE_READ_AT_ALL(UNIT, offset, VAR, cnt, MPI_REAL, mpistatus, STATUS) VERIFY_(STATUS) call MPI_GET_COUNT( mpistatus, MPI_REAL, numread, STATUS ) VERIFY_(STATUS) ASSERT_(cnt == numread) offset = offset - (arrdes%j1(myrow+1)-1)*IM_WORLD*4 arrdes%offset = offset + IM_WORLD*JM_WORLD*4 + 8 #ifdef DEBUG_MPIIO print*, offset, numread, IM_WORLD*jsize, VAR(1,1) #endif jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) buf(k) = VAR(i,jprev+j) k=k+1 end do end do end do jprev = jprev + jsize end do end if !DSK avoid "Attempt to fetch from allocatable variable BUF when it is not allocated" if(myiorank/=0) then allocate(buf(0), stat=status) VERIFY_(STATUS) endif call mpi_scatterv( buf, sendcounts, displs, MPI_REAL, & a, size(a), MPI_REAL, & 0, arrdes%ioscattercomm, status ) VERIFY_(STATUS) if(myiorank==0) then deallocate(VAR, stat=status) VERIFY_(STATUS) ! deallocate(buf, stat=status) ! VERIFY_(STATUS) endif deallocate(buf, stat=status) VERIFY_(STATUS) deallocate (sendcounts, displs, stat=status) VERIFY_(STATUS) end if elseif(unit < 0) then ASSERT_(-UNIT<=LAST_UNIT) munit => MEM_units(-unit) munit%prevrec = munit%prevrec + 1 ASSERT_(associated(munit%Records(munit%prevrec)%R4_2)) ASSERT_(size(A)==size(munit%Records(munit%prevrec)%R4_2)) A = munit%Records(munit%prevrec)%R4_2 else call ESMF_GridGet(GRID, dimCount=gridRank, rc=STATUS) VERIFY_(STATUS) call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, RC=STATUS) VERIFY_(STATUS) IM_WORLD = DIMS(1) JM_WORLD = DIMS(2) if (present(MASK)) JM_WORLD=size(A,2) call ESMF_GridGet(grid, distGrid=distGrid, rc=status) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=status) VERIFY_(STATUS) am_i_root = MAPL_am_i_root(layout) if (am_i_root) then allocate(VAR(IM_WORLD,JM_WORLD), stat=status) VERIFY_(STATUS) read (UNIT, IOSTAT=status) VAR VERIFY_(STATUS) else allocate(VAR(0,JM_WORLD), stat=status) VERIFY_(STATUS) end if if (MAPL_ShmInitialized .and. present(mask)) then call MAPL_AllocNodeArray(var1d,(/IM_WORLD/),rc=STATUS) VERIFY_(STATUS) do j=1,JM_WORLD if (am_i_root) then var1d = var(:,j) end if call ArrayScatterShm(A(:,j), VAR1d, grid, mask=mask, rc=status) VERIFY_(STATUS) end do call MAPL_DeAllocNodeArray(VAR1d,rc=STATUS) VERIFY_(STATUS) else call ArrayScatter(A, VAR, grid, mask=mask, rc=status) VERIFY_(STATUS) end if deallocate(VAR) VERIFY_(STATUS) END IF #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) VERIFY_(STATUS) itime_end = MPI_Wtime(STATUS) VERIFY_(STATUS) bwidth = REAL(IM_WORLD*JM_WORLD*4/1024.0/1024.0,kind=8) bwidth = bwidth/(itime_end-itime_beg) if (bwidth > peak_ioread_bandwidth) peak_ioread_bandwidth = bwidth mean_ioread_bandwidth = (mean_ioread_bandwidth + bwidth) ioread_counter=ioread_counter+1 if (mod(ioread_counter,72.d0)==0) then if (MAPL_AM_I_Root()) write(*,'(a64,3es11.3)') 'MPIIO Read Bandwidth (MB per second): ', peak_ioread_bandwidth, bwidth, mean_ioread_bandwidth/ioread_counter endif #endif RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarRead_R4_2d !--------------------------- subroutine MAPL_VarRead_R4_3d(UNIT, GRID, A, Arrdes, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R4) , intent( OUT) :: A(:,:,:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables integer :: status character(len=ESMF_MAXSTR) :: IAm='MAPL_VarRead_R4_3d' integer :: L do L = 1, size(A,3) call MAPL_VarRead(UNIT, GRID, A(:,:,L), ARRDES=arrdes, rc=status) VERIFY_(STATUS) end do RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarRead_R4_3d !--------------------------- subroutine MAPL_VarRead_R4_4d(UNIT, GRID, A, Arrdes, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R4) , intent( OUT) :: A(:,:,:,:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables integer :: status character(len=ESMF_MAXSTR) :: IAm='MAPL_VarRead_R4_4d' integer :: L do L = 1, size(A,4) call MAPL_VarRead(UNIT, GRID, A(:,:,:,L), ARRDES=arrdes, rc=status) VERIFY_(STATUS) end do RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarRead_R4_4d !--------------------------- subroutine MAPL_VarRead_R8_1d(UNIT, GRID, A, MASK, arrdes, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R8) , intent( OUT) :: A(:) integer, optional , intent(IN ) :: MASK(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables real(kind=ESMF_KIND_R8), allocatable :: VAR(:) integer :: IM_WORLD integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) type (ESMF_DELayout) :: layout type (ESMF_DistGrid) :: distGRID character(len=ESMF_MAXSTR) :: IAm='MAPL_VarRead_R8_1d' integer, allocatable :: msk(:), sendcounts(:), displs(:) integer, allocatable :: idx(:) integer :: nrdrs, mype, npes, recvcount integer :: mypeRd integer :: Rsize, first, last integer(KIND=MPI_OFFSET_KIND) :: offset integer(KIND=MPI_OFFSET_KIND) :: loffset integer :: i, k, n, i1, in real(kind=ESMF_KIND_R4) :: dummy integer :: group, newgroup integer :: thiscomm integer :: nactive integer :: ntransl integer, allocatable :: pes(:) integer, allocatable :: r2g(:) integer, allocatable :: rpes(:) integer, allocatable :: activeranks(:) integer, allocatable :: activesendcounts(:) integer :: numread, mpistatus(MPI_STATUS_SIZE) integer :: cnt if(present(arrdes)) then ASSERT_(present(mask)) IM_WORLD = arrdes%im_world call mpi_comm_size(arrdes%ioscattercomm,npes ,status) VERIFY_(STATUS) if(arrdes%readers_comm /= MPI_COMM_NULL) then call mpi_comm_rank(arrdes%readers_comm,mypeRd ,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%readers_comm,nrdrs,status) VERIFY_(STATUS) else mypeRd = -1 endif call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) call MAPL_CommsBcast(layout, nrdrs, 1, 0, rc = status) Rsize = im_world/nrdrs + 1 first = mypeRd*Rsize + 1 if(mypeRd >= mod(im_world,nrdrs)) then Rsize = Rsize - 1 first = first - (mypeRd-mod(im_world,nrdrs)) endif last = first + Rsize - 1 #ifdef DEBUG_MPIIO if (mypeRd <= nrdrs-1) write(*,'(5i)') mypeRd, IM_WORLD, first, last, Rsize #endif allocate(VAR(Rsize), stat=status) VERIFY_(STATUS) allocate(msk(Rsize), stat=status) VERIFY_(STATUS) allocate (sendcounts(0:npes-1), stat=status) VERIFY_(STATUS) allocate (r2g(0:nrdrs-1), stat=status) VERIFY_(STATUS) if(arrdes%readers_comm /= MPI_COMM_NULL) then if(arrdes%offset<=0) then offset = 4 else offset = arrdes%offset endif loffset = offset + (first-1)*8 cnt = Rsize call MPI_FILE_READ_AT_ALL(UNIT, loffset, VAR, cnt, & MPI_DOUBLE_PRECISION, mpistatus, STATUS) VERIFY_(STATUS) call MPI_GET_COUNT( mpistatus, MPI_DOUBLE_PRECISION, numread, STATUS ) VERIFY_(STATUS) ASSERT_(cnt == numread) #ifdef DEBUG_MPIIO write(*,'(3i,1f)') IM_WORLD, loffset, numread, VAR(1) #endif ASSERT_( (lbound(mask,1) <= first) ) ASSERT_( (ubound(mask,1) >= last ) ) msk = mask(first:last) allocate(idx(Rsize), stat=status) VERIFY_(STATUS) do i=1,Rsize idx(i) = i enddo msk = mask(first:last) call MAPL_Sort(msk,idx) msk = mask(first:last) call MAPL_Sort(msk,var) arrdes%offset = offset + IM_WORLD*8 + 8 endif call mpi_comm_rank(arrdes%ioscattercomm,mype ,status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%ioscattercomm, GROUP, STATUS) VERIFY_(STATUS) #if 1 if (arrdes%readers_comm /= MPI_COMM_NULL) then allocate(rpes(0:nrdrs-1), stat=status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%readers_comm, NEWGROUP, STATUS) VERIFY_(STATUS) do n=0,nrdrs-1 rpes(n) = n end do call MPI_Group_translate_ranks(newgroup, nrdrs, rpes, group, r2g, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) deallocate(rpes) end if call MAPL_CommsBcast(layout, r2g, nrdrs, 0, rc = status) #else do n=0,nrdrs-1 r2g(n) = (npes/nrdrs)*n end do #endif offset = 1 do n=0,nrdrs-1 Rsize = im_world/nrdrs + 1 first = n*Rsize + 1 if(n >= mod(im_world,nrdrs)) then Rsize = Rsize - 1 first = first - (n-mod(im_world,nrdrs)) endif last = first + Rsize - 1 sendcounts = 0 do i=first,last sendcounts(mask(i)) = sendcounts(mask(i)) + 1 enddo ! Reader "n" must be included in the mpi group + evevybody that need the data nactive = count(sendcounts > 0) if (sendcounts(r2g(n)) == 0) then nactive = nactive + 1 end if allocate (activeranks(0:nactive-1), activesendcounts(0:nactive-1), stat=status) VERIFY_(STATUS) allocate(pes(0:nactive-1), stat=status) VERIFY_(STATUS) allocate (displs(0:nactive), stat=status) VERIFY_(STATUS) k = 0 do i=0, npes-1 if (sendcounts(i) > 0) then pes(k) = i k = k+1 end if enddo if (k /= nactive) then k = k+1 ASSERT_(k == nactive) ASSERT_(sendcounts(r2g(n)) == 0) pes(nactive-1) = r2g(n) end if call MPI_GROUP_INCL (GROUP, nactive, PES, newgroup, STATUS) VERIFY_(STATUS) call MPI_COMM_CREATE(arrdes%ioscattercomm, newgroup, thiscomm, STATUS) VERIFY_(STATUS) call MPI_Group_translate_ranks(group, nactive, pes, newgroup, activeranks, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) if (thiscomm /= MPI_COMM_NULL) then activesendcounts = 0 do i=0,nactive-1 activesendcounts(activeranks(i)) = sendcounts(pes(i)) if (pes(i) == r2g(n)) ntransl = activeranks(i) end do displs(0) = 0 do i=1,nactive displs(i) = displs(i-1) + activesendcounts(i-1) enddo if(n==mypeRd) then do i=0,nactive-1 if(activesendcounts(i)>0) then i1 = displs(i ) + 1 in = displs(i+1) call MAPL_Sort(idx(i1:in),var(i1:in)) endif end do endif recvcount = sendcounts(mype) if (recvcount == 0) then call MPI_SCATTERV( var, activesendcounts, displs, & MPI_DOUBLE_PRECISION, & dummy, recvcount, MPI_DOUBLE_PRECISION, & ntransl, thiscomm, status ) else call MPI_SCATTERV( var, activesendcounts, displs, & MPI_DOUBLE_PRECISION, & a(offset), recvcount, MPI_DOUBLE_PRECISION, & ntransl, thiscomm, status ) endif VERIFY_(STATUS) call MPI_Comm_Free(thiscomm, status) VERIFY_(STATUS) offset = offset + recvcount end if deallocate (displs) deallocate(pes) deallocate (activesendcounts, activeranks) enddo call MPI_GROUP_FREE (GROUP, STATUS) VERIFY_(STATUS) deallocate(var,msk) deallocate (r2g) deallocate(sendcounts) if(arrdes%readers_comm /= MPI_COMM_NULL) then deallocate(idx) end if elseif(unit < 0) then ASSERT_(-UNIT<=LAST_UNIT) munit => MEM_units(-unit) munit%prevrec = munit%prevrec + 1 ASSERT_(associated(munit%Records(munit%prevrec)%R8_1)) ASSERT_(size(A)==size(munit%Records(munit%prevrec)%R8_1)) A = munit%Records(munit%prevrec)%R8_1 else call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, RC=STATUS) VERIFY_(STATUS) IM_WORLD = DIMS(1) allocate(VAR(IM_WORLD), stat=status) VERIFY_(STATUS) call ESMF_GridGet(grid, distGrid=distGrid, rc=status) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=status) VERIFY_(STATUS) if (MAPL_am_i_root(layout)) then read (UNIT, IOSTAT=status) VAR VERIFY_(STATUS) end if call ArrayScatter(A, VAR, grid, mask=mask, rc=status) VERIFY_(STATUS) deallocate(VAR) end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarRead_R8_1d !--------------------------- subroutine MAPL_VarRead_R8_2d(UNIT, GRID, A, MASK, arrdes, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R8) , intent( OUT) :: A(:,:) integer, optional , intent(IN ) :: MASK(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables real(kind=ESMF_KIND_R8), allocatable :: VAR(:,:) integer :: IM_WORLD integer :: JM_WORLD integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) integer :: gridRank type (ESMF_DELayout) :: layout type (ESMF_DistGrid) :: distGRID character(len=ESMF_MAXSTR) :: IAm='MAPL_VarRead_R8_2d' real(kind=ESMF_KIND_R8), allocatable :: buf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x integer(kind=MPI_OFFSET_KIND) :: offset integer :: jstart, jsize, jprev integer :: num_io_rows integer, allocatable :: sendcounts(:), displs(:) real(kind=ESMF_KIND_R8) :: itime_beg, itime_end, bwidth integer :: numread, mpistatus(MPI_STATUS_SIZE) integer :: cnt #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) VERIFY_(STATUS) itime_beg = MPI_Wtime(STATUS) VERIFY_(STATUS) #endif if(present(arrdes)) then if(present(mask)) then JM_WORLD = size(A,2) arrdes%offset = 0 do j=1,jm_world call MAPL_VarRead(Unit, Grid, a(:,j), mask, arrdes, rc=status) arrdes%offset = arrdes%offset - 8 enddo arrdes%offset = arrdes%offset + 8 else ndes_x = size(arrdes%in) IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%ioscattercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%ioscattercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (sendcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 sendcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + sendcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize), stat=status) VERIFY_(STATUS) allocate(buf(IM_WORLD*jsize), stat=status) VERIFY_(STATUS) if(arrdes%offset<=0) then offset = 4 else offset = arrdes%offset endif offset = offset + (arrdes%j1(myrow+1)-1)*IM_WORLD*8 cnt = IM_WORLD*jsize call MPI_FILE_READ_AT_ALL(UNIT, offset, VAR, cnt, MPI_DOUBLE_PRECISION, mpistatus, STATUS) VERIFY_(STATUS) call MPI_GET_COUNT( mpistatus, MPI_DOUBLE_PRECISION, numread, STATUS ) VERIFY_(STATUS) ASSERT_(cnt == numread) offset = offset - (arrdes%j1(myrow+1)-1)*IM_WORLD*8 arrdes%offset = offset + IM_WORLD*JM_WORLD*8 + 8 #ifdef DEBUG_MPIIO print*, offset, numread, VAR(1,1) #endif jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) buf(k) = VAR(i,jprev+j) k=k+1 end do end do end do jprev = jprev + jsize end do end if !DSK avoid "Attempt to fetch from allocatable variable BUF when it is not allocated" if(myiorank/=0) then allocate(buf(0), stat=status) VERIFY_(STATUS) endif call mpi_scatterv( buf, sendcounts, displs, MPI_DOUBLE_PRECISION, & a, size(a), MPI_DOUBLE_PRECISION, & 0, arrdes%ioscattercomm, status ) VERIFY_(STATUS) if(myiorank==0) then deallocate(VAR, stat=status) VERIFY_(STATUS) ! deallocate(buf, stat=status) ! VERIFY_(STATUS) endif deallocate(buf, stat=status) VERIFY_(STATUS) deallocate (sendcounts, displs, stat=status) VERIFY_(STATUS) endif elseif(unit < 0) then ASSERT_(-UNIT<=LAST_UNIT) munit => MEM_units(-unit) munit%prevrec = munit%prevrec + 1 ASSERT_(associated(munit%Records(munit%prevrec)%R8_2)) ASSERT_(size(A)==size(munit%Records(munit%prevrec)%R8_2)) A = munit%Records(munit%prevrec)%R8_2 else call ESMF_GridGet(GRID, dimCount=gridRank, rc=STATUS) VERIFY_(STATUS) call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, RC=STATUS) VERIFY_(STATUS) IM_WORLD = DIMS(1) JM_WORLD = DIMS(2) if(present(MASK)) JM_WORLD=size(A,2) allocate(VAR(IM_WORLD,JM_WORLD), stat=status) VERIFY_(STATUS) call ESMF_GridGet(grid, distGrid=distGrid, rc=status) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=status) VERIFY_(STATUS) if (MAPL_am_i_root(layout)) then read (UNIT, IOSTAT=status) VAR VERIFY_(STATUS) end if call ArrayScatter(A, VAR, grid, mask=mask, rc=status) VERIFY_(STATUS) deallocate(VAR) END IF #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) VERIFY_(STATUS) itime_end = MPI_Wtime(STATUS) VERIFY_(STATUS) bwidth = REAL(IM_WORLD*JM_WORLD*8/1024.0/1024.0,kind=8) bwidth = bwidth/(itime_end-itime_beg) if (bwidth > peak_ioread_bandwidth) peak_ioread_bandwidth = bwidth mean_ioread_bandwidth = (mean_ioread_bandwidth + bwidth) ioread_counter=ioread_counter+1 if (mod(ioread_counter,72.d0)==0) then if (MAPL_AM_I_Root()) write(*,'(a64,3es11.3)') 'MPIIO Read Bandwidth (MB per second): ', peak_ioread_bandwidth, bwidth, mean_ioread_bandwidth/ioread_counter endif #endif RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarRead_R8_2d !--------------------------- subroutine MAPL_VarRead_R8_3d(UNIT, GRID, A, arrdes, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R8) , intent( OUT) :: A(:,:,:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables integer :: status character(len=ESMF_MAXSTR) :: IAm='MAPL_VarRead_R8_3d' integer :: L do L = 1, size(A,3) call MAPL_VarRead(UNIT, GRID, A(:,:,L), ARRDES=arrdes, rc=status) VERIFY_(STATUS) end do RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarRead_R8_3d !--------------------------- subroutine MAPL_VarRead_R8_4d(UNIT, GRID, A, arrdes, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R8) , intent( OUT) :: A(:,:,:,:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables integer :: status character(len=ESMF_MAXSTR) :: IAm='MAPL_VarRead_R8_4d' integer :: L do L = 1, size(A,4) call MAPL_VarRead(UNIT, GRID, A(:,:,:,L), ARRDES=arrdes, rc=status) VERIFY_(STATUS) end do RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarRead_R8_4d !--------------------------- ! Write routines !--------------------------- subroutine MAPL_StateVarWrite(UNIT, STATE, NAME, RESOLUTION, ARRDES, forceWriteNoRestart, RC) integer , intent(IN ) :: UNIT type (ESMF_State) , intent(INout) :: STATE character(len=*), optional, intent(IN ) :: NAME integer, optional, pointer :: RESOLUTION(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES logical, optional, intent(IN ) :: forceWriteNoRestart integer, optional, intent( OUT) :: RC ! Local vars type (ESMF_FieldBundle) :: bundle type (ESMF_Field) :: field type (ESMF_Grid) :: grid integer :: status integer :: I, ITEMCOUNT, varid, ind logical :: FOUND type (ESMF_StateItem_Flag), pointer :: ITEMTYPES(:) character(len=ESMF_MAXSTR ), pointer :: ITEMNAMES(:) logical, pointer :: DOIT(:) character(len=ESMF_MAXSTR) :: IAm='MAPL_StateVarWrite' logical :: skipWriting integer :: RST, dna character(len=ESMF_MAXSTR) :: FieldName logical :: forceWriteNoRestart_ integer :: DIMS integer, pointer :: MASK(:) => null() integer, allocatable :: orderlist(:) integer :: jj character(len=ESMF_MAXSTR) :: attrName character(len=ESMF_MAXSTR), allocatable :: currList(:) integer :: natt call ESMF_StateGet(STATE,ITEMCOUNT=ITEMCOUNT,RC=STATUS) VERIFY_(STATUS) ASSERT_(ITEMCOUNT>0) allocate(ITEMNAMES(ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) allocate(ITEMTYPES(ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) allocate(DOIT (ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) call ESMF_StateGet(STATE,ITEMNAMELIST=ITEMNAMES,itemTypeList=ITEMTYPES,RC=STATUS) VERIFY_(STATUS) forceWriteNoRestart_ = .false. if(present(forceWriteNoRestart)) then forceWriteNoRestart_ = forceWriteNoRestart endif if(present(NAME)) then DOIT = ITEMNAMES==NAME ASSERT_(count(DOIT)/=0) else DOIT = .true. endif attrName = MAPL_StateItemOrderList call ESMF_AttributeGet(state, NAME=attrName, itemcount=natt, RC=STATUS) VERIFY_(STATUS) ASSERT_(natt > 0) allocate(orderlist(natt), stat=status) VERIFY_(STATUS) allocate(currList(natt), stat=status) VERIFY_(STATUS) ! get the current list call ESMF_AttributeGet(state, NAME=attrName, VALUELIST=currList, rc=status) VERIFY_(STATUS) orderList = -1 ! not found do i = 1, natt ! search loop do jj = 1, ITEMCOUNT if (itemNames(jj) == currList(i)) then orderList(i) = jj exit end if end do end do deallocate(currList) do JJ = 1, natt I = ORDERLIST(JJ) IF (DOIT (I)) then #ifdef TIME_MPIIO call write_parallel(itemnames(i)) #endif IF (ITEMTYPES(I) == ESMF_StateItem_FieldBundle) then call ESMF_StateGet(state, itemnames(i), bundle, rc=status) VERIFY_(STATUS) skipWriting = .false. if (.not. forceWriteNoRestart_) then call ESMF_AttributeGet(bundle, name='RESTART', value=RST, rc=status) if (STATUS == ESMF_SUCCESS) then skipWriting = (RST == MAPL_RestartSkip) end if end if if (skipWriting) cycle call MAPL_BundleWrite(unit, bundle, RESOLUTION=RESOLUTION, arrdes=arrdes, rc=status) VERIFY_(STATUS) ELSE IF (ITEMTYPES(I) == ESMF_StateItem_Field) THEN call ESMF_StateGet(state, itemnames(i), field, rc=status) VERIFY_(STATUS) skipWriting = .false. if (.not. forceWriteNoRestart_) then call ESMF_AttributeGet(field, name='RESTART', value=RST, rc=status) if (STATUS == ESMF_SUCCESS) then skipWriting = (RST == MAPL_RestartSkip) end if end if if (skipWriting) cycle call ESMF_AttributeGet(field, name='doNotAllocate', value=dna, rc=status) if (STATUS == ESMF_SUCCESS) then skipWriting = (dna /= 0) endif if (skipWriting) cycle if(.not.associated(MASK)) then call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) VERIFY_(STATUS) if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call ESMF_FieldGet (field, grid=grid, rc=status) VERIFY_(STATUS) call MAPL_TileMaskGet(grid, mask, rc=status) VERIFY_(STATUS) endif endif call MAPL_FieldWrite(unit, field, RESOLUTION=RESOLUTION, arrdes=arrdes, HomePE=mask, rc=status) VERIFY_(STATUS) end IF END IF END DO deallocate(orderlist) deallocate(ITEMNAMES) deallocate(ITEMTYPES) deallocate(DOIT ) if(associated(MASK)) then DEALOC_(MASK) end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_StateVarWrite !--------------------------- subroutine MAPL_BundleWrite(UNIT,BUNDLE, RESOLUTION, ARRDES, RC) integer , intent(IN ) :: UNIT type (ESMF_FieldBundle) , intent(INOUT) :: BUNDLE integer, optional , pointer :: RESOLUTION(:) type(ArrDescr), optional , intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC integer :: status integer :: J, N, varid, fieldCount, ind character(len=ESMF_MAXSTR) :: IAm='MAPL_BundleWrite' type (ESMF_Field) :: field character(len=ESMF_MAXSTR),allocatable :: nameList(:) character(len=ESMF_MAXSTR) :: FieldName, BundleName call ESMF_FieldBundleGet(bundle, fieldCount=N, name=BundleName, rc=STATUS) VERIFY_(STATUS) allocate(namelist(N), stat=status) VERIFY_(STATUS) call ESMF_FieldBundleGet(bundle, fieldNameList=nameList, fieldCount=FieldCount, rc=STATUS) VERIFY_(STATUS) ASSERT_(N==fieldCount) DO J = 1, N call MAPL_FieldBundleGet(bundle, fieldIndex=J, field=field, rc=status) VERIFY_(STATUS) call MAPL_FieldWrite(unit, field, RESOLUTION=RESOLUTION, arrdes=ARRDES, rc=status) VERIFY_(STATUS) END DO deallocate(nameList) RETURN_(ESMF_SUCCESS) end subroutine MAPL_BundleWrite !--------------------------- subroutine MAPL_FieldWriteNCPar(ncioObj, name, FIELD, ARRDES, HomePE, RC) type(MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name type (ESMF_Field) , intent(INOUT) :: field !ALT: intent(in) type(ArrDescr) , intent(INOUT) :: ARRDES integer, target, optional , intent(IN ) :: HomePE(:) integer, optional , intent( OUT) :: RC ! Local vars type (ESMF_Array) :: array type (ESMF_DELayout) :: layout type (ESMF_Grid) :: GRID integer :: rank integer :: status integer :: DIMS real(KIND=ESMF_KIND_R4), pointer, dimension(:) :: var_1d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:) :: var_2d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:,:) :: var_3d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:,:,:) :: var_4d real(KIND=ESMF_KIND_R8), pointer, dimension(:) :: vr8_1d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:) :: vr8_2d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:,:) :: vr8_3d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:,:,:) :: vr8_4d type(ESMF_TypeKind_Flag) :: tk integer, pointer :: mask(:) character(len=ESMF_MAXSTR) :: FORMATTED integer :: count integer :: J,K character(len=ESMF_MAXSTR) :: IAm='MAPL_FieldWriteNCPar' type (ESMF_DistGrid) :: distGrid call ESMF_FieldGet(field, grid=grid, rc=status) VERIFY_(STATUS) call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) VERIFY_(STATUS) if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then if(present(HomePE)) then mask => HomePE else call MAPL_TileMaskGet(grid, mask, rc=status) VERIFY_(STATUS) endif end if call ESMF_FieldGet(field, Array=array, rc=status) VERIFY_(STATUS) call ESMF_ArrayGet(array, typekind=tk, rank=rank, rc=status) VERIFY_(STATUS) if (rank == 1) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_1d, rc=status) VERIFY_(STATUS) if (associated(var_1d)) then if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call MAPL_VarWrite(ncioObj, name, var_1d, layout=layout, arrdes=arrdes, mask=mask, rc=status) else if (DIMS == MAPL_DimsVertOnly .or. DIMS==MAPL_DimsNone) then call MAPL_VarWrite(ncioObj, name, var_1d, layout=layout, arrdes=arrdes, rc=status) else RETURN_(ESMF_FAILURE) end if end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_1d, rc=status) VERIFY_(STATUS) if (associated(vr8_1d)) then if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call MAPL_VarWrite(ncioObj, name, vr8_1d, layout=layout, arrdes=arrdes, mask=mask, rc=status) else if (DIMS == MAPL_DimsVertOnly .or. DIMS==MAPL_DimsNone) then call MAPL_VarWrite(ncioObj, name, vr8_1d, layout=layout, arrdes=arrdes, rc=status) else RETURN_(ESMF_FAILURE) end if end if endif else if (rank == 2) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_2d, rc=status) VERIFY_(STATUS) if (associated(var_2d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(var_2d,2) call MAPL_VarWrite(ncioObj, name, var_2d(:,J), layout=layout, arrdes=arrdes, mask=mask, offset1=j, rc=status) end do else if (DIMS == MAPL_DimsTileTile) then do j=1,size(var_2d,2) call MAPL_VarWrite(ncioObj, name, var_2d(:,J), layout=layout, arrdes=arrdes, mask=mask, offset1=j, rc=status) enddo else call MAPL_VarWrite(ncioObj, name, var_2d, arrdes=arrdes, rc=status) end if end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_2d, rc=status) VERIFY_(STATUS) if (associated(vr8_2d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(vr8_2d,2) call MAPL_VarWrite(ncioObj, name, vr8_2d(:,J), layout=layout, arrdes=arrdes, mask=mask, offset1=j, rc=status) end do else if (DIMS == MAPL_DimsTileTile) then do j=1,size(var_2d,2) call MAPL_VarWrite(ncioObj, name, vr8_2d(:,J), layout=layout, arrdes=arrdes, mask=mask, offset1=j, rc=status) enddo else call MAPL_VarWrite(ncioObj, name, vr8_2d, arrdes=arrdes, rc=status) end if end if endif else if (rank == 3) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_3d, rc=status) VERIFY_(STATUS) if (associated(var_3d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(var_3d,2) do K = 1,size(var_3d,3) call MAPL_VarWrite(ncioObj, name, var_3d(:,J,K), layout=layout, arrdes=arrdes, mask=mask, offset1=j, offset2=k, rc=status) end do end do else call MAPL_VarWrite(ncioObj, name, var_3d, arrdes=arrdes, rc=status) endif end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_3d, rc=status) VERIFY_(STATUS) if (associated(vr8_3d)) then !ALT: temp kludge if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(vr8_3d,2) do K = 1,size(vr8_3d,3) call MAPL_VarWrite(ncioObj, name, vr8_3d(:,J,K), layout=layout, arrdes=arrdes, mask=mask, offset1=j, offset2=k, rc=status) end do end do else call MAPL_VarWrite(ncioObj, name, vr8_3d, arrdes=arrdes, rc=status) end if end if endif else print *, "ERROR: unsupported RANK" RETURN_(ESMF_FAILURE) endif VERIFY_(STATUS) if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then if(.not.present(HomePE)) then DEALOC_(mask) end if end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_FieldWriteNCPar subroutine MAPL_FieldWrite(UNIT,FIELD, RESOLUTION, ARRDES, HomePE, RC) integer , intent(IN ) :: UNIT type (ESMF_Field) , intent(INOUT) :: field !ALT: intent(in) integer, optional , pointer :: RESOLUTION(:) type(ArrDescr), optional , intent(INOUT) :: ARRDES integer, target, optional , intent(IN ) :: HomePE(:) integer, optional , intent( OUT) :: RC ! Local vars type (ESMF_Array) :: array type (ESMF_DELayout) :: layout type (ESMF_Grid) :: GRID integer :: rank integer :: status integer :: DIMS real(KIND=ESMF_KIND_R4), pointer, dimension(:) :: var_1d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:) :: var_2d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:,:) :: var_3d real(KIND=ESMF_KIND_R4), pointer, dimension(:,:,:,:) :: var_4d real(KIND=ESMF_KIND_R8), pointer, dimension(:) :: vr8_1d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:) :: vr8_2d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:,:) :: vr8_3d real(KIND=ESMF_KIND_R8), pointer, dimension(:,:,:,:) :: vr8_4d type(ESMF_TypeKind_Flag) :: tk integer, pointer :: mask(:) => NULL() character(len=ESMF_MAXSTR) :: FORMATTED integer :: count integer :: J,K character(len=ESMF_MAXSTR) :: IAm='MAPL_FieldWrite' type (ESMF_DistGrid) :: distGrid if (unit < 0 .or. present(arrdes)) then FORMATTED = "NO" else inquire(unit=UNIT, formatted=FORMATTED) end if call ESMF_FieldGet(field, grid=grid, rc=status) VERIFY_(STATUS) call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) call ESMF_AttributeGet(field, name='DIMS', value=DIMS, rc=status) VERIFY_(STATUS) if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then if(present(HomePE)) then mask => HomePE else call MAPL_TileMaskGet(grid, mask, rc=status) VERIFY_(STATUS) endif end if call ESMF_FieldGet(field, Array=array, rc=status) VERIFY_(STATUS) call ESMF_ArrayGet(array, typekind=tk, rank=rank, rc=status) VERIFY_(STATUS) if (rank == 1) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_1d, rc=status) VERIFY_(STATUS) if (associated(var_1d)) then if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call MAPL_VarWrite(unit, grid, var_1d, arrdes=arrdes, mask=mask, rc=status) else if (DIMS == MAPL_DimsVertOnly .or. DIMS==MAPL_DimsNone) then call WRITE_PARALLEL(var_1d, unit, arrdes=arrdes, rc=status) else RETURN_(ESMF_FAILURE) end if end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_1d, rc=status) VERIFY_(STATUS) if (associated(vr8_1d)) then if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then call MAPL_VarWrite(unit, grid, vr8_1d, arrdes=arrdes, mask=mask, rc=status) else if (DIMS == MAPL_DimsVertOnly .or. DIMS==MAPL_DimsNone) then call WRITE_PARALLEL(vr8_1d, unit, arrdes=arrdes, rc=status) else RETURN_(ESMF_FAILURE) end if end if endif else if (rank == 2) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_2d, rc=status) VERIFY_(STATUS) if (associated(var_2d)) then !ALT: temp kludge if (FORMATTED=="YES") THEN call WRITE_PARALLEL( & var_2d(lbound(var_2d,1),:), unit, rc=status) else if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(var_2d,2) call MAPL_VarWrite(unit, grid, var_2d(:,J), arrdes=arrdes, mask=mask, rc=status) end do else if (DIMS == MAPL_DimsTileTile) then call MAPL_VarWrite(unit, grid, var_2d, arrdes=arrdes, mask=mask, resolution=resolution, rc=status) else call MAPL_VarWrite(unit, grid, var_2d, resolution=resolution, arrdes=arrdes, rc=status) end if end if end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_2d, rc=status) VERIFY_(STATUS) if (associated(vr8_2d)) then !ALT: temp kludge if (FORMATTED=="YES") THEN call WRITE_PARALLEL( & vr8_2d(lbound(vr8_2d,1),:), unit, rc=status) else if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(vr8_2d,2) call MAPL_VarWrite(unit, grid, vr8_2d(:,J), arrdes=arrdes, mask=mask, rc=status) end do else if (DIMS == MAPL_DimsTileTile) then call MAPL_VarWrite(unit, grid, vr8_2d, mask=mask, resolution=resolution, rc=status) else call MAPL_VarWrite(unit, grid, vr8_2d, resolution=resolution, arrdes=arrdes, rc=status) end if end if end if endif else if (rank == 3) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_3d, rc=status) VERIFY_(STATUS) if (associated(var_3d)) then !ALT: temp kludge if (FORMATTED=="YES") THEN call WRITE_PARALLEL( & var_3d(lbound(var_3d,1),lbound(var_3d,2),:), unit) else if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(var_3d,2) do K = 1,size(var_3d,3) call MAPL_VarWrite(unit, grid, var_3d(:,J,K), arrdes=arrdes, mask=mask, rc=status) end do end do else call MAPL_VarWrite(unit, grid, var_3d, resolution=resolution, arrdes=arrdes, rc=status) endif endif end if else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_3d, rc=status) VERIFY_(STATUS) if (associated(vr8_3d)) then !ALT: temp kludge if (FORMATTED=="YES") THEN call WRITE_PARALLEL( & vr8_3d(lbound(vr8_3d,1),lbound(vr8_3d,2),:), unit) else if (DIMS == MAPL_DimsTileOnly) then do J = 1,size(vr8_3d,2) do K = 1,size(vr8_3d,3) call MAPL_VarWrite(unit, grid, vr8_3d(:,J,K), arrdes=arrdes, mask=mask, rc=status) end do end do else call MAPL_VarWrite(unit, grid, vr8_3d, resolution=resolution, arrdes=arrdes, rc=status) end if endif end if endif else if (rank == 4) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_4d, rc=status) VERIFY_(STATUS) call MAPL_VarWrite(unit, grid, var_4d, resolution=resolution, rc=status) else call ESMF_ArrayGet(array, localDE=0, farrayptr=vr8_4d, rc=status) VERIFY_(STATUS) call MAPL_VarWrite(unit, grid, vr8_4d, resolution=resolution, rc=status) endif else print *, "ERROR: unsupported RANK" RETURN_(ESMF_FAILURE) endif VERIFY_(STATUS) if (DIMS == MAPL_DimsTileOnly .or. DIMS == MAPL_DimsTileTile) then if(.not.present(HomePE)) then DEALOC_(mask) end if end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_FieldWrite subroutine alloc_(A,type,im,jm,rc) type (Ptr), intent(INOUT) :: A integer, intent(IN) :: TYPE integer, intent(IN) :: IM integer, optional, intent(IN) :: JM integer, optional, intent(out) :: rc integer :: status character(len=ESMF_MAXSTR) :: IAm='alloc_' call dealloc_(A,RC=STATUS) VERIFY_(STATUS) select case (type) case (R4_2) ASSERT_(present(jm)) allocate(A%r4_2(IM,JM)) case (R4_1) ASSERT_(.not.present(jm)) allocate(A%r4_1(IM)) case (R8_2) ASSERT_(present(jm)) allocate(A%r8_2(IM,JM)) case (R8_1) ASSERT_(.not.present(jm)) allocate(A%r8_1(IM)) case (i4_1) ASSERT_(.not.present(jm)) allocate(A%I4_1(IM)) case (i4_2) ASSERT_(present(jm)) allocate(A%I4_2(IM,JM)) case default ASSERT_(.false.) end select a%allocated=type RETURN_(ESMF_SUCCESS) end subroutine alloc_ subroutine dealloc_(A,RC) type (Ptr), intent(INOUT) :: A integer, optional, intent(out) :: rc integer :: status character(len=ESMF_MAXSTR) :: IAm='dealloc_' if(a%allocated/=not_allocated) then select case (a%allocated) case (R4_2) if(associated(A%r4_2)) deallocate(A%r4_2) case (R4_1) if(associated(A%r4_1)) deallocate(A%r4_1) case (R8_2) if(associated(A%r8_2)) deallocate(A%r8_2) case (R8_1) if(associated(A%r8_1)) deallocate(A%r8_1) case (i4_1) if(associated(A%i4_1)) deallocate(A%i4_1) case (i4_2) if(associated(A%i4_2)) deallocate(A%i4_2) case default ASSERT_(.false.) end select a%allocated=not_allocated end if RETURN_(ESMF_SUCCESS) end subroutine dealloc_ !--------------------------- subroutine MAPL_VarWrite_I4_1d(UNIT, GRID, A, MASK, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID integer(kind=ESMF_KIND_I4) , intent(IN ) :: A(:) integer, optional , intent(IN ) :: MASK(:) integer, optional , intent( OUT) :: RC ! Local variables integer(kind=ESMF_KIND_I4), allocatable :: VAR(:) integer :: IM_WORLD integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) type (ESMF_DELayout) :: layout type (ESMF_DistGrid) :: distGrid character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWrite_I4_1d' if(unit < 0) then munit => MEM_units(-unit) munit%prevrec = munit%prevrec + 1 if(.not.associated(munit%Records)) then allocate(munit%Records(16),stat=status) VERIFY_(STATUS) elseif(size(munit%Records)< munit%prevrec) then allocate(REC(munit%prevrec*2),stat=status) VERIFY_(STATUS) REC(:munit%prevrec-1) = munit%Records deallocate(munit%Records) munit%Records => REC endif call alloc_(munit%Records(munit%prevrec),i4_1,size(A),rc=status) VERIFY_(STATUS) munit%Records(munit%prevrec)%I4_1 = A else call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, RC=STATUS) VERIFY_(STATUS) IM_WORLD = DIMS(1) allocate(VAR(IM_WORLD), stat=status) VERIFY_(STATUS) call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) call ArrayGather(A, VAR, grid, mask=mask, rc=status) VERIFY_(STATUS) if (MAPL_am_i_root(layout)) then write (UNIT, IOSTAT=status) VAR VERIFY_(STATUS) end if deallocate(VAR) endif RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWrite_I4_1d !--------------------------- subroutine MAPL_VarWrite_R4_1d(UNIT, GRID, A, MASK, arrdes, writeFCtrl, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R4) , intent(IN ) :: A(:) integer, optional , intent(IN ) :: MASK(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES logical, optional , intent(IN ) :: writeFCtrl ! if not present default is .true. integer, optional , intent( OUT) :: RC ! Local variables real(kind=ESMF_KIND_R4), allocatable :: VAR(:) real(kind=ESMF_KIND_R4), allocatable :: GVAR(:) integer :: IM_WORLD integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) type (ESMF_DELayout) :: layout type (ESMF_DistGrid) :: distGrid character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWrite_R4_1d' integer, allocatable :: msk(:), recvcounts(:), displs(:) integer :: nwrts, mype, npes, sendcount integer :: mypeWr integer :: Rsize, first, last integer(KIND=MPI_OFFSET_KIND) :: offset integer(KIND=MPI_OFFSET_KIND) :: loffset integer :: i, k, n, i1, in integer :: ii real(kind=ESMF_KIND_R4) :: dummy integer :: group, newgroup integer :: thiscomm integer :: nactive integer :: ntransl integer, allocatable :: pes(:) integer, allocatable :: inv_pes(:) integer, allocatable :: r2g(:) integer, allocatable :: rpes(:) integer, allocatable :: activeranks(:) integer, allocatable :: activerecvcounts(:) integer :: recl logical :: useWriteFCtrl integer :: numwrite, mpistatus(MPI_STATUS_SIZE) logical :: amIRoot if(present(writeFCtrl)) then useWriteFCtrl = writeFCtrl else useWriteFCtrl = .true. end if if(present(arrdes)) then ASSERT_(present(mask)) IM_WORLD = arrdes%im_world recl = IM_WORLD*4 call mpi_comm_size(arrdes%iogathercomm,npes ,status) VERIFY_(STATUS) if(arrdes%writers_comm /= MPI_COMM_NULL) then call mpi_comm_rank(arrdes%writers_comm,mypeWr ,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%writers_comm,nwrts,status) VERIFY_(STATUS) else mypeWr = -1 endif call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) call MAPL_CommsBcast(layout, nwrts, 1, 0, rc = status) Rsize = im_world/nwrts + 1 first = mypeWr*Rsize + 1 if(mypeWr >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (mypeWr-mod(im_world,nwrts)) endif last = first + Rsize - 1 #ifdef DEBUG_MPIIO if (mypeWr <= nwrts-1) write(*,'(5i)') mypeWr, IM_WORLD, first, last, Rsize #endif if(arrdes%writers_comm /= MPI_COMM_NULL) then allocate(GVAR(Rsize), stat=status) VERIFY_(STATUS) end if allocate(VAR(Rsize), stat=status) VERIFY_(STATUS) allocate(msk(Rsize), stat=status) VERIFY_(STATUS) allocate (recvcounts(0:npes-1), stat=status) VERIFY_(STATUS) allocate (r2g(0:nwrts-1), stat=status) VERIFY_(STATUS) allocate(inv_pes(0:npes-1),stat=status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%iogathercomm,mype ,status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%iogathercomm, GROUP, STATUS) VERIFY_(STATUS) #if 1 if (arrdes%writers_comm /= MPI_COMM_NULL) then allocate(rpes(0:nwrts-1), stat=status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%writers_comm, NEWGROUP, STATUS) VERIFY_(STATUS) do n=0,nwrts-1 rpes(n) = n end do call MPI_Group_translate_ranks(newgroup, nwrts, rpes, group, r2g, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) deallocate(rpes) end if call MAPL_CommsBcast(layout, r2g, nwrts, 0, rc = status) #else do n=0,nrdrs-1 r2g(n) = (npes/nrdrs)*n end do #endif offset = 1 do n=0,nwrts-1 Rsize = im_world/nwrts + 1 first = n*Rsize + 1 if(n >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (n-mod(im_world,nwrts)) endif last = first + Rsize - 1 recvcounts = 0 do i=first,last recvcounts(mask(i)) = recvcounts(mask(i)) + 1 enddo ! Writer "n" must be included in the mpi group + evevybody that need the data nactive = count(recvcounts > 0) if (recvcounts(r2g(n)) == 0) then nactive = nactive + 1 end if allocate (activeranks(0:nactive-1), activerecvcounts(0:nactive-1), stat=status) VERIFY_(STATUS) allocate(pes(0:nactive-1), stat=status) VERIFY_(STATUS) allocate (displs(0:nactive), stat=status) VERIFY_(STATUS) k = 0 do i=0, npes-1 if (recvcounts(i) > 0) then pes(k) = i k = k+1 end if enddo if (k /= nactive) then k = k+1 ASSERT_(k == nactive) ASSERT_(recvcounts(r2g(n)) == 0) pes(nactive-1) = r2g(n) end if call MPI_GROUP_INCL (GROUP, nactive, PES, newgroup, STATUS) VERIFY_(STATUS) call MPI_COMM_CREATE(arrdes%iogathercomm, newgroup, thiscomm, STATUS) VERIFY_(STATUS) call MPI_Group_translate_ranks(group, nactive, pes, newgroup, activeranks, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) inv_pes = -1 ! initialized to invalid do i=0,nactive-1 inv_pes(pes(i)) = i end do if (thiscomm /= MPI_COMM_NULL) then activerecvcounts = 0 do i=0,nactive-1 activerecvcounts(activeranks(i)) = recvcounts(pes(i)) if (pes(i) == r2g(n)) ntransl = activeranks(i) end do displs(0) = 0 do i=1,nactive displs(i) = displs(i-1) + activerecvcounts(i-1) enddo sendcount = recvcounts(mype) if (sendcount == 0) then call MPI_GATHERV( dummy, sendcount, MPI_REAL, & var, activerecvcounts, displs, MPI_REAL, & ntransl, thiscomm, status ) else call MPI_GATHERV( a(offset), sendcount, MPI_REAL, & var, activerecvcounts, displs, MPI_REAL, & ntransl, thiscomm, status ) endif VERIFY_(STATUS) call MPI_Comm_Free(thiscomm, status) VERIFY_(STATUS) if(n==mypeWr) then msk = mask(first:last) do I=1,Rsize K = inv_pes(MSK(I)) II = displs(K)+1 ! var is 1-based GVAR(I) = VAR(II) displs(K) = displs(K) + 1 end do endif offset = offset + sendcount end if deallocate (displs) deallocate(pes) deallocate (activerecvcounts, activeranks) enddo if(arrdes%writers_comm /= MPI_COMM_NULL) then if(arrdes%offset<=0) then offset = 4 else offset = arrdes%offset endif if(useWriteFCtrl .and. mypeWr==0) then call MPI_FILE_SEEK(UNIT, offset-4, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif Rsize = im_world/nwrts + 1 first = mypeWr*Rsize + 1 if(mypeWr >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (mypeWr-mod(im_world,nwrts)) endif last = first + Rsize - 1 ASSERT_( (lbound(mask,1) <= first) ) ASSERT_( (ubound(mask,1) >= last ) ) loffset = offset + (first-1)*4 call MPI_FILE_WRITE_AT_ALL(UNIT, loffset, GVAR, Rsize, MPI_REAL, mpistatus, STATUS) VERIFY_(STATUS) #ifdef DEBUG_MPIIO call MPI_GET_COUNT( mpistatus, MPI_REAL, numwrite, STATUS ) VERIFY_(STATUS) write(*,'(4i,1f)') IM_WORLD, loffset, numwrite, GVAR(1) #endif if(useWriteFCtrl .and. mypeWr==0) then call MPI_FILE_SEEK(UNIT, offset+recl, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif arrdes%offset = offset + recl + 8 endif call MPI_GROUP_FREE (GROUP, STATUS) VERIFY_(STATUS) deallocate(var,msk) deallocate (inv_pes) deallocate (r2g) deallocate(recvcounts) if(arrdes%writers_comm /= MPI_COMM_NULL) then deallocate(gvar) end if elseif(unit < 0) then munit => MEM_units(-unit) munit%prevrec = munit%prevrec + 1 if(.not.associated(munit%Records)) then allocate(munit%Records(16),stat=status) VERIFY_(STATUS) elseif(size(munit%Records)< munit%prevrec) then allocate(REC(munit%prevrec*2),stat=status) VERIFY_(STATUS) REC(:munit%prevrec-1) = munit%Records deallocate(munit%Records) munit%Records => REC endif call alloc_(munit%Records(munit%prevrec),R4_1,size(A),rc=status) VERIFY_(STATUS) munit%Records(munit%prevrec)%R4_1 = A else call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, RC=STATUS) VERIFY_(STATUS) IM_WORLD = DIMS(1) call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) amIRoot = MAPL_am_i_root(layout) if (amIRoot) then allocate(VAR(IM_WORLD), stat=status) VERIFY_(STATUS) else allocate(VAR(0), stat=status) VERIFY_(STATUS) end if call ArrayGather(A, VAR, grid, mask=mask, rc=status) VERIFY_(STATUS) if (MAPL_am_i_root(layout)) then write (UNIT, IOSTAT=status) VAR VERIFY_(STATUS) end if deallocate(VAR) end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWrite_R4_1d !--------------------------- !--------------------------- subroutine MAPL_VarWrite_R4_2d(UNIT, GRID, A, MASK, RESOLUTION, ARRDES, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R4) , intent(IN ) :: A(:,:) integer, optional , intent(IN ) :: MASK(:) integer, optional , pointer :: RESOLUTION(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables real(kind=ESMF_KIND_R4), allocatable :: VAR(:,:) integer :: IM_WORLD integer :: JM_WORLD real , allocatable :: VARin(:,:) real , allocatable :: VARout(:,:) integer :: IM0 integer :: JM0 integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) integer :: gridRank type (ESMF_DELayout) :: layout type (ESMF_DistGrid) :: distGrid character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWrite_R4_2d' character(len=ESMF_MAXSTR) :: GridTypeAttribute real(kind=ESMF_KIND_R4), allocatable :: buf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x integer(kind=MPI_OFFSET_KIND) :: offset integer :: jsize, jprev, num_io_rows integer, allocatable :: sendcounts(:), displs(:) real(kind=ESMF_KIND_R8) :: itime_beg, itime_end, bwidth integer :: mypeWr integer :: recl integer :: numread, mpistatus(MPI_STATUS_SIZE) logical :: amIRoot #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) VERIFY_(STATUS) itime_beg = MPI_Wtime(STATUS) VERIFY_(STATUS) #endif if(present(arrdes)) then IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world mypeWr = -1 !mark it invalid if(arrdes%writers_comm /= MPI_COMM_NULL) then call mpi_comm_rank(arrdes%writers_comm,mypeWr ,status) VERIFY_(STATUS) end if if(present(mask)) then JM_WORLD=size(a,2) ! arrdes%offset = 0 ! write Fortran control if(arrdes%writers_comm /= MPI_COMM_NULL) then if(arrdes%offset<=0) then offset = 4 else offset = arrdes%offset endif recl = IM_WORLD*JM_WORLD*4 if(mypeWr==0) then call MPI_FILE_SEEK(UNIT, offset-4, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif end if do j=1,jm_world call MAPL_VarWrite(Unit, Grid, a(:,j), mask, arrdes, writeFCtrl=.false., rc=status) arrdes%offset = arrdes%offset - 8 enddo arrdes%offset = arrdes%offset + 8 ! write Fortran control if(arrdes%writers_comm /= MPI_COMM_NULL) then if(mypeWr==0) then call MPI_FILE_SEEK(UNIT, offset+recl, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif end if else ndes_x = size(arrdes%in) call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%iogathercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%iogathercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (sendcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 sendcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + sendcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize), stat=status) VERIFY_(STATUS) allocate(buf(IM_WORLD*jsize), stat=status) VERIFY_(STATUS) end if !DSK avoid "Attempt to fetch from allocatable variable BUF when it is not allocated" if(myiorank/=0) then allocate(buf(0), stat=status) VERIFY_(STATUS) endif call mpi_gatherv( a, size(a), MPI_REAL, buf, sendcounts, displs, MPI_REAL, & 0, arrdes%iogathercomm, status ) VERIFY_(STATUS) if(myiorank==0) then jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) VAR(i,jprev+j) = buf(k) k=k+1 end do end do end do jprev = jprev + jsize end do jsize=jprev if(arrdes%offset<=0) then offset = 0 else offset = arrdes%offset endif recl = IM_WORLD*JM_WORLD*4 if (mypeWr==0) then #ifdef DEBUG_MPIIO print*, offset, recl, offset + IM_WORLD*JM_WORLD*4 + 8 #endif call MPI_FILE_SEEK(UNIT, offset, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif offset = offset + 4 offset = offset + (arrdes%j1(myrow+1)-1)*IM_WORLD*4 call MPI_FILE_WRITE_AT_ALL(UNIT, offset, VAR, IM_WORLD*jsize, MPI_REAL, mpistatus, STATUS) VERIFY_(STATUS) offset = offset - (arrdes%j1(myrow+1)-1)*IM_WORLD*4 offset = offset + IM_WORLD*JM_WORLD*4 if (mypeWr==0) then call MPI_FILE_SEEK(UNIT, offset, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif arrdes%offset = offset + 4 end if if(myiorank==0) then deallocate(VAR, stat=status) VERIFY_(STATUS) ! deallocate(buf, stat=status) ! VERIFY_(STATUS) endif deallocate(buf, stat=status) VERIFY_(STATUS) deallocate (sendcounts, displs, stat=status) VERIFY_(STATUS) endif elseif(unit < 0) then munit => MEM_units(-unit) munit%prevrec = munit%prevrec + 1 if(.not.associated(munit%Records)) then allocate(munit%Records(16),stat=status) VERIFY_(STATUS) elseif(size(munit%Records)< munit%prevrec) then allocate(REC(munit%prevrec*2),stat=status) VERIFY_(STATUS) REC(:munit%prevrec-1) = munit%Records deallocate(munit%Records) munit%Records => REC endif call alloc_(munit%Records(munit%prevrec),r4_2,size(A,1),size(a,2),rc=status) VERIFY_(STATUS) munit%Records(munit%prevrec)%R4_2 = A else call ESMF_GridGet(GRID, dimCount=gridRank, rc=STATUS) VERIFY_(STATUS) call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, RC=STATUS) VERIFY_(STATUS) IM_WORLD = DIMS(1) JM_WORLD = DIMS(2) if(present(MASK)) JM_WORLD=size(a,2) call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) amIRoot = MAPL_am_i_root(layout) if (amIRoot) then allocate(VAR(IM_WORLD,JM_WORLD), stat=status) VERIFY_(STATUS) else allocate(VAR(0,JM_WORLD), stat=status) VERIFY_(STATUS) end if call ArrayGather(A, VAR, grid, mask=mask, rc=status) VERIFY_(STATUS) if (amIRoot) then if (present(RESOLUTION)) then if (associated(RESOLUTION)) then IM0 = RESOLUTION(1) JM0 = RESOLUTION(2) if (IM_WORLD /= IM0 .or. JM_WORLD /= JM0) then ! call ESMF_AttributeGet(grid, 'GridType', value=GridTypeAttribute, rc=STATUS) ! if (STATUS /= ESMF_SUCCESS) then ! GridTypeAttribute = 'UNKNOWN' ! endif GridTypeAttribute='Cubed-Sphere' if (TRIM(GridTypeAttribute) == 'Cubed-Sphere') then #ifdef USE_CUBEDSPHERE allocate(VARin(IM_WORLD,JM_WORLD), stat=status) VERIFY_(STATUS) allocate(VARout(IM0,JM0), stat=status) VERIFY_(STATUS) VARin = VAR call cube2latlon(IM_WORLD, JM_WORLD, IM0, JM0, VARin, VARout) deallocate (VAR) allocate ( VAR(IM0,JM0), stat=status ) VERIFY_(STATUS) VAR = VARout deallocate(VARout) deallocate(VARin) #else print *,'MAPL is compiled without Cubed Sphere support' ASSERT_(.false.) #endif else print *, "ERROR: unsupported RESOLUTION Change" RETURN_(ESMF_FAILURE) end if end if end if end if write (UNIT, IOSTAT=status) VAR VERIFY_(STATUS) end if deallocate(VAR) end if #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) VERIFY_(STATUS) itime_end = MPI_Wtime(STATUS) VERIFY_(STATUS) bwidth = REAL(IM_WORLD*JM_WORLD*4/1024.0/1024.0,kind=8) bwidth = bwidth/(itime_end-itime_beg) if (bwidth > peak_iowrite_bandwidth) peak_iowrite_bandwidth = bwidth mean_iowrite_bandwidth = (mean_iowrite_bandwidth + bwidth) iowrite_counter=iowrite_counter+1 if (mod(iowrite_counter,72.d0)==0) then if (MAPL_AM_I_Root()) write(*,'(a64,3es11.3)') 'MPIIO Write Bandwidth (MB per second): ', peak_iowrite_bandwidth, bwidth, mean_iowrite_bandwidth/iowrite_counter endif #endif RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWrite_R4_2d !--------------------------- subroutine MAPL_VarWrite_R4_3d(UNIT, GRID, A, RESOLUTION, ARRDES, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R4) , intent(IN ) :: A(:,:,:) integer, optional , pointer :: RESOLUTION(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables integer :: status character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWrite_R4_3d' integer :: L do L = 1, size(A,3) call MAPL_VarWrite(UNIT, GRID, A(:,:,L), RESOLUTION=RESOLUTION, ARRDES=ARRDES, rc=status) VERIFY_(STATUS) end do RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWrite_R4_3d !--------------------------- subroutine MAPL_VarWrite_R4_4d(UNIT, GRID, A, RESOLUTION, ARRDES, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R4) , intent(IN ) :: A(:,:,:,:) integer, optional , pointer :: RESOLUTION(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables integer :: status character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWrite_R4_4d' integer :: L do L = 1, size(A,4) call MAPL_VarWrite(UNIT, GRID, A(:,:,:,L), RESOLUTION=RESOLUTION, ARRDES=ARRDES, rc=status) VERIFY_(STATUS) end do RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWrite_R4_4d !--------------------------- subroutine MAPL_VarWrite_R8_1d(UNIT, GRID, A, MASK, arrdes, writeFCtrl, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R8) , intent(IN ) :: A(:) integer, optional , intent(IN ) :: MASK(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES logical, optional , intent(IN ) :: writeFCtrl ! if not present default is .true. integer, optional , intent( OUT) :: RC ! Local variables real(kind=ESMF_KIND_R8), allocatable :: VAR(:) real(kind=ESMF_KIND_R8), allocatable :: GVAR(:) integer :: IM_WORLD integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) type (ESMF_DELayout) :: layout type (ESMF_DistGrid) :: distGrid character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWrite_R8_1d' integer, allocatable :: msk(:), recvcounts(:), displs(:) integer :: nwrts, mype, npes, sendcount integer :: mypeWr integer :: Rsize, first, last integer(KIND=MPI_OFFSET_KIND) :: offset integer(KIND=MPI_OFFSET_KIND) :: loffset integer :: i, k, n, i1, in integer :: ii real(kind=ESMF_KIND_R8) :: dummy integer :: group, newgroup integer :: thiscomm integer :: nactive integer :: ntransl integer, allocatable :: pes(:) integer, allocatable :: inv_pes(:) integer, allocatable :: r2g(:) integer, allocatable :: rpes(:) integer, allocatable :: activeranks(:) integer, allocatable :: activerecvcounts(:) integer :: recl logical :: useWriteFCtrl integer :: numwrite, mpistatus(MPI_STATUS_SIZE) if(present(writeFCtrl)) then useWriteFCtrl = writeFCtrl else useWriteFCtrl = .true. end if if(present(arrdes)) then ASSERT_(present(mask)) IM_WORLD = arrdes%im_world recl = IM_WORLD*8 call mpi_comm_size(arrdes%iogathercomm,npes ,status) VERIFY_(STATUS) if(arrdes%writers_comm /= MPI_COMM_NULL) then call mpi_comm_rank(arrdes%writers_comm,mypeWr ,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%writers_comm,nwrts,status) VERIFY_(STATUS) else mypeWr = -1 endif call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) call MAPL_CommsBcast(layout, nwrts, 1, 0, rc = status) Rsize = im_world/nwrts + 1 first = mypeWr*Rsize + 1 if(mypeWr >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (mypeWr-mod(im_world,nwrts)) endif last = first + Rsize - 1 #ifdef DEBUG_MPIIO if (mypeWr <= nwrts-1) write(*,'(5i)') mypeWr, IM_WORLD, first, last, Rsize #endif if(arrdes%writers_comm /= MPI_COMM_NULL) then allocate(GVAR(Rsize), stat=status) VERIFY_(STATUS) end if allocate(VAR(Rsize), stat=status) VERIFY_(STATUS) allocate(msk(Rsize), stat=status) VERIFY_(STATUS) allocate (recvcounts(0:npes-1), stat=status) VERIFY_(STATUS) allocate (r2g(0:nwrts-1), stat=status) VERIFY_(STATUS) allocate(inv_pes(0:npes-1),stat=status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%iogathercomm,mype ,status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%iogathercomm, GROUP, STATUS) VERIFY_(STATUS) #if 1 if (arrdes%writers_comm /= MPI_COMM_NULL) then allocate(rpes(0:nwrts-1), stat=status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%writers_comm, NEWGROUP, STATUS) VERIFY_(STATUS) do n=0,nwrts-1 rpes(n) = n end do call MPI_Group_translate_ranks(newgroup, nwrts, rpes, group, r2g, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) deallocate(rpes) end if call MAPL_CommsBcast(layout, r2g, nwrts, 0, rc = status) #else do n=0,nrdrs-1 r2g(n) = (npes/nrdrs)*n end do #endif offset = 1 do n=0,nwrts-1 Rsize = im_world/nwrts + 1 first = n*Rsize + 1 if(n >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (n-mod(im_world,nwrts)) endif last = first + Rsize - 1 recvcounts = 0 do i=first,last recvcounts(mask(i)) = recvcounts(mask(i)) + 1 enddo ! Writer "n" must be included in the mpi group + evevybody that need the data nactive = count(recvcounts > 0) if (recvcounts(r2g(n)) == 0) then nactive = nactive + 1 end if allocate (activeranks(0:nactive-1), activerecvcounts(0:nactive-1), stat=status) VERIFY_(STATUS) allocate(pes(0:nactive-1), stat=status) VERIFY_(STATUS) allocate (displs(0:nactive), stat=status) VERIFY_(STATUS) k = 0 do i=0, npes-1 if (recvcounts(i) > 0) then pes(k) = i k = k+1 end if enddo if (k /= nactive) then k = k+1 ASSERT_(k == nactive) ASSERT_(recvcounts(r2g(n)) == 0) pes(nactive-1) = r2g(n) end if call MPI_GROUP_INCL (GROUP, nactive, PES, newgroup, STATUS) VERIFY_(STATUS) call MPI_COMM_CREATE(arrdes%iogathercomm, newgroup, thiscomm, STATUS) VERIFY_(STATUS) call MPI_Group_translate_ranks(group, nactive, pes, newgroup, activeranks, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) inv_pes = -1 ! initialized to invalid do i=0,nactive-1 inv_pes(pes(i)) = i end do if (thiscomm /= MPI_COMM_NULL) then activerecvcounts = 0 do i=0,nactive-1 activerecvcounts(activeranks(i)) = recvcounts(pes(i)) if (pes(i) == r2g(n)) ntransl = activeranks(i) end do displs(0) = 0 do i=1,nactive displs(i) = displs(i-1) + activerecvcounts(i-1) enddo sendcount = recvcounts(mype) if (sendcount == 0) then call MPI_GATHERV( dummy, sendcount, MPI_DOUBLE_PRECISION, & var, activerecvcounts, displs, MPI_DOUBLE_PRECISION, & ntransl, thiscomm, status ) else call MPI_GATHERV( a(offset), sendcount, MPI_DOUBLE_PRECISION, & var, activerecvcounts, displs, MPI_DOUBLE_PRECISION, & ntransl, thiscomm, status ) endif VERIFY_(STATUS) call MPI_Comm_Free(thiscomm, status) VERIFY_(STATUS) if(n==mypeWr) then msk = mask(first:last) do I=1,Rsize K = inv_pes(MSK(I)) II = displs(K)+1 ! var is 1-based GVAR(I) = VAR(II) displs(K) = displs(K) + 1 end do endif offset = offset + sendcount end if deallocate (displs) deallocate(pes) deallocate (activerecvcounts, activeranks) enddo if(arrdes%writers_comm /= MPI_COMM_NULL) then if(arrdes%offset<=0) then offset = 4 else offset = arrdes%offset endif if(useWriteFCtrl .and. mypeWr==0) then call MPI_FILE_SEEK(UNIT, offset-4, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif Rsize = im_world/nwrts + 1 first = mypeWr*Rsize + 1 if(mypeWr >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (mypeWr-mod(im_world,nwrts)) endif last = first + Rsize - 1 ASSERT_( (lbound(mask,1) <= first) ) ASSERT_( (ubound(mask,1) >= last ) ) loffset = offset + (first-1)*8 call MPI_FILE_WRITE_AT_ALL(UNIT, loffset, GVAR, Rsize, MPI_DOUBLE_PRECISION, mpistatus, STATUS) VERIFY_(STATUS) #ifdef DEBUG_MPIIO call MPI_GET_COUNT( mpistatus, MPI_DOUBLE_PRECISION, numwrite, STATUS ) VERIFY_(STATUS) write(*,'(4i,1f)') IM_WORLD, loffset, numwrite, GVAR(1) #endif if(useWriteFCtrl .and. mypeWr==0) then call MPI_FILE_SEEK(UNIT, offset+recl, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif arrdes%offset = offset + recl + 8 endif call MPI_GROUP_FREE (GROUP, STATUS) VERIFY_(STATUS) deallocate(var,msk) deallocate (inv_pes) deallocate (r2g) deallocate(recvcounts) if(arrdes%writers_comm /= MPI_COMM_NULL) then deallocate(gvar) end if elseif(unit < 0) then munit => MEM_units(-unit) munit%prevrec = munit%prevrec + 1 if(.not.associated(munit%Records)) then allocate(munit%Records(16),stat=status) VERIFY_(STATUS) elseif(size(munit%Records)< munit%prevrec) then allocate(REC(munit%prevrec*2),stat=status) VERIFY_(STATUS) REC(:munit%prevrec-1) = munit%Records deallocate(munit%Records) munit%Records => REC endif call alloc_(munit%Records(munit%prevrec),R8_1,size(A),rc=status) VERIFY_(STATUS) munit%Records(munit%prevrec)%R8_1 = A else call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, RC=STATUS) VERIFY_(STATUS) IM_WORLD = DIMS(1) allocate(VAR(IM_WORLD), stat=status) VERIFY_(STATUS) call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) call ArrayGather(A, VAR, grid, mask=mask, rc=status) VERIFY_(STATUS) if (MAPL_am_i_root(layout)) then write (UNIT, IOSTAT=status) VAR VERIFY_(STATUS) end if deallocate(VAR) end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWrite_R8_1d !--------------------------- subroutine MAPL_VarWrite_R8_2d(UNIT, GRID, A, MASK, RESOLUTION, ARRDES, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R8) , intent(IN ) :: A(:,:) integer, optional , intent(IN ) :: MASK(:) integer, optional , pointer :: RESOLUTION(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables real(kind=ESMF_KIND_R8), allocatable :: VAR(:,:) integer :: IM_WORLD integer :: JM_WORLD real , allocatable :: VARin(:,:) real , allocatable :: VARout(:,:) integer :: IM0 integer :: JM0 integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) integer :: gridRank type (ESMF_DELayout) :: layout type (ESMF_DistGrid) :: distGrid character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWrite_R8_2d' character(len=ESMF_MAXSTR) :: GridTypeAttribute real(kind=ESMF_KIND_R8), allocatable :: buf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x integer(kind=MPI_OFFSET_KIND) :: offset integer :: jsize, jprev, num_io_rows integer, allocatable :: sendcounts(:), displs(:) real(kind=ESMF_KIND_R8) :: itime_beg, itime_end, bwidth integer :: mypeWr integer :: recl integer :: numread, mpistatus(MPI_STATUS_SIZE) #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) VERIFY_(STATUS) itime_beg = MPI_Wtime(STATUS) VERIFY_(STATUS) #endif if(present(arrdes)) then IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world mypeWr = -1 !mark it invalid if(arrdes%writers_comm /= MPI_COMM_NULL) then call mpi_comm_rank(arrdes%writers_comm,mypeWr ,status) VERIFY_(STATUS) end if if(present(mask)) then ASSERT_(JM_WORLD==size(A,2)) ! arrdes%offset = 0 ! write Fortran control if(arrdes%writers_comm /= MPI_COMM_NULL) then if(arrdes%offset<=0) then offset = 4 else offset = arrdes%offset endif recl = IM_WORLD*JM_WORLD*8 if(mypeWr==0) then call MPI_FILE_SEEK(UNIT, offset-4, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif end if do j=1,jm_world call MAPL_VarWrite(Unit, Grid, a(:,j), mask, arrdes, writeFCtrl=.false., rc=status) arrdes%offset = arrdes%offset - 8 enddo arrdes%offset = arrdes%offset + 8 ! write Fortran control if(arrdes%writers_comm /= MPI_COMM_NULL) then if(mypeWr==0) then call MPI_FILE_SEEK(UNIT, offset+recl, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif end if else ndes_x = size(arrdes%in) call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%iogathercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%iogathercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (sendcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 sendcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + sendcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize), stat=status) VERIFY_(STATUS) allocate(buf(IM_WORLD*jsize), stat=status) VERIFY_(STATUS) end if !DSK avoid "Attempt to fetch from allocatable variable BUF when it is not allocated" if(myiorank/=0) then allocate(buf(0), stat=status) VERIFY_(STATUS) endif call mpi_gatherv( a, size(a), MPI_DOUBLE_PRECISION, buf, sendcounts, displs, MPI_DOUBLE_PRECISION, & 0, arrdes%iogathercomm, status ) VERIFY_(STATUS) if(myiorank==0) then jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) VAR(i,jprev+j) = buf(k) k=k+1 end do end do end do jprev = jprev + jsize end do jsize=jprev if(arrdes%offset<=0) then offset = 0 else offset = arrdes%offset endif recl = IM_WORLD*JM_WORLD*8 if (mypeWr==0) then #ifdef DEBUG_MPIIO print*, offset, recl, offset + IM_WORLD*JM_WORLD*8 + 8 #endif call MPI_FILE_SEEK(UNIT, offset, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif offset = offset + 4 offset = offset + (arrdes%j1(myrow+1)-1)*IM_WORLD*8 call MPI_FILE_WRITE_AT_ALL(UNIT, offset, VAR, IM_WORLD*jsize, MPI_DOUBLE_PRECISION, mpistatus, STATUS) VERIFY_(STATUS) offset = offset - (arrdes%j1(myrow+1)-1)*IM_WORLD*8 offset = offset + IM_WORLD*JM_WORLD*8 if (mypeWr==0) then call MPI_FILE_SEEK(UNIT, offset, MPI_SEEK_SET, STATUS) VERIFY_(STATUS) call MPI_FILE_WRITE(UNIT, recl, 1, MPI_INTEGER, MPI_STATUS_IGNORE, STATUS) VERIFY_(STATUS) endif arrdes%offset = offset + 4 end if if(myiorank==0) then deallocate(VAR, stat=status) VERIFY_(STATUS) ! deallocate(buf, stat=status) ! VERIFY_(STATUS) endif deallocate(buf, stat=status) VERIFY_(STATUS) deallocate (sendcounts, displs, stat=status) VERIFY_(STATUS) endif elseif(unit < 0) then munit => MEM_units(-unit) munit%prevrec = munit%prevrec + 1 if(.not.associated(munit%Records)) then allocate(munit%Records(16),stat=status) VERIFY_(STATUS) elseif(size(munit%Records)< munit%prevrec) then allocate(REC(munit%prevrec*2),stat=status) VERIFY_(STATUS) REC(:munit%prevrec-1) = munit%Records deallocate(munit%Records) munit%Records => REC endif call alloc_(munit%Records(munit%prevrec),r8_2,size(A,1),size(a,2),rc=status) VERIFY_(STATUS) munit%Records(munit%prevrec)%R8_2 = A else call ESMF_GridGet(GRID, dimCount=gridRank, rc=STATUS) VERIFY_(STATUS) call MAPL_GridGet(GRID, globalCellCountPerDim=DIMS, RC=STATUS) VERIFY_(STATUS) IM_WORLD = DIMS(1) JM_WORLD = DIMS(2) if (present(MASK)) JM_WORLD=size(A,2) allocate(VAR(IM_WORLD,JM_WORLD), stat=status) VERIFY_(STATUS) call ESMF_GridGet(grid, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGrid, delayout=layout, rc=STATUS) VERIFY_(STATUS) call ArrayGather(A, VAR, grid, mask=mask, rc=status) VERIFY_(STATUS) if (MAPL_am_i_root(layout)) then if (present(RESOLUTION)) then if (associated(RESOLUTION)) then IM0 = RESOLUTION(1) JM0 = RESOLUTION(2) if (IM_WORLD /= IM0 .or. JM_WORLD /= JM0) then ! call ESMF_AttributeGet(grid, 'GridType', value=GridTypeAttribute, rc=STATUS) ! if (STATUS /= ESMF_SUCCESS) then ! GridTypeAttribute = 'UNKNOWN' ! endif GridTypeAttribute='Cubed-Sphere' if (TRIM(GridTypeAttribute) == 'Cubed-Sphere') then #ifdef USE_CUBEDSPHERE allocate(VARin(IM_WORLD,JM_WORLD), stat=status) VERIFY_(STATUS) allocate(VARout(IM0,JM0), stat=status) VERIFY_(STATUS) VARin = VAR call cube2latlon(IM_WORLD, JM_WORLD, IM0, JM0, VARin, VARout) deallocate (VAR) allocate ( VAR(IM0,JM0), stat=status ) VERIFY_(STATUS) VAR = VARout deallocate(VARout) deallocate(VARin) #else print *,'MAPL is compiled without Cubed Sphere support' ASSERT_(.false.) #endif else print *, "ERROR: unsupported RESOLUTION Change" RETURN_(ESMF_FAILURE) end if end if end if end if write (UNIT, IOSTAT=status) VAR VERIFY_(STATUS) end if deallocate(VAR) end if #ifdef TIME_MPIIO call MPI_BARRIER(MPI_COMM_WORLD,STATUS) VERIFY_(STATUS) itime_end = MPI_Wtime(STATUS) VERIFY_(STATUS) bwidth = REAL(IM_WORLD*JM_WORLD*8/1024.0/1024.0,kind=8) bwidth = bwidth/(itime_end-itime_beg) if (bwidth > peak_iowrite_bandwidth) peak_iowrite_bandwidth = bwidth mean_iowrite_bandwidth = (mean_iowrite_bandwidth + bwidth) iowrite_counter=iowrite_counter+1 if (mod(iowrite_counter,72.d0)==0) then if (MAPL_AM_I_Root()) write(*,'(a64,3es11.3)') 'MPIIO Write Bandwidth (MB per second): ', peak_iowrite_bandwidth, bwidth, mean_iowrite_bandwidth/iowrite_counter endif #endif RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWrite_R8_2d !--------------------------- subroutine MAPL_VarWrite_R8_3d(UNIT, GRID, A, RESOLUTION, ARRDES, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R8) , intent(IN ) :: A(:,:,:) integer, optional , pointer :: RESOLUTION(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables integer :: status character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWrite_R8_3d' integer :: L do L = 1, size(A,3) call MAPL_VarWrite(UNIT, GRID, A(:,:,L), RESOLUTION=RESOLUTION, ARRDES=ARRDES, rc=status) VERIFY_(STATUS) end do RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWrite_R8_3d !--------------------------- subroutine MAPL_VarWrite_R8_4d(UNIT, GRID, A, RESOLUTION, ARRDES, RC) integer , intent(IN ) :: UNIT type (ESMF_Grid) , intent(INout) :: GRID real(kind=ESMF_KIND_R8) , intent(IN ) :: A(:,:,:,:) integer, optional , pointer :: RESOLUTION(:) type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables integer :: status character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWrite_R8_4d' integer :: L do L = 1, size(A,4) call MAPL_VarWrite(UNIT, GRID, A(:,:,:,L), RESOLUTION=RESOLUTION, ARRDES=ARRDES, rc=status) VERIFY_(STATUS) end do RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWrite_R8_4d !--------------------------- !--------------------------- !--------------------------- !--------------------------- #define RANK_ 1 #define VARTYPE_ 3 #include "arrayscatter.H" !--------------------------- #define RANK_ 1 #define VARTYPE_ 4 #include "arrayscatter.H" !--------------------------- #define RANK_ 2 #define VARTYPE_ 3 #include "arrayscatter.H" !--------------------------- #define RANK_ 2 #define VARTYPE_ 4 #include "arrayscatter.H" !--------------------------- #define RANK_ 1 #define VARTYPE_ 3 #include "arraygather.H" !--------------------------- #define RANK_ 1 #define VARTYPE_ 4 #include "arraygather.H" !--------------------------- #define RANK_ 2 #define VARTYPE_ 3 #include "arraygather.H" !--------------------------- #define RANK_ 2 #define VARTYPE_ 4 #include "arraygather.H" !--------------------------- !--------------------------- subroutine MAPL_ClimUpdate ( STATE, BEFORE, AFTER, & CURRENT_TIME, NAMES, FILE, RC ) type(ESMF_State), intent(INOUT) :: STATE type(ESMF_Time), intent( out) :: BEFORE, AFTER type(ESMF_Time), intent(inout) :: CURRENT_TIME !ALT:intent(in) character(len=*), intent(in ) :: NAMES(:) character(len=*), intent(in ) :: FILE integer, optional, intent( out) :: RC integer :: STATUS character(len=ESMF_MAXSTR) :: IAm = 'MAPL_ClimUpdate' integer :: I, M, M1, M2 integer :: NFLD integer :: UNIT integer :: DONE real :: dum(1) type (ESMF_Field ), pointer :: PREV(:) type (ESMF_Field ), pointer :: NEXT(:) type (ESMF_DELayout) :: LAYOUT type (ESMF_Grid ) :: GRID type (ESMF_DistGrid) :: distGRID ! -------------------------------------------------------------------------- ! Allocate the number of fileds in the file ! -------------------------------------------------------------------------- NFLD = size(NAMES) ASSERT_(NFLD>0) allocate(PREV(NFLD),stat=STATUS) VERIFY_(STATUS) allocate(NEXT(NFLD),stat=STATUS) VERIFY_(STATUS) ! -------------------------------------------------------------------------- ! get the fields from the state ! -------------------------------------------------------------------------- do I=1,NFLD call ESMF_StateGet ( STATE, trim(NAMES(I))//'_PREV', PREV(I), RC=STATUS ) VERIFY_(STATUS) call ESMF_StateGet ( STATE, trim(NAMES(I))//'_NEXT', NEXT(I), RC=STATUS ) VERIFY_(STATUS) end do call ESMF_FieldGet(PREV(1), GRID=GRID, RC=STATUS) VERIFY_(STATUS) call ESMF_GridGet (GRID, distGrid=distGrid, rc=STATUS) VERIFY_(STATUS) call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS) VERIFY_(STATUS) ! -------------------------------------------------------------------------- ! Find out the times of next, prev from the field attributes ! -------------------------------------------------------------------------- call MAPL_FieldGetTime ( PREV(1), BEFORE, RC=STATUS ) VERIFY_(STATUS) call MAPL_FieldGetTime ( NEXT(1), AFTER , RC=STATUS ) VERIFY_(STATUS) ! -------------------------------------------------------------------------- ! check to see if albedos need to be refreshed in the ! ESMF Internal State (prev, next need to surround ! the current time) ! -------------------------------------------------------------------------- call ESMF_TimeGet ( BEFORE, yy=I, rc=STATUS ) VERIFY_(STATUS) DONE = 0 if( I > 0) then if( (BEFORE <= CURRENT_TIME) .and. (AFTER >= CURRENT_TIME)) then DONE = 1 end if end if if(DONE /= 1) then ! -------------------------------------------------------------------------- ! Get the midmonth times for the months before and after the current time ! -------------------------------------------------------------------------- call MAPL_GetClimMonths ( CURRENT_TIME, BEFORE, AFTER, RC=STATUS ) VERIFY_(STATUS) call ESMF_TimeGet ( BEFORE, MM=M1, rc=STATUS ) VERIFY_(STATUS) call ESMF_TimeGet ( AFTER , MM=M2, rc=STATUS ) VERIFY_(STATUS) ! -------------------------------------------------------------------------- ! Read the albedo climatologies from file ! -------------------------------------------------------------------------- UNIT = GETFILE(FILE, form="unformatted", RC=STATUS) VERIFY_(STATUS) DONE = 0 do M=1,12 if (M==M1) then do I=1,NFLD call MAPL_VarRead(UNIT, PREV(I), RC=STATUS) VERIFY_(STATUS) end do if(DONE==1) exit DONE = DONE + 1 elseif(M==M2) then do I=1,NFLD call MAPL_VarRead(UNIT, NEXT(I), RC=STATUS) VERIFY_(STATUS) end do if(DONE==1) exit DONE = DONE + 1 else call MAPL_Skip(UNIT,LAYOUT,COUNT=NFLD,rc=status) VERIFY_(STATUS) end if end do call FREE_FILE ( Unit ) ! -------------------------------------------------------------------------- ! Reset the time on all fields ! -------------------------------------------------------------------------- do I=1,NFLD call MAPL_FieldSetTime ( PREV(I), BEFORE, rc=STATUS ) VERIFY_(STATUS) call MAPL_FieldSetTime ( NEXT(I), AFTER , rc=STATUS ) VERIFY_(STATUS) end do endif deallocate(NEXT) deallocate(PREV) RETURN_(ESMF_SUCCESS) end subroutine MAPL_ClimUpdate subroutine MAPL_GetClimMonths ( CURRENT_TIME, BEFORE, AFTER, RC ) type(ESMF_Time), intent(inout) :: CURRENT_TIME !ALT: intent(in) type(ESMF_Time), intent(out) :: BEFORE, AFTER integer,optional,intent(out) :: RC integer :: STATUS character(len=ESMF_MAXSTR) :: IAm = 'MAPL_GetClimMonths' integer :: MonthCurr type(ESMF_Time ) :: midMonth type(ESMF_TimeInterval) :: oneMonth call ESMF_TimeIntervalSet(oneMonth, MM = 1, RC=STATUS ) VERIFY_(STATUS) call ESMF_TimeGet(CURRENT_TIME, midMonth=midMonth, mm=MonthCurr, RC=STATUS ) VERIFY_(STATUS) if( CURRENT_TIME < midMonth ) then AFTER = midMonth midMonth = midMonth - oneMonth call ESMF_TimeGet (midMonth, midMonth=BEFORE, rc=STATUS ) VERIFY_(STATUS) else BEFORE = midMonth midMonth = midMonth + oneMonth call ESMF_TimeGet (midMonth, midMonth=AFTER , rc=STATUS ) VERIFY_(STATUS) endif RETURN_(ESMF_SUCCESS) end subroutine MAPL_GetClimMonths subroutine MAPL_Skip(UNIT, LAYOUT, COUNT, RC) integer , intent(IN ) :: UNIT type (ESMF_DELayout) , intent(IN ) :: LAYOUT integer, optional , intent(IN ) :: COUNT integer, optional , intent( OUT) :: RC ! Local variables integer :: STATUS character(len=ESMF_MAXSTR) :: IAm='MAPL_Skip' integer :: N, NN if(present(COUNT)) then NN=COUNT else NN=1 endif if (unit < 0) then munit => MEM_units(-unit) munit%prevrec = munit%prevrec + NN RETURN_(ESMF_SUCCESS) endif if (MAPL_AM_I_ROOT(LAYOUT)) then do N=1,NN read (unit=UNIT, IOSTAT=status) VERIFY_(STATUS) end do end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_Skip subroutine MAPL_Backspace(UNIT, LAYOUT, COUNT, RC) integer , intent(IN ) :: UNIT type (ESMF_DELayout) , intent(IN ) :: LAYOUT integer, optional , intent(IN ) :: COUNT integer, optional , intent( OUT) :: RC ! Local variables integer :: STATUS character(len=ESMF_MAXSTR) :: IAm='MAPL_Backspace' integer :: N, NN if (MAPL_AM_I_ROOT(LAYOUT)) then if(present(COUNT)) then NN=COUNT else NN=1 endif do N=1,NN backspace(unit=UNIT, IOSTAT=status) VERIFY_(STATUS) end do end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_Backspace subroutine MAPL_Rewind(UNIT, LAYOUT, RC) integer , intent(IN ) :: UNIT type (ESMF_DELayout) , intent(IN ) :: LAYOUT integer, optional , intent( OUT) :: RC ! Local variables integer :: STATUS character(len=ESMF_MAXSTR) :: IAm='MAPL_Rewind' if (MAPL_AM_I_ROOT(LAYOUT)) then rewind(unit=UNIT, IOSTAT=status) VERIFY_(STATUS) end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_Rewind subroutine MAPL_TileMaskGet(grid, mask, rc) type (ESMF_Grid), intent(INout) :: GRID integer, pointer :: mask(:) integer, optional , intent( OUT) :: RC ! Local variables integer :: STATUS character(len=ESMF_MAXSTR) :: IAm='MAPL_TileMaskGet' integer, pointer :: tileIndex(:) integer :: gcount(2), lcount(2) integer :: gsize, lsize integer :: gridRank integer :: n type (ESMF_DistGrid) :: distGrid integer, allocatable :: AL(:,:) integer, allocatable :: AU(:,:) integer, allocatable, dimension(:) :: recvcounts, displs integer :: de, deId integer :: nDEs integer :: sendcount integer :: I, II integer :: I1, IN integer, allocatable :: var(:) integer :: deList(1) type (ESMF_DELayout) :: layout integer :: mmax type(ESMF_VM) :: vm logical :: amIRoot call ESMF_GridGet(grid, dimCount=gridRank, distGrid=distGrid, rc=status) VERIFY_(STATUS) ASSERT_(gridRank == 1) call MAPL_GridGet(grid, globalCellCountPerDim=gcount, & localCellCountPerDim=lcount, RC=STATUS) VERIFY_(STATUS) gsize = gcount(1) lsize = lcount(1) call ESMF_DistGridGet(distgrid, localDe=0, elementCount=n, rc=status) ASSERT_(lsize == n) allocate(tileIndex(lsize), stat=status) VERIFY_(STATUS) call ESMF_DistGridGet(distgrid, localDe=0, seqIndexList=tileIndex, rc=status) VERIFY_(STATUS) call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS) VERIFY_(STATUS) call ESMF_DELayoutGet(layout, deCount =nDEs, localDeList=deList, rc=status) VERIFY_(STATUS) deId = deList(1) call ESMF_DELayoutGet(layout, vm=vm, rc=status) VERIFY_(STATUS) amIRoot = MAPL_AM_I_Root(vm) call ESMF_VmBarrier(vm, rc=status) VERIFY_(STATUS) if (.not. MAPL_ShmInitialized) then allocate(mask(gsize), stat=status) VERIFY_(STATUS) else call MAPL_AllocNodeArray(mask,(/gsize/),rc=STATUS) VERIFY_(STATUS) end if allocate (AL(gridRank,0:nDEs-1), stat=status) VERIFY_(STATUS) allocate (AU(gridRank,0:nDEs-1), stat=status) VERIFY_(STATUS) call ESMF_DistGridGet(distgrid, & minIndexPDe=AL, maxIndexPDe=AU, rc=status) VERIFY_(STATUS) allocate (recvcounts(0:nDEs-1), displs(0:nDEs), stat=status) VERIFY_(STATUS) if (.not. MAPL_ShmInitialized .or. amIRoot) then allocate(VAR(0:gsize-1), stat=status) VERIFY_(STATUS) else allocate(VAR(0), stat=status) VERIFY_(STATUS) end if displs(0) = 0 do I = 0,nDEs-1 de = I I1 = AL(1,I) IN = AU(1,I) recvcounts(I) = (IN - I1 + 1) if (de == deId) then sendcount = recvcounts(I) ! Count I will send endif displs(I+1) = displs(I) + recvcounts(I) enddo #ifdef NEW ASSERT_(.false.) !ALT this section is questionable do I = 0,nDEs-1 de = I I1 = AL(1,I) IN = AU(1,I) var(I1:IN) = -9999 if (de == deId) then var(I1:IN) = tileindex endif do II=I1,IN mmax=var(II) call MAPL_CommsAllReduceMax(vm, mmax, var(II), 1, rc=status) VERIFY_(STATUS) enddo end do #else if (MAPL_ShmInitialized) then call MAPL_CommsGatherV(layout, tileindex, sendcount, & var, recvcounts, displs, MAPL_Root, status) VERIFY_(STATUS) else call MAPL_CommsAllGatherV(layout, tileindex, sendcount, & var, recvcounts, displs, status) VERIFY_(STATUS) endif #endif if (.not. MAPL_ShmInitialized .or. amIRoot) then do I = 0,nDEs-1 mask(displs(I)+1:displs(I+1)) = I end do call MAPL_SORT(var,MASK) end if ! clean up deallocate(var) deallocate (recvcounts, displs) deallocate (AU) deallocate (AL) deallocate(tileIndex) ! mask is deallocated in the caller routine call MAPL_BroadcastToNodes(MASK, N=gsize, ROOT=MAPL_Root, rc=status) VERIFY_(STATUS) call MAPL_SyncSharedMemory(rc=status) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) end subroutine MAPL_TileMaskGet !--------------------------- subroutine MAPL_VarWriteNCpar_R4_3d(ncioObj, name, A, ARRDES, RC) type(MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R4) , intent(IN ) :: A(:,:,:) type(ArrDescr) , intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variablesi integer :: varid, fid real(kind=ESMF_KIND_R4), allocatable :: VAR(:,:,:) integer :: IM_WORLD integer :: JM_WORLD integer :: KM_WORLD real , allocatable :: VARin(:,:) real , allocatable :: VARout(:,:) integer :: IM0 integer :: JM0 integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) integer :: gridRank character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWriteNCpar_R4_3d' character(len=ESMF_MAXSTR) :: GridTypeAttribute real(kind=ESMF_KIND_R4), allocatable :: recvbuf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x,lev integer :: ndims, start(4), cnt(4), dimids(4) character(len=ESMF_MAXSTR) :: dimname integer :: jsize, jprev, num_io_rows integer, allocatable :: recvcounts(:), displs(:) if (arrdes%writers_comm/=MPI_COMM_NULL) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) fid = ncioObj%ncid end if IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world KM_WORLD = size(a,3) ndes_x = size(arrdes%in) call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%iogathercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%iogathercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (recvcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 recvcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize * KM_WORLD enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + recvcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize,KM_WORLD), stat=status) VERIFY_(STATUS) allocate(recvbuf(IM_WORLD*jsize*KM_WORLD), stat=status) VERIFY_(STATUS) ! VAR=Z'7FA00000' ! recvbuf=Z'7FA00000' end if if(myiorank/=0) then allocate(recvbuf(0), stat=status) VERIFY_(STATUS) endif call mpi_gatherv( a, size(a), MPI_REAL, recvbuf, recvcounts, displs, MPI_REAL, & 0, arrdes%iogathercomm, status ) VERIFY_(STATUS) if(myiorank==0) then jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do lev=1,KM_WORLD do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) VAR(i,jprev+j,lev) = recvbuf(k) k=k+1 end do end do enddo end do jprev = jprev + jsize end do jsize=jprev start(1) = 1 start(2) = arrdes%j1(myrow+1) start(3) = 1 start(4) = 1 cnt(1) = IM_WORLD cnt(2) = jsize cnt(3) = KM_WORLD cnt(4) = 1 STATUS = NF_PUT_VARA_REAL(fid, varid, start, cnt, VAR) if(status /= nf_noerr) then print*,'Error writing variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif deallocate(VAR, stat=status) VERIFY_(STATUS) endif ! myiorank deallocate(recvbuf, stat=status) VERIFY_(STATUS) deallocate (recvcounts, displs, stat=status) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWriteNCpar_R4_3d !--------------------------- subroutine MAPL_VarReadNCpar_R4_3d(ncioObj, name, A, ARRDES, RC) type (MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R4) , intent(IN ) :: A(:,:,:) type(ArrDescr) , intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables integer :: fid, varid real(kind=ESMF_KIND_R4), allocatable :: VAR(:,:,:) integer :: IM_WORLD integer :: JM_WORLD integer :: KM_WORLD integer :: status integer :: gridRank integer :: DIMS(ESMF_MAXGRIDDIM) character(len=ESMF_MAXSTR) :: IAm='MAPL_VarReadNCpar_R4_3d' real(kind=ESMF_KIND_R4), allocatable :: buf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x,lev integer :: ndims, start(4), cnt(4), dimids(4) integer :: jsize, jprev, num_io_rows integer, allocatable :: sendcounts(:), displs(:) if (arrdes%readers_comm/=MPI_COMM_NULL) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) fid = ncioObj%ncid end if ndes_x = size(arrdes%in) IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world KM_WORLD = size(a,3) call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%ioscattercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%ioscattercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (sendcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 sendcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize * KM_WORLD enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + sendcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize,KM_WORLD), stat=status) VERIFY_(STATUS) allocate(buf(IM_WORLD*jsize*KM_WORLD), stat=status) VERIFY_(STATUS) start(1) = 1 start(2) = arrdes%j1(myrow+1) start(3) = 1 start(4) = 1 cnt(1) = IM_WORLD cnt(2) = jsize cnt(3) = KM_WORLD cnt(4) = 1 STATUS = NF_GET_VARA_REAL(fid, varid, start, cnt, VAR) if(status /= nf_noerr) then print*,'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do lev=1,KM_WORLD do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) buf(k) = VAR(i,jprev+j,lev) k=k+1 end do end do enddo end do jprev = jprev + jsize end do deallocate(VAR, stat=status) VERIFY_(STATUS) end if ! myiorank if(myiorank/=0) then allocate(buf(0), stat=status) VERIFY_(STATUS) endif call mpi_scatterv( buf, sendcounts, displs, MPI_REAL, & a, size(a), MPI_REAL, & 0, arrdes%ioscattercomm, status ) VERIFY_(STATUS) deallocate(buf, stat=status) VERIFY_(STATUS) deallocate (sendcounts, displs, stat=status) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarReadNCpar_R4_3d !--------------------------- subroutine MAPL_VarWriteNCpar_R8_3d(ncioObj, name, A, ARRDES, RC) type (MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R8) , intent(IN ) :: A(:,:,:) type(ArrDescr) , intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables integer :: fid, varid real(kind=ESMF_KIND_R8), allocatable :: VAR(:,:,:) integer :: IM_WORLD integer :: JM_WORLD integer :: KM_WORLD real , allocatable :: VARin(:,:) real , allocatable :: VARout(:,:) integer :: IM0 integer :: JM0 integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) integer :: gridRank character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWriteNCpar_R8_3d' character(len=ESMF_MAXSTR) :: GridTypeAttribute real(kind=ESMF_KIND_R8), allocatable :: recvbuf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x,lev integer :: ndims, start(4), cnt(4), dimids(4) character(len=ESMF_MAXSTR) :: dimname integer :: jsize, jprev, num_io_rows integer, allocatable :: recvcounts(:), displs(:) if (arrdes%writers_comm/=MPI_COMM_NULL) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) fid = ncioObj%ncid end if IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world KM_WORLD = size(a,3) ndes_x = size(arrdes%in) call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%iogathercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%iogathercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (recvcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 recvcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize * KM_WORLD enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + recvcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize,KM_WORLD), stat=status) VERIFY_(STATUS) allocate(recvbuf(IM_WORLD*jsize*KM_WORLD), stat=status) VERIFY_(STATUS) ! VAR=Z'7FFC000000000000' ! recvbuf=Z'7FFC000000000000' end if if(myiorank/=0) then allocate(recvbuf(0), stat=status) VERIFY_(STATUS) endif call mpi_gatherv( a, size(a), MPI_DOUBLE_PRECISION, recvbuf, recvcounts, displs, & MPI_DOUBLE_PRECISION, 0, arrdes%iogathercomm, status ) VERIFY_(STATUS) if(myiorank==0) then jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do lev=1,KM_WORLD do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) VAR(i,jprev+j,lev) = recvbuf(k) k=k+1 end do end do enddo end do jprev = jprev + jsize end do jsize=jprev start(1) = 1 start(2) = arrdes%j1(myrow+1) start(3) = 1 start(4) = 1 cnt(1) = IM_WORLD cnt(2) = jsize cnt(3) = KM_WORLD cnt(4) = 1 STATUS = NF_PUT_VARA_DOUBLE(fid, varid, start, cnt, VAR) if(status /= nf_noerr) then print*,'Error writing variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif deallocate(VAR, stat=status) VERIFY_(STATUS) endif ! myiorank deallocate(recvbuf, stat=status) VERIFY_(STATUS) deallocate (recvcounts, displs, stat=status) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWriteNCpar_R8_3d !--------------------------- subroutine MAPL_VarReadNCpar_R8_3d(ncioObj, name, A, ARRDES, RC) type(MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R8) , intent(IN ) :: A(:,:,:) type(ArrDescr) , intent(INOUT) :: ARRDES integer, optional , intent( OUT) :: RC ! Local variables real(kind=ESMF_KIND_R8), allocatable :: VAR(:,:,:) integer :: IM_WORLD integer :: JM_WORLD integer :: KM_WORLD integer :: status integer :: gridRank integer :: DIMS(ESMF_MAXGRIDDIM) character(len=ESMF_MAXSTR) :: IAm='MAPL_VarReadNCpar_R8_3d' integer :: varid, fid real(kind=ESMF_KIND_R8), allocatable :: buf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x,lev integer :: ndims, start(4), cnt(4), dimids(4) integer :: jsize, jprev, num_io_rows integer, allocatable :: sendcounts(:), displs(:) if (arrdes%readers_comm/=MPI_COMM_NULL) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) fid = ncioObj%ncid end if ndes_x = size(arrdes%in) IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world KM_WORLD = size(a,3) call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%ioscattercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%ioscattercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (sendcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 sendcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize * KM_WORLD enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + sendcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize,KM_WORLD), stat=status) VERIFY_(STATUS) allocate(buf(IM_WORLD*jsize*KM_WORLD), stat=status) VERIFY_(STATUS) ! VAR=Z'7FFC000000000000' ! buf=Z'7FFC000000000000' start(1) = 1 start(2) = arrdes%j1(myrow+1) start(3) = 1 start(4) = 1 cnt(1) = IM_WORLD cnt(2) = jsize cnt(3) = KM_WORLD cnt(4) = 1 STATUS = NF_GET_VARA_DOUBLE(fid, varid, start, cnt, VAR) if(status /= nf_noerr) then print*,'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do lev=1,KM_WORLD do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) buf(k) = VAR(i,jprev+j,lev) k=k+1 end do end do enddo end do jprev = jprev + jsize end do deallocate(VAR, stat=status) VERIFY_(STATUS) end if ! myiorank if(myiorank/=0) then allocate(buf(0), stat=status) VERIFY_(STATUS) endif call mpi_scatterv( buf, sendcounts, displs, MPI_DOUBLE_PRECISION, & a, size(a), MPI_DOUBLE_PRECISION, & 0, arrdes%ioscattercomm, status ) VERIFY_(STATUS) deallocate(buf, stat=status) VERIFY_(STATUS) deallocate (sendcounts, displs, stat=status) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarReadNCpar_R8_3d !--------------------------- subroutine MAPL_VarWriteNCpar_R4_2d(ncioObj, name, A, ARRDES, lev, RC) type(MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R4) , intent(IN ) :: A(:,:) type(ArrDescr), optional , intent(INOUT) :: ARRDES integer, optional , intent(IN ) :: lev integer, optional , intent( OUT) :: RC ! Local variables integer :: fid, varid real(kind=ESMF_KIND_R4), allocatable :: VAR(:,:) integer :: IM_WORLD integer :: JM_WORLD real , allocatable :: VARin(:,:) real , allocatable :: VARout(:,:) integer :: IM0 integer :: JM0 integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) integer :: gridRank character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWriteNCpar_R4_2d' character(len=ESMF_MAXSTR) :: GridTypeAttribute real(kind=ESMF_KIND_R4), allocatable :: recvbuf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x integer :: ndims, start(4), cnt(4), dimids(4) integer :: isize, first, last integer :: nwrts, mype, npes, sendcount integer :: mypeWr character(len=ESMF_MAXSTR) :: dimname integer :: ii real(kind=ESMF_KIND_R4) :: dummy integer :: group, newgroup integer :: thiscomm integer :: nactive integer :: ntransl integer, allocatable :: pes(:) integer, allocatable :: inv_pes(:) integer, allocatable :: r2g(:) integer, allocatable :: rpes(:) integer, allocatable :: activeranks(:) integer, allocatable :: activerecvcounts(:) integer :: jsize, jprev, num_io_rows integer, allocatable :: msk(:), recvcounts(:), displs(:) real(kind=ESMF_KIND_R8) :: itime_beg, itime_end, bwidth logical :: AM_WRITER AM_WRITER = .false. if (present(arrdes)) then if (arrdes%writers_comm/=MPI_COMM_NULL) then AM_WRITER = .true. end if else AM_WRITER = .true. end if if (AM_WRITER) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) fid = ncioObj%ncid end if if (present(arrdes)) then IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world ndes_x = size(arrdes%in) call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%iogathercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%iogathercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (recvcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 recvcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + recvcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize), stat=status) VERIFY_(STATUS) allocate(recvbuf(IM_WORLD*jsize), stat=status) VERIFY_(STATUS) end if if(myiorank/=0) then allocate(recvbuf(0), stat=status) VERIFY_(STATUS) endif call mpi_gatherv( a, size(a), MPI_REAL, recvbuf, recvcounts, displs, MPI_REAL, & 0, arrdes%iogathercomm, status ) VERIFY_(STATUS) if(myiorank==0) then jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) VAR(i,jprev+j) = recvbuf(k) k=k+1 end do end do end do jprev = jprev + jsize end do jsize=jprev start(1) = 1 start(2) = arrdes%j1(myrow+1) start(3) = 1 start(4) = 1 cnt(1) = IM_WORLD cnt(2) = jsize cnt(3) = 1 cnt(4) = 1 STATUS = NF_PUT_VARA_REAL(fid, varid, start, cnt, VAR) if(status /= nf_noerr) then print*,'Error writing variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif deallocate(VAR, stat=status) VERIFY_(STATUS) endif ! myiorank deallocate(recvbuf, stat=status) VERIFY_(STATUS) deallocate (recvcounts, displs, stat=status) VERIFY_(STATUS) else start(1) = 1 start(2) = 1 start(3) = 1 if (present(lev)) start(3)=lev start(4) = 1 cnt(1) = size(a,1) cnt(2) = size(a,2) cnt(3) = 1 cnt(4) = 1 STATUS = NF_PUT_VARA_REAL(fid, varid, start, cnt, a) if(status /= nf_noerr) then print*,'Error writing variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWriteNCpar_R4_2d !--------------------------- subroutine MAPL_VarReadNCpar_R4_2d(ncioObj, name, A, ARRDES, lev, RC) type(MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R4) , intent( OUT) :: A(:,:) type(ArrDescr), optional , intent(INOUT) :: ARRDES integer, optional , intent(IN ) :: lev integer, optional , intent( OUT) :: RC ! Local variables integer :: varid,unit real(kind=ESMF_KIND_R4), allocatable :: VAR(:,:) integer :: IM_WORLD integer :: JM_WORLD integer :: status integer :: gridRank integer :: DIMS(ESMF_MAXGRIDDIM) character(len=ESMF_MAXSTR) :: IAm='MAPL_VarReadNCpar_R4_2d' real(kind=ESMF_KIND_R4), allocatable :: buf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x integer :: ndims, start(4), cnt(4), dimids(4) integer :: jsize, jprev, num_io_rows integer, allocatable :: sendcounts(:), displs(:) logical :: AM_READER AM_READER = .false. if (present(arrdes)) then if (arrdes%readers_comm/=MPI_COMM_NULL) then AM_READER = .true. end if else AM_READER = .true. end if if (AM_READER) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) unit = ncioObj%ncid end if if (present(arrdes) ) then IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world ndes_x = size(arrdes%in) call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%ioscattercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%ioscattercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (sendcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 sendcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + sendcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize), stat=status) VERIFY_(STATUS) allocate(buf(IM_WORLD*jsize), stat=status) VERIFY_(STATUS) start(1) = 1 start(2) = arrdes%j1(myrow+1) start(3) = 1 start(4) = 1 cnt(1) = IM_WORLD cnt(2) = jsize cnt(3) = 1 cnt(4) = 1 STATUS = NF_GET_VARA_REAL(UNIT, varid, start, cnt, VAR) if(status /= nf_noerr) then print*,'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) buf(k) = VAR(i,jprev+j) k=k+1 end do end do end do jprev = jprev + jsize end do deallocate(VAR, stat=status) VERIFY_(STATUS) end if ! myiorank if(myiorank/=0) then allocate(buf(0), stat=status) VERIFY_(STATUS) endif call mpi_scatterv( buf, sendcounts, displs, MPI_REAL, & a, size(a), MPI_REAL, & 0, arrdes%ioscattercomm, status ) VERIFY_(STATUS) deallocate(buf, stat=status) VERIFY_(STATUS) deallocate (sendcounts, displs, stat=status) VERIFY_(STATUS) else start(1) = 1 start(2) = 1 start(3) = 1 if (present(lev) ) start(3)=lev start(4) = 1 cnt(1) = size(a,1) cnt(2) = size(a,2) cnt(3) = 1 cnt(4) = 1 STATUS = NF_GET_VARA_REAL(UNIT, varid, start, cnt, a) if(status /= nf_noerr) then print*,'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarReadNCpar_R4_2d !--------------------------- subroutine MAPL_VarWriteNCpar_R4_1d(ncioObj, name, A, layout, ARRDES, MASK, offset1, offset2, RC) type(MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R4) , intent(IN ) :: A(:) type (ESMF_DELayout), optional, intent(IN ) :: layout type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent(IN ) :: MASK(:) integer, optional, intent(IN ) :: offset1 integer, optional, intent(IN ) :: offset2 integer, optional , intent( OUT) :: RC ! Local variables integer :: varid, unit real(kind=ESMF_KIND_R4), allocatable :: VAR(:) real(kind=ESMF_KIND_R4), allocatable :: GVAR(:) integer :: IM_WORLD integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) type (ESMF_DistGrid) :: distGrid character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWriteNCpar_R4_1d' integer, allocatable :: msk(:), recvcounts(:), displs(:) integer :: nwrts, mype, npes, sendcount integer :: mypeWr, io_rank integer :: Rsize, first, last integer(KIND=MPI_OFFSET_KIND) :: offset integer(KIND=MPI_OFFSET_KIND) :: loffset integer :: i, k, n, i1, in integer :: ii real(kind=ESMF_KIND_R4) :: dummy integer :: group, newgroup integer :: thiscomm integer :: nactive integer :: ntransl integer, allocatable :: pes(:) integer, allocatable :: inv_pes(:) integer, allocatable :: r2g(:) integer, allocatable :: rpes(:) integer, allocatable :: activeranks(:) integer, allocatable :: activerecvcounts(:) integer :: start(4), cnt(4) logical :: AM_WRITER AM_WRITER = .false. if (present(arrdes)) then if (arrdes%writers_comm/=MPI_COMM_NULL) then AM_WRITER = .true. end if else AM_WRITER = .true. end if if (AM_WRITER) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) unit = ncioObj%ncid end if if(present(mask) .and. present(layout) .and. present(arrdes) ) then IM_WORLD = arrdes%im_world call mpi_comm_size(arrdes%iogathercomm,npes ,status) VERIFY_(STATUS) if(arrdes%writers_comm /= MPI_COMM_NULL) then call mpi_comm_rank(arrdes%writers_comm,mypeWr ,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%writers_comm,nwrts,status) VERIFY_(STATUS) else mypeWr = -1 endif call MAPL_CommsBcast(layout, nwrts, 1, 0, rc = status) Rsize = im_world/nwrts + 1 first = mypeWr*Rsize + 1 if(mypeWr >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (mypeWr-mod(im_world,nwrts)) endif last = first + Rsize - 1 #ifdef DEBUG_MPIIO if (mypeWr <= nwrts-1) write(*,'(5i)') mypeWr, IM_WORLD, first, last, Rsize #endif if(arrdes%writers_comm /= MPI_COMM_NULL) then allocate(GVAR(Rsize), stat=status) VERIFY_(STATUS) end if allocate(VAR(Rsize), stat=status) VERIFY_(STATUS) allocate(msk(Rsize), stat=status) VERIFY_(STATUS) allocate (recvcounts(0:npes-1), stat=status) VERIFY_(STATUS) allocate (r2g(0:nwrts-1), stat=status) VERIFY_(STATUS) allocate(inv_pes(0:npes-1),stat=status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%iogathercomm,mype ,status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%iogathercomm, GROUP, STATUS) VERIFY_(STATUS) #if 1 if (arrdes%writers_comm /= MPI_COMM_NULL) then allocate(rpes(0:nwrts-1), stat=status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%writers_comm, NEWGROUP, STATUS) VERIFY_(STATUS) do n=0,nwrts-1 rpes(n) = n end do call MPI_Group_translate_ranks(newgroup, nwrts, rpes, group, r2g, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) deallocate(rpes) end if call MAPL_CommsBcast(layout, r2g, nwrts, 0, rc = status) #else do n=0,nrdrs-1 r2g(n) = (npes/nrdrs)*n end do #endif offset = 1 do n=0,nwrts-1 Rsize = im_world/nwrts + 1 first = n*Rsize + 1 if(n >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (n-mod(im_world,nwrts)) endif last = first + Rsize - 1 recvcounts = 0 do i=first,last recvcounts(mask(i)) = recvcounts(mask(i)) + 1 enddo ! Writer "n" must be included in the mpi group + evevybody that need the data nactive = count(recvcounts > 0) if (recvcounts(r2g(n)) == 0) then nactive = nactive + 1 end if allocate (activeranks(0:nactive-1), activerecvcounts(0:nactive-1), stat=status) VERIFY_(STATUS) allocate(pes(0:nactive-1), stat=status) VERIFY_(STATUS) allocate (displs(0:nactive), stat=status) VERIFY_(STATUS) k = 0 do i=0, npes-1 if (recvcounts(i) > 0) then pes(k) = i k = k+1 end if enddo if (k /= nactive) then k = k+1 ASSERT_(k == nactive) ASSERT_(recvcounts(r2g(n)) == 0) pes(nactive-1) = r2g(n) end if call MPI_GROUP_INCL (GROUP, nactive, PES, newgroup, STATUS) VERIFY_(STATUS) call MPI_COMM_CREATE(arrdes%iogathercomm, newgroup, thiscomm, STATUS) VERIFY_(STATUS) call MPI_Group_translate_ranks(group, nactive, pes, newgroup, activeranks, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) inv_pes = -1 ! initialized to invalid do i=0,nactive-1 inv_pes(pes(i)) = i end do if (thiscomm /= MPI_COMM_NULL) then activerecvcounts = 0 do i=0,nactive-1 activerecvcounts(activeranks(i)) = recvcounts(pes(i)) if (pes(i) == r2g(n)) ntransl = activeranks(i) end do displs(0) = 0 do i=1,nactive displs(i) = displs(i-1) + activerecvcounts(i-1) enddo sendcount = recvcounts(mype) if (sendcount == 0) then call MPI_GATHERV( dummy, sendcount, MPI_REAL, & var, activerecvcounts, displs, MPI_REAL, & ntransl, thiscomm, status ) else call MPI_GATHERV( a(offset), sendcount, MPI_REAL, & var, activerecvcounts, displs, MPI_REAL, & ntransl, thiscomm, status ) endif VERIFY_(STATUS) call MPI_Comm_Free(thiscomm, status) VERIFY_(STATUS) if(n==mypeWr) then msk = mask(first:last) do I=1,Rsize K = inv_pes(MSK(I)) II = displs(K)+1 ! var is 1-based GVAR(I) = VAR(II) displs(K) = displs(K) + 1 end do endif offset = offset + sendcount end if deallocate (displs) deallocate(pes) deallocate (activerecvcounts, activeranks) enddo if(arrdes%writers_comm /= MPI_COMM_NULL) then Rsize = im_world/nwrts + 1 first = mypeWr*Rsize + 1 if(mypeWr >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (mypeWr-mod(im_world,nwrts)) endif last = first + Rsize - 1 ASSERT_( (lbound(mask,1) <= first) ) ASSERT_( (ubound(mask,1) >= last ) ) ! lon, lat, lev, time start(1) = first start(2) = 1 start(3) = 1 if (present(offset1)) start(2) = offset1 if (present(offset2)) start(3) = offset2 start(4) = 1 cnt(1) = Rsize cnt(2) = 1 cnt(3) = 1 cnt(4) = 1 ! print*,'start values are ',start ! print*,'count values are ',cnt STATUS = NF_PUT_VARA_REAL(UNIT, varid, start, cnt, GVAR) if(status /= nf_noerr) then print*,'Error writing variable ', status print*, NF_STRERROR(status) VERIFY_(STATUS) endif endif call MPI_GROUP_FREE (GROUP, STATUS) VERIFY_(STATUS) deallocate(var,msk) deallocate (inv_pes) deallocate (r2g) deallocate(recvcounts) if(arrdes%writers_comm /= MPI_COMM_NULL) then deallocate(gvar) end if else ! Comments ! This routine is used to write PREF to moist_import_checkpoint start(1) = 1 start(2) = 1 start(3) = 1 if (present(offset1)) start(2) = offset1 if (present(offset2)) start(3) = offset2 start(4) = 1 cnt(1) = size(a) cnt(2) = 1 cnt(3) = 1 cnt(4) = 1 if (present(layout)) then if (arrdes%writers_comm/=MPI_COMM_NULL) then call MPI_COMM_RANK(arrdes%writers_comm, io_rank, STATUS) VERIFY_(STATUS) if (io_rank == 0) then STATUS = NF_PUT_VARA_REAL(UNIT, varid, start, cnt, A) if(status /= nf_noerr) then print*,trim(IAm),'Error writing variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif endif endif else STATUS = NF_PUT_VARA_REAL(UNIT, varid, start, cnt, A) if(status /= nf_noerr) then print*,trim(IAm),'Error writing variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif end if end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWriteNCpar_R4_1d subroutine MAPL_VarWriteNCpar_R8_1d(ncioObj, name, A, layout, ARRDES, MASK, offset1, offset2, RC) type(MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R8) , intent(IN ) :: A(:) type (ESMF_DELayout), optional, intent(IN ) :: layout type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent(IN ) :: MASK(:) integer, optional, intent(IN ) :: offset1 integer, optional, intent(IN ) :: offset2 integer, optional , intent( OUT) :: RC ! Local variables integer :: varid, unit real(kind=ESMF_KIND_R8), allocatable :: VAR(:) real(kind=ESMF_KIND_R8), allocatable :: GVAR(:) integer :: IM_WORLD integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) type (ESMF_DistGrid) :: distGrid character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWriteNCpar_R8_1d' integer, allocatable :: msk(:), recvcounts(:), displs(:) integer :: nwrts, mype, npes, sendcount integer :: mypeWr, io_rank integer :: Rsize, first, last integer(KIND=MPI_OFFSET_KIND) :: offset integer(KIND=MPI_OFFSET_KIND) :: loffset integer :: i, k, n, i1, in integer :: ii real(kind=ESMF_KIND_R8) :: dummy integer :: group, newgroup integer :: thiscomm integer :: nactive integer :: ntransl integer, allocatable :: pes(:) integer, allocatable :: inv_pes(:) integer, allocatable :: r2g(:) integer, allocatable :: rpes(:) integer, allocatable :: activeranks(:) integer, allocatable :: activerecvcounts(:) integer :: start(4), cnt(4) logical :: AM_WRITER AM_WRITER = .false. if (present(arrdes)) then if (arrdes%writers_comm/=MPI_COMM_NULL) then AM_WRITER = .true. end if else AM_WRITER = .true. end if if (AM_WRITER) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) unit = ncioObj%ncid end if if(present(mask) .and. present(layout) .and. present(arrdes) ) then IM_WORLD = arrdes%im_world call mpi_comm_size(arrdes%iogathercomm,npes ,status) VERIFY_(STATUS) if(arrdes%writers_comm /= MPI_COMM_NULL) then call mpi_comm_rank(arrdes%writers_comm,mypeWr ,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%writers_comm,nwrts,status) VERIFY_(STATUS) else mypeWr = -1 endif call MAPL_CommsBcast(layout, nwrts, 1, 0, rc = status) Rsize = im_world/nwrts + 1 first = mypeWr*Rsize + 1 if(mypeWr >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (mypeWr-mod(im_world,nwrts)) endif last = first + Rsize - 1 #ifdef DEBUG_MPIIO if (mypeWr <= nwrts-1) write(*,'(5i)') mypeWr, IM_WORLD, first, last, Rsize #endif if(arrdes%writers_comm /= MPI_COMM_NULL) then allocate(GVAR(Rsize), stat=status) VERIFY_(STATUS) end if allocate(VAR(Rsize), stat=status) VERIFY_(STATUS) allocate(msk(Rsize), stat=status) VERIFY_(STATUS) allocate (recvcounts(0:npes-1), stat=status) VERIFY_(STATUS) allocate (r2g(0:nwrts-1), stat=status) VERIFY_(STATUS) allocate(inv_pes(0:npes-1),stat=status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%iogathercomm,mype ,status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%iogathercomm, GROUP, STATUS) VERIFY_(STATUS) #if 1 if (arrdes%writers_comm /= MPI_COMM_NULL) then allocate(rpes(0:nwrts-1), stat=status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%writers_comm, NEWGROUP, STATUS) VERIFY_(STATUS) do n=0,nwrts-1 rpes(n) = n end do call MPI_Group_translate_ranks(newgroup, nwrts, rpes, group, r2g, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) deallocate(rpes) end if call MAPL_CommsBcast(layout, r2g, nwrts, 0, rc = status) #else do n=0,nrdrs-1 r2g(n) = (npes/nrdrs)*n end do #endif offset = 1 do n=0,nwrts-1 Rsize = im_world/nwrts + 1 first = n*Rsize + 1 if(n >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (n-mod(im_world,nwrts)) endif last = first + Rsize - 1 recvcounts = 0 do i=first,last recvcounts(mask(i)) = recvcounts(mask(i)) + 1 enddo ! Writer "n" must be included in the mpi group + evevybody that need the data nactive = count(recvcounts > 0) if (recvcounts(r2g(n)) == 0) then nactive = nactive + 1 end if allocate (activeranks(0:nactive-1), activerecvcounts(0:nactive-1), stat=status) VERIFY_(STATUS) allocate(pes(0:nactive-1), stat=status) VERIFY_(STATUS) allocate (displs(0:nactive), stat=status) VERIFY_(STATUS) k = 0 do i=0, npes-1 if (recvcounts(i) > 0) then pes(k) = i k = k+1 end if enddo if (k /= nactive) then k = k+1 ASSERT_(k == nactive) ASSERT_(recvcounts(r2g(n)) == 0) pes(nactive-1) = r2g(n) end if call MPI_GROUP_INCL (GROUP, nactive, PES, newgroup, STATUS) VERIFY_(STATUS) call MPI_COMM_CREATE(arrdes%iogathercomm, newgroup, thiscomm, STATUS) VERIFY_(STATUS) call MPI_Group_translate_ranks(group, nactive, pes, newgroup, activeranks, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) inv_pes = -1 ! initialized to invalid do i=0,nactive-1 inv_pes(pes(i)) = i end do if (thiscomm /= MPI_COMM_NULL) then activerecvcounts = 0 do i=0,nactive-1 activerecvcounts(activeranks(i)) = recvcounts(pes(i)) if (pes(i) == r2g(n)) ntransl = activeranks(i) end do displs(0) = 0 do i=1,nactive displs(i) = displs(i-1) + activerecvcounts(i-1) enddo sendcount = recvcounts(mype) if (sendcount == 0) then call MPI_GATHERV( dummy, sendcount, MPI_DOUBLE_PRECISION, & var, activerecvcounts, displs, MPI_DOUBLE_PRECISION, & ntransl, thiscomm, status ) else call MPI_GATHERV( a(offset), sendcount, MPI_DOUBLE_PRECISION, & var, activerecvcounts, displs, MPI_DOUBLE_PRECISION, & ntransl, thiscomm, status ) endif VERIFY_(STATUS) call MPI_Comm_Free(thiscomm, status) VERIFY_(STATUS) if(n==mypeWr) then msk = mask(first:last) do I=1,Rsize K = inv_pes(MSK(I)) II = displs(K)+1 ! var is 1-based GVAR(I) = VAR(II) displs(K) = displs(K) + 1 end do endif offset = offset + sendcount end if deallocate (displs) deallocate(pes) deallocate (activerecvcounts, activeranks) enddo if(arrdes%writers_comm /= MPI_COMM_NULL) then Rsize = im_world/nwrts + 1 first = mypeWr*Rsize + 1 if(mypeWr >= mod(im_world,nwrts)) then Rsize = Rsize - 1 first = first - (mypeWr-mod(im_world,nwrts)) endif last = first + Rsize - 1 ASSERT_( (lbound(mask,1) <= first) ) ASSERT_( (ubound(mask,1) >= last ) ) ! lon, lat, lev, time start(1) = first start(2) = 1 start(3) = 1 if (present(offset1)) start(2) = offset1 if (present(offset2)) start(3) = offset2 start(4) = 1 cnt(1) = Rsize cnt(2) = 1 cnt(3) = 1 cnt(4) = 1 ! print*,'start values are ',start ! print*,'count values are ',cnt STATUS = NF_PUT_VARA_DOUBLE(UNIT, varid, start, cnt, GVAR) if(status /= nf_noerr) then print*,'Error writing variable ', status print*, NF_STRERROR(status) VERIFY_(STATUS) endif endif call MPI_GROUP_FREE (GROUP, STATUS) VERIFY_(STATUS) deallocate(var,msk) deallocate (inv_pes) deallocate (r2g) deallocate(recvcounts) if(arrdes%writers_comm /= MPI_COMM_NULL) then deallocate(gvar) end if else ! Comments ! This routine is used to write PREF to moist_import_checkpoint start(1) = 1 start(2) = 1 start(3) = 1 if (present(offset1)) start(2) = offset1 if (present(offset2)) start(3) = offset2 start(4) = 1 cnt(1) = size(a) cnt(2) = 1 cnt(3) = 1 cnt(4) = 1 if (present(layout)) then if (arrdes%writers_comm/=MPI_COMM_NULL) then call MPI_COMM_RANK(arrdes%writers_comm, io_rank, STATUS) VERIFY_(STATUS) if (io_rank == 0) then STATUS = NF_PUT_VARA_DOUBLE(UNIT, varid, start, cnt, A) if(status /= nf_noerr) then print*,trim(IAm),'Error writing variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif endif endif else STATUS = NF_PUT_VARA_DOUBLE(UNIT, varid, start, cnt, A) if(status /= nf_noerr) then print*,trim(IAm),'Error writing variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif end if end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWriteNCpar_R8_1d !---------------------------------------------------------------------------- subroutine MAPL_VarReadNCpar_R4_1d(ncioObj, name, A, layout, ARRDES, MASK, offset1, offset2, RC) type(MAPL_NCIO) , intent(in ) :: ncioObj character(len=*) , intent(in ) :: name real(kind=ESMF_KIND_R4) , intent( OUT) :: A(:) type (ESMF_DELayout), optional, intent(IN ) :: layout type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent(IN ) :: MASK(:) integer, optional, intent(IN ) :: offset1 integer, optional, intent(IN ) :: offset2 integer, optional , intent( OUT) :: RC ! Local variables integer :: unit, varid real(kind=ESMF_KIND_R4), allocatable :: VAR(:) integer :: IM_WORLD integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) character(len=ESMF_MAXSTR) :: IAm='MAPL_VarReadNCpar_R4_1d' integer, allocatable :: msk(:), sendcounts(:), displs(:) integer, allocatable :: idx(:) integer :: nrdrs, mype, npes, recvcount integer :: mypeRd, io_rank, reader integer :: Rsize, first, last integer(KIND=MPI_OFFSET_KIND) :: offset integer(KIND=MPI_OFFSET_KIND) :: loffset integer :: i, k, n, i1, in real(kind=ESMF_KIND_R4) :: dummy integer :: group, newgroup integer :: thiscomm integer :: nactive integer :: ntransl integer, allocatable :: pes(:) integer, allocatable :: r2g(:) integer, allocatable :: rpes(:) integer, allocatable :: activeranks(:) integer, allocatable :: activesendcounts(:) integer :: start(4), cnt(4) logical :: AM_READER AM_READER = .false. if (present(arrdes)) then if (arrdes%readers_comm/=MPI_COMM_NULL) then AM_READER = .true. end if else AM_READER = .true. end if if (AM_READER) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) unit = ncioObj%ncid end if if(present(mask) .and. present(layout) .and. present(arrdes) ) then IM_WORLD = arrdes%im_world call mpi_comm_size(arrdes%ioscattercomm,npes ,status) VERIFY_(STATUS) if(arrdes%readers_comm /= MPI_COMM_NULL) then call mpi_comm_rank(arrdes%readers_comm,mypeRd ,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%readers_comm,nrdrs,status) VERIFY_(STATUS) else mypeRd = -1 endif call MAPL_CommsBcast(layout, nrdrs, 1, 0, rc = status) VERIFY_(STATUS) Rsize = im_world/nrdrs + 1 first = mypeRd*Rsize + 1 if(mypeRd >= mod(im_world,nrdrs)) then Rsize = Rsize - 1 first = first - (mypeRd-mod(im_world,nrdrs)) endif last = first + Rsize - 1 #ifdef DEBUG_MPIIO if (mypeRd <= nrdrs-1) write(*,'(5i)') mypeRd, IM_WORLD, first, last, Rsize #endif allocate(VAR(Rsize), stat=status) VERIFY_(STATUS) allocate(msk(Rsize), stat=status) VERIFY_(STATUS) allocate (sendcounts(0:npes-1), stat=status) VERIFY_(STATUS) allocate (r2g(0:nrdrs-1), stat=status) VERIFY_(STATUS) if(arrdes%readers_comm /= MPI_COMM_NULL) then start(1) = first start(2) = 1 start(3) = 1 if ( present(offset1) ) start(2) = offset1 if ( present(offset2) ) start(3) = offset2 start(4) = 1 cnt(1) = Rsize cnt(2) = 1 cnt(3) = 1 cnt(4) = 1 ! print*,'start values are ',start ! print*,'count values are ',count STATUS = NF_GET_VARA_REAL(UNIT, varid, start, cnt, VAR) if(status /= nf_noerr) then print*,'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif ASSERT_( (lbound(mask,1) <= first) ) ASSERT_( (ubound(mask,1) >= last ) ) msk = mask(first:last) allocate(idx(Rsize), stat=status) VERIFY_(STATUS) do i=1,Rsize idx(i) = i enddo msk = mask(first:last) call MAPL_Sort(msk,idx) msk = mask(first:last) call MAPL_Sort(msk,var) endif call mpi_comm_rank(arrdes%ioscattercomm,mype ,status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%ioscattercomm, GROUP, STATUS) VERIFY_(STATUS) #if 1 if (arrdes%readers_comm /= MPI_COMM_NULL) then allocate(rpes(0:nrdrs-1), stat=status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%readers_comm, NEWGROUP, STATUS) VERIFY_(STATUS) do n=0,nrdrs-1 rpes(n) = n end do call MPI_Group_translate_ranks(newgroup, nrdrs, rpes, group, r2g, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) deallocate(rpes) end if call MAPL_CommsBcast(layout, r2g, nrdrs, 0, rc = status) VERIFY_(STATUS) #else do n=0,nrdrs-1 r2g(n) = (npes/nrdrs)*n end do #endif offset = 1 do n=0,nrdrs-1 Rsize = im_world/nrdrs + 1 first = n*Rsize + 1 if(n >= mod(im_world,nrdrs)) then Rsize = Rsize - 1 first = first - (n-mod(im_world,nrdrs)) endif last = first + Rsize - 1 sendcounts = 0 do i=first,last sendcounts(mask(i)) = sendcounts(mask(i)) + 1 enddo ! Reader "n" must be included in the mpi group + evevybody that need the data nactive = count(sendcounts > 0) if (sendcounts(r2g(n)) == 0) then nactive = nactive + 1 end if allocate (activeranks(0:nactive-1), activesendcounts(0:nactive-1), stat=status) VERIFY_(STATUS) allocate(pes(0:nactive-1), stat=status) VERIFY_(STATUS) allocate (displs(0:nactive), stat=status) VERIFY_(STATUS) k = 0 do i=0, npes-1 if (sendcounts(i) > 0) then pes(k) = i k = k+1 end if enddo if (k /= nactive) then k = k+1 ASSERT_(k == nactive) ASSERT_(sendcounts(r2g(n)) == 0) pes(nactive-1) = r2g(n) end if call MPI_GROUP_INCL (GROUP, nactive, PES, newgroup, STATUS) VERIFY_(STATUS) call MPI_COMM_CREATE(arrdes%ioscattercomm, newgroup, thiscomm, STATUS) VERIFY_(STATUS) call MPI_Group_translate_ranks(group, nactive, pes, newgroup, activeranks, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) if (thiscomm /= MPI_COMM_NULL) then activesendcounts = 0 do i=0,nactive-1 activesendcounts(activeranks(i)) = sendcounts(pes(i)) if (pes(i) == r2g(n)) ntransl = activeranks(i) end do displs(0) = 0 do i=1,nactive displs(i) = displs(i-1) + activesendcounts(i-1) enddo if(n==mypeRd) then do i=0,nactive-1 if(activesendcounts(i)>0) then i1 = displs(i ) + 1 in = displs(i+1) call MAPL_Sort(idx(i1:in),var(i1:in)) endif end do endif recvcount = sendcounts(mype) if (recvcount == 0) then call MPI_SCATTERV( var, activesendcounts, displs, MPI_REAL, & dummy, recvcount, MPI_REAL, & ntransl, thiscomm, status ) else call MPI_SCATTERV( var, activesendcounts, displs, MPI_REAL, & a(offset), recvcount, MPI_REAL, & ntransl, thiscomm, status ) endif VERIFY_(STATUS) call MPI_Comm_Free(thiscomm, status) VERIFY_(STATUS) offset = offset + recvcount end if deallocate (displs) deallocate(pes) deallocate (activesendcounts, activeranks) enddo call MPI_GROUP_FREE (GROUP, STATUS) VERIFY_(STATUS) deallocate(var,msk) deallocate (r2g) deallocate(sendcounts) if(arrdes%readers_comm /= MPI_COMM_NULL) then deallocate(idx) end if else start(1) = 1 start(2) = 1 start(3) = 1 if ( present(offset1) ) start(2) = offset1 if ( present(offset2) ) start(3) = offset2 start(4) = 1 cnt(1) = size(a) cnt(2) = 1 cnt(3) = 1 cnt(4) = 1 if (present(layout) ) then if (MAPL_am_i_root(layout)) then STATUS = NF_GET_VARA_REAL(UNIT, varid, start, cnt, A) if(status /= nf_noerr) then print*,trim(IAm),'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif endif call MAPL_CommsBcast(layout, A, size(A), MAPL_Root, status) VERIFY_(STATUS) else STATUS = NF_GET_VARA_REAL(UNIT, varid, start, cnt, A) if(status /= nf_noerr) then print*,trim(IAm),'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif end if end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarReadNCpar_R4_1d subroutine MAPL_VarReadNCpar_R8_1d(ncioObj, name, A, layout, ARRDES, MASK, offset1, offset2, RC) type(MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R8) , intent( OUT) :: A(:) type (ESMF_DELayout), optional, intent(IN ) :: layout type(ArrDescr), optional, intent(INOUT) :: ARRDES integer, optional , intent(IN ) :: MASK(:) integer, optional, intent(IN ) :: offset1 integer, optional, intent(IN ) :: offset2 integer, optional , intent( OUT) :: RC ! Local variables integer :: varid, unit real(kind=ESMF_KIND_R8), allocatable :: VAR(:) integer :: IM_WORLD integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) character(len=ESMF_MAXSTR) :: IAm='MAPL_VarReadNCpar_R8_1d' integer, allocatable :: msk(:), sendcounts(:), displs(:) integer, allocatable :: idx(:) integer :: nrdrs, mype, npes, recvcount integer :: mypeRd, io_rank, reader integer :: Rsize, first, last integer(KIND=MPI_OFFSET_KIND) :: offset integer(KIND=MPI_OFFSET_KIND) :: loffset integer :: i, k, n, i1, in real(kind=ESMF_KIND_R8) :: dummy integer :: group, newgroup integer :: thiscomm integer :: nactive integer :: ntransl integer, allocatable :: pes(:) integer, allocatable :: r2g(:) integer, allocatable :: rpes(:) integer, allocatable :: activeranks(:) integer, allocatable :: activesendcounts(:) integer :: start(4), cnt(4) logical :: AM_READER AM_READER = .false. if (present(arrdes)) then if (arrdes%readers_comm/=MPI_COMM_NULL) then AM_READER = .true. end if else AM_READER = .true. end if if (AM_READER) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) unit = ncioObj%ncid end if if(present(mask) .and. present(layout) .and. present(arrdes) ) then IM_WORLD = arrdes%im_world call mpi_comm_size(arrdes%ioscattercomm,npes ,status) VERIFY_(STATUS) if(arrdes%readers_comm /= MPI_COMM_NULL) then call mpi_comm_rank(arrdes%readers_comm,mypeRd ,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%readers_comm,nrdrs,status) VERIFY_(STATUS) else mypeRd = -1 endif call MAPL_CommsBcast(layout, nrdrs, 1, 0, rc = status) VERIFY_(STATUS) Rsize = im_world/nrdrs + 1 first = mypeRd*Rsize + 1 if(mypeRd >= mod(im_world,nrdrs)) then Rsize = Rsize - 1 first = first - (mypeRd-mod(im_world,nrdrs)) endif last = first + Rsize - 1 #ifdef DEBUG_MPIIO if (mypeRd <= nrdrs-1) write(*,'(5i)') mypeRd, IM_WORLD, first, last, Rsize #endif allocate(VAR(Rsize), stat=status) VERIFY_(STATUS) allocate(msk(Rsize), stat=status) VERIFY_(STATUS) allocate (sendcounts(0:npes-1), stat=status) VERIFY_(STATUS) allocate (r2g(0:nrdrs-1), stat=status) VERIFY_(STATUS) if(arrdes%readers_comm /= MPI_COMM_NULL) then start(1) = first start(2) = 1 start(3) = 1 if ( present(offset1) ) start(2) = offset1 if ( present(offset2) ) start(3) = offset2 start(4) = 1 cnt(1) = Rsize cnt(2) = 1 cnt(3) = 1 cnt(4) = 1 ! print*,'start values are ',start ! print*,'count values are ',count STATUS = NF_GET_VARA_DOUBLE(UNIT, varid, start, cnt, VAR) if(status /= nf_noerr) then print*,'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif ASSERT_( (lbound(mask,1) <= first) ) ASSERT_( (ubound(mask,1) >= last ) ) msk = mask(first:last) allocate(idx(Rsize), stat=status) VERIFY_(STATUS) do i=1,Rsize idx(i) = i enddo msk = mask(first:last) call MAPL_Sort(msk,idx) msk = mask(first:last) call MAPL_Sort(msk,var) endif call mpi_comm_rank(arrdes%ioscattercomm,mype ,status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%ioscattercomm, GROUP, STATUS) VERIFY_(STATUS) #if 1 if (arrdes%readers_comm /= MPI_COMM_NULL) then allocate(rpes(0:nrdrs-1), stat=status) VERIFY_(STATUS) call MPI_COMM_GROUP (arrdes%readers_comm, NEWGROUP, STATUS) VERIFY_(STATUS) do n=0,nrdrs-1 rpes(n) = n end do call MPI_Group_translate_ranks(newgroup, nrdrs, rpes, group, r2g, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) deallocate(rpes) end if call MAPL_CommsBcast(layout, r2g, nrdrs, 0, rc = status) VERIFY_(STATUS) #else do n=0,nrdrs-1 r2g(n) = (npes/nrdrs)*n end do #endif offset = 1 do n=0,nrdrs-1 Rsize = im_world/nrdrs + 1 first = n*Rsize + 1 if(n >= mod(im_world,nrdrs)) then Rsize = Rsize - 1 first = first - (n-mod(im_world,nrdrs)) endif last = first + Rsize - 1 sendcounts = 0 do i=first,last sendcounts(mask(i)) = sendcounts(mask(i)) + 1 enddo ! Reader "n" must be included in the mpi group + evevybody that need the data nactive = count(sendcounts > 0) if (sendcounts(r2g(n)) == 0) then nactive = nactive + 1 end if allocate (activeranks(0:nactive-1), activesendcounts(0:nactive-1), stat=status) VERIFY_(STATUS) allocate(pes(0:nactive-1), stat=status) VERIFY_(STATUS) allocate (displs(0:nactive), stat=status) VERIFY_(STATUS) k = 0 do i=0, npes-1 if (sendcounts(i) > 0) then pes(k) = i k = k+1 end if enddo if (k /= nactive) then k = k+1 ASSERT_(k == nactive) ASSERT_(sendcounts(r2g(n)) == 0) pes(nactive-1) = r2g(n) end if call MPI_GROUP_INCL (GROUP, nactive, PES, newgroup, STATUS) VERIFY_(STATUS) call MPI_COMM_CREATE(arrdes%ioscattercomm, newgroup, thiscomm, STATUS) VERIFY_(STATUS) call MPI_Group_translate_ranks(group, nactive, pes, newgroup, activeranks, status) VERIFY_(STATUS) call MPI_GROUP_FREE (NEWGROUP, STATUS) VERIFY_(STATUS) if (thiscomm /= MPI_COMM_NULL) then activesendcounts = 0 do i=0,nactive-1 activesendcounts(activeranks(i)) = sendcounts(pes(i)) if (pes(i) == r2g(n)) ntransl = activeranks(i) end do displs(0) = 0 do i=1,nactive displs(i) = displs(i-1) + activesendcounts(i-1) enddo if(n==mypeRd) then do i=0,nactive-1 if(activesendcounts(i)>0) then i1 = displs(i ) + 1 in = displs(i+1) call MAPL_Sort(idx(i1:in),var(i1:in)) endif end do endif recvcount = sendcounts(mype) if (recvcount == 0) then call MPI_SCATTERV( var, activesendcounts, displs, MPI_DOUBLE_PRECISION, & dummy, recvcount, MPI_DOUBLE_PRECISION, & ntransl, thiscomm, status ) else call MPI_SCATTERV( var, activesendcounts, displs, MPI_DOUBLE_PRECISION, & a(offset), recvcount, MPI_DOUBLE_PRECISION, & ntransl, thiscomm, status ) endif VERIFY_(STATUS) call MPI_Comm_Free(thiscomm, status) VERIFY_(STATUS) offset = offset + recvcount end if deallocate (displs) deallocate(pes) deallocate (activesendcounts, activeranks) enddo call MPI_GROUP_FREE (GROUP, STATUS) VERIFY_(STATUS) deallocate(var,msk) deallocate (r2g) deallocate(sendcounts) if(arrdes%readers_comm /= MPI_COMM_NULL) then deallocate(idx) end if else start(1) = 1 start(2) = 1 start(3) = 1 if ( present(offset1) ) start(2) = offset1 if ( present(offset2) ) start(3) = offset2 start(4) = 1 cnt(1) = size(a) cnt(2) = 1 cnt(3) = 1 cnt(4) = 1 if (present(layout) ) then if (MAPL_am_i_root(layout)) then STATUS = NF_GET_VARA_DOUBLE(UNIT, varid, start, cnt, A) if(status /= nf_noerr) then print*,trim(IAm),'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif endif call MAPL_CommsBcast(layout, A, size(A), MAPL_Root, status) VERIFY_(STATUS) else STATUS = NF_GET_VARA_DOUBLE(UNIT, varid, start, cnt, A) if(status /= nf_noerr) then print*,trim(IAm),'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif end if end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarReadNCpar_R8_1d !--------------------------- subroutine MAPL_VarWriteNCpar_R8_2d(ncioObj, name, A, ARRDES, lev, RC) type(MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R8) , intent(IN ) :: A(:,:) type(ArrDescr), optional , intent(INOUT) :: ARRDES integer, optional , intent(IN ) :: lev integer, optional , intent( OUT) :: RC ! Local variables integer :: fid, varid real(kind=ESMF_KIND_R8), allocatable :: VAR(:,:) integer :: IM_WORLD integer :: JM_WORLD real , allocatable :: VARin(:,:) real , allocatable :: VARout(:,:) integer :: IM0 integer :: JM0 integer :: status integer :: DIMS(ESMF_MAXGRIDDIM) integer :: gridRank character(len=ESMF_MAXSTR) :: IAm='MAPL_VarWriteNCpar_R8_2d' character(len=ESMF_MAXSTR) :: GridTypeAttribute real(kind=ESMF_KIND_R8), allocatable :: recvbuf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x integer :: ndims, start(4), cnt(4), dimids(4) character(len=ESMF_MAXSTR) :: dimname integer(kind=MPI_OFFSET_KIND) :: offset integer :: jsize, jprev, num_io_rows integer, allocatable :: recvcounts(:), displs(:) real(kind=ESMF_KIND_R8) :: itime_beg, itime_end, bwidth logical :: AM_WRITER AM_WRITER = .false. if (present(arrdes)) then if (arrdes%writers_comm/=MPI_COMM_NULL) then AM_WRITER = .true. end if else AM_WRITER = .true. end if if (AM_WRITER) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) fid = ncioObj%ncid end if if (present(arrdes)) then IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world ndes_x = size(arrdes%in) call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%iogathercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%iogathercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (recvcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 recvcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + recvcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize), stat=status) VERIFY_(STATUS) allocate(recvbuf(IM_WORLD*jsize), stat=status) VERIFY_(STATUS) end if if(myiorank/=0) then allocate(recvbuf(0), stat=status) VERIFY_(STATUS) endif call mpi_gatherv( a, size(a), MPI_DOUBLE_PRECISION, recvbuf, recvcounts, displs, & MPI_DOUBLE_PRECISION, 0, arrdes%iogathercomm, status ) VERIFY_(STATUS) if(myiorank==0) then jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) VAR(i,jprev+j) = recvbuf(k) k=k+1 end do end do end do jprev = jprev + jsize end do jsize=jprev ! lon, lat, lev, time start(1) = 1 start(2) = arrdes%j1(myrow+1) start(3) = 1 start(4) = 1 cnt(1) = IM_WORLD cnt(2) = jsize cnt(3) = 1 cnt(4) = 1 STATUS = NF_PUT_VARA_DOUBLE(fid, varid, start, cnt, VAR) if(status /= nf_noerr) then print*,'Error writing variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif deallocate(VAR, stat=status) VERIFY_(STATUS) endif ! myiorank deallocate(recvbuf, stat=status) VERIFY_(STATUS) deallocate (recvcounts, displs, stat=status) VERIFY_(STATUS) else start(1) = 1 start(2) = 1 start(3) = 1 if (present(lev)) start(3) = lev start(4) = 1 cnt(1) = size(a,1) cnt(2) = size(a,2) cnt(3) = 1 cnt(4) = 1 STATUS = NF_PUT_VARA_DOUBLE(fid, varid, start, cnt, a) if(status /= nf_noerr) then print*,'Error writing variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarWriteNCpar_R8_2d !--------------------------- subroutine MAPL_VarReadNCpar_R8_2d(ncioObj, name, A, ARRDES, lev, RC) type(MAPL_NCIO) , intent(IN ) :: ncioObj character(len=*) , intent(IN ) :: name real(kind=ESMF_KIND_R8) , intent(IN ) :: A(:,:) type(ArrDescr), optional , intent(INOUT) :: ARRDES integer, optional , intent(IN ) :: lev integer, optional , intent( OUT) :: RC ! Local variables integer :: fid, varid real(kind=ESMF_KIND_R8), allocatable :: VAR(:,:) integer :: IM_WORLD integer :: JM_WORLD integer :: status integer :: gridRank integer :: DIMS(ESMF_MAXGRIDDIM) character(len=ESMF_MAXSTR) :: IAm='MAPL_VarReadNCpar_R8_2d' real(kind=ESMF_KIND_R8), allocatable :: buf(:) integer :: I,J,N,K,L,myrow,myiorank,ndes_x integer :: ndims, start(4), cnt(4), dimids(4) integer(kind=MPI_OFFSET_KIND) :: offset integer :: jsize, jprev, num_io_rows integer, allocatable :: sendcounts(:), displs(:) real(kind=ESMF_KIND_R8) :: itime_beg, itime_end, bwidth logical :: AM_READER AM_READER = .false. if (present(arrdes)) then if (arrdes%readers_comm/=MPI_COMM_NULL) then AM_READER = .true. end if else AM_READER = .true. end if if (AM_READER) then varid = MAPL_NCIOGetVarid(ncioObj,name,rc=status) VERIFY_(STATUS) fid = ncioObj%ncid end if if (present(arrdes)) then ndes_x = size(arrdes%in) IM_WORLD = arrdes%im_world JM_WORLD = arrdes%jm_world call mpi_comm_rank(arrdes%ycomm,myrow,status) VERIFY_(STATUS) call mpi_comm_rank(arrdes%ioscattercomm,myiorank,status) VERIFY_(STATUS) call mpi_comm_size(arrdes%ioscattercomm,num_io_rows,status) VERIFY_(STATUS) num_io_rows=num_io_rows/ndes_x allocate (sendcounts(ndes_x*num_io_rows), displs(ndes_x*num_io_rows), stat=status) VERIFY_(STATUS) if(myiorank==0) then do j=1,num_io_rows jsize = arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1 sendcounts((j-1)*ndes_x+1:(j-1)*ndes_x+ndes_x) = ( arrdes%IN - arrdes%I1 + 1) * jsize enddo displs(1) = 0 do i=2,ndes_x*num_io_rows displs(i) = displs(i-1) + sendcounts(i-1) enddo jsize = 0 do j=1,num_io_rows jsize=jsize + (arrdes%jn(myrow+j) - arrdes%j1(myrow+j) + 1) enddo allocate(VAR(IM_WORLD,jsize), stat=status) VERIFY_(STATUS) allocate(buf(IM_WORLD*jsize), stat=status) VERIFY_(STATUS) start(1) = 1 start(2) = arrdes%j1(myrow+1) start(3) = 1 start(4) = 1 cnt(1) = IM_WORLD cnt(2) = jsize cnt(3) = 1 cnt(4) = 1 STATUS = NF_GET_VARA_DOUBLE(fid, varid, start, cnt, VAR) if(status /= nf_noerr) then print*,'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif jprev = 0 k=1 do l=1,num_io_rows jsize = arrdes%jn(myrow+l) - arrdes%j1(myrow+l) + 1 do n=1,ndes_x do j=1,jsize do i=arrdes%i1(n),arrdes%in(n) buf(k) = VAR(i,jprev+j) k=k+1 end do end do end do jprev = jprev + jsize end do deallocate(VAR, stat=status) VERIFY_(STATUS) end if ! myiorank if(myiorank/=0) then allocate(buf(0), stat=status) VERIFY_(STATUS) endif call mpi_scatterv( buf, sendcounts, displs, MPI_DOUBLE_PRECISION, & a, size(a), MPI_DOUBLE_PRECISION, & 0, arrdes%ioscattercomm, status ) VERIFY_(STATUS) deallocate(buf, stat=status) VERIFY_(STATUS) deallocate (sendcounts, displs, stat=status) VERIFY_(STATUS) else start(1) = 1 start(2) = 1 start(3) = 1 if (present(lev) ) start(3) = lev start(4) = 1 cnt(1) = size(a,1) cnt(2) = size(a,2) cnt(3) = 1 cnt(4) = 1 STATUS = NF_GET_VARA_DOUBLE(fid, varid, start, cnt, a) if(status /= nf_noerr) then print*,'Error reading variable ',status print*, NF_STRERROR(status) VERIFY_(STATUS) endif endif RETURN_(ESMF_SUCCESS) end subroutine MAPL_VarReadNCpar_R8_2d !--------------------------- subroutine MAPL_BundleReadNCPar(Bundle, arrdes, filename, rc) type(ESMF_FieldBundle), intent(inout) :: Bundle type(ArrDescr), intent(inout) :: arrdes character(len=*), intent(in ) :: filename integer, optional, intent(out) :: rc integer :: nVars integer :: l type(ESMF_Field) :: field character(len=ESMF_MAXSTR) :: FieldName integer :: varid integer :: unit, info integer :: STATUS character(len=ESMF_MAXSTR) :: IAm='MAPL_BundleReadNCPar' integer :: dims(3) integer :: counts(5) integer :: numvars, ind type(ESMF_Grid) :: grid real, pointer :: ptr1(:), ptr2(:,:), ptr3(:,:,:) character(len=ESMF_MAXSTR) :: vname integer :: vdim,vlocation integer :: MAPL_DIMS integer, pointer :: MASK(:) => null() type(MAPL_NCIO) :: ncioObj call ESMF_FieldBundleGet(Bundle,FieldCount=nVars,rc=STATUS) VERIFY_(STATUS) !open the file for parallel reading if (arrdes%readers_comm/=MPI_COMM_NULL) then call MPI_Info_create(info,STATUS) VERIFY_(STATUS) call MPI_Info_set(info,"romio_cb_read", trim(arrdes%romio_cb_read),STATUS) VERIFY_(STATUS) call MPI_Info_set(info,"cb_buffer_size", trim(arrdes%cb_buffer_size),STATUS) VERIFY_(STATUS) if (arrdes%num_readers == 1) then ncioObj= MAPL_NCIOOpen(filename,rc=STATUS) VERIFY_(STATUS) else ncioObj= MAPL_NCIOOpen(filename,comm=arrdes%readers_comm,info=info,rc=STATUS) VERIFY_(STATUS) end if endif do l=1,nVars call ESMF_FieldBundleGet(bundle, fieldIndex=l, field=field, rc=status) VERIFY_(STATUS) call ESMF_FieldGet(field,name=FieldName,rc=status) VERIFY_(STATUS) ! Check for old style aerosol names ind= index(FieldName, '::') if (ind> 0) then FieldName = trim(FieldName(ind+2:)) end if if(.not.associated(MASK)) then call ESMF_AttributeGet(field, name='DIMS', value=MAPL_DIMS, rc=status) VERIFY_(STATUS) if (MAPL_DIMS == MAPL_DimsTileOnly .or. MAPL_DIMS == MAPL_DimsTileTile) then call ESMF_FieldGet (field, grid=grid, rc=status) VERIFY_(STATUS) call MAPL_TileMaskGet(grid, mask, rc=status) VERIFY_(STATUS) !@ else !@ allocate(Mask(1)) endif endif call MAPL_FieldReadNCPar(ncioObj, FieldName, field, arrdes=arrdes, HomePE=mask, rc=status) VERIFY_(STATUS) enddo if(associated(MASK)) then DEALOC_(MASK) end if if (arrdes%readers_comm/=MPI_COMM_NULL) then call MAPL_NCIOClose(ncioObj,destroy=.true.,rc=status) VERIFY_(STATUS) call MPI_Info_free(info, status) VERIFY_(STATUS) end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_BundleReadNCPar subroutine MAPL_StateVarReadNCPar(filename, STATE, arrdes, bootstrapable, NAME, RC) character(len=*) , intent(IN ) :: filename type (ESMF_State) , intent(INOUT) :: STATE type(ArrDescr) , intent(INOUT) :: ARRDES logical , intent(IN ) :: bootstrapable character(len=*), optional, intent(IN ) :: NAME integer, optional, intent( OUT) :: RC ! Local vars type (ESMF_FieldBundle) :: bundle type (ESMF_Field) :: field type (ESMF_Grid) :: grid integer :: status integer :: I, K, N character(len=ESMF_MAXSTR) :: IAm='MAPL_StateVarReadNCPar' integer :: J, ITEMCOUNT type (ESMF_StateItem_Flag), pointer :: ITEMTYPES(:) character(len=ESMF_MAXSTR ), pointer :: ITEMNAMES(:) logical, pointer :: DOIT(:) integer :: DIMS type (ESMF_Array) :: array integer :: rank, varid, ind logical :: skipReading integer :: RST character(len=ESMF_MAXSTR) :: FieldName, BundleName type (ESMF_Field) :: new_field type (ESMF_FieldBundle) :: bundle_read integer :: nBundle integer :: attr logical :: tile integer :: nVarFile, ncid character(len=ESMF_MAXSTR), pointer :: VarNamesFile(:) => null() type(ESMF_VM) :: VM logical :: foundInFile integer :: dna logical :: bootstrapable_ ! get a list of variables in the file so we can skip if the ! variable in the state is not in the file and it is bootstrapable ! will just let root do this since everybody will need it ! and avoid complications with doing later on when only readers_comm has opened file call ESMF_VMGetCurrent(VM,rc=status) VERIFY_(STATUS) if (MAPL_AM_I_Root()) then status = nf_open(trim(filename),NF_NOWRITE, ncid) VERIFY_(STATUS) status = nf_inq_nvars(ncid, nVarFile) VERIFY_(STATUS) end if call MAPL_CommsBcast(vm, nVarFile, n=1, ROOT=MAPL_Root, rc=status) VERIFY_(STATUS) allocate(VarNamesFile(nVarFile),stat=status) VERIFY_(STATUS) if (MAPL_AM_I_Root()) then do i=1,nVarFile status = nf_inq_varname(ncid, i, VarNamesFile(i)) VERIFY_(STATUS) end do status = nf_close(ncid) VERIFY_(STATUS) end if do i=1,nVarFile call MAPL_CommsBcast(vm, VarNamesFile(i), N=ESMF_MAXSTR, ROOT=MAPL_Root, rc=status) VERIFY_(STATUS) end do call ESMF_StateGet(STATE,ITEMCOUNT=ITEMCOUNT,RC=STATUS) VERIFY_(STATUS) ASSERT_(ITEMCOUNT>0) allocate(ITEMNAMES(ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) allocate(ITEMTYPES(ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) allocate( DOIT(ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) call ESMF_StateGet(STATE,ITEMNAMELIST=ITEMNAMES,& ITEMTYPELIST=ITEMTYPES,RC=STATUS) VERIFY_(STATUS) if(present(NAME)) then DOIT = ITEMNAMES==NAME ASSERT_(count(DOIT)/=0) else DOIT = .true. endif bundle_read = ESMF_FieldBundleCreate(rc=STATUS) VERIFY_(STATUS) call ESMF_FieldBundleSet(bundle_read,grid=arrdes%grid,rc=STATUS) VERIFY_(STATUS) do I = 1, ITEMCOUNT if (DOIT(I)) then if (ITEMTYPES(I) == ESMF_StateItem_FieldBundle) then call ESMF_StateGet(state, itemnames(i), bundle, rc=status) VERIFY_(STATUS) skipReading = .false. call ESMF_AttributeGet(bundle, name='RESTART', value=RST, rc=status) if (STATUS /= ESMF_SUCCESS) then RST = MAPL_RestartOptional end if skipReading = (RST == MAPL_RestartSkip) if (skipReading) cycle bootstrapable_ = bootstrapable .and. (RST == MAPL_RestartOptional) call ESMF_FieldBundleGet(bundle, fieldCount=nBundle, rc=STATUS) VERIFY_(STATUS) call ESMF_FieldBundleGet(bundle, name=BundleName, rc=status) VERIFY_(STATUS) DO J = 1,nBundle call ESMF_FieldBundleGet(bundle, fieldIndex=J, field=field, rc=status) VERIFY_(STATUS) call ESMF_FieldGet(field,name=FieldName,rc=status) VERIFY_(STATUS) skipReading = .false. call ESMF_AttributeGet(field, name='RESTART', value=RST, rc=status) if (STATUS /= ESMF_SUCCESS) then RST = MAPL_RestartOptional end if skipReading = (RST == MAPL_RestartSkip) if (skipReading) cycle ind= index(FieldName, '::') if (ind> 0) then FieldName = trim(FieldName(ind+2:)) end if ! Tack on BundleName to distiguish duplicate FieldNames in different Bundles (PCHEM for instance) FieldName = trim(BundleName) //'_'// trim(FieldName) ! now check if the fieldname is in the list of available fields ! ------------------------------------------------------------- foundInFile = .false. do k=1,nVarFile if (trim(FieldName) == trim(VarNamesFile(k))) then FoundInFile = .true. exit end if end do if (foundInFile) then new_field = MAPL_FieldCreate(Field,FieldName,rc=status) VERIFY_(STATUS) call MAPL_FieldBundleAdd(bundle_read,new_field,rc=status) VERIFY_(STATUS) else if (bootStrapable_ .and. (RST == MAPL_RestartOptional)) then call WRITE_PARALLEL(" Bootstrapping Variable: "//trim(FieldName)//" in "//trim(filename)) else call WRITE_PARALLEL(" Could not find field "//trim(FieldName)//" in "//trim(filename)) ASSERT_(.false.) end if end if ENDDO else if (ITEMTYPES(I) == ESMF_StateItem_Field) then call ESMF_StateGet(state, itemnames(i), field, rc=status) VERIFY_(STATUS) FieldName = trim(itemnames(i)) ind= index(FieldName, '::') if (ind> 0) then FieldName = trim(FieldName(ind+2:)) end if skipReading = .false. call ESMF_AttributeGet(field, name='RESTART', value=RST, rc=status) if (STATUS /= ESMF_SUCCESS) then RST = MAPL_RestartOptional end if skipReading = (RST == MAPL_RestartSkip) if (skipReading) cycle call ESMF_AttributeGet(field, name='doNotAllocate', value=DNA, rc=status) if (STATUS == ESMF_SUCCESS) then skipReading = (DNA /= 0) end if if (skipReading) cycle ! now check if the field is in the list of available fields ! --------------------------------------------------------- foundInFile = .false. do k=1,nVarFile if (trim(Fieldname) == trim(VarNamesFile(k))) then FoundInFile = .true. exit end if end do if (foundInFile) then call MAPL_FieldBundleAdd(bundle_read,field,rc=status) VERIFY_(STATUS) else if (bootStrapable .and. (RST == MAPL_RestartOptional)) then call WRITE_PARALLEL(" Bootstrapping Variable: "//trim(FieldName)//" in "//trim(filename)) else call WRITE_PARALLEL(" Could not find field "//trim(Fieldname)//" in "//trim(filename)) ASSERT_(.false.) end if end if end if end if end do tile = arrdes%tile call MAPL_VarReadNCPar(Bundle_Read, arrdes, filename, rc=status) VERIFY_(STATUS) deallocate(ITEMNAMES) deallocate(ITEMTYPES) deallocate( DOIT) deallocate(VarNamesFile) RETURN_(ESMF_SUCCESS) end subroutine MAPL_StateVarReadNCPar subroutine MAPL_ArrayReadNCpar_1d(varn,filename,farrayPtr,arrDes,rc) character(len=*), intent(IN ) :: varn character(len=*), intent(IN ) :: filename real, pointer :: farrayPtr(:) type(arrDescr), intent(INOUT) :: arrDes integer, optional, intent(OUT ) :: rc character(len=*), parameter :: Iam="MAPL_ArrayReadNCpar_1d" integer :: status type(ESMF_Field) :: field type(ESMF_FieldBundle) :: bundle FIELD = ESMF_FieldCreate(grid=arrDes%grid, datacopyflag=ESMF_DATACOPY_VALUE, & farrayPtr=farrayPtr, name=trim(varn), RC=STATUS) VERIFY_(STATUS) if (arrDes%tile) then call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsTileOnly,rc=status) VERIFY_(STATUS) endif BUNDLE = ESMF_FieldBundleCreate ( name=Iam, rc=STATUS ) VERIFY_(STATUS) call ESMF_FieldBundleSet ( bundle, grid=arrDes%grid, rc=STATUS ) VERIFY_(STATUS) call MAPL_FieldBundleAdd(BUNDLE, FIELD, rc=STATUS) VERIFY_(STATUS) call MAPL_VarReadNCPar(Bundle, arrdes, filename, rc=status) VERIFY_(STATUS) call ESMF_FieldBundleDestroy(bundle,rc=status) VERIFY_(STATUS) call ESMF_FieldDestroy(field,rc=status) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) end subroutine MAPL_ArrayReadNCpar_1d subroutine MAPL_ArrayReadNCpar_2d(varn,filename,farrayPtr,arrDes,rc) character(len=*), intent(IN ) :: varn character(len=*), intent(IN ) :: filename real, pointer :: farrayPtr(:,:) type(arrDescr), intent(INOUT) :: arrDes integer, optional, intent(OUT ) :: rc character(len=*), parameter :: Iam="MAPL_ArrayReadNCpar_2d" integer :: status type(ESMF_Field) :: field type(ESMF_FieldBundle) :: bundle FIELD = ESMF_FieldCreate(grid=arrDes%grid, datacopyflag=ESMF_DATACOPY_VALUE, & farrayPtr=farrayPtr, name=trim(varn), RC=STATUS) VERIFY_(STATUS) if (arrDes%tile) then call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsTileTile,rc=status) VERIFY_(STATUS) else call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsHorzOnly,rc=status) VERIFY_(STATUS) endif BUNDLE = ESMF_FieldBundleCreate ( name=Iam, rc=STATUS ) VERIFY_(STATUS) call ESMF_FieldBundleSet ( bundle, grid=arrDes%grid, rc=STATUS ) VERIFY_(STATUS) call MAPL_FieldBundleAdd(BUNDLE, FIELD, rc=STATUS) VERIFY_(STATUS) call MAPL_VarReadNCPar(Bundle, arrdes, filename, rc=status) VERIFY_(STATUS) call ESMF_FieldBundleDestroy(bundle,rc=status) VERIFY_(STATUS) call ESMF_FieldDestroy(field,rc=status) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) end subroutine MAPL_ArrayReadNCpar_2d subroutine MAPL_ArrayReadNCpar_3d(varn,filename,farrayPtr,arrDes,rc) character(len=*), intent(IN ) :: varn character(len=*), intent(IN ) :: filename real, pointer :: farrayPtr(:,:,:) type(arrDescr), intent(INOUT) :: arrDes integer, optional, intent(OUT ) :: rc character(len=*), parameter :: Iam="MAPL_ArrayReadNCpar_3d" integer :: status type(ESMF_Field) :: field type(ESMF_FieldBundle) :: bundle FIELD = ESMF_FieldCreate(grid=arrDes%grid, datacopyflag=ESMF_DATACOPY_VALUE, & farrayPtr=farrayPtr, name=trim(varn), RC=STATUS) call ESMF_AttributeSet(field,name='DIMS',value=MAPL_DimsHorzVert,rc=status) VERIFY_(STATUS) VERIFY_(STATUS) BUNDLE = ESMF_FieldBundleCreate ( name=Iam, rc=STATUS ) VERIFY_(STATUS) call ESMF_FieldBundleSet ( bundle, grid=arrDes%grid, rc=STATUS ) VERIFY_(STATUS) call MAPL_FieldBundleAdd(BUNDLE, FIELD, rc=STATUS) VERIFY_(STATUS) call MAPL_VarReadNCPar(Bundle, arrdes, filename, rc=status) VERIFY_(STATUS) call ESMF_FieldBundleDestroy(bundle,rc=status) VERIFY_(STATUS) call ESMF_FieldDestroy(field,rc=status) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) end subroutine MAPL_ArrayReadNCpar_3d subroutine MAPL_BundleWriteNCPar(Bundle, arrdes, CLOCK, filename, rc) type(ESMF_FieldBundle), intent(inout) :: Bundle type(ArrDescr), intent(inout) :: arrdes type(ESMF_Clock), intent(in) :: CLOCK character(len=*), intent(in ) :: filename integer, optional, intent(out) :: rc integer :: nVars, ndims integer :: i,j,k,l type(ESMF_Field) :: field type(ESMF_Array) :: array type(ESMF_Grid) :: grid character(len=ESMF_MAXSTR) :: FieldName integer :: varid integer :: YYYY, MM, DD, H, M, S type(ESMF_Time) :: currentTime character(len=ESMF_MAXSTR) :: TimeString, TimeUnits type(ESMF_TypeKind_Flag) :: tk integer :: ind integer :: londim, lonid, latdim, latid, levdim, levid, edgedim, edgeid integer :: tiledim, tileid, subtiledim, subtileid, tdim, tid logical :: Have_HorzOnly, Have_HorzVert, Have_VertOnly, Have_TileOnly logical :: Have_TileTile, Have_VLocationCenter, Have_VLocationEdge real(KIND=ESMF_KIND_R8), allocatable :: lon(:), lat(:), lev(:), edges(:) integer, allocatable :: LOCATION(:), DIMS(:), UNGRID_DIMS(:,:) integer, allocatable :: UNIQUE_UNGRID_DIMS(:), ungriddim(:) integer :: myungriddim1, myungriddim2 real(KIND=ESMF_KIND_R8) :: dlon, dlat integer :: arrayRank, KM_WORLD, DataType integer :: ungrid_dim_max_size, n_unique_ungrid_dims character(len=ESMF_MAXSTR) :: ungrid_dim_name real(KIND=ESMF_KIND_R4), pointer, dimension(:,:,:) :: var_3d => null() real(KIND=ESMF_KIND_R8), pointer, dimension(:,:,:) :: var8_3d => null() real(KIND=ESMF_KIND_R4), pointer, dimension(:,:) :: var_2d => null() real(KIND=ESMF_KIND_R8), pointer, dimension(:,:) :: var8_2d => null() real(KIND=ESMF_KIND_R4), pointer, dimension(:) :: var_1d => null() real(KIND=ESMF_KIND_R8), pointer, dimension(:) :: var8_1d => null() character(len=ESMF_MAXSTR ) :: STD_NAME, LONG_NAME, UNITS integer :: info integer :: MAPL_DIMS integer :: JM_WORLD integer, pointer :: MASK(:) => null() logical :: isCubed logical :: found type(MAPL_NCIO) :: ncioObj integer :: STATUS character(len=ESMF_MAXSTR) :: IAm='MAPL_BundleWriteNCPar' call ESMF_FieldBundleGet(Bundle,FieldCount=nVars,rc=STATUS) VERIFY_(STATUS) ! verify that file is compatible with fields in bundle we are reading if (nVars == 0) then if (MAPL_AM_I_root()) WRITE(*,*)"The bundle you are trying to write is empty" ASSERT_(.FALSE.) endif ! first we need to prep the netcdf file for writing allocate(LOCATION(nVars), stat=STATUS) VERIFY_(STATUS) allocate(DIMS(nVars), stat=STATUS) VERIFY_(STATUS) allocate(UNGRID_DIMS(nVars,2),stat=STATUS) VERIFY_(STATUS) UNGRID_DIMS = 0 ! now determine the dimensionality and vertical structure of each field JM_WORLD=1 DO I = 1, nVars call ESMF_FieldBundleGet(Bundle,fieldIndex=I, field=field, rc=status) VERIFY_(STATUS) call ESMF_AttributeGet(field, NAME='DIMS', VALUE=DIMS(I), rc=status) VERIFY_(STATUS) call ESMF_AttributeGet(field, NAME='VLOCATION', VALUE=LOCATION(I), rc=status) VERIFY_(STATUS) ! now check if we have an ungridded dimension call ESMF_FieldGet(field,array=array,rc=status) VERIFY_(STATUS) call ESMF_ArrayGet(array, typekind=tk, rank=arrayRank, RC=STATUS) VERIFY_(STATUS) if (arrayRank == 3 .and. DIMS(I) == MAPL_DimsHorzOnly) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_3d, rc=status) VERIFY_(STATUS) UNGRID_DIMS(I,1) = size(var_3d,3) elseif (tk == ESMF_TYPEKIND_R8) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var8_3d, rc=status) VERIFY_(STATUS) UNGRID_DIMS(I,1) = size(var8_3d,3) endif else if (arrayRank == 2 .and. DIMS(I) == MAPL_DimsTileOnly) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_2d, rc=status) VERIFY_(STATUS) UNGRID_DIMS(I,1) = size(var_2d,2) elseif (tk == ESMF_TYPEKIND_R8) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var8_2d, rc=status) VERIFY_(STATUS) UNGRID_DIMS(I,1) = size(var8_2d,2) endif else if (arrayRank == 2 .and. DIMS(I) == MAPL_DimsTileTile) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_2d, rc=status) VERIFY_(STATUS) JM_WORLD = max(JM_WORLD,size(var_2d,2)) elseif (tk == ESMF_TYPEKIND_R8) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var8_2d, rc=status) VERIFY_(STATUS) JM_WORLD = max(JM_WORLD,size(var_2d,2)) endif else if (arrayRank == 1 .and. DIMS(I) == MAPL_DimsNone) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_1d, rc=status) VERIFY_(STATUS) UNGRID_DIMS(I,1) = size(var_1d) elseif (tk == ESMF_TYPEKIND_R8) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var8_1d, rc=status) VERIFY_(STATUS) UNGRID_DIMS(I,1) = size(var8_1d) endif else if (arrayRank == 3 .and. DIMS(I) == MAPL_DimsTileOnly) then if (tk == ESMF_TYPEKIND_R4) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var_3d, rc=status) VERIFY_(STATUS) UNGRID_DIMS(I,1) = size(var_3d,2) UNGRID_DIMS(I,2) = size(var_3d,3) elseif (tk == ESMF_TYPEKIND_R8) then call ESMF_ArrayGet(array, localDE=0, farrayptr=var8_3d, rc=status) VERIFY_(STATUS) UNGRID_DIMS(I,1) = size(var8_3d,2) UNGRID_DIMS(I,2) = size(var8_3d,3) endif endif ENDDO Have_HorzOnly = any(DIMS==MAPL_DimsHorzOnly) Have_HorzVert = any(DIMS==MAPL_DimsHorzVert) Have_VertOnly = any(DIMS==MAPL_DimsVertOnly) Have_TileOnly = any(DIMS==MAPL_DimsTileOnly) Have_TileTile = any(DIMS==MAPL_DimsTileTile) Have_VLocationCenter = any(LOCATION==MAPL_VLocationCenter) Have_VLocationEdge = any(LOCATION==MAPL_VLocationEdge) ungrid_dim_max_size = maxval(UNGRID_DIMS) n_unique_ungrid_dims = 0 if (ungrid_dim_max_size /= 0) then n_unique_ungrid_dims = 0 do i = 1,ungrid_dim_max_size if (any(ungrid_dims == i)) n_unique_ungrid_dims = n_unique_ungrid_dims + 1 end do allocate(unique_ungrid_dims(n_unique_ungrid_dims),stat=status) VERIFY_(STATUS) allocate(ungriddim(n_unique_ungrid_dims),stat=status) VERIFY_(STATUS) n_unique_ungrid_dims = 0 do i = 1,ungrid_dim_max_size if (any(ungrid_dims == i)) then n_unique_ungrid_dims = n_unique_ungrid_dims + 1 unique_ungrid_dims(n_unique_ungrid_dims) = i end if end do endif deallocate(DIMS) deallocate(LOCATION) if (Have_TileTile) then call ArrDescrSet(arrdes, JM_WORLD=JM_WORLD) end if ! count dimensions for NCIO ndims = 0 if (Have_HorzVert .or. Have_HorzOnly) ndims = ndims + 2 if (Have_VLocationCenter) ndims = ndims + 1 if (Have_VLocationEdge) ndims = ndims + 1 if (Have_TileOnly .or. Have_TileTile) then ndims = ndims + 1 if (Have_TileTile) ndims = ndims + 1 end if ndims = ndims + n_unique_ungrid_dims ! add 1 for time ndims = ndims + 1 call MAPL_NCIOSet(ncioObj,filename=filename,nvars=nvars,ndims=ndims) if (arrdes%writers_comm/=MPI_COMM_NULL) then ! Create dimensions as needed if (Have_HorzVert .or. Have_HorzOnly) then if (arrdes%IM_WORLD*6 == arrdes%JM_WORLD) then isCubed = .true. else isCubed = .false. endif dlon = 360.d0/dble(arrdes%IM_WORLD) allocate(lon(arrdes%IM_WORLD)) do i =1, arrdes%IM_WORLD if (isCubed) then lon(i) = i else lon(i) = -180.d0 + (i-1)*dlon end if end do call MAPL_NCIOAddDim(ncioObj,"lon",arrdes%IM_World,londim,dimType=MAPL_NCIODimLon,varR8=lon,units="degrees_east",long_name="Longitude",rc=status) VERIFY_(STATUS) dlat = 180.d0/dble(arrdes%JM_WORLD-1) allocate(lat(arrdes%JM_WORLD)) do j =1, arrdes%JM_WORLD if (isCubed) then lat(j) = j else lat(j) = -90.d0 + (j-1)*dlat end if end do call MAPL_NCIOAddDim(ncioObj,"lat",arrdes%JM_World,latdim,dimType=MAPL_NCIODimLat,varR8=lat,units="degrees_north",long_name="Latitude",rc=status) VERIFY_(STATUS) endif if (Have_HorzVert .or. Have_VertOnly) then if (Have_VLocationCenter) then ! Level variable KM_World = arrdes%lm_World allocate(lev(KM_WORLD)) lev = (/(L, L=1,KM_WORLD)/) call MAPL_NCIOAddDim(ncioObj,'lev',KM_World,levdim,dimType=MAPL_NCIODimLev,varR8=lev,units="layer",long_name="sigma at layer midpoints", & standard_name="atmosphere_hybrid_sigma_pressure_coordinate",coordinate="eta",formulaTerms="ap: ak b: bk ps: ps p0: p00", & positive="down",rc=status) VERIFY_(STATUS) deallocate(lev) endif if (Have_VLocationEdge) then ! Edges variable KM_World = arrdes%lm_World allocate(edges(KM_WORLD+1)) edges = (/(L, L=1,KM_WORLD+1)/) call MAPL_NCIOAddDim(ncioObj,'edge',KM_World+1,edgedim,dimType=MAPL_NCIODimEdge,varR8=edges,units="level",long_name="sigma at layer edges", & standard_name="atmosphere_hybrid_sigma_pressure_coordinate",coordinate="eta",formulaTerms="ap: ak b: bk ps: ps p0: p00", & positive="down",rc=status) VERIFY_(STATUS) deallocate(edges) endif endif if (Have_TileOnly .or. Have_TileTile) then call MAPL_NCIOAddDim(ncioObj,'tile',arrdes%IM_World,tiledim,rc=status) VERIFY_(STATUS) if(Have_TileTile) then call MAPL_NCIOAddDim(ncioObj,'subtile',arrdes%JM_World,subtiledim,rc=status) VERIFY_(STATUS) endif endif if (ungrid_dim_max_size /=0) then do i=1,n_unique_ungrid_dims if (i < 10) then write(ungrid_dim_name, '(A11,I1)')"unknown_dim",i else if (i > 9 .and. i < 100) then write(ungrid_dim_name, '(A11,I2)')"unknown_dim",i else if (i > 99 .and. i < 1000) then write(ungrid_dim_name, '(A11,I3)')"unknown_dim",i end if call MAPL_NCIOAddDim(ncioObj,trim(ungrid_dim_name),unique_ungrid_dims(i),ungriddim(i),rc=status) VERIFY_(STATUS) end do endif ! Time variable call ESMF_ClockGet ( clock, currTime=CurrentTime ,rc=STATUS ) VERIFY_(STATUS) call ESMF_TimeGet ( CurrentTime, timeString=TimeString, rc=status ) VERIFY_(STATUS) TimeUnits = "minutes since "//timestring( 1: 10)//" "//timestring(12:19) call MAPL_NCIOAddDim(ncioObj,'time',1,tdim,dimType=MAPL_NCIODimTime,varR8=(/0.d0/),units=TimeUnits,rc=status) VERIFY_(STATUS) allocate(DIMS(1), stat=STATUS) VERIFY_(STATUS) allocate(LOCATION(1), stat=STATUS) VERIFY_(STATUS) do i=1,nVars call ESMF_FieldBundleGet(Bundle,fieldIndex=I, field=field, rc=status) VERIFY_(STATUS) call ESMF_AttributeGet(FIELD, NAME='LONG_NAME' , VALUE=LONG_NAME , rc=status) VERIFY_(STATUS) call ESMF_AttributeGet(FIELD, NAME='UNITS' , VALUE=UNITS , rc=status) VERIFY_(STATUS) call ESMF_AttributeGet(field, NAME='DIMS' , VALUE=DIMS(1) , rc=status) VERIFY_(STATUS) call ESMF_AttributeGet(field, NAME="VLOCATION" , VALUE=LOCATION(1) , RC=STATUS) if ( status /= 0 ) LOCATION(1) = MAPL_VLocationNone call ESMF_FieldGet (FIELD, ARRAY=array, name=FieldName, RC=STATUS) VERIFY_(STATUS) ! Check for old style aerosol names ind= index(FieldName, '::') if (ind> 0) then FieldName = trim(FieldName(ind+2:)) end if ! Extract some info from the array and define variables accordingly call ESMF_ArrayGet (array, typekind=tk, rank=arrayRank, RC=STATUS) VERIFY_(STATUS) !ALT if (tk .eq. ESMF_TYPEKIND_I1) DataType = NF_BYTE !ALT if (tk .eq. ESMF_TYPEKIND_I2) DataType = NF_SHORT if (tk .eq. ESMF_TYPEKIND_I4) DataType = NF_INT if (tk .eq. ESMF_TYPEKIND_R4) DataType = NF_FLOAT if (tk .eq. ESMF_TYPEKIND_R8) DataType = NF_DOUBLE if (arrayRank == 1) then if (DIMS(1)==MAPL_DimsVertOnly) then if (LOCATION(1) == MAPL_VLocationCenter) then call MAPL_NCIOAddVar(ncioObj,trim(fieldname),(/levdim/),DataType,units=units,long_name=long_name,rc=status) VERIFY_(STATUS) elseif(LOCATION(1) == MAPL_VLocationEdge) then call MAPL_NCIOAddVar(ncioObj,trim(fieldname),(/edgedim/),DataType,units=units,long_name=long_name,rc=status) VERIFY_(STATUS) else print *, 'ERROR: LOCATION not recognized for rank 1' ASSERT_(.false.) endif elseif(DIMS(1)==MAPL_DimsTileOnly) then call MAPL_NCIOAddVar(ncioObj,trim(fieldname),(/tiledim/),DataType,units=units,long_name=long_name,rc=status) VERIFY_(STATUS) elseif(DIMS(1)==MAPL_DimsNone) then found = .false. do j=1,n_unique_ungrid_dims if (ungrid_dims(i,1) == unique_ungrid_dims(j) ) then myungriddim1 = j found = .true. exit end if end do ASSERT_(found) call MAPL_NCIOAddVar(ncioObj,trim(fieldname),(/ungriddim(myungriddim1)/),DataType,units=units,long_name=long_name,rc=status) VERIFY_(STATUS) else print *, 'ERROR: blah blah blah' ASSERT_(.false.) endif else if(arrayRank == 2) then if (DIMS(1)==MAPL_DimsHorzOnly) then call MAPL_NCIOAddVar(ncioObj,trim(fieldname),(/londim,latdim/),DataType,units=units,long_name=long_name,rc=status) VERIFY_(STATUS) else if(DIMS(1)==MAPL_DimsTileTile) then call MAPL_NCIOAddVar(ncioObj,trim(fieldname),(/tiledim,subtiledim/),DataType,units=units,long_name=long_name,rc=status) VERIFY_(STATUS) elseif(DIMS(1)==MAPL_DimsTileOnly) then do j=1,n_unique_ungrid_dims if (ungrid_dims(i,1) == unique_ungrid_dims(j) ) then myungriddim1 = j exit end if end do call MAPL_NCIOAddVar(ncioObj,trim(fieldname),(/tiledim,ungriddim(myungriddim1)/),DataType,units=units,long_name=long_name,rc=status) VERIFY_(STATUS) else print *, 'ERROR: DIMS not recognized for rank 2 variable ',trim(FieldName), DIMS(1) ASSERT_(.false.) endif else if(arrayRank == 3) then if (DIMS(1)==MAPL_DimsHorzVert) then if (LOCATION(1) == MAPL_VLocationCenter) then call MAPL_NCIOAddVar(ncioObj,trim(fieldname),(/londim,latdim,levdim/),DataType,units=units,long_name=long_name,rc=status) VERIFY_(STATUS) else if(LOCATION(1) == MAPL_VLocationEdge) then call MAPL_NCIOAddVar(ncioObj,trim(fieldname),(/londim,latdim,edgedim/),DataType,units=units,long_name=long_name,rc=status) VERIFY_(STATUS) else print *, 'ERROR: LOCATION not recognized for rank 3' ASSERT_(.false.) endif else if(DIMS(1)==MAPL_DimsHorzOnly) then do j=1,n_unique_ungrid_dims if (ungrid_dims(i,1) == unique_ungrid_dims(j) ) then myungriddim1 = j exit end if end do call MAPL_NCIOAddVar(ncioObj,trim(fieldname),(/londim,latdim,ungriddim(myungriddim1)/),DataType,units=units,long_name=long_name,rc=status) VERIFY_(STATUS) else if (DIMS(1)==MAPL_DimsTileOnly) then do j=1,n_unique_ungrid_dims if (ungrid_dims(i,1) == unique_ungrid_dims(j) ) then myungriddim1 = j exit end if end do do j=1,n_unique_ungrid_dims if (ungrid_dims(i,2) == unique_ungrid_dims(j) ) then myungriddim2 = j exit end if end do call MAPL_NCIOAddVar(ncioObj,trim(fieldname),(/tiledim,ungriddim(myungriddim1),ungriddim(myungriddim2)/), & DataType,units=units,long_name=long_name,rc=status) VERIFY_(STATUS) else if(DIMS(1)/=MAPL_DimsHorzVert .and. DIMS(1)/=MAPL_DimsHorzOnly) then print *, 'ERROR: What else could it be' ASSERT_(.false.) endif else print *, 'ERROR: arrayRank ',arrayRank, ' not supported' ASSERT_(.false.) endif enddo if (ungrid_dim_max_size /= 0) then deallocate(unique_ungrid_dims) deallocate(ungriddim) end if deallocate(ungrid_dims) call MPI_Info_create(info,STATUS) VERIFY_(STATUS) call MPI_Info_set(info,"romio_cb_write", trim(arrdes%romio_cb_write),STATUS) VERIFY_(STATUS) call MPI_Info_set(info,"cb_buffer_size", trim(arrdes%cb_buffer_size),STATUS) VERIFY_(STATUS) call MAPL_NCIOSet( ncioObj,filename=filename ) if (arrdes%num_writers == 1) then call MAPL_NCIOCreateFile(ncioObj,rc=status) VERIFY_(STATUS) else call MAPL_NCIOCreateFile(ncioObj,comm=arrdes%writers_comm,info=info,rc=status) VERIFY_(STATUS) end if endif !am writer do l=1,nVars call ESMF_FieldBundleGet(bundle, fieldIndex=l, field=field, rc=status) VERIFY_(STATUS) call ESMF_FieldGet(field,name=FieldName,rc=status) VERIFY_(STATUS) ! Check for old style aerosol names ind= index(FieldName, '::') if (ind> 0) then FieldName = trim(FieldName(ind+2:)) end if if (.not.associated(MASK)) then call ESMF_AttributeGet(field, name='DIMS', value=MAPL_DIMS, rc=status) VERIFY_(STATUS) if (MAPL_DIMS == MAPL_DimsTileOnly .or. MAPL_DIMS == MAPL_DimsTileTile) then call ESMF_FieldGet (field, grid=grid, rc=status) VERIFY_(STATUS) call MAPL_TileMaskGet(grid, mask, rc=status) VERIFY_(STATUS) endif endif call MAPL_FieldWriteNCPar(ncioObj, fieldName, field, arrdes, HomePE=mask, rc=status) VERIFY_(STATUS) enddo if (arrdes%writers_comm/=MPI_COMM_NULL) then call MAPL_NCIOClose(ncioObj,destroy=.true.,rc=status) VERIFY_(STATUS) call MPI_Info_free(info, status) VERIFY_(STATUS) end if if(associated(MASK)) then DEALOC_(MASK) end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_BundleWriteNCPar subroutine MAPL_StateVarWriteNCPar(filename, STATE, ARRDES, CLOCK, NAME, forceWriteNoRestart, RC) character(len=*) , intent(IN ) :: filename type (ESMF_State) , intent(IN ) :: STATE type(ArrDescr) , intent(INOUT) :: ARRDES type(ESMF_Clock) , intent(IN ) :: CLOCK character(len=*), optional, intent(IN ) :: NAME logical, optional, intent(IN ) :: forceWriteNoRestart integer, optional, intent( OUT) :: RC ! Local vars type (ESMF_FieldBundle) :: bundle type (ESMF_Field) :: field integer :: status integer :: I, J, ITEMCOUNT, varid, ind logical :: FOUND type (ESMF_StateItem_Flag), pointer :: ITEMTYPES(:) character(len=ESMF_MAXSTR ), pointer :: ITEMNAMES(:) logical, pointer :: DOIT(:) character(len=ESMF_MAXSTR) :: IAm='MAPL_StateVarWriteNCPar' logical :: skipWriting integer :: RST, dna character(len=ESMF_MAXSTR) :: FieldName,BundleName,StateName logical :: forceWriteNoRestart_ type (ESMF_Field) :: new_field type (ESMF_FieldBundle) :: bundle_write integer :: nBundle integer :: attr call ESMF_StateGet(STATE,ITEMCOUNT=ITEMCOUNT,RC=STATUS) VERIFY_(STATUS) ASSERT_(ITEMCOUNT>0) allocate(ITEMNAMES(ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) allocate(ITEMTYPES(ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) allocate(DOIT (ITEMCOUNT),STAT=STATUS) VERIFY_(STATUS) call ESMF_StateGet(STATE,ITEMNAMELIST=ITEMNAMES,ITEMTYPELIST=ITEMTYPES,RC=STATUS) VERIFY_(STATUS) call ESMF_StateGet(STATE,name=StateName,RC=STATUS) VERIFY_(STATUS) forceWriteNoRestart_ = .false. if(present(forceWriteNoRestart)) then forceWriteNoRestart_ = forceWriteNoRestart endif if(present(NAME)) then DOIT = ITEMNAMES==NAME ASSERT_(count(DOIT)/=0) else DOIT = .true. endif bundle_write = ESMF_FieldBundleCreate(name=trim(StateName),rc=STATUS) VERIFY_(STATUS) call ESMF_FieldBundleSet(bundle_write,grid=arrdes%grid,rc=STATUS) VERIFY_(STATUS) DO I = 1, ITEMCOUNT IF (DOIT (I)) then IF (ITEMTYPES(I) == ESMF_StateItem_FieldBundle) then call ESMF_StateGet(state, itemnames(i), bundle, rc=status) VERIFY_(STATUS) skipWriting = .false. if (.not. forceWriteNoRestart_) then call ESMF_AttributeGet(bundle, name='RESTART', value=RST, rc=status) if (STATUS == ESMF_SUCCESS) then skipWriting = (RST == MAPL_RestartSkip) end if else skipWriting = .true. end if if (skipWriting) cycle call ESMF_FieldBundleGet(bundle, fieldCount=nBundle, rc=STATUS) VERIFY_(STATUS) call ESMF_FieldBundleGet(bundle, name=BundleName, rc=status) VERIFY_(STATUS) DO J = 1,nBundle call ESMF_FieldBundleGet(bundle, fieldIndex=J, field=field, rc=status) VERIFY_(STATUS) call ESMF_FieldGet(field,name=FieldName,rc=status) VERIFY_(STATUS) ! Tack on BundleName to distiguish duplicate FieldNames in different Bundles (PCHEM for instance) FieldName = trim(BundleName) //'_'// trim(FieldName) new_field = MAPL_FieldCreate(Field,FieldName,rc=status) VERIFY_(STATUS) call MAPL_FieldBundleAdd(bundle_write,new_field,rc=status) VERIFY_(STATUS) ENDDO ELSE IF (ITEMTYPES(I) == ESMF_StateItem_Field) THEN call ESMF_StateGet(state, itemnames(i), field, rc=status) VERIFY_(STATUS) skipWriting = .false. if (.not. forceWriteNoRestart_) then call ESMF_AttributeGet(field, name='RESTART', value=RST, rc=status) if (STATUS == ESMF_SUCCESS) then skipWriting = (RST == MAPL_RestartSkip) end if else skipWriting = .true. end if if (skipWriting) cycle call ESMF_AttributeGet(field, name='doNotAllocate', value=dna, rc=status) if (STATUS == ESMF_SUCCESS) then skipWriting = (dna /= 0) endif if (skipWriting) cycle call MAPL_FieldBundleAdd(bundle_write,field,rc=status) VERIFY_(STATUS) end IF END IF END DO deallocate(ITEMNAMES) deallocate(ITEMTYPES) deallocate(DOIT ) call MAPL_BundleWriteNCPar(Bundle_Write, arrdes, CLOCK, filename, rc=status) VERIFY_(STATUS) RETURN_(ESMF_SUCCESS) end subroutine MAPL_StateVarWriteNCPar function MAPL_NCIOOpen(filename,writing,comm,info,rc) result(NCIO) character(len=*), intent(in ) :: filename logical, optional, intent(in ) :: writing integer, optional, intent(inout) :: comm integer, optional, intent(inout) :: info integer, optional, intent(out ) :: rc type(MAPL_NCIO) :: NCIO character(len=ESMF_MAXSTR) :: Iam integer :: i, j, status, nVars ,nDims, ncid, varid integer :: vDims, totVars, dimNum, dimid integer :: StartDate,StartTime,nTimes character(len=ESMF_MAXSTR) :: TimeUnits integer :: nAttr integer :: vdimids(7) character(len=ESMF_MAXSTR) :: vname,ctemp character(len=ESMF_MAXSTR) :: dname, dunits logical :: foundDimName integer :: status_var,status_units,LM_World,Extra_Dim,ncDataType logical :: writing_ logical :: fparallel integer :: writeMode integer :: year, month, day, hour, min, sec Iam = "MAPL_NCIOOpen" if (present(comm)) then ASSERT_(present(info)) end if if (present(info)) then ASSERT_(present(comm)) end if if (present(writing)) then writing_=writing else writing_=.false. end if if (writing_) then writeMode = NF90_CLOBBER else writeMode = NF90_NOWRITE end if NCIO%filename = filename fparallel = .false. if (present(comm) .and. present(info) ) then status = nf90_open(filename,IOR(writeMode,NF90_MPIIO),ncid,comm=comm,info=info) fparallel = .true. else status = nf90_open(filename,writeMode,ncid) fparallel = .false. end if NCIO%fparallel=fparallel VERIFY_(STATUS) NCIO%ncid = ncid NCIO%isOpen = .true. VERIFY_(STATUS) if (writing_) then RETURN_(ESMF_SUCCESS) end if ! get numbers of dimensions and variables on file status = nf90_inquire(ncid, nDimensions = nDims, nVariables = totVars, nAttributes = nAttr) VERIFY_(STATUS) ! set number of dimensions NCIO%ncid = ncid NCIO%nDims = nDims !NCIO%nAttr = nAttr allocate(NCIO%dims(nDims)) ! add dimension info to NCIO object and determine the type do i=1,NCIO%nDims status = nf90_inquire_dimension(ncid,i,NCIO%dims(i)%name,NCIO%dims(i)%len) VERIFY_(STATUS) status = nf90_inq_dimid(ncid,trim(NCIO%dims(i)%name),NCIO%dims(i)%dimid) VERIFY_(STATUS) dname = NCIO%dims(i)%name status_var = NF90_inq_varid(ncid,dname,varid) if (status_var == nf90_NoErr) then status_units = NF90_get_att(NCIO%ncid,varid,"units",dUnits) NCIO%dims(i)%hasVar = .true. else dUnits=" " varId = -1 NCIO%dims(i)%hasVar = .false. end if NCIO%dims(i)%dimType = MAPL_NCIOIdentifyDim(dname,dunits) end do ! find non-dimension variables by checking whether variable has the same name as a dimension nVars = 0 do i=1,totVars foundDimName = .false. varid = i status = nf90_inquire_variable(ncid, varid, name = vname) VERIFY_(STATUS) do j=1, nDims if (trim(NCIO%dims(j)%name ) == trim(vname)) then foundDimName = .true. end if end do if (.not.foundDimName) then nVars = nVars + 1 end if end do ! allocate space now that we know how many non-dimension variables we have in file NCIO%nVars = nVars allocate(NCIO%vars(nVars)) ! now that we have allocated space get variable information, repeat nVars = 0 do i=1,totVars foundDimName = .false. varid = i status = nf90_inquire_variable(ncid, varid, name = vname) VERIFY_(STATUS) ! check if the variable is a dimension variable do j=1, nDims if (trim(NCIO%dims(j)%name ) == trim(vname)) then foundDimName = .true. NCIO%dims(j)%varid = varid status = nf90_inquire_variable(ncid,varid,xtype = NCIO%dims(j)%ncDataType) VERIFY_(STATUS) if (NCIO%dims(j)%ncDataType == NF90_FLOAT) then allocate(NCIO%dims(j)%dimPtrR4(NCIO%dims(j)%len),stat=status) VERIFY_(STATUS) status = NF90_Get_Var(ncid,varid,NCIO%dims(j)%dimPtrR4) VERIFY_(STATUS) else if (NCIO%dims(j)%ncDataType == NF90_DOUBLE) then allocate(NCIO%dims(j)%dimPtrR8(NCIO%dims(j)%len),stat=status) VERIFY_(STATUS) status = NF90_Get_Var(ncid,varid,NCIO%dims(j)%dimPtrR8) VERIFY_(STATUS) else if (NCIO%dims(j)%ncDataType == NF90_INT) then allocate(NCIO%dims(j)%dimPtrI4(NCIO%dims(j)%len),stat=status) VERIFY_(STATUS) status = NF90_Get_Var(ncid,varid,NCIO%dims(j)%dimPtrI4) VERIFY_(STATUS) end if if (NCIO%dims(j)%dimType == MAPL_NCIODimLon .or. NCIO%dims(j)%dimType == MAPL_NCIODimLat) then status = nf90_get_att(ncid,varid,"units",ctemp) if (status == NF90_NoErr) then NCIO%dims(j)%units = ctemp end if status = nf90_get_att(ncid,varid,"long_name",ctemp) if (status == NF90_NoErr) then NCIO%dims(j)%long_name = ctemp end if else if (NCIO%dims(j)%dimType == MAPL_NCIODimLev .or. NCIO%dims(j)%dimType == MAPL_NCIODimEdge) then status = nf90_get_att(ncid,varid,"units",ctemp) if (status == NF90_NoErr) then NCIO%dims(j)%units = ctemp end if status = nf90_get_att(ncid,varid,"long_name",ctemp) if (status == NF90_NoErr) then NCIO%dims(j)%long_name = ctemp end if status = nf90_get_att(ncid,varid,"standard_name",ctemp) if (status == NF90_NoErr) then NCIO%dims(j)%standard_name = ctemp end if status = nf90_get_att(ncid,varid,"coordinate",ctemp) if (status == NF90_NoErr) then NCIO%dims(j)%coordinate = ctemp end if status = nf90_get_att(ncid,varid,"formulaTerms",ctemp) if (status == NF90_NoErr) then NCIO%dims(j)%formulaTerms = ctemp end if status = nf90_get_att(ncid,varid,"positive",ctemp) if (status == NF90_NoErr) then NCIO%dims(j)%positive = ctemp end if else if (NCIO%dims(j)%dimType == MAPL_NCIODimTime) then status = nf90_get_att(ncid,varid,"units",ctemp) if (status == NF90_NoErr) then NCIO%dims(j)%units = ctemp call MAPL_NCIOParseTimeUnits(ctemp,year,month,day,hour,min,sec,status) NCIO%date = year*10000 + month*100 + day NCIO%time = hour*10000 + min*100 + sec end if status = nf90_get_att(ncid,varid,"time_increment",sec) if (status == NF90_NoErr) then NCIO%time_increment = sec end if end if end if end do ! if it is not a dimension variable then get the info if (.not.foundDimName) then nVars = nVars + 1 NCIO%vars(nVars)%varid = i status = nf90_inquire_variable(ncid, varid, name = vname, xtype = ncDataType, ndims = vDims, dimids = vDimids) VERIFY_(STATUS) NCIO%vars(nVars)%name = trim(vname) NCIO%vars(nVars)%varid = varid NCIO%vars(nVars)%ndims = vDims NCIO%vars(nVars)%ncDataType = ncDataType allocate(NCIO%vars(nVars)%dimids(vDims)) do j=1,vDims NCIO%vars(nVars)%dimids(j)=vDimids(j) end do ! units and long name would be nice to make this more general status = nf90_get_att(ncid,varid,"units",ctemp) if (status == NF90_NoErr) then NCIO%vars(nVars)%units = ctemp end if status = nf90_get_att(ncid,varid,"long_name",ctemp) if (status == NF90_NoErr) then NCIO%vars(nVars)%long_name = ctemp end if end if end do ! now find number of non-time dimension of each non-dimension variable do i=1,NCIO%nVars NCIO%vars(i)%spatialDims = NCIO%vars(i)%ndims do j=1,NCIO%vars(i)%ndims dimid = NCIO%vars(i)%dimids(j) dname = NCIO%dims(dimid)%Name dunits = " " dimNum = MAPL_NCIOIdentifyDim(dname,dunits) if (dimNum == MAPL_NCIODimTime) then NCIO%vars(i)%spatialDims = NCIO%vars(i)%SpatialDims - 1 exit end if end do end do call MAPL_NCIOGetGridType(NCIO,rc=status) RETURN_(ESMF_SUCCESS) end function MAPL_NCIOOpen integer function MAPL_NCIOIdentifyDim(dimName,dimUnits) character(len=*), intent(in) :: dimName character(len=*), intent(in) :: dimUnits if (TRIM(dimUnits) .EQ. "hPa" ) then MAPL_NCIOIdentifyDim = MAPL_NCIODimLev return end if if ( trim(dimName) .eq. "time" ) then MAPL_NCIOIdentifyDim = MAPL_NCIODimTime return end if if (TRIM(dimUnits) .EQ. "degrees_east" .OR. & trim(dimName) .eq. "longitude" .OR. & trim(dimName) .eq. "lon" ) then MAPL_NCIOIdentifyDim = MAPL_NCIODimLon else if (TRIM(dimUnits) .EQ. "degrees_north" ) then MAPL_NCIOIdentifyDim = MAPL_NCIODimLat else if ( trim(dimName) .eq. "latitude" .OR. & trim(dimName) .eq. "lat" ) then MAPL_NCIOIdentifyDim = MAPL_NCIODimLat else if (INDEX(dimName,"lev") .NE. 0 .OR. & INDEX(dimName,"Height") .NE. 0) then MAPL_NCIOIdentifyDim = MAPL_NCIODimLev else if (INDEX(dimName,"edge") /= 0 .OR. INDEX(dimName,"EDGE") /= 0) then MAPL_NCIOIdentifyDim = MAPL_NCIODimEdge else if (TRIM(dimUnits) .EQ. "mb" .OR. & TRIM(dimUnits) .EQ. "millibar" .OR. & TRIM(dimUnits) .EQ. "sigma_level" .OR. & TRIM(dimUnits) .EQ. "hPa") then MAPL_NCIOIdentifyDim = MAPL_NCIODimLev else if (trim(dimName) .eq. "TIME" .OR. & trim(dimName) .eq. "TIME:EOSGRID" .OR. & trim(dimName) .eq. "time" .OR. & trim(dimName) .eq. "Time") then MAPL_NCIOIdentifyDim = MAPL_NCIODimTime else if (dimName(1:11) .eq. "unknown_dim") then MAPL_NCIOIdentifyDim = MAPL_NCIODimExtraDim else if (trim(dimName) .eq. "tile") then MAPL_NCIOIdentifyDim = MAPL_NCIODimTile else if (trim(dimName) .eq. "subtile") then MAPL_NCIOIdentifyDim = MAPL_NCIODimSubTile else MAPL_NCIOIdentifyDim = MAPL_NCIODimUnknown endif end function MAPL_NCIOIdentifyDim subroutine MAPL_NCIOGetGridType(NCIO,rc) type(MAPL_NCIO), intent(inout) :: NCIO integer, optional, intent(out ) :: rc integer :: gridType integer :: i,dim_Type,lonSize,latSize,latVarid,lonVarid,tileSize,tileId logical :: foundLon,foundLat,foundTile foundLon = .false. foundLat = .false. foundTile = .false. do i =1,NCIO%nDims dim_Type = NCIO%dims(i)%dimType if (dim_Type == MAPL_NCIODimLon) then foundLon = .true. lonSize = NCIO%Dims(i)%len LonVarId = i end if if (dim_Type == MAPL_NCIODimLat) then foundLat = .true. latSize = NCIO%Dims(i)%len LatVarId = i end if if (dim_Type == MAPL_NCIODimTile) then foundTile = .true. end if end do if (foundTile) then gridType = MAPL_NCIOGridTile else if (foundLat .and. foundLon) then if (latSize == 6*lonSize) then gridType = MAPL_NCIOGridCS else gridType = MAPL_NCIOGridLL end if else gridType = MAPL_NCIOGridUnknown endif NCIO%gridType = gridType rc = 0 end subroutine MAPL_NCIOGetGridType subroutine MAPL_NCIOClose(NCIO,destroy,rc) type(MAPL_NCIO), intent(inout) :: NCIO logical, optional, intent(in ) :: destroy integer, optional, intent(out ) :: rc integer :: status character(len=ESMF_MAXSTR) :: Iam integer :: i Iam = "MAPL_NCIOClose" if (NCIO%isOpen) then status = NF90_Close(NCIO%ncid) NCIO%isOpen = .false. VERIFY_(STATUS) end if if (present(destroy)) then do i=1,NCIO%ndims if (allocated(NCIO%dims(i)%dimPtrR4)) deallocate(NCIO%dims(i)%dimPtrR4) if (allocated(NCIO%dims(i)%dimPtrR8)) deallocate(NCIO%dims(i)%dimPtrR8) enddo do i=1,NCIO%nvars if (allocated(NCIO%vars(i)%dimids)) deallocate(NCIO%vars(i)%dimids) enddo deallocate(NCIO%dims) deallocate(NCIO%vars) end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_NCIOClose subroutine MAPL_NCIOCreateFile(NCIO,comm,info,rc) type(MAPL_NCIO), intent(inout) :: NCIO integer, optional, intent(inout) :: comm integer, optional, intent(inout) :: info integer, optional, intent(out ) :: rc integer :: status character(len=ESMF_MAXSTR) :: Iam integer :: i,j,tindex integer :: year, month, day, hour, min, sec, date, time integer, allocatable :: dimids(:) Iam = "MAPL_NCIOCreateFile" if (present(comm)) then ASSERT_(present(info)) end if if (present(info)) then ASSERT_(present(comm)) end if if (.not.NCIO%isOpen) then if (present(comm) .and. present(info)) then status = NF90_Create(NCIO%filename,IOR(NF90_NETCDF4,IOR(NF90_CLOBBER,NF90_MPIIO)), & NCIO%ncid,comm=comm,info=info) VERIFY_(STATUS) else status = NF90_Create(NCIO%filename,IOR(NF90_NETCDF4,NF90_CLOBBER),NCIO%ncid) VERIFY_(STATUS) end if NCIO%isOpen=.true. end if ! define dimensions do i=1,NCIO%nDims status = nf90_def_dim(NCIO%ncid,NCIO%dims(i)%name,NCIO%dims(i)%len,NCIO%dims(i)%dimid) VERIFY_(STATUS) enddo ! define any dimension variables, lat, lon, etc do i=1,NCIO%nDims if (NCIO%dims(i)%hasVar) then status = nf90_def_var(NCIO%ncid,NCIO%dims(i)%name,NCIO%dims(i)%ncDataType, & (/NCIO%dims(i)%dimid/),NCIO%dims(i)%varid) VERIFY_(STATUS) if (NCIO%dims(i)%dimType == MAPL_NCIODimLon) then status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"units",NCIO%dims(i)%units) VERIFY_(STATUS) status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"long_name",NCIO%dims(i)%long_name) VERIFY_(STATUS) else if (NCIO%dims(i)%dimType == MAPL_NCIODimLat) then status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"units",NCIO%dims(i)%units) VERIFY_(STATUS) status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"long_name",NCIO%dims(i)%long_name) VERIFY_(STATUS) else if (NCIO%dims(i)%dimType == MAPL_NCIODimLev .or. NCIO%dims(i)%dimType == MAPL_NCIODimEdge) then status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"units",NCIO%dims(i)%units) VERIFY_(STATUS) status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"long_name",NCIO%dims(i)%long_name) VERIFY_(STATUS) status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"standard_name",NCIO%dims(i)%standard_name) VERIFY_(STATUS) status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"coordinate",NCIO%dims(i)%coordinate) VERIFY_(STATUS) status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"positive",NCIO%dims(i)%positive) VERIFY_(STATUS) status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"formulaTerms",NCIO%dims(i)%formulaTerms) VERIFY_(STATUS) else if (NCIO%dims(i)%dimType == MAPL_NCIODimTime) then status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"units",NCIO%dims(i)%units) VERIFY_(STATUS) status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"long_name","time") VERIFY_(STATUS) call MAPL_NCIOParseTimeUnits(trim(NCIO%dims(i)%units),year,month,day,hour,min,sec,status) VERIFY_(STATUS) date = year*10000 + month*100 + day time = hour*10000 + min*100 + sec status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"begin_date",date) VERIFY_(STATUS) status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"begin_time",time) VERIFY_(STATUS) if (NCIO%time_increment /= -999) then status = nf90_put_att(NCIO%ncid,NCIO%dims(i)%varid,"time_increment",NCIO%time_increment) VERIFY_(STATUS) end if end if end if enddo ! define regular, non-dimension variables do i=1,NCIO%nVars allocate(dimids(NCIO%vars(i)%ndims),stat=status) VERIFY_(STATUS) do j=1,NCIO%vars(i)%ndims tindex = NCIO%vars(i)%dimids(j) dimids(j) = NCIO%dims(tindex)%dimid enddo status = nf90_def_var(NCIO%ncid,NCIO%vars(i)%name,NCIO%vars(i)%ncDataType, & dimids,NCIO%vars(i)%VarId,contiguous=.true.) VERIFY_(STATUS) status = nf90_def_var_fill(NCIO%ncid,NCIO%vars(i)%VarId,NF90_NOFILL,0) VERIFY_(STATUS) deallocate(dimids) status = nf90_put_att(NCIO%ncid,NCIO%vars(i)%VarId,"long_name",NCIO%vars(i)%long_name) VERIFY_(STATUS) status = nf90_put_att(NCIO%ncid,NCIO%vars(i)%VarId,"units",NCIO%vars(i)%units) VERIFY_(STATUS) enddo status = NF90_ENDDEF(NCIO%ncid) VERIFY_(STATUS) ! fill in lats/lons do i=1,NCIO%nDims if (NCIO%dims(i)%hasVar) then if (NCIO%dims(i)%ncDataType == NF90_FLOAT) then status = nf90_put_var(NCIO%ncid,NCIO%dims(i)%varid,NCIO%dims(i)%dimPtrR4) VERIFY_(STATUS) else if (NCIO%dims(i)%ncDataType == NF90_DOUBLE) then status = nf90_put_var(NCIO%ncid,NCIO%dims(i)%varid,NCIO%dims(i)%dimPtrR8) VERIFY_(STATUS) else if (NCIO%dims(i)%ncDataType == NF90_INT) then status = nf90_put_var(NCIO%ncid,NCIO%dims(i)%varid,NCIO%dims(i)%dimPtrI4) VERIFY_(STATUS) end if end if enddo RETURN_(ESMF_SUCCESS) end subroutine MAPL_NCIOCreateFile subroutine MAPL_NCIOChangeRes(NCIOOld,NCIONew,tileSize,latSize,lonSize,levSize,rc) type(MAPL_NCIO), intent(inout) :: NCIOOld type(MAPL_NCIO), intent(inout) :: NCIONew integer, optional, intent(in ) :: tileSize integer, optional, intent(in ) :: latSize integer, optional, intent(in ) :: lonSize integer, optional, intent(in ) :: levSize integer, optional, intent(out ) :: rc integer :: status character(len=ESMF_MAXSTR) :: Iam logical :: presentTile,presentLat,presentLon,presentLev integer :: i,tileDim,lonDim,latDim,levDim,EdgeDim real(kind=ESMF_KIND_R4) :: flon,flat real(kind=ESMF_KIND_R8) :: dlon,dlat Iam = "MAPL_NCIOChangeRes" NCIONew = NCIOOld NCIONew%isOpen=.false. presentTile = present(tileSize) presentLon = present(lonSize) presentLat = present(latSize) presentLev = present(levSize) if (presentLon .and. presentLat) then if (latSize == 6*lonSize) then NCIONew%gridType = MAPL_NCIOGridCS else NCIONew%gridTYpe = MAPL_NCIOGridLL end if end if if (NCIONew%gridType == MAPL_NCIOGridTile) then ASSERT_(presentTile) do i=1,NCIONew%ndims if (NCIONew%dims(i)%dimType == MAPL_NCIODimTile) then tileDim = i exit end if end do NCIONew%dims(tileDim)%len = tileSize else if (NCIONew%gridType == MAPL_NCIOGridLL .or. NCIONew%gridType == MAPL_NCIOGridCS) then ASSERT_(presentLon) ASSERT_(presentLat) do i=1,NCIONew%ndims if (NCIONew%dims(i)%dimType == MAPL_NCIODimLon) then lonDim = i exit end if end do do i=1,NCIONew%ndims if (NCIONew%dims(i)%dimType == MAPL_NCIODimLat) then latDim = i exit end if end do levDim = -1 do i=1,NCIONew%ndims if (NCIONew%dims(i)%dimType == MAPL_NCIODimLev) then levDim = i exit end if end do edgeDim = -1 do i=1,NCIONew%ndims if (NCIONew%dims(i)%dimType == MAPL_NCIODimEdge) then edgeDim = i exit end if end do NCIONew%dims(lonDim)%len = lonSize NCIONew%dims(latDim)%len = latSize if (NCIONew%dims(lonDim)%ncDataType == NF90_FLOAT) then deallocate(NCIONew%dims(lonDim)%dimPtrR4,stat=status) VERIFY_(status) allocate(NCIONew%dims(lonDim)%dimPtrR4(lonSize),stat=status) VERIFY_(status) if (NCIONew%gridtype == MAPL_NCIOGridCS) then do i=1,lonSize NCIONew%dims(lonDim)%dimPtrR4(i)=i enddo else flon = 360.0/NCIONew%dims(lonDim)%len do i=1,lonSize NCIONew%dims(lonDim)%dimPtrR4(i)=-180.0+(i-1)*flon enddo end if else if (NCIONew%dims(lonDim)%ncDataType == NF90_DOUBLE) then deallocate(NCIONew%dims(lonDim)%dimPtrR8,stat=status) VERIFY_(status) allocate(NCIONew%dims(lonDim)%dimPtrR8(lonSize),stat=status) VERIFY_(status) if (NCIONew%gridtype == MAPL_NCIOGridCS) then do i=1,lonSize NCIONew%dims(lonDim)%dimPtrR8(i)=i enddo else dlon = 360.d0/NCIONew%dims(lonDim)%len do i=1,lonSize NCIONew%dims(lonDim)%dimPtrR8(i)=-180.d0+(i-1)*dlon enddo end if endif if (NCIONew%dims(latDim)%ncDataType == NF90_FLOAT) then deallocate(NCIONew%dims(latDim)%dimPtrR4,stat=status) VERIFY_(status) allocate(NCIONew%dims(latDim)%dimPtrR4(latSize),stat=status) VERIFY_(status) if (NCIONew%gridtype == MAPL_NCIOGridCS) then do i=1,latSize NCIONew%dims(latDim)%dimPtrR4(i)=i enddo else flat = 180.d0/(NCIONew%dims(latDim)%len-1) do i=1,latSize NCIONew%dims(latDim)%dimPtrR4(i)=-90.0+(i-1)*flat enddo end if else if (NCIONew%dims(latDim)%ncDataType == NF90_DOUBLE) then deallocate(NCIONew%dims(latDim)%dimPtrR8,stat=status) VERIFY_(status) allocate(NCIONew%dims(latDim)%dimPtrR8(latSize),stat=status) VERIFY_(status) if (NCIONew%gridtype == MAPL_NCIOGridCS) then do i=1,latSize NCIONew%dims(latDim)%dimPtrR8(i)=i enddo else dlat = 180.d0/(NCIONew%dims(latDim)%len-1) do i=1,latSize NCIONew%dims(latDim)%dimPtrR8(i)=-90.d0+(i-1)*dlat enddo end if endif if (presentLev) then if (levDim /= -1) then NCIONew%dims(levDim)%len = levSize if (NCIONew%dims(levDim)%ncDataType == NF90_FLOAT) then deallocate(NCIONew%dims(levDim)%dimPtrR4,stat=status) VERIFY_(status) allocate(NCIONew%dims(levDim)%dimPtrR4(levSize),stat=status) VERIFY_(status) do i=1,levSize NCIONew%dims(levDim)%dimPtrR4(i)=i enddo else if (NCIONew%dims(levDim)%ncDataType == NF90_DOUBLE) then deallocate(NCIONew%dims(levDim)%dimPtrR8,stat=status) VERIFY_(status) allocate(NCIONew%dims(levDim)%dimPtrR8(levSize),stat=status) VERIFY_(status) do i=1,levSize NCIONew%dims(levDim)%dimPtrR8(i)=i enddo end if end if if (edgeDim /= -1) then NCIONew%dims(EdgeDim)%len = levSize+1 if (NCIONew%dims(EdgeDim)%ncDataType == NF90_FLOAT) then deallocate(NCIONew%dims(edgeDim)%dimPtrR4,stat=status) VERIFY_(status) allocate(NCIONew%dims(edgeDim)%dimPtrR4(levSize+1),stat=status) VERIFY_(status) do i=1,levSize+1 NCIONew%dims(edgeDim)%dimPtrR4(i)=i enddo else if (NCIONew%dims(edgeDim)%ncDataType == NF90_DOUBLE) then deallocate(NCIONew%dims(edgeDim)%dimPtrR8,stat=status) VERIFY_(status) allocate(NCIONew%dims(edgeDim)%dimPtrR8(levSize+1),stat=status) VERIFY_(status) do i=1,levSize+1 NCIONew%dims(edgeDim)%dimPtrR8(i)=i enddo end if end if end if else write(*,*)"No grid found, do not know what rescale" end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_NCIOChangeRes subroutine MAPL_NCIOSet(NCIO,filename,ncid,nvars,ndims,overwriteVars,rc) type(MAPL_NCIO), intent(inout) :: NCIO character(len=*), optional, intent(in ) :: filename integer, optional, intent(in ) :: ncid integer, optional, intent(in ) :: nvars integer, optional, intent(in ) :: ndims logical, optional, intent(in ) :: overwriteVars integer, optional, intent(out ) :: rc integer :: status character(len=ESMF_MAXSTR) :: Iam integer :: i Iam = "MAPL_NCIOSet" if (present(filename)) then NCIO%filename = filename end if if (present(ncid)) then NCIO%isOpen = .true. NCIO%ncid = ncid end if if (present(overWriteVars)) then ASSERT_(present(nVars)) ASSERT_(allocated(NCIO%vars)) do i=1,NCIO%nVars deallocate(NCIO%vars(i)%dimids,stat=status) VERIFY_(STATUS) enddo deallocate(NCIO%vars,stat=status) end if if (present(nvars)) then NCIO%nVars = nVars allocate(NCIO%vars(nVars),stat=status) VERIFY_(STATUS) do i=1,nVars NCIO%vars(i)%name="null" enddo end if if (present(ndims)) then NCIO%nDims = nDims allocate(NCIO%dims(nDims),stat=status) VERIFY_(STATUS) do i=1,nDims NCIO%dims(i)%name="null" enddo end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_NCIOSet subroutine MAPL_NCIOAddDim(NCIO,name,len,dimid,dimType,varR4,varR8,units,long_name,standard_name, & coordinate,formulaTerms,positive,rc) type(MAPL_NCIO), intent(inout) :: NCIO character(len=*), intent(in ) :: name integer, intent(in ) :: len integer, intent(out ) :: dimid integer, optional, intent(in ) :: dimType real(kind=ESMF_KIND_R4), optional, intent(in ) :: varR4(:) real(kind=ESMF_KIND_R8), optional, intent(in ) :: varR8(:) character(len=*), optional, intent(in ) :: units character(len=*), optional, intent(in ) :: long_name character(len=*), optional, intent(in ) :: standard_name character(len=*), optional, intent(in ) :: coordinate character(len=*), optional, intent(in ) :: formulaTerms character(len=*), optional, intent(in ) :: positive integer, optional, intent(out ) :: rc integer :: status character(len=ESMF_MAXSTR) :: Iam integer :: i, idx Iam = "MAPL_NCIOAddDim" ! find free dimension idx = -1 do i=1,NCIO%nDims if (trim(NCIO%dims(i)%name) == "null" ) then idx = i exit end if enddo ASSERT_(idx /= -1) NCIO%dims(idx)%name = name NCIO%dims(idx)%len = len dimid = idx if (present(dimType)) then NCIO%dims(idx)%dimType=dimType else NCIO%dims(idx)%dimType=MAPL_NCIODimUnknown end if if (present(varR4)) then allocate(NCIO%dims(idx)%dimPtrR4(len),stat=status) VERIFY_(STATUS) NCIO%dims(idx)%dimPtrR4 = varR4 NCIO%dims(idx)%ncDataType = NF90_FLOAT NCIO%dims(idx)%hasVar = .true. else if (present(varR8)) then allocate(NCIO%dims(idx)%dimPtrR8(len),stat=status) VERIFY_(STATUS) NCIO%dims(idx)%dimPtrR8 = varR8 NCIO%dims(idx)%ncDataType = NF90_DOUBLE NCIO%dims(idx)%hasVar = .true. else NCIO%dims(idx)%hasVar = .false. end if if (present(units)) then NCIO%dims(idx)%units = units end if if (present(long_name)) then NCIO%dims(idx)%long_name = long_name end if if (present(standard_name)) then NCIO%dims(idx)%standard_name = standard_name end if if (present(coordinate)) then NCIO%dims(idx)%coordinate = coordinate end if if (present(formulaTerms)) then NCIO%dims(idx)%formulaTerms = formulaTerms end if if (present(positive)) then NCIO%dims(idx)%positive = positive end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_NCIOAddDim subroutine MAPL_NCIOAddVar(NCIO,name,dimids,dataType,long_name,units,rc) type(MAPL_NCIO), intent(inout) :: NCIO character(len=*), intent(in ) :: name integer, intent(in ) :: dimids(:) integer, intent(in ) :: dataType character(len=*), optional, intent(in ) :: units character(len=*), optional, intent(in ) :: long_name integer, optional, intent(out ) :: rc integer :: status character(len=ESMF_MAXSTR) :: Iam integer :: i,idx Iam = "MAPL_NCIOAddVar" ! find variable that has not been used yet idx = -1 do i=1,NCIO%nVars if (trim(NCIO%vars(i)%name) == "null" ) then idx = i exit end if enddo ASSERT_(idx /= -1) NCIO%vars(idx)%name=name allocate(NCIO%vars(idx)%dimids(size(dimids)),stat=status) VERIFY_(STATUS) NCIO%vars(idx)%ndims = size(dimids) NCIO%vars(idx)%dimids=dimids NCIO%vars(idx)%ncDataType = dataType if (present(units)) then NCIO%vars(idx)%units = units end if if (present(long_name)) then NCIO%vars(idx)%long_name = long_name end if RETURN_(ESMF_SUCCESS) end subroutine MAPL_NCIOAddVar subroutine MAPL_NCIOGetDimSizes(NCIO,lon,lat,lev,edges,tile,nvars,date,time,slices,lonid,latid,levid,edgeid,rc) type(MAPL_NCIO), intent(inout) :: NCIO integer, optional, intent(out ) :: lon integer, optional, intent(out ) :: lat integer, optional, intent(out ) :: lev integer, optional, intent(out ) :: edges integer, optional, intent(out ) :: tile integer, optional, intent(out ) :: nvars integer, optional, intent(out ) :: date integer, optional, intent(out ) :: time integer, optional, intent(inout) :: slices integer, optional, intent(out ) :: lonid integer, optional, intent(out ) :: latid integer, optional, intent(out ) :: levid integer, optional, intent(out ) :: edgeid integer, optional, intent(out ) :: rc integer :: status character(len=ESMF_MAXSTR) :: Iam integer :: i,j,vertDim logical :: found,foundLev integer :: nDims,dimSizes(4),dimType(4) Iam = "MAPL_NCIOGetDimSizes" if (present(slices)) then slices = 0 if (NCIO%gridType == MAPL_NCIOGridLL .or. NCIO%gridType == MAPL_NCIOGridCS) then do i=1,NCIO%nVars call MAPL_NCIOVarGetDims(NCIO,NCIO%vars(i)%name,nDims,dimSizes,dimType) foundLev = .false. do j=1,nDims if (dimType(j) == MAPL_NCIODimLev .or. dimType(j) == MAPL_NCIODimEdge) then foundLev = .true. vertDim = j exit end if enddo if (foundLev) then slices = slices + dimSizes(vertDim) else slices = slices + 1 end if enddo end if end if if (present(lon)) then found = .false. do i=1,NCIO%ndims if (NCIO%dims(i)%dimType == MAPL_NCIODimLon) then lon = NCIO%dims(i)%len found = .true. exit end if enddo if (.not.found) then RETURN_(ESMF_FAILURE) end if endif if (present(lat)) then found = .false. do i=1,NCIO%ndims if (NCIO%dims(i)%dimType == MAPL_NCIODimLat) then lat = NCIO%dims(i)%len found = .true. exit end if enddo if (.not.found) then RETURN_(ESMF_FAILURE) end if endif if (present(lev)) then found = .false. do i=1,NCIO%ndims if (NCIO%dims(i)%dimType == MAPL_NCIODimLev) then lev = NCIO%dims(i)%len found = .true. exit end if enddo if (.not.found) then RETURN_(ESMF_FAILURE) end if endif if (present(edges)) then found = .false. do i=1,NCIO%ndims if (NCIO%dims(i)%dimType == MAPL_NCIODimEdge) then edges = NCIO%dims(i)%len found = .true. exit end if enddo if (.not.found) then RETURN_(ESMF_FAILURE) end if endif if (present(tile)) then found = .false. do i=1,NCIO%ndims if (NCIO%dims(i)%dimType == MAPL_NCIODimTile) then tile = NCIO%dims(i)%len found = .true. exit end if enddo if (.not.found) then RETURN_(ESMF_FAILURE) end if endif if (present(nvars)) then nvars = NCIO%nvars end if if (present(date)) then date = NCIO%date end if if (present(time)) then time = NCIO%time end if if (present(lonid)) then found = .false. do i=1,NCIO%ndims if (NCIO%dims(i)%dimType == MAPL_NCIODimLon) then lonid = i found = .true. exit end if enddo if (.not.found) then RETURN_(ESMF_FAILURE) end if endif if (present(latid)) then found = .false. do i=1,NCIO%ndims if (NCIO%dims(i)%dimType == MAPL_NCIODimLat) then latid = i found = .true. exit end if enddo if (.not.found) then RETURN_(ESMF_FAILURE) end if endif if (present(levid)) then found = .false. do i=1,NCIO%ndims if (NCIO%dims(i)%dimType == MAPL_NCIODimLev) then levid = i found = .true. exit end if enddo if (.not.found) then RETURN_(ESMF_FAILURE) end if endif if (present(edgeid)) then found = .false. do i=1,NCIO%ndims if (NCIO%dims(i)%dimType == MAPL_NCIODimEdge) then edgeid = i found = .true. exit end if enddo if (.not.found) then RETURN_(ESMF_FAILURE) end if endif end subroutine MAPL_NCIOGetDimSizes subroutine MAPL_NCIOVarGetDims(NCIO,name,ndims,dimSize,dimType,nSpatialDims,rc) type(MAPL_NCIO), intent(inout) :: NCIO character(len=*), intent(in ) :: name integer, intent(out ) :: ndims integer, intent(out ) :: dimSize(:) integer, optional, intent(out) :: dimType(:) integer, optional, intent(out) :: nSpatialDims integer, optional, intent(out ) :: rc integer :: status character(len=ESMF_MAXSTR) :: Iam integer :: i,j,dimid logical :: found Iam = "MAPL_NCIOVarGetDims" dimSize = 0 found = .false. do i=1,NCIO%nVars if (trim(name) == trim(NCIO%vars(i)%name)) then ndims = NCIO%vars(i)%ndims ASSERT_(size(dimSize) >= ndims) if (present(dimType)) then ASSERT_(size(dimType) >= ndims) end if do j=1,NCIO%vars(i)%ndims dimid = NCIO%vars(i)%dimids(j) dimSize(j) = NCIO%dims(dimid)%len if (present(dimType)) dimType(j) = NCIO%dims(dimid)%dimType enddo if (present(nSpatialDims)) nSpatialDims = NCIO%vars(i)%spatialDims found = .true. exit end if enddo if (found) then RETURN_(ESMF_SUCCESS) else RETURN_(ESMF_FAILURE) end if end subroutine MAPL_NCIOVarGetDims subroutine MAPL_NCIOGetFileType(filename,filetype,rc) implicit none ! Arguments !---------- character(len=*), intent(IN ) :: filename integer, intent(INOUT) :: filetype integer, optional, intent( OUT) :: RC ! ErrLog variables !----------------- integer :: STATUS character(len=128) :: Iam="GuessFileType" character(len=1) :: word(4) character(len=1) :: TwoWords(8) integer, parameter :: hdf5(8) = (/137, 72, 68, 70, 13, 10, 26, 10 /) integer :: irec integer :: unit integer :: i, nx, cwrd logical :: typehdf5 UNIT = 10 INQUIRE(IOLENGTH=IREC) WORD open (UNIT=UNIT, FILE=FILENAME, FORM='unformatted', ACCESS='DIRECT', RECL=IREC, IOSTAT=status) VERIFY_(STATUS) ! Read first 8 characters and compare with HDF5 signature read (UNIT, REC=1, ERR=100) TwoWords(1:4) read (UNIT, REC=2, ERR=100) TwoWords(5:8) close(UNIT) typehdf5 = .true. filetype = -1 ! Unknown do i = 1, 8 if (iachar(TwoWords(i)) /= hdf5(i)) then typehdf5 = .false. exit end if end do if (typehdf5) then filetype = 0 ! HDF5 RETURN_(ESMF_SUCCESS) end if ! Attempt to identify as fortran binary cwrd = transfer(TwoWords(1:4), irec) ! check if divisible by 4 irec = cwrd/4 filetype = irec if (cwrd /= 4*irec) then RETURN_(ESMF_FAILURE) end if filetype = -1 RETURN_(ESMF_SUCCESS) 100 continue RETURN_(ESMF_FAILURE) end subroutine MAPL_NCIOGetFileType subroutine MAPL_NCIOGetVarName(ncioObj,idx,name,rc) type(MAPL_NCIO), intent(in ) :: ncioObj integer, intent(in ) :: idx character(len=*), intent(out ) :: name integer, optional, intent(out ) :: rc integer :: varid character(len=ESMF_MAXSTR) :: Iam integer :: status integer :: i Iam = "MAPL_NCIOGetVarName" ASSERT_(idx <= ncioObj%nVars) name = ncioObj%Vars(idx)%name RETURN_(ESMF_SUCCESS) end subroutine MAPL_NCIOGetVarName function MAPL_NCIOGetVarid(ncioObj,name,rc) result(varid) type(MAPL_NCIO), intent(in ) :: ncioObj character(len=*), intent(in ) :: name integer, optional, intent(out ) :: rc integer :: varid character(len=ESMF_MAXSTR) :: Iam integer :: status integer :: i Iam = "MAPL_NCIOGetVarid" do i=1,ncioObj%nVars if (trim(name) == trim(ncioObj%vars(i)%name)) then varid = ncioObj%vars(i)%varid RETURN_(ESMF_SUCCESS) end if enddo RETURN_(ESMF_FAILURE) end function MAPL_NCIOGetVarid subroutine MAPL_NCIOParseTimeUnits ( TimeUnits, year, month, day, hour, min, sec, rc ) implicit none ! ! !INPUT PARAMETERS: ! character(len=*) TimeUnits ! Units metadata string from the Time coord var ! ! !OUTPUT PARAMETERS: ! integer year ! 4-digit year integer month ! month integer day ! day integer hour ! hour integer min ! minute integer sec ! second integer rc ! return code ! 0 = no error ! -1 = problem parsing string character(ESMF_MAXSTR) NewUnits integer ypos(2), mpos(2), dpos(2), hpos(2), minpos(2), spos(2) integer i, j, inew, strlen integer firstdash, lastdash integer firstcolon, lastcolon integer lastspace strlen = LEN_TRIM (TimeUnits) firstdash = index(TimeUnits, '-') lastdash = index(TimeUnits, '-', BACK=.TRUE.) if (firstdash .LE. 0 .OR. lastdash .LE. 0) then rc = -1 return endif ypos(2) = firstdash - 1 mpos(1) = firstdash + 1 ypos(1) = ypos(2) - 3 mpos(2) = lastdash - 1 dpos(1) = lastdash + 1 dpos(2) = dpos(1) + 1 read ( TimeUnits(ypos(1):ypos(2)), * ) year read ( TimeUnits(mpos(1):mpos(2)), * ) month read ( TimeUnits(dpos(1):dpos(2)), * ) day firstcolon = index(TimeUnits, ':') if (firstcolon .LE. 0) then ! If no colons, check for hour. ! Logic below assumes a null character or something else is after the hour ! if we do not find a null character add one so that it correctly parses time if (TimeUnits(strlen:strlen) /= char(0)) then TimeUnits = trim(TimeUnits)//char(0) strlen=len_trim(TimeUnits) endif lastspace = index(TRIM(TimeUnits), ' ', BACK=.TRUE.) if ((strlen-lastspace).eq.2 .or. (strlen-lastspace).eq.3) then hpos(1) = lastspace+1 hpos(2) = strlen-1 read (TimeUnits(hpos(1):hpos(2)), * ) hour min = 0 sec = 0 else print *, 'ParseTimeUnits: Assuming a starting time of 00z' hour = 0 min = 0 sec = 0 endif else hpos(1) = firstcolon - 2 hpos(2) = firstcolon - 1 lastcolon = index(TimeUnits, ':', BACK=.TRUE.) if ( lastcolon .EQ. firstcolon ) then mpos(1) = firstcolon + 1 mpos(2) = firstcolon + 2 read (TimeUnits(hpos(1):hpos(2)), * ) hour read (TimeUnits(mpos(1):mpos(2)), * ) min sec = 0 else mpos(1) = firstcolon + 1 mpos(2) = lastcolon - 1 spos(1) = lastcolon + 1 spos(2) = lastcolon + 2 read (TimeUnits(hpos(1):hpos(2)), * ) hour read (TimeUnits(mpos(1):mpos(2)), * ) min read (TimeUnits(spos(1):spos(2)), * ) sec endif endif rc = 0 return end subroutine MAPL_NCIOParseTimeUnits subroutine ArrayScatterShmR4D1(local_array, global_array, grid, mask, rc) ! Mask is really a permutation on the first dimension real, intent( OUT) :: local_array(:) ! TYPE_(kind=EKIND_), target, intent(IN ) :: global_array DIMENSIONS_ real, target :: global_array(:) type (ESMF_Grid) :: grid integer, optional, intent(IN ) :: mask(:) integer, optional, intent( OUT) :: rc ! Local variables integer :: status character(len=ESMF_MAXSTR) :: IAm='ArrayScatterShmR4D1' real, pointer :: myglob(:) => null() real, pointer :: VAR(:) type (ESMF_DistGrid) :: distGrid type(ESMF_DELayout) :: LAYOUT integer, allocatable :: AL(:,:) integer, allocatable :: AU(:,:) integer, dimension(:), allocatable :: SENDCOUNTS, DISPLS integer :: KK integer :: nDEs integer :: recvcount integer :: I, J, K, II, JJ, de, deId integer :: I1, IN, J1, JN integer :: gridRank integer :: LX, LY integer :: srcPE integer :: ISZ integer :: deList(1) logical :: alloc_var logical :: use_shmem ! Works only on 1D and 2D arrays ! Note: for tile variables the gridRank is 1 ! and the case RANK_=2 needs additional attention ! use_shmem controls communication (bcastToNodes+local copy vs scatterv) use_shmem = .true. ! temporary Shmem restricted only to 1d and tile vars if (.not.present(mask)) use_shmem = .false. ! Optional change of source PE. Default=MAPL_Root srcPE = MAPL_Root ! Initialize alloc_var = .true. ! Get grid and layout information call ESMF_GridGet (GRID, dimCount=gridRank, rc=STATUS);VERIFY_(STATUS) call ESMF_GridGet (GRID, distGrid=distGrid, rc=STATUS);VERIFY_(STATUS) call ESMF_DistGridGet(distGRID, delayout=layout, rc=STATUS);VERIFY_(STATUS) call ESMF_DELayoutGet(layout, deCount =nDEs, localDeList=deList, rc=status) VERIFY_(STATUS) deId = deList(1) if (use_shmem) then srcPE = deId end if allocate (AL(gridRank,0:nDEs-1), stat=status) VERIFY_(STATUS) allocate (AU(gridRank,0:nDEs-1), stat=status) VERIFY_(STATUS) allocate (sendcounts(0:nDEs-1), stat=status) VERIFY_(STATUS) call ESMF_DistGridGet(distgrid, & minIndexPDe=AL, maxIndexPDe=AU, rc=status) VERIFY_(STATUS) ISZ = size(GLOBAL_ARRAY,1) if (use_shmem) then call MAPL_SyncSharedMemory(rc=STATUS) VERIFY_(STATUS) call MAPL_BroadcastToNodes(global_array, N=ISZ, ROOT=MAPL_Root, rc=status) VERIFY_(STATUS) call MAPL_SyncSharedMemory(rc=STATUS) VERIFY_(STATUS) end if ! Compute count to be sent to each PE if(present(mask)) then sendcounts = 0 do II = 1,ISZ sendcounts(mask(ii)) = sendcounts(mask(ii)) + 1 enddo else do I = 0,nDEs-1 LX = AU(1,I) - AL(1,I) + 1 sendcounts(I) = LX end do end if ! Count I will recieve recvcount = sendcounts(deId) ! Put VAR together at the srcPE if (deId == srcPE) then allocate(DISPLS(0:nDEs ), stat=status) VERIFY_(STATUS) ! Compute displacements into the VAR vector displs(0) = 0 do I = 1,nDEs displs(I) = displs(I-1) + sendcounts(I-1) end do myglob => global_array ! Fill the VAR vector if (present(mask)) then allocate(VAR(displs(deId):displs(deId+1)-1), stat=status) VERIFY_(STATUS) KK = DISPLS(deId) do I=1,ISZ K = MASK(I) if(K == deId) then II = KK VAR(II) = MYGLOB(I) KK = KK + 1 end if end do else var => myglob alloc_var = .false. endif ! present(mask) else allocate(var(0:1), stat=status) VERIFY_(STATUS) allocate(DISPLS(0:nDEs), stat=status) VERIFY_(STATUS) end if ! I am srcPEa ! Do the communications if (use_shmem) then ! copy my piece from var (var is local but was filled from shared array) call MAPL_SyncSharedMemory(rc=STATUS) VERIFY_(STATUS) local_array = var(displs(deId):displs(deId+1)-1) call MAPL_SyncSharedMemory(rc=STATUS) VERIFY_(STATUS) else call MAPL_CommsScatterV(layout, var, sendcounts, displs, & local_array, recvcount, srcPE, status) VERIFY_(STATUS) end if ! Clean-up deallocate(displs, stat=status) VERIFY_(STATUS) if(alloc_var) then deallocate(VAR, stat=status) VERIFY_(STATUS) end if deallocate(sendcounts, stat=status) VERIFY_(STATUS) deallocate(AU, stat=status) VERIFY_(STATUS) deallocate(AL, stat=status) VERIFY_(STATUS) ! All done RETURN_(ESMF_SUCCESS) end subroutine ArrayScatterShmR4D1 end module MAPL_IOMod