!-------------------------------------- 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 acqui - read the dynamics fields from entrance programs
*
#include "model_macros_f.h"
*
* subroutine acqui, explicit interface for pointer as dummy args.
subroutine acqui 1,5
#include "acq_int.cdk"
* (impnone included in acq_int.cdk)
*
*author
* Luc Corbeil, mai 2002
*
*revision
* v3_01 - Corbeil L. - initial version
* v3_10 - Lee V. - unique bmfscraps...
* v3_11 - Gravel S. - provide for variable topography
* v3_12 - Dugas B. & Winger K. - read TD in pressure-mode rather than HU
* v3_21 - Dugas B. - replace TD by ES in pressure mode
* v3_30 - Tanguay M. - Modify Check topo when no interpolation
* v3_30 - McTaggart-Cowan R. - update implementation of variable orography
* v3_31 - Gravel S. - only blend topo for LAM if VERTINT is true
* v3_31 - McTaggart-Cowan R. - do not set Vtopo to false if not the same topo
* v3_31 - Bilodeau B. - correct offline bug
*
*object
*
*arguments
* none
*
*implicits
#include "lun.cdk"
#include "bmf.cdk"
#include "glb_pil.cdk"
#include "geomg.cdk"
#include "lam.cdk"
#include "grd.cdk"
#include "pres.cdk"
#include "dcst.cdk"
#include "ptopo.cdk"
#include "cstv.cdk"
#include "hblen.cdk"
#include "ind.cdk"
#include "acq.cdk"
#include "vtopo.cdk"
#include "schm.cdk"
#include "lctl.cdk"
#include "path.cdk"
*modules
integer bmf_gobe,bmf_get
external bmf_gobe,bmf_get
*
character*504 pe_file
integer nk_anal
integer hh,mm,ss, nerr, err, length, i,j,k, errprdf,prdfsum
integer, parameter :: maxerr = 400
integer, dimension(maxerr) :: error
integer, allocatable, dimension(:) :: bmfni,bmfnj,bmfnk,
$ bmfdatyp,bmfvtime1,bmfvtime2,
$ bmfscrap,bmfscrap1,bmfscrap2,bmfscrap3,bmfscrap4,bmfscrap5,
$ bmfscrap6,bmfscrap7,bmfscrap8,bmfscrap9
character*4, allocatable, dimension(:) :: bmfnom
real difsig,prdfsgz,prdf
real(kind=8), dimension(l_ni,l_nj) :: current_topo
parameter (difsig = 1.e-5)
**
* ---------------------------------------------------------------
*
call bmf_init
*
hh=bmf_time2/1000000
mm=bmf_time2/10000-hh*100
ss=bmf_time2/100-hh*10000-mm*100
*
call bmf_splitname ( pe_file,Ptopo_mycol,Ptopo_myrow,
$ trim(Path_ind_S),'BM',bmf_time1,hh,mm,ss )
*
do i=1,maxerr
error(i) = -1
end do
nerr=0
*
* Read the BMF file associated to Ptopo_myproc
*
length=bmf_gobe(pe_file)
*
* Build a catalog to allow proper dimensionning of some variables
*
allocate (bmfnom(length),bmfni(length),bmfnj(length),
$ bmfnk(length), bmfvtime1(length),bmfvtime2(length),
$ bmfdatyp(length),bmfscrap(length),
$ bmfscrap1(length),bmfscrap2(length),bmfscrap3(length),
$ bmfscrap4(length),bmfscrap5(length),bmfscrap6(length),
$ bmfscrap7(length),bmfscrap8(length),bmfscrap9(length))
call bmf_catalog ( bmfnom,bmfni,bmfscrap,bmfscrap1,bmfnj,
$ bmfscrap2,bmfscrap3,bmfnk,bmfscrap4,bmfscrap5,bmfvtime1,
$ bmfvtime2,bmfscrap6,bmfscrap7,bmfdatyp,bmfscrap8,bmfscrap9 )
*
* Initialization of some switches and dimensions
*
err = bmf_get ('AHAV',bmf_time1,bmf_time2,Acqi_datasp,-1,-1.,
$ 1,2,1,1,1,1)
*
Acql_horzint = (Acqi_datasp(1).eq.1)
Acql_hybanl = (Acqi_datasp(2).eq.1)
Acql_etaanl = (Acqi_datasp(2).eq.2)
Acql_siganl = (Acqi_datasp(2).eq.3)
Acql_prsanl = (Acqi_datasp(2).eq.4)
Acql_ecmanl = (Acqi_datasp(2).eq.5)
Acql_vertint = Acql_horzint
if( (Acql_etaanl .or. Acql_hybanl) .and. Vtopo_L )
$ Acql_vertint = .false.
*
Acqi_nbpts = l_ni*l_nj
Acqi_vterplv = -1
*
do i=1,length
if(bmfnom(i).eq.'RNA ') then
Acqi_vterplv=bmfni(i)
allocate ( lna(Acqi_vterplv), rna(Acqi_vterplv),
$ sdd(Acqi_vterplv) )
cycle
else if(bmfnom(i).eq.'UU ') then
Acqi_niu=bmfni(i)
Acqi_nju=bmfnj(i)
cycle
else if(bmfnom(i).eq.'VV ') then
Acqi_niv=bmfni(i)
Acqi_njv=bmfnj(i)
cycle
endif
enddo
*
deallocate (bmfni,bmfnj,bmfnk,bmfdatyp,bmfvtime1,
$ bmfvtime2,bmfnom,bmfscrap,
$ bmfscrap1,bmfscrap2,bmfscrap3,bmfscrap4,bmfscrap5,
$ bmfscrap6,bmfscrap7,bmfscrap8,bmfscrap9)
*
* Save current model topography for "growing" mode
current_topo = Ind_topo(1:l_ni,1:l_nj)
*
error(1) = bmf_get ('RNA ',bmf_time1,bmf_time2,-1,rna,-1.,1,
$ Acqi_vterplv,1,1,1,1)
error(2) = bmf_get ('ME ',bmf_time1,bmf_time2,-1,Ind_topo,-1.,
$ LDIST_DIM,1,1)
*
* Check if Vtopo is requested when the analysis is on pressure levels
if (Acql_prsanl .and. Vtopo_L) then
write(Lun_out,*)
$ 'PRESSURE input data is incompatible with growing orography.',
$ 'Set Vtopo_start=-1 in your settings file to continue.'
call gem_stop('acqui',-1)
endif
do j=1,l_nj
do i=1,l_ni
Ind_topo (i,j) = dble(Ind_topo(i,j)) * Dcst_grav_8
topo_temp(i,j) = Ind_topo (i,j)
end do
end do
nerr = nerr + 2
*
Acqi_nim = max (l_ni, Acqi_niu, Acqi_niv)
Acqi_njm = max (l_nj, Acqi_nju, Acqi_njv)
nk_anal = Acqi_vterplv
if (Acql_ecmanl) nk_anal = Acqi_vterplv+1
Acqi_nktmp = max (nk_anal,G_nk )
allocate ( u_temp(Acqi_niu ,Acqi_nju ,Acqi_nktmp),
$ v_temp(Acqi_niv ,Acqi_njv ,Acqi_nktmp),
$ hu_temp(l_ni,l_nj,Acqi_nktmp), tt_temp(l_ni,l_nj,Acqi_nktmp),
$ gz_temp(l_ni,l_nj,Acqi_nktmp) )
*
nerr = nerr + 1
error(nerr) = bmf_get('UU ',bmf_time1,bmf_time2,-1,u_temp,-1,
$ 1,Acqi_niu,1,Acqi_nju,1,Acqi_nktmp)
*
nerr = nerr + 1
error(nerr) = bmf_get('VV ',bmf_time1,bmf_time2,-1,v_temp,-1,
$ 1,Acqi_niv,1,Acqi_njv,1,Acqi_nktmp)
*
if (Schm_offline_L) then
gz_temp = 0.
else
if (.not.Acql_horzint .or. Acql_prsanl) then
nerr = nerr + 1
error(nerr) = bmf_get('GZ ',bmf_time1,bmf_time2,-1,
$ gz_temp,-1.,1,l_ni,1,l_nj,1,Acqi_nktmp)
else
nerr = nerr + 1
error(nerr) = bmf_get('GZ ',bmf_time1,bmf_time2,-1,
$ gz_temp(1,1,nk_anal),-1.,1,l_ni,1,l_nj,1,1)
endif
endif
*
* Set first level heights to current for "growing" mode
if (Vtopo_L .and. Lctl_step > Vtopo_start) then
gz_temp(1:l_ni,1:l_nj,nk_anal) = current_topo
endif
*
if (Acql_prsanl) then
* Convert millibar to pascal unit - Pressure Analysis
do k=1,Acqi_vterplv
lna(k) = alog(rna(k))
rna(k) = rna(k)*100.
enddo
do k=1,Acqi_vterplv-1
sdd(k) = 1./(lna(k+1)-lna(k))
enddo
nerr = nerr + 1
error(nerr) = bmf_get('ES ',bmf_time1,bmf_time2,-1,hu_temp,-1.,
$ 1,l_ni,1,l_nj,1,Acqi_nktmp)
else
if (Acql_siganl) Acqr_ptopa = 0.
nerr = nerr + 1
error(nerr) = bmf_get('P0 ',bmf_time1,bmf_time2,-1,ps,
$ -1.,1,l_ni,1,l_nj,1,1)
nerr = nerr + 1
error(nerr) = bmf_get('VT ',bmf_time1,bmf_time2,-1,tt_temp,
$ -1.,1,l_ni,1,l_nj,1,Acqi_nktmp)
nerr = nerr + 1
error(nerr) = bmf_get('HU ',bmf_time1,bmf_time2,-1,hu_temp,-1.,
$ 1,l_ni,1,l_nj,1,Acqi_nktmp)
endif
*
if (Acql_hybanl .or. Acql_etaanl) then
nerr = nerr + 1
error(nerr) = bmf_get('PTOP',bmf_time1,bmf_time2,-1,
$ Acqr_ptopa,-1.,1,1,1,1,1,1)
nerr = nerr + 1
error(nerr) = bmf_get('PREF',bmf_time1,bmf_time2,-1,
$ Acqr_prefa,-1.,1,1,1,1,1,1)
nerr = nerr + 1
error(nerr) = bmf_get('RCOF',bmf_time1,bmf_time2,-1,
$ Acqr_rcoefa,-1.,1,1,1,1,1,1)
else
Acql_vertint = .true.
endif
*
if (Acql_ecmanl ) then
nerr = nerr + 1
error(nerr) = bmf_get('US ',bmf_time1,bmf_time2,-1,
$ u_temp(1,1,nk_anal),-1.,
$ 1,Acqi_niu,1,Acqi_nju,1,1)
nerr = nerr + 1
error(nerr) = bmf_get('VS ',bmf_time1,bmf_time2,-1,
$ v_temp(1,1,nk_anal),-1.,
$ 1,Acqi_niv,1,Acqi_njv,1,1)
nerr = nerr + 1
error(nerr) = bmf_get('TE ',bmf_time1,bmf_time2,-1,
$ tt_temp(1,1,nk_anal),-1.,
$ 1,l_ni,1,l_nj,1,1)
nerr = nerr + 1
error(nerr) = bmf_get('HE ',bmf_time1,bmf_time2,-1,
$ hu_temp(1,1,nk_anal),-1.,
$ 1,l_ni,1,l_nj,1,1)
endif
*
* To determine further if vertical interpolation is needed
*
if ( .not. Acql_vertint) then
if (G_nk.ne.Acqi_vterplv ) Acql_vertint=.true.
if (abs(Acqr_rcoefa-Grd_rcoef) .gt. difsig) Acql_vertint=.true.
if (abs(Acqr_prefa -Pres_pref) .gt. difsig) Acql_vertint=.true.
if (abs(Acqr_ptopa -Pres_ptop) .gt. difsig) Acql_vertint=.true.
do i=1,Acqi_vterplv
if (abs(rna(i)-Geomg_hyb(i)) .gt. difsig) Acql_vertint=.true.
end do
endif
*
* Check if analysis and model have the same topography
*
if (.not. Acql_vertint) then
prdfsgz = 25.
errprdf = 0
do j= 1+pil_s, l_nj-pil_n
do i= 1+pil_w, l_ni-pil_e
C do j=1,l_nj
C do i=1,l_ni
prdf= abs( gz_temp(i,j,Acqi_vterplv) - Ind_topo(i,j))
if ( prdf .gt. prdfsgz ) errprdf = 1
enddo
enddo
call rpn_comm_allreduce (errprdf,prdfsum,1,"MPI_INTEGER",
$ "MPI_SUM","grid",err)
*
if ( prdfsum.ne.0 ) then
if( .not. Vtopo_L ) then
Acql_vertint = .true.
if (Ptopo_myproc.eq.0) then
write(lun_out,*) ' ******* WARNING ********'
write(lun_out,*)
$ 'ANALYSIS AND MODEL HAVE THE SAME GRID & LEVELS'
write(lun_out,*)
$ ' ...BUT THE TOPOGRAPHY IS NOT EQUIVALENT...'
endif
endif
endif
endif
*
* Obtain other fields to compute PSU_TEMP,PSV_TEMP
* for wind interpolation
*
Acqi_datasp(1) = 0
if ( Acql_vertint ) then
Acqi_datasp(1) = 1
allocate (
$ topu_temp (Acqi_niu,Acqi_nju), topv_temp(Acqi_niv,Acqi_njv),
$ psu_temp (Acqi_niu,Acqi_nju), psv_temp(Acqi_niv,Acqi_njv),
$ gzu_temp (Acqi_niu,Acqi_nju,Acqi_nktmp),
$ gzv_temp (Acqi_niv,Acqi_njv,Acqi_nktmp) )
*
nerr = nerr + 1
error(nerr) = bmf_get('TOPU',bmf_time1,bmf_time2,-1,
$ topu_temp,-1.,1,Acqi_niu,1,Acqi_nju,1,1)
nerr = nerr + 1
error(nerr) = bmf_get('TOPV',bmf_time1,bmf_time2,-1,
$ topv_temp,-1.,1,Acqi_niv,1,Acqi_njv,1,1)
if ( .not. Vtopo_L ) then
do j=1,Acqi_nju
do i=1,Acqi_niu
topu_temp(i,j) = dble(topu_temp(i,j))*Dcst_grav_8
enddo
enddo
do j=1,Acqi_njv
do i=1,Acqi_niv
topv_temp(i,j) = dble(topv_temp(i,j))*Dcst_grav_8
enddo
enddo
endif
*
if (.not. Schm_offline_L) then
if (Acql_prsanl) then
nerr = nerr + 1
error(nerr) = bmf_get('GZU ',bmf_time1,bmf_time2,-1,
$ gzu_temp,-1.,1,Acqi_niu,1,Acqi_nju,1,Acqi_nktmp)
nerr = nerr + 1
error(nerr) = bmf_get('GZV ',bmf_time1,bmf_time2,-1,
$ gzv_temp,-1.,1,Acqi_niv,1,Acqi_njv,1,Acqi_nktmp)
else
nerr = nerr + 1
error(nerr) = bmf_get('GZU ',bmf_time1,bmf_time2,-1,
$ gzu_temp(1,1,nk_anal),-1.,1,Acqi_niu,1,
$ Acqi_nju,1,Acqi_nktmp)
nerr = nerr + 1
error(nerr) = bmf_get('GZV ',bmf_time1,bmf_time2,-1,
$ gzv_temp(1,1,nk_anal),-1.,1,Acqi_niv,1,
$ Acqi_njv,1,Acqi_nktmp)
* Also need these variables for hybrid/eta/sigma analyses
allocate (
$ apsu_temp(Acqi_niu,Acqi_nju), apsv_temp(Acqi_niv,Acqi_njv),
$ ttu_temp(Acqi_niu,Acqi_nju,Acqi_nktmp),
$ ttv_temp(Acqi_niv,Acqi_njv,Acqi_nktmp) )
nerr = nerr + 1
error(nerr) = bmf_get('VTU ',bmf_time1,bmf_time2,-1,
$ ttu_temp,-1.,1,Acqi_niu,1,Acqi_nju,1,Acqi_nktmp)
nerr = nerr + 1
error(nerr) = bmf_get('VTV ',bmf_time1,bmf_time2,-1,
$ ttv_temp,-1.,1,Acqi_niv,1,Acqi_njv,1,Acqi_nktmp)
nerr = nerr + 1
error(nerr) = bmf_get('APSU',bmf_time1,bmf_time2,-1,
$ apsu_temp, -1.,1,Acqi_niu,1,Acqi_nju,1,1)
nerr = nerr + 1
error(nerr) = bmf_get('APSV',bmf_time1,bmf_time2,-1,
$ apsv_temp, -1.,1,Acqi_niv,1,Acqi_njv,1,1)
if (Acql_ecmanl ) then
nerr = nerr + 1
error(nerr) = bmf_get('STU ',bmf_time1,bmf_time2,-1,
$ ttu_temp(1,1,nk_anal),-1.,
$ 1,Acqi_niu,1,Acqi_nju,1,1)
nerr = nerr + 1
error(nerr) = bmf_get('STV ',bmf_time1,bmf_time2,-1,
$ ttv_temp(1,1,nk_anal),-1.,
$ 1,Acqi_niv,1,Acqi_njv,1,1)
endif
endif
*
if ( Vtopo_L ) then
do j=1,Acqi_nju
do i=1,Acqi_niu
topu_temp(i,j) = gzu_temp(i,j,nk_anal)
enddo
enddo
do j=1,Acqi_njv
do i=1,Acqi_niv
topv_temp(i,j) = gzv_temp(i,j,nk_anal)
enddo
enddo
endif
endif
endif
* Check for error in BMF_GETS above...
err = 0
do i=1,nerr
err = err + error(i)
end do
*
call rpn_comm_allreduce (err,error(1),1,"MPI_INTEGER",
$ "MPI_SUM","grid",nerr)
*
if (error(1).ne.0) call gem_stop ('acqui',-1)
*
if (Lam_blendoro_L) then
if ((Acql_vertint).and.(G_lam).and.(.not.Acql_prsanl).and.(.not.Schm_offline_L)) then
*
do j=1,pil_s
do i=1,l_ni
topo_temp(i,j) = gz_temp(i,j,nk_anal)
end do
end do
do j=l_nj-pil_n+1,l_nj
do i=1,l_ni
topo_temp(i,j) = gz_temp(i,j,nk_anal)
end do
end do
do i=1,pil_w
do j=pil_s+1,l_nj-pil_n
topo_temp(i,j) = gz_temp(i,j,nk_anal)
end do
end do
do i=l_ni-pil_e+1,l_ni
do j=pil_s+1,l_nj-pil_n
topo_temp(i,j) = gz_temp(i,j,nk_anal)
end do
end do
*
call nesajr (topo_temp, gz_temp (1,1,nk_anal), 1,l_ni,1,l_nj,
$ 1,0,0,Hblen_x,Hblen_y)
*
if( .not. Vtopo_L ) then
do j=1,pil_s
do i=1,Acqi_niu
topu_temp(i,j) = gzu_temp(i,j,nk_anal)
end do
end do
do j=Acqi_nju-pil_n+1,Acqi_nju
do i=1,Acqi_niu
topu_temp(i,j) = gzu_temp(i,j,nk_anal)
end do
end do
do i=1,pil_w
do j=pil_s+1,Acqi_nju-pil_n
topu_temp(i,j) = gzu_temp(i,j,nk_anal)
end do
end do
do i=Acqi_niu-pil_e+1,Acqi_niu
do j=pil_s+1,Acqi_nju-pil_n
topu_temp(i,j) = gzu_temp(i,j,nk_anal)
end do
end do
*
do j=1,pil_s
do i=1,Acqi_niv
topv_temp(i,j) = gzv_temp(i,j,nk_anal)
end do
end do
do j=Acqi_njv-pil_n+1,Acqi_njv
do i=1,Acqi_niv
topv_temp(i,j) = gzv_temp(i,j,nk_anal)
end do
end do
do i=1,pil_w
do j=pil_s+1,Acqi_njv-pil_n
topv_temp(i,j) = gzv_temp(i,j,nk_anal)
end do
end do
do i=Acqi_niv-pil_e+1,Acqi_niv
do j=pil_s+1,Acqi_njv-pil_n
topv_temp(i,j) = gzv_temp(i,j,nk_anal)
end do
end do
*
call nesajr (topu_temp, gzu_temp(1,1,nk_anal), 1,Acqi_niu,
$ 1,Acqi_nju,1,1,0,Hblen_x,Hblen_y)
call nesajr (topv_temp, gzv_temp(1,1,nk_anal), 1,Acqi_niv,
$ 1,Acqi_njv,1,0,1,Hblen_x,Hblen_y)
*
endif
*
do j=1,l_nj
do i=1,l_ni
Ind_topo (i,j) = topo_temp(i,j)
end do
end do
*
endif
endif
*
if (Vtopo_L) then
do j=1,l_nj
do i=1,l_ni
topo_temp(i,j) = gz_temp (i,j,nk_anal)
end do
end do
endif
*
*
* ---------------------------------------------------------------
*
return
end