!-------------------------------------- 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 --------------------------------------
!
subroutine putprofad 2,13
use mod4dv
, only : mvar, maxxy
USE obstag
USE procs_topo
USE modfgat,only : istepobs,icount,istepobs_last,nstepobs,nobs,notag ,id_nonzero
implicit none
*
* Author: Simon Pellerin *ARMA/SMC Nov. 2001
* Purpose: Write adjoint profile in prof file for adjoint model integration
*
* Revision:
* S. Pellerin *ARMA/SMC Feb. 2002
* . Fix for automatic arrays dimensioned from common block
* (causing problems with PGI compilation)
* . Fix to Model tag writing
* S. Pellerin, ARMA, August 2008
* - Added calls to 'tmg_*' subroutines
* Bin He, ARMA, Jan. 2009
* - Implemented MPI to 3/4DVAR
* E. Lapalme, May 2011
* - changed path to .prof file to include subdirectory named by the MPI tile number
* Bin He, *ARMA/MRB* DEC. 2011
* - added communication among processors to find the first one which has non-zero observations.
*
#include "comdim.cdk"
#include "comlun.cdk"
#include "comdimo.cdk"
#include "commvo.cdk"
#include "comcva.cdk"
#include "comvfiles.cdk"
#include <prof_f.h>
c
c Local variables
c
integer ihdlout, prof_wrrec, imvar, ix, iy, jx, jy
integer iobs, istat, jk, jobs,i,j, jlat, jbit,ipes
character (len=512) :: clprof
character (len=2) :: cljx, cljy,cistep
integer ier
real*8, allocatable, dimension(:,:) :: dlbuff
real*8, allocatable, dimension(:) :: dlbuff2d
integer, allocatable, dimension(:) :: ibuff2d
integer, allocatable, dimension(:) :: nobs_g
integer :: istep1
c
write(nulout,*) 'IN PUTPROFAD for simulation ',nsim3d,' istepobs= ',istepobs,' nobs=',nobs(istepobs)
call vflush(nulout)
c
allocate(dlbuff(nflev,nobtot))
allocate(dlbuff2d(nobtot))
allocate(ibuff2d(nobtot))
allocate(nobs_g(nprocs))
ix = 0
iy = 0
call mvbits(maxxy,16,16,ix,0)
call mvbits(maxxy,0,16,iy,0)
c
imvar = mvar
imvar = ibset(imvar,v2d_mtag)
write(nulout,*) 'Entering PUTPROFAD for simulation ',nsim3d
call vflush(nulout)
c
jx=myidx
jy=myidy
istep1=istepobs-1
ipes = 0
ipes = ishft(jx,16)
call mvbits(jy,0,16,ipes,0)
c
write(cljx,'(i2.2)') myidx
write(cljy,'(i2.2)') myidy
write(cistep,'(i2.2)') istep1
ccc clprof = trim(CEXC4DV) // '/dwya_'//cljx//'_'//cljy//'_'//cistep//'.prof'
ccc clprof = trim(CEXC4DV) // '/' // cljx//'_'//cljy // '/dwya_'//cljx//'_'//cljy//'_'//cistep//'.prof'
clprof = trim(CEXC4DV) // '/' // cljx//'_'// cljy //'_'// cistep // '/dwya_'//cljx//'_'//cljy//'_'//cistep//'.prof'
c
IF(nobs(istepobs) > 0) THEN
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
istat = 0
do jbit = 0,31
if(btest(imvar,jbit)) call putfld(jbit,istat,ipes)
enddo
c
if(istat == 0) then
ISTAT = PROF_PVAR(IHDLOUT,nsim3d,PRM_EVNT) + istat
call tmg_start(81,'PROF_R+W')
ISTAT = prof_wrrec(IHDLOUT) + istat
ISTAT = PROF_CLOSE(IHDLOUT)
call tmg_stop(81)
write(nulout,*)'Close IHDLOUT'
call vflush(nulout)
c
else
write(nulout,*)
& 'PUTPROFAD - ERROR : Problems pushing fields in prof ',
& 'data base'
call vflush(nulout)
ISTAT = PROF_PVAR(IHDLOUT,evn_ferr,PRM_EVNT)
call tmg_start(81,'PROF_R+W')
ISTAT = PROF_CLOSE(IHDLOUT)
call tmg_stop(81)
IF(myid == id_nonzero) THEN
clprof = trim(CEXC4DV) // '/evnt.prof'
WRITE(NULOUT,*)'PUTPROFAD - SENDING EVN_FERR SIGNAL :'
& ,EVN_FERR
call vflush(nulout)
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_FERR,PRM_EVNT)
call tmg_start(81,'PROF_R+W')
istat = prof_wrrec(ihdlout)
ISTAT = PROF_CLOSE(IHDLOUT)
call tmg_stop(81)
ENDIF
call abort3d(nulout,'PUTPROFAD')
endif
ENDIF ! ==> if (nobs(istepobs) >0)
c
IF(myid == id_nonzero .and. istepobs == istepobs_last ) THEN
clprof = trim(CEXC4DV) // '/evnt.prof'
WRITE(NULOUT,*)'PUTPROFAD - SENDING EVN_ADJM SIGNAL :'
& ,EVN_ADJM
call vflush(nulout)
IHDLOUT = PROF_OPEN(clprof,'WRITE','FILE')
ISTAT = PROF_PVAR(IHDLOUT,EVN_ADJM,PRM_EVNT)
call tmg_start(81,'PROF_R+W')
istat = prof_wrrec(ihdlout)
ISTAT = PROF_CLOSE(IHDLOUT)
call tmg_stop(81)
ENDIF
c
ccc CALL RPN_COMM_barrier("GRID",ier)
deallocate(dlbuff)
deallocate(dlbuff2d)
deallocate(ibuff2d)
deallocate(nobs_g)
write(nulout,*) 'Leaving PUTPROFAD'
call vflush(nulout)
contains
subroutine putfld(kbit,kstat,kpes) 1
c
integer, intent(in) :: kbit, kpes
integer, intent(inout) :: kstat
! Local variables
integer :: mobs,iobs,kobs
c
select case(kbit)
case(V3D_UTRU)
DO mobs=1,nobs(istepobs)
jobs=notag(mobs,istepobs)
!iobs = locObsTag0(jobs)
!i = ObsTagLoc(iobs)
DO jk = 1,nflev
dlbuff(jk,mobs) = gomu(jk,jobs)
ENDDO
ENDDO
kstat = PROF_PVAR(IHDLOUT,dlbuff(1:nflev,1:nobs(istepobs)),V3D_UTRU) + kstat
case(V3D_VTRU)
DO mobs=1,nobs(istepobs)
jobs=notag(mobs,istepobs)
!iobs = locObsTag0(jobs)
!i = ObsTagLoc(iobs)
DO jk = 1,nflev
dlbuff(jk,mobs) = gomv(jk,jobs)
ENDDO
ENDDO
KSTAT = PROF_PVAR(IHDLOUT,dlbuff(1:nflev,1:nobs(istepobs)),V3D_VTRU) + kstat
case(V3D_TEMP)
DO mobs=1,nobs(istepobs)
jobs=notag(mobs,istepobs)
!iobs = locObsTag0(jobs)
!i = ObsTagLoc(iobs)
DO jk = 1,nflev
dlbuff(jk,mobs) = gomt(jk,jobs)
ENDDO
ENDDO
KSTAT = PROF_PVAR(IHDLOUT,dlbuff(1:nflev,1:nobs(istepobs)),V3D_TEMP) + kstat
case(V3D_SPHU)
DO mobs=1,nobs(istepobs)
jobs=notag(mobs,istepobs)
!iobs = locObsTag0(jobs)
!i = ObsTagLoc(iobs)
DO jk = 1,nflev
dlbuff(jk,mobs) = gomq(jk,jobs)
ENDDO
ENDDO
KSTAT = PROF_PVAR(IHDLOUT,dlbuff(1:nflev,1:nobs(istepobs)),V3D_SPHU) + kstat
case(V2D_PSUR)
DO mobs=1,nobs(istepobs)
jobs=notag(mobs,istepobs)
!iobs = locObsTag0(jobs)
!i = ObsTagLoc(iobs)
dlbuff2d(mobs) = gomps(1,jobs)
ENDDO
KSTAT = PROF_PVAR(IHDLOUT,dlbuff2d(1:nobs(istepobs)),V2D_PSUR) + kstat
case(V2D_TGRN)
DO mobs=1,nobs(istepobs)
jobs=notag(mobs,istepobs)
!iobs = locObsTag0(jobs)
!i = ObsTagLoc(iobs)
dlbuff2d(mobs) = gomtgr(1,jobs)
ENDDO
KSTAT = PROF_PVAR(IHDLOUT,dlbuff2d(1:nobs(istepobs)),V2D_TGRN) + kstat
case(V2D_MTAG)
DO mobs=1,nobs(istepobs)
jobs=notag(mobs,istepobs)
!!! iobs = locObsTag0(jobs)
!!! ibuff2d(mobs) = mtag(iobs)
ibuff2d(mobs) = mtag(jobs)
end do
KSTAT = PROF_PVAR(IHDLOUT,ibuff2D(1:nobs(istepobs)),V2D_MTAG) + kstat
end select
end subroutine putfld
end subroutine putprofad