subroutine getprof,1
use mod4dv, only : maxxy
implicit none
*
*author P.Gauthier
*
*revision M.Tanguay
* Simon Pellerin : . Get distributed profiles from TLM
* . Book keeping of PEs, model and observation
* tags and for further communications of
* adjoint profiles (putprofad)
* . Introduction of events (EVN_*) protocol
* S. Pellerin, ARMA, August 2008
* .Added calls to 'tmg_*' subroutines
* C. Charette ARMA 2007
* .Added O3, CH4 and N2O cases
*
* Correction dlbuff2d
* -------------------
*
#include "comdim.cdk"
#include "comcva.cdk"
#include "comlun.cdk"
#include "comdimo.cdk"
#include "commvo.cdk"
#include "comvfiles.cdk"
#include "comchem.cdk"
include 'prof_f.h'
*
* Local variables
*
integer :: ievent,prof_wrrec,prof_size,ibid_nlev,nprof
INTEGER :: ITR, ITRLEV, JTR
character(len=128) :: clprof
character(len=2) :: cljx, cljy
integer jobs, jk, ibprm, ibint, ibreal,ibdbl,jbit,ix,iy, ipes
integer ihdl, prof_rdrec, istat,prof_bitptrn,iobs,ixy,jx,jy
integer, pointer, dimension(:) :: iotag,imtag
real*8, pointer:: dlbuff(:,:), dlbuff2d(:)
*
nullify(iotag,imtag,dlbuff,dlbuff2d)
*
* Opening Prof_File
*
write(nulout,*) 'Entering GETPROF for simulation ',nsim3d
ix = 0
iy = 0
jx = 0
jy = 0
pes : do
write(cljx,'(i2.2)') jx
write(cljy,'(i2.2)') jy
! Building (jx,jy) bit encoded PEs
ipes = 0
ipes = ishft(jx,16)
call mvbits(jy,0,16,ipes,0)
clprof = trim(CEXC4DV) // '/dwyf_'//cljx//'_'//cljy//'.prof'
call tmg_start(82,'I/O_WAIT')
IHDL = PROF_OPEN(clprof,'READ','FILE')
call tmg_stop(82)
if(ihdl > 0) then
record: do
call tmg_start(81,'PROF_R+W')
ISTAT = prof_rdrec(ihdl)
call tmg_stop(81)
if(istat /= 0) exit record
istat = prof_gvar(ihdl,ievent,prm_evnt)
if(ievent == nsim3d) then
istat = prof_gvar(ihdl,maxxy,prm_pexy) + istat
call mvbits(maxxy,16,16,ix,0)
call mvbits(maxxy,0,16,iy,0)
istat = prof_size(ihdl,ibid_nlev,nprof)
if(nprof.gt.0) then
istat = prof_gvar(ihdl,iotag,v2d_otag) + istat
istat = prof_gvar(ihdl,imtag,v2d_mtag) + istat
do jobs = 1, size(iotag)
iobs = iotag(jobs)
npexy(iobs) = ipes
mtag(iobs) = imtag(jobs)
end do
ibprm = 0
ibint = 0
ibreal = 0
ibdbl = 0
istat = prof_bitptrn(ihdl,ibprm,ibint,ibreal,ibdbl)
do jbit = 0,31
if(btest(ibdbl,jbit))
& call getfld(jbit,iotag,size(iotag))
enddo
endif
else
istat = prof_close(ihdl,.false.)
write(nulout,*)
& 'GETPROF - ERROR - ABNORMAL TERMINATION : ievent = '
& ,ievent
clprof = trim(CEXC4DV) // '/dwya_'//cljx//'_'//cljy/
& /'.prof'
IHDL = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDL,EVN_FERR,PRM_EVNT)
call tmg_start(81,'PROF_R+W')
istat = prof_wrrec(ihdl)
istat = prof_close(ihdl)
call tmg_stop(81)
call abort3d(nulout,'GETPROF')
endif
enddo record
istat = prof_close(ihdl,.true.)
else
write(nulout,*)'GETPROF - ERROR: Problem opening file ',clprof
clprof = trim(CEXC4DV) // '/dwya_'//cljx//'_'//cljy/
& /'.prof'
IHDL = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDL,EVN_FERR,PRM_EVNT)
call tmg_start(81,'PROF_R+W')
istat = prof_wrrec(ihdl)
istat = prof_close(ihdl)
call tmg_stop(81)
call abort3d(nulout,'GETPROF')
endif
if (jx < ix) then
jx = jx + 1
elseif(jx == ix) then
jx = 0
jy = jy + 1
if(jy > iy) exit pes
endif
enddo pes
*
write(nulout,*) 'Leaving GETPROF'
call vflush(nulout)
contains
subroutine getfld(kbit,kotag,kobs) 1
*
integer, intent(in) :: kbit, kobs
integer, intent(in), dimension(kobs) :: kotag
*
* Local variables
*
select case (kbit)
case(V3D_UTRU)
istat = prof_gvar(IHDL,DLBUFF,V3D_UTRU)
do jobs = 1, kobs
iobs = kotag(jobs)
do jk = 1, nflev
gomu(jk,iobs) = dlbuff(jk,jobs)
end do
end do
case(V3D_VTRU)
istat = prof_gvar(IHDL,DLBUFF,V3D_VTRU)
do jobs = 1, kobs
iobs = kotag(jobs)
do jk = 1, nflev
gomv(jk,iobs) = dlbuff(jk,jobs)
end do
end do
case(V3D_TEMP)
istat = prof_gvar(IHDL,DLBUFF,V3D_TEMP)
do jobs = 1, kobs
iobs = kotag(jobs)
do jk = 1, nflev
gomt(jk,iobs) = dlbuff(jk,jobs)
end do
end do
case(V3D_SPHU)
istat = prof_gvar(IHDL,DLBUFF,V3D_SPHU)
do jobs = 1, kobs
iobs = kotag(jobs)
do jk = 1, nflev
gomq(jk,iobs) = dlbuff(jk,jobs)
end do
end do
*
* TRACERS
*
case(V3D_O3)
IF(NOCMT .GT. 0) THEN
DO JTR = 1,NOCMT
IF(CMVOCMT(JTR) .EQ. 'O3') THEN
ITR = JTR
istat = prof_gvar(IHDL,DLBUFF,V3D_O3)
do jobs = 1, kobs
iobs = kotag(jobs)
do jk = 1, nflev
ITRLEV = (ITR-1)*NFLEV + JK
gomtr(itrlev,iobs) = dlbuff(jk,jobs)
end do
end do
endif
END DO
ENDIF
case(V3D_CH4)
IF(NOCMT .GT. 0) THEN
DO JTR = 1,NOCMT
IF(CMVOCMT(JTR) .EQ. 'CH4') THEN
ITR = JTR
istat = prof_gvar(IHDL,DLBUFF,V3D_CH4)
do jobs = 1, kobs
iobs = kotag(jobs)
do jk = 1, nflev
ITRLEV = (ITR-1)*NFLEV + JK
gomtr(itrlev,iobs) = dlbuff(jk,jobs)
end do
end do
endif
END DO
ENDIF
case(V3D_N2O)
IF(NOCMT .GT. 0) THEN
DO JTR = 1,NOCMT
IF(CMVOCMT(JTR) .EQ. 'N2O') THEN
ITR = JTR
istat = prof_gvar(IHDL,DLBUFF,V3D_N2O)
do jobs = 1, kobs
iobs = kotag(jobs)
do jk = 1, nflev
ITRLEV = (ITR-1)*NFLEV + JK
gomtr(itrlev,iobs) = dlbuff(jk,jobs)
end do
end do
endif
END DO
ENDIF
case(V2D_PSUR)
istat = prof_gvar(IHDL,DLBUFF2d,V2D_PSUR)
do jobs = 1, kobs
iobs = kotag(jobs)
gomps(1,iobs) = dlbuff2d(jobs)
end do
case(V2D_TGRN)
istat = prof_gvar(IHDL,DLBUFF2d,V2D_TGRN)
do jobs = 1, kobs
iobs = kotag(jobs)
C gomtgr(1,iobs) = dlbuff2d(jobs)
gomtgr(1,iobs) = 0.
end do
end select
*
end subroutine getfld
end subroutine getprof