!--------------------------------------- LICENCE BEGIN -----------------------------------
!Environment Canada - Atmospheric Science and Technology License/Disclaimer,
! version 3; Last Modified: May 7, 2008.
!This is free but copyrighted software; you can use/redistribute/modify it under the terms
!of the Environment Canada - Atmospheric Science and Technology License/Disclaimer
!version 3 or (at your option) any later version that should be found at:
!http://collaboration.cmc.ec.gc.ca/science/rpn.comm/license.html
!
!This software is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY;
!without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
!See the above mentioned License/Disclaimer for more details.
!You should have received a copy of the License/Disclaimer along with this software;
!if not, you can write to: EC-RPN COMM Group, 2121 TransCanada, suite 500, Dorval (Quebec),
!CANADA, H9P 1J3; or send e-mail to service.rpn@ec.gc.ca
!-------------------------------------- LICENCE END --------------------------------------
!--------------------------------------------------------------------------
! MODULE gridStateVector (The grid-point state vector and related information. prefix="gsv")
!
! Purpose:
!
! Type definitions:
! struct_gsv
!
! Subroutines:
! (see "public" statements for publicly accessible subroutines and functions)
!
! Dependencies:
! varNameList_mod
! verticalCoord_mod
! MathPhysConstants_mod
! getStampList
!
!--------------------------------------------------------------------------
MODULE gridStateVector_mod 18,5
use mpivar_mod
use varNameList_mod
use verticalCoord_mod
use horizontalCoord_mod
use MathPhysConstants_mod
implicit none
save
private
! public structure definition
public :: struct_gsv
! public subroutines and functions
public :: gsv_setup, gsv_allocate, gsv_deallocate, gsv_zero, gsv_3dto4d, gsv_3dto4dAdj, gsv_varExist, gsv_getOffsetFromVarName
public :: gsv_getField, gsv_getField3D, gsv_getDateStamp, gsv_getNumLev, gsv_add
public :: gsv_getVco, gsv_setVco, gsv_getHco, gsv_setHco
public :: gsv_commMPIGlobal, gsv_commMPIGlobal3D
public :: gsv_commLatLon, gsv_commLatLonAd
! public entities accessed through inheritance
public :: struct_vco, vco_SetupFromFile
public :: vnl_varnameFromVarnum, vnl_vartypeFromVarnum, vnl_vartypeFromVarname
public :: vnl_numvarmax2d, vnl_numvarmax3d,vnl_numvarmax
public :: vnl_varNameList2d, vnl_varNameList3d, vnl_varNameList
public :: vgd_get,vgd_levels,vgd_ok,vgd_dpidpis,vgd_write
type struct_gsv
real*8,pointer :: gd(:,:,:,:)
real*8,pointer :: gd3d(:,:,:)
integer :: ni,nj,nk,numStep,anltime
integer :: latPerPE,myLatBeg,myLatEnd
integer :: lonPerPE,myLonBeg,myLonEnd
integer, pointer :: allLatBeg(:), allLatEnd(:)
integer, pointer :: allLonBeg(:), allLonEnd(:)
integer, pointer :: dateStampList(:)
integer, pointer :: dateStamp3d
logical :: allocated=.false.
type(struct_vco),pointer :: vco => null()
type(struct_hco),pointer :: hco => null()
integer,pointer :: varOffset(:),varNumLev(:)
logical :: mpi_local=.false.
end type struct_gsv
logical :: NGEXIST(VNL_NUMVARMAX)
character(len=8) :: ANLTIME_BIN
CONTAINS
function gsv_getOffsetFromVarName(statevector,varName) result(offset) 6,1
implicit none
type(struct_gsv) :: statevector
character(len=*), intent(in) :: varName
integer :: offset
offset=statevector%varOffset(vnl_varListIndex(varName))
end function gsv_getOffsetFromVarName
function gsv_varExist(varName) result(varExist) 35,1
implicit none
character(len=*), intent(in) :: varName
logical :: varExist
if(ngexist(vnl_varListIndex(varName))) then
varExist = .true.
else
varExist = .false.
endif
end function gsv_varExist
function gsv_getNumLev(statevector,varType) result(nlev) 17,1
implicit none
type(struct_gsv), intent(in) :: statevector
character(len=*), intent(in) :: varType
integer :: nlev
nlev = vco_getNumLev(statevector%vco,varType)
end function gsv_getNumLev
SUBROUTINE gsv_setup 2,6
implicit none
INTEGER JVAR, IPOS
integer :: fnom,fclos,nulnam,ierr
CHARACTER(len=4) :: CGNEED(VNL_NUMVARMAX)
NAMELIST /NAMSTATE/CGNEED,ANLTIME_BIN
if(mpi_myid.eq.0) write(*,*) 'gsv_setup: List of known (valid) variable names'
if(mpi_myid.eq.0) write(*,*) 'gsv_setup: varNameList3D=',vnl_varNameList3D
if(mpi_myid.eq.0) write(*,*) 'gsv_setup: varNameList2D=',vnl_varNameList2D
if(mpi_myid.eq.0) write(*,*) 'gsv_setup: varNameList =',vnl_varNameList
! Read NAMELIST NAMSTATE to find which fields are needed
cgneed(1:vnl_numvarmax) = ' '
ANLTIME_BIN = 'MIDDLE'
nulnam=0
ierr=fnom(nulnam,'./flnml','FTN+SEQ+R/O',0)
read(nulnam,nml=namstate,iostat=ierr)
if(ierr.ne.0) call abort3d('gsv_setup: Error reading namelist')
if(mpi_myid.eq.0) write(*,nml=namstate)
ierr=fclos(nulnam)
if(varneed('GZ')) call abort3d('gsv_setup: GZ can no longer be included as a variable in gridStateVector!')
do jvar = 1, vnl_numvarmax3D
if (varneed(vnl_varNameList3D(jvar))) then
ngexist(jvar) = .true.
else
ngexist(jvar) = .false.
endif
enddo
do jvar = 1, vnl_numvarmax2D
if (varneed(vnl_varNameList2D(jvar))) then
ngexist(jvar+vnl_numvarmax3D) = .true.
else
ngexist(jvar+vnl_numvarmax3D) = .false.
endif
enddo
if(mpi_myid.eq.0) write(*,*) 'gsv_setup: ngexist =',ngexist
!
! Check value for ANLTIME_BIN
!
if (ANLTIME_BIN .ne. 'MIDDLE' .and. ANLTIME_BIN .ne. 'FIRST' .and. ANLTIME_BIN .ne. 'LAST') then
call abort3d('gsv_setup: Problem setting ANLTIME_BIN. Verify NAMSTATE namelist. Aborting!')
endif
RETURN
CONTAINS
LOGICAL FUNCTION VARNEED(varName) 6
character(len=*) :: varName
integer :: jvar
varneed=.false.
do jvar=1,VNL_NUMVARMAX
if (trim(varName).eq.trim(cgneed(jvar))) then
varneed=.true.
endif
enddo
END FUNCTION VARNEED
END SUBROUTINE gsv_setup
SUBROUTINE gsv_allocate(statevector,numStep,dateStamp,mpi_local) 11,8
implicit none
type(struct_gsv) :: statevector
integer, intent(in) :: numStep
integer, optional :: dateStamp
integer :: ierr,iloc,jvar,jvar2,jstep,lon1,lat1
logical, optional :: mpi_local
if(.not.statevector%vco%initialized) then
call abort3d('statevector_allocate: VerticalCoord has not been initialized!')
endif
if (statevector%allocated)then
if(mpi_myid.eq.0) write(*,*) 'gridStateVector already allocated! Deallocating first.'
call gsv_deallocate(statevector)
statevector%allocated=.false.
end if
statevector%ni=statevector%hco%ni
statevector%nj=statevector%hco%nj
statevector%numStep=numStep
if(present(mpi_local)) then
statevector%mpi_local=mpi_local
else
statevector%mpi_local=.false.
endif
if(statevector%mpi_local) then
call mpivar_setup_latbands(statevector%hco%nj,statevector%latPerPE,statevector%myLatBeg, &
statevector%myLatEnd)
call mpivar_setup_lonbands(statevector%hco%ni,statevector%lonPerPE,statevector%myLonBeg, &
statevector%myLonEnd)
else
statevector%mpi_local=.false.
statevector%latPerPE=statevector%hco%nj
statevector%myLatBeg=1
statevector%myLatEnd=statevector%hco%nj
statevector%lonPerPE=statevector%hco%ni
statevector%myLonBeg=1
statevector%myLonEnd=statevector%hco%ni
endif
allocate(statevector%allLonBeg(mpi_npex))
CALL rpn_comm_allgather(statevector%myLonBeg,1,"mpi_integer", &
statevector%allLonBeg,1,"mpi_integer","EW",ierr)
allocate(statevector%allLonEnd(mpi_npex))
CALL rpn_comm_allgather(statevector%myLonEnd,1,"mpi_integer", &
statevector%allLonEnd,1,"mpi_integer","EW",ierr)
allocate(statevector%allLatBeg(mpi_npey))
CALL rpn_comm_allgather(statevector%myLatBeg,1,"mpi_integer", &
statevector%allLatBeg,1,"mpi_integer","NS",ierr)
allocate(statevector%allLatEnd(mpi_npey))
CALL rpn_comm_allgather(statevector%myLatEnd,1,"mpi_integer", &
statevector%allLatEnd,1,"mpi_integer","NS",ierr)
select case (ANLTIME_BIN)
case ("FIRST")
statevector%anltime=1
case ("MIDDLE")
statevector%anltime=nint((real(numStep,8)+1.0d0)/2.0d0)
case ("LAST")
statevector%anltime=numStep
end select
if(present(dateStamp)) then
allocate(statevector%dateStampList(numStep))
call getstamplist(statevector%dateStampList,numStep,dateStamp)
!do jstep = 1,numStep
! write(*,*) 'gsv_allocate: jstep,dateStampList=',jstep,statevector%dateStampList(jstep)
!enddo
statevector%dateStamp3d => statevector%dateStampList(statevector%anltime)
!write(*,*) 'gsv_allocate: dateStamp3d=',statevector%dateStamp3d
else
nullify(statevector%dateStamplist)
!write(*,*) 'gsv_allocate: no date stamp supplied, dateStampList not available!'
endif
allocate(statevector%varOffset(vnl_numvarmax))
statevector%varOffset(:)=0
allocate(statevector%varNumLev(vnl_numvarmax))
statevector%varNumLev(:)=0
iloc=0
do jvar = 1, vnl_numvarmax3d
if(ngexist(jvar)) then
statevector%varOffset(jvar)=iloc
statevector%varNumLev(jvar)=gsv_getNumLev(statevector,vnl_vartypeFromVarname(vnl_varNameList(jvar)))
iloc = iloc + statevector%varNumLev(jvar)
endif
enddo
do jvar2 = 1, vnl_numvarmax2d
jvar=jvar2+vnl_numvarmax3d
if(ngexist(jvar)) then
statevector%varOffset(jvar)=iloc
statevector%varNumLev(jvar)=1
iloc = iloc + 1
endif
enddo
statevector%nk=iloc
if(statevector%mpi_local) then
allocate(statevector%gd(statevector%myLonBeg:(statevector%myLonEnd+1),statevector%nk, &
statevector%myLatBeg:(statevector%myLatEnd+1),numStep),stat=ierr)
else
allocate(statevector%gd(statevector%hco%ni,statevector%nk,statevector%hco%nj,numStep),stat=ierr)
endif
if(ierr.ne.0) then
write(*,*) 'gridStateVector: Problem allocating memory! id=1',ierr
call abort3d('aborting in gsv_allocate')
endif
lon1=statevector%myLonBeg
lat1=statevector%myLatBeg
statevector%gd3d(lon1:,1:,lat1:) => statevector%gd(:,:,:,statevector%anltime)
statevector%allocated=.true.
END SUBROUTINE GSV_allocate
SUBROUTINE GSV_zero(statevector) 5,1
implicit none
type(struct_gsv) :: statevector
integer :: jstep,jlon,jlev,jlat,lat1,lat2,lon1,lon2
if(.not.statevector%allocated) then
call abort3d('gridStateVector not yet allocated! Aborting.')
endif
lon1=statevector%myLonBeg
lon2=min(statevector%myLonEnd+1,statevector%hco%ni)
lat1=statevector%myLatBeg
lat2=min(statevector%myLatEnd+1,statevector%hco%nj)
!$OMP PARALLEL
!$OMP DO PRIVATE (jstep,jlat,jlev,jlon)
do jlat = lat1, lat2
do jstep = 1, statevector%numStep
do jlev = 1, statevector%nk
do jlon = lon1, lon2
statevector%gd(jlon,jlev,jlat,jstep)= 0.0d0
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END SUBROUTINE GSV_zero
SUBROUTINE GSV_commLatLon(statevector_in) 1
implicit none
type(struct_gsv) :: statevector_in
integer :: nsize, ierr, status, latPerPEhalo, myLatEndP1
! ******First send latitude halos
nsize=statevector_in%lonPerPE*statevector_in%nk*statevector_in%numStep
! southern most latitude band
if(mpi_myidy.eq.(mpi_npey-1)) then
call rpn_comm_send(statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonEnd,:, &
statevector_in%myLatBeg:statevector_in%myLatBeg,:),nsize, &
"mpi_double_precision",mpi_myidy-1,mpi_myidy*500+(mpi_myidy-1), &
"NS",ierr)
endif
! all latitude bands not at the north or south poles
if(mpi_myidy.ne.0.and.mpi_myidy.ne.(mpi_npey-1)) then
call rpn_comm_sendrecv(statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonEnd,:, &
statevector_in%myLatBeg:statevector_in%myLatBeg,:), &
nsize,"mpi_double_precision",mpi_myidy-1,mpi_myidy*500+(mpi_myidy-1), &
statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonEnd,:, &
(statevector_in%myLatEnd+1):(statevector_in%myLatEnd+1),:), &
nsize,"mpi_double_precision",mpi_myidy+1,(mpi_myidy+1)*500+mpi_myidy, &
"NS",status,ierr)
endif
! northern most latitude band
if(mpi_myidy.eq.0) then
call rpn_comm_recv(statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonEnd,:, &
(statevector_in%myLatEnd+1):(statevector_in%myLatEnd+1),:),nsize, &
"mpi_double_precision",mpi_myidy+1,(mpi_myidy+1)*500+mpi_myidy, &
"NS",status,ierr)
endif
! ******Now send longitude halos
if(mpi_myidy.eq.(mpi_npey-1)) then
! southern most latitude band does not have a latitude halo to the south
latPerPEhalo = statevector_in%latPerPE
myLatEndP1 = statevector_in%myLatEnd
else
! all others do
latPerPEhalo = statevector_in%latPerPE + 1
myLatEndP1 = statevector_in%myLatEnd + 1
endif
if(mpi_npex.gt.1) then ! only do exchange when more than one mpi task in X direction
nsize=latPerPEhalo*statevector_in%nk*statevector_in%numStep
! eastern most longitude band
if(mpi_myidx.eq.(mpi_npex-1)) then
call rpn_comm_send(statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonBeg,:, &
statevector_in%myLatBeg:myLatEndP1,:),nsize, &
"mpi_double_precision",mpi_myidx-1,mpi_myidx*500+(mpi_myidx-1),"EW",ierr)
endif
! all other longitude bands (not first nor last)
if(mpi_myidx.ne.0.and.mpi_myidx.ne.(mpi_npex-1)) then
call rpn_comm_sendrecv(statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonBeg,:, &
statevector_in%myLatBeg:myLatEndP1,:), &
nsize,"mpi_double_precision",mpi_myidx-1,mpi_myidx*500+(mpi_myidx-1), &
statevector_in%gd((statevector_in%myLonEnd+1):(statevector_in%myLonEnd+1),:, &
statevector_in%myLatBeg:myLatEndP1,:), &
nsize,"mpi_double_precision",mpi_myidx+1,(mpi_myidx+1)*500+mpi_myidx, &
"EW",status,ierr)
endif
! western most longitude band
if(mpi_myidx.eq.0) then
call rpn_comm_recv(statevector_in%gd((statevector_in%myLonEnd+1):(statevector_in%myLonEnd+1),:, &
statevector_in%myLatBeg:myLatEndP1,:),nsize, &
"mpi_double_precision",mpi_myidx+1,(mpi_myidx+1)*500+mpi_myidx,"EW",status,ierr)
endif
! periodic, so also send the first meridian on myidx=0 to the last meridian on myidx=(npex-1)
if(mpi_myidx.eq.0) then
call rpn_comm_send(statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonBeg,:, &
statevector_in%myLatBeg:myLatEndP1,:),nsize, &
"mpi_double_precision",mpi_npex-1,mpi_myidx*500+(mpi_npex-1),"EW",ierr)
endif
if(mpi_myidx.eq.(mpi_npex-1)) then
call rpn_comm_recv(statevector_in%gd((statevector_in%myLonEnd+1):(statevector_in%myLonEnd+1),:, &
statevector_in%myLatBeg:myLatEndP1,:),nsize, &
"mpi_double_precision",0,0*500+mpi_myidx,"EW",status,ierr)
endif
else ! only one mpi task in X direction, so just copy first meridian to last (plus 1)
statevector_in%gd(statevector_in%myLonEnd+1,:,statevector_in%myLatBeg:myLatEndP1,:) = &
statevector_in%gd(1 ,:,statevector_in%myLatBeg:myLatEndP1,:)
endif
END SUBROUTINE GSV_commLatLon
SUBROUTINE GSV_commLatLonAd(statevector_in) 1
implicit none
type(struct_gsv) :: statevector_in
integer :: nsize, ierr, status, latPerPEhalo, myLatEndP1
real*8, allocatable :: latHalo(:,:,:,:)
real*8, allocatable :: lonHalo(:,:,:,:)
! ******Adjoint of sending longitude halos
if(mpi_myidy.eq.(mpi_npey-1)) then
! southern most latitude band does not have a latitude halo to the south
latPerPEhalo = statevector_in%latPerPE
myLatEndP1 = statevector_in%myLatEnd
else
! all others do
latPerPEhalo = statevector_in%latPerPE + 1
myLatEndP1 = statevector_in%myLatEnd + 1
endif
if(mpi_npex.gt.1) then ! only do adjoint of exchange when more than one mpi task in X direction
allocate(lonHalo(1, statevector_in%nk, latPerPEhalo, statevector_in%numStep))
nsize=latPerPEhalo*statevector_in%nk*statevector_in%numStep
! periodic, so also do adjoint of sending the first meridian on myidx=0 to the last meridian on myidx=(npex-1)
if(mpi_myidx.eq.(mpi_npex-1)) then
call rpn_comm_send(statevector_in%gd((statevector_in%myLonEnd+1):(statevector_in%myLonEnd+1),:, &
statevector_in%myLatBeg:myLatEndP1,:),nsize, &
"mpi_double_precision",0,0*500+mpi_myidx, &
"EW",ierr)
endif
if(mpi_myidx.eq.0) then
call rpn_comm_recv(lonHalo,nsize, &
"mpi_double_precision",mpi_npex-1,mpi_myidx*500+(mpi_npex-1),"EW",status,ierr)
endif
! western most longitude band
if(mpi_myidx.eq.0) then
call rpn_comm_send(statevector_in%gd((statevector_in%myLonEnd+1):(statevector_in%myLonEnd+1),:, &
statevector_in%myLatBeg:myLatEndP1,:),nsize, &
"mpi_double_precision",mpi_myidx+1,(mpi_myidx+1)*500+mpi_myidx, &
"EW",ierr)
endif
! all other longitude bands (not first nor last)
if(mpi_myidx.ne.0.and.mpi_myidx.ne.(mpi_npex-1)) then
call rpn_comm_sendrecv(statevector_in%gd((statevector_in%myLonEnd+1):(statevector_in%myLonEnd+1),:, &
statevector_in%myLatBeg:myLatEndP1,:), &
nsize,"mpi_double_precision",mpi_myidx+1,(mpi_myidx+1)*500+mpi_myidx, &
lonHalo, &
nsize,"mpi_double_precision",mpi_myidx-1,mpi_myidx*500+(mpi_myidx-1), &
"EW",status,ierr)
endif
! eastern most longitude band
if(mpi_myidx.eq.(mpi_npex-1)) then
call rpn_comm_recv(lonHalo,nsize, &
"mpi_double_precision",mpi_myidx-1,mpi_myidx*500+(mpi_myidx-1),"EW",status,ierr)
endif
! add the sensitivity from the halo to the in situ sensitivity
statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonBeg,:, &
statevector_in%myLatBeg:myLatEndP1,:) = &
statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonBeg,:, &
statevector_in%myLatBeg:myLatEndP1,:) + lonHalo(:,:,:,:)
! to make sure sensitivity from the halo is not double counted, set to zero
statevector_in%gd(statevector_in%myLonEnd+1,:,statevector_in%myLatBeg:myLatEndP1,:) = 0.0d0
deallocate(lonHalo)
else ! only one mpi task in X direction, so just adjoint of copying first meridian to last (plus 1)
statevector_in%gd(1 ,:,statevector_in%myLatBeg:myLatEndP1,:) = &
statevector_in%gd(1 ,:,statevector_in%myLatBeg:myLatEndP1,:) + &
statevector_in%gd(statevector_in%myLonEnd+1,:,statevector_in%myLatBeg:myLatEndP1,:)
! to make sure sensitivity from the halo is not double counted, set to zero
statevector_in%gd(statevector_in%myLonEnd+1,:,statevector_in%myLatBeg:myLatEndP1,:) = 0.0d0
endif
! ******Adjoint of sending latitude halos
allocate(latHalo(statevector_in%lonPerPE, statevector_in%nk, 1, statevector_in%numStep))
nsize=statevector_in%lonPerPE*statevector_in%nk*statevector_in%numStep
! northern most latitude band
if(mpi_myidy.eq.0) then
call rpn_comm_send(statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonEnd,:, &
(statevector_in%myLatEnd+1):(statevector_in%myLatEnd+1),:), &
nsize,"mpi_double_precision",mpi_myidy+1,(mpi_myidy+1)*500+mpi_myidy,"NS",ierr)
endif
! all latitude bands not at the north or south poles
if(mpi_myidy.ne.0.and.mpi_myidy.ne.(mpi_npey-1)) then
call rpn_comm_sendrecv(statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonEnd,:, &
(statevector_in%myLatEnd+1):(statevector_in%myLatEnd+1),:), &
nsize,"mpi_double_precision",mpi_myidy+1,(mpi_myidy+1)*500+mpi_myidy, &
latHalo, &
nsize,"mpi_double_precision",mpi_myidy-1,mpi_myidy*500+(mpi_myidy-1), &
"NS",status,ierr)
endif
! southern most latitude band
if(mpi_myidy.eq.(mpi_npey-1)) then
call rpn_comm_recv(latHalo,nsize, &
"mpi_double_precision",mpi_myidy-1,mpi_myidy*500+(mpi_myidy-1), &
"NS",status,ierr)
endif
! add the sensitivity from the halo to the in situ sensitivity
if(mpi_myidy.ne.0) then
statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonEnd,:, &
statevector_in%myLatBeg:statevector_in%myLatBeg,:) = &
statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonEnd,:, &
statevector_in%myLatBeg:statevector_in%myLatBeg,:) + latHalo(:,:,:,:)
endif
! to make sure sensitivity from the halo is not double counted, set to zero
if(mpi_myidy.ne.(mpi_npey-1)) then
statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonEnd,:,statevector_in%myLatEnd+1,:)=0.0d0
endif
deallocate(latHalo)
END SUBROUTINE GSV_commLatLonAd
SUBROUTINE GSV_commMPIGlobal(statevector_in) 3,1
implicit none
type(struct_gsv) :: statevector_in
integer :: nsize,ierr,jlat,jstep,jlev,jlon
integer :: IP, IP_x, IP_y
real*8, pointer :: gd_mpiglobal(:,:,:,:) => null()
real*8, allocatable :: gd_temp(:,:,:,:)
if(.not.statevector_in%mpi_local) then
call abort3d('gsv_commMPIGlobal: statevector already global!')
endif
! only allocate a single 3D mpiglobal statevector as an array of latlon tiles
allocate(gd_temp(statevector_in%lonPerPE,statevector_in%nk,statevector_in%latPerPE,mpi_nprocs))
nsize=statevector_in%lonPerPE*statevector_in%nk*statevector_in%latPerPE
! NOTE: result of mpiglobal 3D statevector for timestep jstep is sent to proc jstep-1
do jstep=1,statevector_in%numStep
call rpn_comm_gather(statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonEnd,:, &
statevector_in%myLatBeg:statevector_in%myLatEnd,jstep), &
nsize,"mpi_double_precision", &
gd_temp, &
nsize,"mpi_double_precision", &
jstep-1,"GRID",ierr)
enddo
deallocate(statevector_in%gd)
if(mpi_myid.lt.statevector_in%numStep) then
! reorganize data into mpiglobal array
allocate(gd_mpiglobal(statevector_in%hco%ni,statevector_in%nk,statevector_in%hco%nj,1))
do IP_y = 0, (mpi_npey-1)
do IP_x = 0, (mpi_npex-1)
IP = IP_x + IP_y*mpi_npex
gd_mpiglobal(statevector_in%allLonBeg(IP_x+1):statevector_in%allLonEnd(IP_x+1),:, &
statevector_in%allLatBeg(IP_y+1):statevector_in%allLatEnd(IP_y+1),1) = &
gd_temp(:,:,:,IP+1)
enddo
enddo
else
allocate(gd_mpiglobal(1,1,1,1)) ! dummy allocation to avoid error when deallocating
endif
deallocate(gd_temp)
! reset values in statevector object for mpiglobal
statevector_in%gd => gd_mpiglobal
statevector_in%gd3d => statevector_in%gd(:,:,:,1)
statevector_in%myLonBeg=1
statevector_in%myLonEnd=statevector_in%hco%ni
statevector_in%lonPerPE=statevector_in%hco%ni
statevector_in%myLatBeg=1
statevector_in%myLatEnd=statevector_in%hco%nj
statevector_in%latPerPE=statevector_in%hco%nj
statevector_in%numStep=1
statevector_in%mpi_local=.false.
END SUBROUTINE GSV_commMPIGlobal
SUBROUTINE GSV_commMPIGlobal3D(statevector_in) 3,1
implicit none
type(struct_gsv) :: statevector_in
integer :: nsize,ierr,jlat,jstep,jlev,jlon
integer :: IP, IP_x, IP_y
real*8, pointer :: gd_mpiglobal(:,:,:,:) => null()
real*8, allocatable :: gd_temp(:,:,:,:)
if(.not.statevector_in%mpi_local) then
call abort3d('gsv_commMPIGlobal3D: statevector already global!')
endif
! only allocate a single 3D mpiglobal statevector as an array of latlon tiles
allocate(gd_temp(statevector_in%lonPerPE,statevector_in%nk,statevector_in%latPerPE,mpi_nprocs))
nsize=statevector_in%lonPerPE*statevector_in%nk*statevector_in%latPerPE
! NOTE: result of mpiglobal 3D statevector for timestep anltime is sent to proc 0
jstep=statevector_in%anltime
call rpn_comm_gather(statevector_in%gd(statevector_in%myLonBeg:statevector_in%myLonEnd,:, &
statevector_in%myLatBeg:statevector_in%myLatEnd,jstep), &
nsize,"mpi_double_precision", &
gd_temp, &
nsize,"mpi_double_precision", &
0,"GRID",ierr)
deallocate(statevector_in%gd)
if(mpi_myid.eq.0) then
! reorganize data into mpiglobal array
allocate(gd_mpiglobal(statevector_in%hco%ni,statevector_in%nk,statevector_in%hco%nj,1))
do IP_y = 0, (mpi_npey-1)
do IP_x = 0, (mpi_npex-1)
IP = IP_x + IP_y*mpi_npex
gd_mpiglobal(statevector_in%allLonBeg(IP_x+1):statevector_in%allLonEnd(IP_x+1),:, &
statevector_in%allLatBeg(IP_y+1):statevector_in%allLatEnd(IP_y+1),1) = &
gd_temp(:,:,:,IP+1)
enddo
enddo
else
allocate(gd_mpiglobal(1,1,1,1)) ! dummy allocation to avoid error when deallocating
endif
deallocate(gd_temp)
! reset values in statevector object for mpiglobal
statevector_in%gd => gd_mpiglobal
statevector_in%gd3d => statevector_in%gd(:,:,:,1)
statevector_in%myLonBeg=1
statevector_in%myLonEnd=statevector_in%hco%ni
statevector_in%lonPerPE=statevector_in%hco%ni
statevector_in%myLatBeg=1
statevector_in%myLatEnd=statevector_in%hco%nj
statevector_in%latPerPE=statevector_in%hco%nj
statevector_in%numStep=1
statevector_in%mpi_local=.false.
END SUBROUTINE GSV_commMPIGlobal3D
SUBROUTINE GSV_add(statevector_in,statevector_inout,scaleFactor) 3,2
implicit none
type(struct_gsv) :: statevector_in,statevector_inout
integer :: jstep,jlon,jlev,jlat,lon1,lon2,lat1,lat2
real(8), optional :: scaleFactor
if(.not.statevector_in%allocated) then
call abort3d('gridStateVector_in not yet allocated! Aborting.')
endif
if(.not.statevector_inout%allocated) then
call abort3d('gridStateVector_inout not yet allocated! Aborting.')
endif
lon1=statevector_in%myLonBeg
lon2=min(statevector_in%myLonEnd+1,statevector_inout%hco%ni)
lat1=statevector_in%myLatBeg
lat2=min(statevector_in%myLatEnd+1,statevector_inout%hco%nj)
if(present(scaleFactor)) then
!$OMP PARALLEL
!$OMP DO PRIVATE (jstep,jlat,jlev,jlon)
do jlat = lat1, lat2
do jstep = 1, statevector_inout%numStep
do jlev = 1, statevector_inout%nk
do jlon = lon1, lon2
statevector_inout%gd(jlon,jlev,jlat,jstep)= statevector_inout%gd(jlon,jlev,jlat,jstep) + &
scaleFactor * statevector_in%gd(jlon,jlev,jlat,jstep)
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
else
!$OMP PARALLEL
!$OMP DO PRIVATE (jstep,jlat,jlev,jlon)
do jlat = lat1, lat2
do jstep = 1, statevector_inout%numStep
do jlev = 1, statevector_inout%nk
do jlon = lon1, lon2
statevector_inout%gd(jlon,jlev,jlat,jstep)= statevector_inout%gd(jlon,jlev,jlat,jstep) + &
statevector_in%gd(jlon,jlev,jlat,jstep)
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
endif
END SUBROUTINE GSV_add
SUBROUTINE GSV_3dto4d(statevector) 1,1
implicit none
type(struct_gsv) :: statevector
integer :: jstep,jlon,jlev,jlat,lon1,lon2,lat1,lat2
if(.not.statevector%allocated) then
call abort3d('gridStateVector not yet allocated! Aborting.')
endif
lon1=statevector%myLonBeg
lon2=min(statevector%myLonEnd+1,statevector%hco%ni)
lat1=statevector%myLatBeg
lat2=min(statevector%myLatEnd+1,statevector%hco%nj)
if(statevector%numStep.eq.1) return
!$OMP PARALLEL
!$OMP DO PRIVATE (jstep,jlat,jlev,jlon)
do jlat = lat1, lat2
do jstep = 1, statevector%numStep
if(jstep.ne.statevector%anltime) then
do jlev = 1, statevector%nk
do jlon = lon1, lon2
statevector%gd(jlon,jlev,jlat,jstep)= statevector%gd3d(jlon,jlev,jlat)
enddo
enddo
endif
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END SUBROUTINE GSV_3dto4d
SUBROUTINE GSV_3dto4dAdj(statevector) 1,1
implicit none
type(struct_gsv) :: statevector
integer :: jstep,jlon,jlev,jlat,lon1,lon2,lat1,lat2
real(8) :: gd3d_tmp(statevector%myLonBeg:(statevector%myLonEnd+1),statevector%nk, &
statevector%myLatBeg:(statevector%myLatEnd+1))
if(.not.statevector%allocated) then
call abort3d('gridStateVector not yet allocated! Aborting.')
endif
lon1=statevector%myLonBeg
lon2=min(statevector%myLonEnd+1,statevector%hco%ni)
lat1=statevector%myLatBeg
lat2=min(statevector%myLatEnd+1,statevector%hco%nj)
if(statevector%numStep.eq.1) return
!$OMP PARALLEL
!$OMP DO PRIVATE (jlat,jlev,jlon)
do jlat = lat1, lat2
do jlev = 1, statevector%nk
do jlon = lon1, lon2
gd3d_tmp(jlon,jlev,jlat) = 0.0d0
enddo
enddo
enddo
!$OMP END DO
!$OMP DO PRIVATE (jstep,jlat,jlev,jlon)
do jlat = lat1, lat2
do jstep = 1, statevector%numStep
do jlev = 1, statevector%nk
do jlon = lon1, lon2
gd3d_tmp(jlon,jlev,jlat) = gd3d_tmp(jlon,jlev,jlat) + &
statevector%gd(jlon,jlev,jlat,jstep)
enddo
enddo
enddo
enddo
!$OMP END DO
!$OMP DO PRIVATE (jlat,jlev,jlon)
do jlat = lat1, lat2
do jlev = 1, statevector%nk
do jlon = lon1, lon2
statevector%gd3d(jlon,jlev,jlat) = gd3d_tmp(jlon,jlev,jlat)
enddo
enddo
enddo
!$OMP END DO
!$OMP END PARALLEL
END SUBROUTINE GSV_3dto4dAdj
SUBROUTINE GSV_deallocate(statevector) 10,1
implicit none
type(struct_gsv) :: statevector
integer :: ierr
if(.not.statevector%allocated) then
call abort3d('gridStateVector not yet allocated! Aborting.')
endif
statevector%allocated=.false.
deallocate(statevector%allLonBeg)
deallocate(statevector%allLonEnd)
deallocate(statevector%allLatBeg)
deallocate(statevector%allLatEnd)
deallocate(statevector%gd,stat=ierr)
nullify(statevector%gd)
if(ierr.ne.0) then
write(*,*) 'Problem detected in gridStateVector. IERR =',ierr
endif
if(associated(statevector%dateStampList)) deallocate(statevector%dateStampList)
deallocate(statevector%varOffset)
deallocate(statevector%varNumLev)
END SUBROUTINE GSV_deallocate
function gsv_getField(statevector,varName) result(field) 33,4
implicit none
type(struct_gsv), intent(in) :: statevector
character(len=*), intent(in), optional :: varName
real*8,pointer :: field(:,:,:,:)
integer :: ilev1,ilev2,lon1,lat1
lon1=statevector%myLonBeg
lat1=statevector%myLatBeg
if(present(varName)) then
if(gsv_varExist(varName)) then
ilev1 = 1 + statevector%varOffset(vnl_varListIndex(varName))
ilev2 = ilev1 - 1 + statevector%varNumLev(vnl_varListIndex(varName))
field(lon1:,1:,lat1:,1:) => statevector%gd(:,ilev1:ilev2,:,:)
else
call abort3d('gsv_getField: Unknown variable name! ' // varName)
endif
else
field(lon1:,1:,lat1:,1:) => statevector%gd(:,:,:,:)
endif
end function gsv_getField
function gsv_getField3D(statevector,varName) result(field3D) 31,4
implicit none
type(struct_gsv), intent(in) :: statevector
character(len=*), intent(in), optional :: varName
real*8,pointer :: field3D(:,:,:)
integer :: ilev1,ilev2,lon1,lat1
lon1=statevector%myLonBeg
lat1=statevector%myLatBeg
if(present(varName)) then
if(gsv_varExist(varName)) then
ilev1 = 1 + statevector%varOffset(vnl_varListIndex(varName))
ilev2 = ilev1 - 1 + statevector%varNumLev(vnl_varListIndex(varName))
field3D(lon1:,1:,lat1:) => statevector%gd3d(:,ilev1:ilev2,:)
else
call abort3d('gsv_getField: Unknown variable name! ' // varName)
endif
else
field3D(lon1:,1:,lat1:) => statevector%gd3d(:,:,:)
endif
end function gsv_getField3D
function gsv_getDateStamp(statevector,step) result(dateStamp) 1,2
implicit none
type(struct_gsv), intent(in) :: statevector
integer, intent(in), optional :: step
integer :: dateStamp
if(associated(statevector%dateStampList)) then
if(present(step)) then
if(step.gt.0.and.step.le.statevector%numStep) then
dateStamp=statevector%dateStampList(step)
else
write(*,*) 'gsv_getDateStamp: requested step is out of range! Step,numStep=',step,statevector%numStep
call abort3d('aborting in gsv_getDateStamp')
endif
else
dateStamp=statevector%dateStamp3D
endif
else
call abort3d('gsv_getDateStamp: dateStampList was not created during allocation!')
endif
end function gsv_getDateStamp
function gsv_getVco(statevector) result(vco_ptr) 2
implicit none
type(struct_gsv) :: statevector
type(struct_vco), pointer :: vco_ptr
vco_ptr => statevector%vco
end function gsv_getVco
subroutine gsv_setVco(statevector,vco_ptr) 9
implicit none
type(struct_gsv) :: statevector
type(struct_vco), pointer :: vco_ptr
statevector%vco => vco_ptr
end subroutine gsv_setVco
function gsv_getHco(statevector) result(hco_ptr)
implicit none
type(struct_gsv) :: statevector
type(struct_hco), pointer :: hco_ptr
hco_ptr => statevector%hco
end function gsv_getHco
subroutine gsv_setHco(statevector,hco_ptr) 9
implicit none
type(struct_gsv) :: statevector
type(struct_hco), pointer :: hco_ptr
statevector%hco => hco_ptr
end subroutine gsv_setHco
END MODULE gridStateVector_mod