!-------------------------------------- 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 --------------------------------------
***s/r v4d_readinit - read lat-lon observations positions from init PROF file and
* evaluate associated px,py grid positioning needed in EZSCINT package
*
#include "model_macros_f.h"
*
subroutine v4d_readinit 2,13
*
use v4d_prof
*
implicit none
*
*author Nils Ek
*
*revision
* v3_00 - N. Ek - initial MPI version
* v3_00 - M. Tanguay - adapt to Simon's exchange
* v3_01 - M. Tanguay - correction for empty processors
* - introduce GAUSS=GEM option
* v3_02 - M. Buehner - changed file and subroutine names to "init"
* - read the restart iteration no. and SGVC parameters
* v3_11 - M. Tanguay - correct relationship between stepob and timestep
* - Remove V4dg_ga_eq_ge_L
* - Add option for profiles done on U-V grids for winds
* v3_20 - Zadra A. - Introduce V4dg_sgvc_dt0
* v3_20 - M. Tanguay - Modifications to allow different cutoff
*
*object
*
*arguments
* none
*
*constants
*
*implicits
#include "glb_ld.cdk"
#include "geomn.cdk"
#include "hgc.cdk"
#include "lun.cdk"
#include "out3.cdk"
#include "ptopo.cdk"
#include "lctl.cdk"
#include "step.cdk"
#include "tr3d.cdk"
#include "v4dg.cdk"
#include "dcst.cdk"
#include "cstv.cdk"
#include "path.cdk"
#include <clib_interface.cdk>
#include <prof_f.h>
*
integer ezqkdef,newdate,ezgdef_fmem,gdxyfll,gdrls,prof_rdrec,incdat,incdatr
external ezqkdef,newdate,ezgdef_fmem,gdxyfll,gdrls,prof_rdrec,incdat,incdatr
*
logical ropr_L,rdvar_L
*
integer gdin,gdinu,gdinv,pnerr,ier,jer,i,j,k,kkk,nnn,n,ntime,
% ihdlin0,irec,nrec,iprof,stepob,pdtst,nowdtst,startdate,enddate,
% isize,mytag,nrectot,testmaxprof,sumzero,ifact,middle,nbin,middle_3dvar
*
character*256 pathob_S
*
real*8 hrperiod_8,hrdiff_8,hour_8
*
integer nrecmax
parameter (nrecmax = 100)
*
logical firstrec_L
*
* Structures used for transferring obs. profile info from
* global file format to local processor format
* -------------------------------------------------------
type lalo8prof
sequence
integer, pointer, dimension(:) :: obstag ! Observations' tags
integer, pointer, dimension(:) :: mdltag ! Model's tags
integer, pointer, dimension(:) :: locproc! 1 if profile on processor
real, pointer, dimension(:) :: pxg ! PX global index
real, pointer, dimension(:) :: pyg ! PY global index
real, pointer, dimension(:) :: pxug ! PX global index (U)
real, pointer, dimension(:) :: pyvg ! PY global index (V)
real*8, pointer, dimension(:) :: lat ! Latitudes in degrees
real*8, pointer, dimension(:) :: lon ! Longitudes in degrees
integer :: inmvar ! Binary variable indicator
integer :: nprof ! Number of profiles
end type lalo8prof
*
type (lalo8prof), dimension(nrecmax):: g_pf ! NB the type !!!
*
integer dat1,dat2
* ____________________________________________________________
*
* Nullify pointers for prof_gvar
* ------------------------------
do nrec = 1,nrecmax
nullify( g_pf(nrec) % lat, g_pf(nrec) % lon, g_pf(nrec) % obstag)
end do
*
* Switch for debugging output
* ---------------------------
ropr_L = .false.
*
* Open init PROF file (TYPE1) containing lat-lon observations positions
* ---------------------------------------------------------------------
pathob_S = trim(Path_xchg_S)//'/init.prof'
*
write(Lun_out,*) 'Opening file: ',trim(pathob_S)
*
ihdlin0 = prof_open(pathob_S,'READ','FILE' )
*
if(ihdlin0.lt.0) then
write(Lun_out,*) ' ERROR WHILE OPENING init PROF file'
call gem_stop('v4d_readinit',-1)
endif
*
* *****************************************************************************
* Read Initialization file for SGVC job
* --------------------------------------
if(V4dg_sgvc_L) then
*
* Read record to get numsegs and restart iteration
* ------------------------------------------------
ier = prof_rdrec(ihdlin0)
*
if(ier.ne.0) then
write(Lun_out,*) 'Error: cannot read RECORD'
call gem_stop('v4d_readinit',-1)
endif
*
firstrec_L = .true.
*
* Get number of iterations already done for restart job
* -----------------------------------------------------
pnerr = prof_gvar(ihdlin0, Pr_nsim4d, PRM_RSTR)
if(pnerr.ne.0) then
write(Lun_out,*) 'Error: cannot read Pr_nsim4d, setting to zero'
c call gem_stop('v4d_readinit',-1)
Pr_nsim4d=0
else
write(Lun_out,*) 'Pr_nsim4d= ',Pr_nsim4d
if(Pr_nsim4d.lt.0) Pr_nsim4d=0
endif
*
* Get number of segments for SV calculation (in stepob)
* -----------------------------------------------------
pnerr = prof_gvar(ihdlin0, V4dg_numseg, PRM_STOB)
if(pnerr.ne.0) then
write(Lun_out,*) 'Error: cannot read NUMSEG'
call gem_stop('v4d_readinit',-1)
else
write(Lun_out,*) 'NUMSEG= ',V4dg_numseg
endif
*
ier = prof_close(ihdlin0,.false.)
*
* *****************************************************************************
* Read Initialization file for 4dvar job
* --------------------------------------
elseif(V4dg_4dvar_L) then
*
* Initialize the date-time stamp for the current integration
* ----------------------------------------------------------
ier = newdate ( Out3_date, dat1, dat2, -3 )
C ier = newdate(startdate, Out1_dato(1) ,Out1_dato(2), 3)
ier = newdate(startdate, dat1 , dat2, 3)
*
write(Lun_out,*)
C % 'Initial date-time stamp (YYYYMMDD,HHMMSSHH): ',Out1_dato(1)
C % ,Out1_dato(2)
% 'Initial date-time stamp (YYYYMMDD,HHMMSSHH): ',dat1,dat2
*
if(Pr_traj0to9_L) then
*
if(.not.V4dg_sgvc_L) then
*
* Add 3hr to the date-time stamp of the given analysis at t=0 hr
* --------------------------------------------------------------
write(Lun_out,*) 'TRAJ0TO9_L is TRUE: STARTING DATE OF INTEGRATION = ANALYSIS (0HR) + 3HR'
ier = incdat(startdate, startdate, 3 )
endif
*
if(V4dg_sgvc_L) then
*
* Add N hr to the date-time stamp of the given analysis at t=0 hr
* ------_--------------------------------------------------------
write(Lun_out,*) 'TRAJ0TO9_L is TRUE: STARTING DATE OF INTEGRATION = ANALYSIS (0HR) + N HR'
ier = incdat(startdate, startdate, v4dg_sgvc_dt0 )
endif
*
else
*
write(Lun_out,*) 'TRAJ0TO9_L is FALSE: STARTING DATE OF INTEGRATION = ANALYSIS (3HR)'
*
endif
*
ier = newdate(startdate, i, j, -3)
write(Lun_out,*) 'STARTING DATE OF INTEGRATION PERIOD ',i,j
*
* Initialize the date-time stamp of the end of the integration period
* -------------------------------------------------------------------
ier = incdatr(enddate, startdate, (Step_total*Cstv_dt_8/3600.) )
ier = newdate(enddate, i, j, -3)
write(Lun_out,*) ' END DATE OF INTEGRATION PERIOD ',i,j
*
call difdatr(enddate,startdate,hrperiod_8)
write(Lun_out,*) 'ASSIMILATION PERIOD in hours = ',hrperiod_8
*
write(Lun_out,9000)
*
* Define input grid to locate pxg-pyg global grid positioning
* of each profile
* -----------------------------------------------------------
gdin = ezgdef_fmem ( G_ni,G_nj,'Z',Hgc_gxtyp_s,
% Hgc_ig1ro, Hgc_ig2ro, Hgc_ig3ro, Hgc_ig4ro,
% Geomn_longs, Geomn_latgs)
*
if(V4dg_pruv_L) then
*
gdinu = ezgdef_fmem ( G_niu,G_nj,'Z',Hgc_gxtyp_s,
% Hgc_ig1ro, Hgc_ig2ro, Hgc_ig3ro, Hgc_ig4ro,
% Geomn_longu, Geomn_latgs)
*
gdinv = ezgdef_fmem( G_ni,G_njv,'Z',Hgc_gxtyp_s,
% Hgc_ig1ro, Hgc_ig2ro, Hgc_ig3ro, Hgc_ig4ro,
% Geomn_longs, Geomn_latgv)
*
endif
*
* -------------------------------------------------------------------------
* Loop over all the records and check if date is in the assimilation period
* -------------------------------------------------------------------------
*
* Initialize counter for maximal number of profiles in init PROF file
* -------------------------------------------------------------------
Pr_maxprof = 0
*
* Initialize counter for maximal number of profiles in each local processor
* -------------------------------------------------------------------------
Pr_nobproc = 0
*
* Read one record to get stepob
* -----------------------------
ier = prof_rdrec(ihdlin0)
*
if(ier.ne.0) then
write(Lun_out,*) 'Error: cannot read RECORD'
call gem_stop('v4d_readinit',-1)
endif
*
firstrec_L = .true.
*
* Get number of iterations already done for restart job
* -----------------------------------------------------
pnerr = prof_gvar(ihdlin0, Pr_nsim4d, PRM_RSTR)
if(pnerr.ne.0) then
write(Lun_out,*) 'Error: cannot read Pr_nsim4d'
call gem_stop('v4d_readinit',-1)
else
write(Lun_out,*) 'Pr_nsim4d= ',Pr_nsim4d
if(Pr_nsim4d.lt.0) Pr_nsim4d=0
endif
*
* Get stepob in minutes
* ---------------------
pnerr = prof_gvar(ihdlin0, stepob, PRM_STOB)
*
if(pnerr.ne.0) then
write(Lun_out,*) 'Error: cannot read PRM_STOB'
call gem_stop('v4d_readinit',-1)
endif
*
write(Lun_out,*) 'Stepob (minutes) from 3D-Var =',stepob
*
* --------------------------------------------------------
* Evaluate at which timesteps are located the observations
* --------------------------------------------------------
*
* Evaluate corresponding V4dg_stepob
* ----------------------------------
V4dg_stepob = nint(float(stepob*60)/Cstv_dt_8)
write(Lun_out,*) 'V4dg_stepob (Lctl_step unit) in GEM ',V4dg_stepob
*
if(V4dg_stepob*Cstv_dt_8.ne.stepob*60) goto 9999
*
* Set middle of the assimilation period as used in 3D-Var in minutes
* (CAUTION: It is hard coded)
* ------------------------------------------------------------------
middle_3dvar = 3.*60.
*
write(Lun_out,*) 'Middle of the assimilation period (minutes) as used in 3D-Var (CAUTION: Hard coded) =',middle_3dvar
*
* Do the conversion in Lctl_step unit
* -----------------------------------
middle = nint(float(middle_3dvar*60)/Cstv_dt_8)
*
write(Lun_out,*) 'Middle of the assimilation period (Lctl_step unit) in GEM ',middle
*
ifact = middle/V4dg_stepob
*
Pr_ibin0 = (middle-ifact*V4dg_stepob)
*
Pr_maxbin = 2*ifact + 1
*
write(Lun_out,*) 'READINIT Pr_ibin0 ',Pr_ibin0
write(Lun_out,*) 'READINIT ifact ',ifact
write(Lun_out,*) 'READINIT middle ',middle
write(Lun_out,*) 'READINIT Pr_maxbin ',Pr_maxbin
*
if(Pr_upperbin.lt.Pr_maxbin) then
write(Lun_out,*) 'Error: Pr_maxbin is not big enough'
call gem_stop('v4d_readinit',-1)
endif
*
* Initialize counter for maximal number of profiles in the local processor
* as function of bin
* ------------------------------------------------------------------------
allocate( Pr_nob (Pr_maxbin), STAT=pnerr)
do n = 1,Pr_maxbin
Pr_nob(n) = 0
enddo
*
* Initialize counter for maximal number of profiles in the local processor
* as function of variable and bin
* ------------------------------------------------------------------------
do i = 1,Pr_maxnmv
do n = 1,Pr_maxbin
Pr_l_mv(i,n) % nprof = 0
enddo
enddo
*
* Allocate doobs who identify if obs available at a particular timestep
* ---------------------------------------------------------------------
allocate( Pr_doobs (0:Step_total), STAT=pnerr)
*
* Initialization to ZERO
* ----------------------
do n = 0,Step_total
Pr_doobs(n) = 0
enddo
*
* Loop over all bins
* ------------------
do nbin = 1,Pr_maxbin
*
ntime = (Pr_ibin0 + (nbin-1) * V4dg_stepob)
hour_8 = (ntime * Cstv_dt_8)/3600.
*
* Update nowdtst for the current read
* -----------------------------------
jer = incdatr( nowdtst , startdate, hour_8 )
jer = newdate( nowdtst, k, kkk, -3)
write(Lun_out,*) 'Search for record with date-time stamp: ',nowdtst,k,kkk
*
if(.not.firstrec_L) ihdlin0 = prof_open(pathob_S,'READ','FILE' )
*
nrec = 0
nrectot = 0
readrec: do
*
if(.not.firstrec_L) ier = prof_rdrec(ihdlin0)
firstrec_L = .false.
*
nrectot = nrectot + 1
*
if(ier.eq.0) then ! Record is read
*
* Get the date time-stamp
* -----------------------
pnerr = prof_gvar(ihdlin0, pdtst, PRM_DTST)
*
if(pnerr.ne.0) then
write(Lun_out,*) 'Error: cannot read PRM_DTST'
call gem_stop('v4d_readinit',-1)
endif
*
ier = newdate(pdtst, k, kkk, -3)
if(ropr_L) write(Lun_out,*) 'Current record has date-time stamp: ',pdtst,k,kkk
*
* Evaluate difference (hours) between the date-time stamp of the record and startdate
* -----------------------------------------------------------------------------------
call difdatr(pdtst,startdate,hrdiff_8)
*
* Verify if record is in the assimilation period
* ----------------------------------------------
if(.not.(hrdiff_8.ge.0.0.and.hrdiff_8.le.hrperiod_8)) then
write(Lun_out,*) 'DATE_TIME STAMP OF RECORD NOT IN THE ASSIMILATION PERIOD'
call gem_stop('v4d_readinit',-1)
endif
*
* The record is at the appropriate bin
* ------------------------------------
if(nowdtst.eq.pdtst) then
*
nrec = nrec + 1
*
if(nrec.gt.nrecmax) then
write(Lun_out,*) 'Error: NRECMAX IS NOT BE ENOUGH'
call gem_stop('v4d_readinit',-1)
endif
*
Pr_doobs(ntime) = 1
*
write(Lun_out,*) ' Right date-time stamp for Record Number =',nrectot
*
* Read lat-lon of record
* ----------------------
pnerr = prof_gvar(ihdlin0, g_pf(nrec) % lat, V2D_LATI)
*
g_pf(nrec) % nprof = size(g_pf(nrec) % lat,1)
*
write(Lun_out,*) ' Total number of profiles in this record =',g_pf(nrec) % nprof
*
pnerr = prof_gvar(ihdlin0, g_pf(nrec) % lon, V2D_LONG)
*
* Allocations
* -----------
allocate( g_pf(nrec) % mdltag (g_pf(nrec) % nprof), STAT=pnerr)
allocate( g_pf(nrec) % locproc(g_pf(nrec) % nprof), STAT=pnerr)
allocate( g_pf(nrec) % pxg (g_pf(nrec) % nprof), STAT=pnerr)
allocate( g_pf(nrec) % pyg (g_pf(nrec) % nprof), STAT=pnerr)
*
if(V4dg_pruv_L) then
*
allocate( g_pf(nrec) % pxug (g_pf(nrec) % nprof), STAT=pnerr)
allocate( g_pf(nrec) % pyvg (g_pf(nrec) % nprof), STAT=pnerr)
*
endif
*
ier = gdxyfll(gdin, g_pf(nrec) % pxg, g_pf(nrec) % pyg,
$ sngl(g_pf(nrec) % lat), sngl(g_pf(nrec) % lon),
$ g_pf(nrec) % nprof)
*
if(V4dg_pruv_L) then
*
ier = gdxyfll(gdinu,g_pf(nrec) % pxug, g_pf(nrec) % pyg,
$ sngl(g_pf(nrec) % lat), sngl(g_pf(nrec) % lon),
$ g_pf(nrec) % nprof)
*
ier = gdxyfll(gdinv,g_pf(nrec) % pxg, g_pf(nrec) % pyvg,
$ sngl(g_pf(nrec) % lat), sngl(g_pf(nrec) % lon),
$ g_pf(nrec) % nprof)
*
endif
*
* Identify to which processor belongs each observation
* ------------------------------------------------------------------
* NOTE: Scalar grid identifies the processor even if V4dg_pruv_L=.T.
* ------------------------------------------------------------------
do 400 i = 1, g_pf(nrec) % nprof
*
* Observations in the interior
* ----------------------------
if ( (g_pf(nrec) %pxg(i).gt.Ptopo_gindx(1,Ptopo_myproc+1)-1) .and.
$ (g_pf(nrec) %pxg(i).le.Ptopo_gindx(2,Ptopo_myproc+1) ) .and.
$ (g_pf(nrec) %pyg(i).gt.Ptopo_gindx(3,Ptopo_myproc+1)-1) .and.
$ (g_pf(nrec) %pyg(i).le.Ptopo_gindx(4,Ptopo_myproc+1) ) ) then
*
Pr_nobproc = Pr_nobproc + 1
Pr_nob(nbin) = Pr_nob(nbin) + 1
*
g_pf(nrec) % mdltag (i) = Pr_nobproc
g_pf(nrec) % locproc(i) = 1
goto 400
endif
*
* Observations after last north latitude
* --------------------------------------
if ( (g_pf(nrec) %pxg(i).gt.Ptopo_gindx(1,Ptopo_myproc+1)-1) .and.
$ (g_pf(nrec) %pxg(i).le.Ptopo_gindx(2,Ptopo_myproc+1) ) .and.
$ (g_pf(nrec) %pyg(i).gt.G_nj.and.l_north ) ) then
*
Pr_nobproc = Pr_nobproc + 1
Pr_nob(nbin) = Pr_nob(nbin) + 1
*
g_pf(nrec) % mdltag (i) = Pr_nobproc
g_pf(nrec) % locproc(i) = 1
goto 400
endif
*
* Observations past easternmost longitude
* ---------------------------------------
if ( (g_pf(nrec) %pyg(i).gt.Ptopo_gindx(3,Ptopo_myproc+1)-1) .and.
$ (g_pf(nrec) %pyg(i).le.Ptopo_gindx(4,Ptopo_myproc+1) ) .and.
$ (g_pf(nrec) %pxg(i).gt.G_ni.and.l_east ) ) then
*
Pr_nobproc = Pr_nobproc + 1
Pr_nob(nbin) = Pr_nob(nbin) + 1
*
g_pf(nrec) % mdltag (i) = Pr_nobproc
g_pf(nrec) % locproc(i) = 1
goto 400
endif
*
* Observations past easternmost longitude
* and after last north latitude
* ---------------------------------------
if ( (g_pf(nrec) %pxg(i).gt.G_ni.and.l_east ) .and.
$ (g_pf(nrec) %pyg(i).gt.G_nj.and.l_north) ) then
*
Pr_nobproc = Pr_nobproc + 1
Pr_nob(nbin) = Pr_nob(nbin) + 1
*
g_pf(nrec) % mdltag (i) = Pr_nobproc
g_pf(nrec) % locproc(i) = 1
goto 400
endif
*
g_pf(nrec) % locproc(i) = 0
if(ropr_L) write(Lun_out,*) 'NOT WITH THIS PROCESSOR',
$ g_pf(nrec) % lon(i),g_pf(nrec) % lat(i)
*
400 continue
*
* Verify which observation do not belong to any processor
* -------------------------------------------------------
if(ropr_L) then
do i = 1, g_pf(nrec) % nprof
call rpn_comm_ALLREDUCE (g_pf(nrec) % locproc(i),sumzero,1,"MPI_INTEGER","MPI_SUM","grid",pnerr)
if(sumzero.eq.0) then
write(Lun_out,*) 'DO NOT BELONG TO ANY PROCESSOR ',i,'LON = ',g_pf(nrec) % lon(i)
write(Lun_out,*) 'DO NOT BELONG TO ANY PROCESSOR ',i,'LAT = ',g_pf(nrec) % lat(i)
write(Lun_out,*) 'DO NOT BELONG TO ANY PROCESSOR ',i,'PXG = ',g_pf(nrec) % pxg(i)
write(Lun_out,*) 'DO NOT BELONG TO ANY PROCESSOR ',i,'PYG = ',g_pf(nrec) % pyg(i)
endif
enddo
endif
*
if(ropr_L) then
do i = 1, g_pf(nrec) % nprof
if(g_pf(nrec) % locproc(i).ne.0) then
write(Lun_out,*) i,'LON = ',g_pf(nrec) % lon(i)
write(Lun_out,*) i,'LAT = ',g_pf(nrec) % lat(i)
write(Lun_out,*) i,'PXG = ',g_pf(nrec) % pxg(i)
write(Lun_out,*) i,'PYG = ',g_pf(nrec) % pyg(i)
endif
enddo
endif
*
* Deallocation if lat-lon not requested
* -------------------------------------
deallocate( g_pf(nrec) %lat, STAT=ier )
deallocate( g_pf(nrec) %lon, STAT=ier )
*
* Read inmvar of record
* ---------------------
pnerr = prof_gvar(ihdlin0, g_pf(nrec) % inmvar, PRM_MVAR)
*
* Read obstag of record
* ---------------------
pnerr = prof_gvar(ihdlin0, g_pf(nrec) % obstag, V2D_OTAG)
*
* Increase maximal number of profiles available over the assimilation period
* --------------------------------------------------------------------------
Pr_maxprof = Pr_maxprof + g_pf(nrec) % nprof
*
else
if(ropr_L) write(Lun_out,*) 'Current record has NOT right date-time stamp'
endif ! if(nowdtst.eq.pdtst) then
*
else ! couldn't read a record
*
* We are at the end of the file
* -----------------------------
exit readrec
*
endif ! ier.eq.0
*
enddo readrec
*
write(Lun_out,*) ' Local number of profiles in this record =',Pr_nob(nbin)
*
* Convert obstag,mdltag,pxg,pyg informations in l_mv structure
* ------------------------------------------------------------
if(Pr_nob(nbin).ne.0) then
*
do i = 1,Pr_nvars
*
if(Pr_varindx(i).ne.V3D_VTRU) then ! skip V; U is sufficient
*
* Count local number of profiles for a given variable and a given bin
* -------------------------------------------------------------------
Pr_l_mv(Pr_varindx(i),nbin) % nprof = 0
*
do irec = 1, nrec
rdvar_L = btest( g_pf(irec) % inmvar,Pr_varindx(i) )
*
if(rdvar_L) then
*
do j = 1, g_pf(irec) % nprof ! size of this record
*
if(g_pf(irec) % locproc(j).eq.1)
$ Pr_l_mv(Pr_varindx(i),nbin) % nprof = Pr_l_mv(Pr_varindx(i),nbin) % nprof + 1
*
enddo
*
endif
*
enddo ! enddo for irec= 1, nrec
*
isize = Pr_l_mv(Pr_varindx(i),nbin) % nprof
*
* Allocate arrays for local coverage of observations
* --------------------------------------------------
allocate (Pr_l_mv(Pr_varindx(i), nbin)%px (isize), STAT=pnerr)
allocate (Pr_l_mv(Pr_varindx(i), nbin)%py (isize), STAT=pnerr)
*
if(V4dg_pruv_L) then
*
allocate (Pr_l_mv(Pr_varindx(i), nbin)%pxu (isize), STAT=pnerr)
allocate (Pr_l_mv(Pr_varindx(i), nbin)%pyv (isize), STAT=pnerr)
*
endif
*
allocate (Pr_l_mv(Pr_varindx(i), nbin)%obstag(isize), STAT=pnerr)
allocate (Pr_l_mv(Pr_varindx(i), nbin)%mdltag(isize), STAT=pnerr)
*
* Introduce obstag,mdltag,pxg,pyg informations in l_mv structure
* --------------------------------------------------------------
nnn = 0
do irec = 1, nrec
rdvar_L = btest( g_pf(irec) % inmvar,Pr_varindx(i) )
*
if(rdvar_L) then
*
if(.not.V4dg_pruv_L) then
*
do j = 1, g_pf(irec) % nprof ! size of this record
*
if(g_pf(irec) % locproc(j).eq.1) then
*
nnn = nnn + 1
*
Pr_l_mv(Pr_varindx(i),nbin) %px (nnn) = g_pf(irec) % pxg(j)
$ - Ptopo_gindx(1,Ptopo_myproc+1)+1
Pr_l_mv(Pr_varindx(i),nbin) %py (nnn) = g_pf(irec) % pyg(j)
$ - Ptopo_gindx(3,Ptopo_myproc+1)+1
Pr_l_mv(Pr_varindx(i),nbin) % obstag(nnn) = g_pf(irec) % obstag(j)
Pr_l_mv(Pr_varindx(i),nbin) % mdltag(nnn) = g_pf(irec) % mdltag(j)
*
endif
*
enddo
*
else
*
do j = 1, g_pf(irec) % nprof ! size of this record
*
if(g_pf(irec) % locproc(j).eq.1) then
*
nnn = nnn + 1
*
Pr_l_mv(Pr_varindx(i),nbin) %px (nnn) = g_pf(irec) % pxg(j)
$ - Ptopo_gindx(1,Ptopo_myproc+1)+1
Pr_l_mv(Pr_varindx(i),nbin) %py (nnn) = g_pf(irec) % pyg(j)
$ - Ptopo_gindx(3,Ptopo_myproc+1)+1
*
Pr_l_mv(Pr_varindx(i),nbin) %pxu (nnn) = g_pf(irec) % pxug(j)
$ - Ptopo_gindx(1,Ptopo_myproc+1)+1
Pr_l_mv(Pr_varindx(i),nbin) %pyv (nnn) = g_pf(irec) % pyvg(j)
$ - Ptopo_gindx(3,Ptopo_myproc+1)+1
*
Pr_l_mv(Pr_varindx(i),nbin) % obstag(nnn) = g_pf(irec) % obstag(j)
Pr_l_mv(Pr_varindx(i),nbin) % mdltag(nnn) = g_pf(irec) % mdltag(j)
*
endif
*
enddo
*
endif
*
endif
*
enddo ! enddo for irec= 1, nrec
*
endif
*
if(Pr_l_mv(Pr_varindx(i),nbin) % nprof.ne.0) write(Lun_out,*)
% ' Variable = ',i,' with local number of profiles =',Pr_l_mv(Pr_varindx(i),nbin) % nprof
*
enddo ! enddo for i = 1, Pr_nvars
*
* Set pointers for V point to those of U
* --------------------------------------
Pr_l_mv(V3D_VTRU,nbin) % nprof = Pr_l_mv(V3D_UTRU,nbin) % nprof
Pr_l_mv(V3D_VTRU,nbin) % obstag => Pr_l_mv(V3D_UTRU,nbin) % obstag
Pr_l_mv(V3D_VTRU,nbin) % mdltag => Pr_l_mv(V3D_UTRU,nbin) % mdltag
Pr_l_mv(V3D_VTRU,nbin) % px => Pr_l_mv(V3D_UTRU,nbin) % px
Pr_l_mv(V3D_VTRU,nbin) % py => Pr_l_mv(V3D_UTRU,nbin) % py
*
if(V4dg_pruv_L) then
*
Pr_l_mv(V3D_VTRU,nbin) % pxu => Pr_l_mv(V3D_UTRU,nbin) % pxu
Pr_l_mv(V3D_VTRU,nbin) % pyv => Pr_l_mv(V3D_UTRU,nbin) % pyv
*
endif
*
* Allocation for storage of profiles
* ----------------------------------
do i = 1,Pr_nvars
*
if(Pr_varindx(i).eq.V2D_PSUR) then
allocate (Pr_l_mv(Pr_varindx(i),nbin)%fprof( 1,isize), STAT=pnerr )
else
allocate (Pr_l_mv(Pr_varindx(i),nbin)%fprof(l_nk,isize), STAT=pnerr )
endif
*
enddo
*
endif
*
ier = prof_close(ihdlin0,.false.)
*
* Deallocate global input structures
* ----------------------------------
do i = 1, nrec
deallocate( g_pf(i) %obstag, STAT=ier )
deallocate( g_pf(i) %mdltag, STAT=ier )
deallocate( g_pf(i) %locproc,STAT=ier )
deallocate( g_pf(i) %pxg, STAT=ier )
deallocate( g_pf(i) %pyg, STAT=ier )
enddo
*
if(V4dg_pruv_L) then
*
do i = 1, nrec
deallocate( g_pf(i) %pxug, STAT=ier )
deallocate( g_pf(i) %pyvg, STAT=ier )
enddo
*
endif
*
enddo ! nbin =1,Pr_maxbin
*
ier = gdrls(gdin)
*
if(V4dg_pruv_L) then
ier = gdrls(gdinu)
ier = gdrls(gdinv)
endif
*
* For simulated 4DVAR cycles, Initialize a tag for each
* profile, to be used later to sort the adjoint profiles
* ------------------------------------------------------
write(Lun_out,*) ' '
write(Lun_out,*) 'Total number of profiles for all times = ',Pr_maxprof
write(Lun_out,*) 'Local number of profiles for all times = ',Pr_nobproc
*
call rpn_comm_ALLREDUCE (Pr_nobproc,testmaxprof,1,"MPI_INTEGER","MPI_SUM","grid",pnerr)
if(Pr_maxprof.ne.testmaxprof) then
write(Lun_out,*) 'Observations are lost or done twice: Sum over processors = ',testmaxprof
call gem_stop('v4d_readinit',-1)
endif
*
allocate ( Pr_mlprof (l_nk,Pr_nobproc,Pr_nvars), STAT=pnerr )
*
do nbin= 1, Pr_maxbin
*
if(Pr_nob(nbin).ne.0) then
*
do j = 1, Pr_nvars
*
nnn = Pr_l_mv(Pr_varindx(j),nbin) % nprof
*
do iprof = 1, nnn
*
mytag = Pr_l_mv(Pr_varindx(j),nbin) % mdltag(iprof)
*
if(Pr_varindx(j).eq. V2D_PSUR) then
Pr_mlprof(1,mytag,j)% ptr => Pr_l_mv(Pr_varindx(j),nbin)%fprof(1,iprof)
else
do k = 1, l_nk
Pr_mlprof(k,mytag,j)% ptr => Pr_l_mv(Pr_varindx(j),nbin)%fprof(k,iprof)
enddo
endif
*
enddo ! iprof
*
enddo ! j
*
endif
*
enddo ! nbin
*
allocate ( Pr_bintag (Pr_nobproc), STAT=pnerr )
*
* Keep bin associated to each model tag
* -------------------------------------
do nbin = 1, Pr_maxbin
*
if(Pr_nob(nbin).ne.0) then
*
do j = 1, Pr_nvars
*
nnn = Pr_l_mv(Pr_varindx(j),nbin) % nprof
*
do iprof = 1, nnn
*
mytag = Pr_l_mv(Pr_varindx(j),nbin) % mdltag(iprof)
*
Pr_bintag(mytag) = nbin
*
enddo ! iprof
*
enddo ! j
*
endif
*
enddo ! nbin
*
endif ! reading initialization file for 4dvar job
* *****************************************************************************
*
* After finishing input, set flag indicating that we are done reading
* -------------------------------------------------------------------
Pr_read_L = .true.
*
write(Lun_out,9900)
*
* Erase init file if Pr_llfrm_L is true
* -------------------------------------
call rpn_comm_barrier("GRID",ier)
if(Ptopo_myproc.eq.0) then
ihdlin0 = prof_open(pathob_S,'READ','FILE' )
ier = prof_close(ihdlin0,Pr_llfrm_L)
endif
*
1001 format(2I4, 2F10.3, 2Z12)
9000 format(
+/,'BEGIN READING OBSERVATION DATA FILE (S/R V4D_READINIT)',
+/,'=======================================================')
9900 format(
+/,'FINISHED READING OBSERVATION DATA FILE (S/R V4D_READINIT)',
+/,'==========================================================')
*
* ---------------------------------------------------------------
*
return
*
9999 continue
*
write(Lun_out,*) 'STEPOB is not coherent with DT'
call gem_stop('v4d_readinit',-1)
*
return
end