!-------------------------------------- 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 1,7
use mod4dv
, only : mvar, maxxy
USE obstag
USE procs_topo
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
*
#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
integer ier
real*8, allocatable, dimension(:,:) :: dlbuff
real*8, allocatable, dimension(:) :: dlbuff2d
integer, allocatable, dimension(:) :: ibuff2d
c
c
allocate(dlbuff(nflev,nobtot))
allocate(dlbuff2d(nobtot))
allocate(ibuff2d(nobtot))
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
ipes = 0
ipes = ishft(jx,16)
call mvbits(jy,0,16,ipes,0)
c
write(cljx,'(i2.2)') myidx
write(cljy,'(i2.2)') myidy
clprof = trim(CEXC4DV) // '/dwya_'//cljx//'_'//cljy//'.prof'
write(nulout,*) 'write to: ',clprof
c
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'
c
else
write(nulout,*)
& 'PUTPROFAD - ERROR : Problems pushing fields in prof ',
& 'data base'
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 == 0) THEN
clprof = trim(CEXC4DV) // '/evnt.prof'
WRITE(NULOUT,*)'PUTPROFAD - SENDING EVN_FERR SIGNAL :'
& ,EVN_FERR
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
c
IF(myid == 0) THEN
clprof = trim(CEXC4DV) // '/evnt.prof'
WRITE(NULOUT,*)'PUTPROFAD - SENDING EVN_ADJM SIGNAL :'
& ,EVN_ADJM
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
CALL RPN_COMM_barrier("GRID",ier)
deallocate(dlbuff)
deallocate(dlbuff2d)
deallocate(ibuff2d)
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 :: iobs,kobs
c
select case(kbit)
case(V3D_UTRU)
DO jobs=1,nobtot
iobs = locObsTag0(jobs)
i = ObsTagLoc(iobs)
DO jk = 1,nflev
dlbuff(jk,jobs) = gomu(jk,i)
ENDDO
ENDDO
kstat = PROF_PVAR(IHDLOUT,dlbuff(1:nflev,1:nobtot),V3D_UTRU) + kstat
case(V3D_VTRU)
DO jobs=1,nobtot
iobs = locObsTag0(jobs)
i = ObsTagLoc(iobs)
DO jk = 1,nflev
dlbuff(jk,jobs) = gomv(jk,i)
ENDDO
ENDDO
KSTAT = PROF_PVAR(IHDLOUT,dlbuff(1:nflev,1:nobtot),V3D_VTRU) + kstat
case(V3D_TEMP)
DO jobs=1,nobtot
iobs = locObsTag0(jobs)
i = ObsTagLoc(iobs)
DO jk = 1,nflev
dlbuff(jk,jobs) = gomt(jk,i)
ENDDO
ENDDO
KSTAT = PROF_PVAR(IHDLOUT,dlbuff(1:nflev,1:nobtot),V3D_TEMP) + kstat
case(V3D_SPHU)
DO jobs=1,nobtot
iobs = locObsTag0(jobs)
i = ObsTagLoc(iobs)
DO jk = 1,nflev
dlbuff(jk,jobs) = gomq(jk,i)
ENDDO
ENDDO
KSTAT = PROF_PVAR(IHDLOUT,dlbuff(1:nflev,1:nobtot),V3D_SPHU) + kstat
case(V2D_PSUR)
DO jobs=1,nobtot
iobs = locObsTag0(jobs)
i = ObsTagLoc(iobs)
dlbuff2d(jobs) = gomps(1,i)
ENDDO
KSTAT = PROF_PVAR(IHDLOUT,dlbuff2d(1:nobtot),V2D_PSUR) + kstat
case(V2D_TGRN)
DO jobs=1,nobtot
iobs = locObsTag0(jobs)
i = ObsTagLoc(iobs)
dlbuff2d(jobs) = gomtgr(1,i)
ENDDO
KSTAT = PROF_PVAR(IHDLOUT,dlbuff2d(1:nobtot),V2D_TGRN) + kstat
case(V2D_MTAG)
do jobs = 1, nobtot
iobs = locObsTag0(jobs)
ibuff2d(jobs) = mtag(iobs)
end do
KSTAT = PROF_PVAR(IHDLOUT,ibuff2D(1:nobtot),V2D_MTAG) + kstat
end select
end subroutine putfld
end subroutine putprofad