!-------------------------------------- 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 geodata - FROM MC2 - read in geophy file created by gengeo
* ?_gfilemap.txt must accompany this ?geophy file
#include "model_macros_f.h"
*
subroutine geodata (dimgx,dimgy,listgeonm) 1,5
implicit none
*
character* (*) listgeonm(2,*)
integer dimgx,dimgy
*
*author M. Desgagne (MC2 2001)
*
*revision
* v3_30 Lee/Desgagne - initial GEM LAM version
* v3_31 Lee V. - to check for rotation of data, search ME or MF in file
*
#include "glb_ld.cdk"
#include "hgc.cdk"
#include "grd.cdk"
#include "ifd.cdk"
#include "ptopo.cdk"
#include "filename.cdk"
#include "schm.cdk"
#include "lun.cdk"
#include "geomg.cdk"
#include "geomn.cdk"
#include "itf_phy_buses.cdk"
#include "itf_phy_config.cdk"
#include "lctl.cdk"
#include "path.cdk"
*
integer fnom,fstouv,fstinf,fstprm,fstluk,fstfrm,fclos,
$ fstopc,nav_3df,fstrhint
external fnom,fstouv,fstinf,fstprm,fstluk,fstfrm,fclos,
$ fstopc,nav_3df,samegrid,fstrhint
*
character*1 typ, grd
character*2 var
character*8 lab, inttyp, h_inttyp, varname
character*8, dimension (:), allocatable :: geop_name
character*512 fn
integer dte, det, ipas, p1, p2, p3, g1, g2, g3, g4, bit,
$ dty, swa, lng, dlf, ubc, ex1, ex2, ex3, longueur,
$ g1o,g2o,g3o,g4o,nvar,errtot,unf,location
logical interpo_L,samegrid
*
integer dgid,ezgdef_fmem,gdll,gdrls,dummy
integer unf2,err,ier,ni1,nj1,nk1,key,ni,nj,n,nia,nja,last,
$ i,j,mgi,z0i,lhi,y7i,y8i,y9i,gai,vgi,vfi,id,gid,ic,
$ lai,loi,mti,nti,mfi,errrot,cnt,offg,mul,i0,j0,in,jn
integer, dimension (:), allocatable :: idxl,idyl,idxn,idyn
real xlat1,xlon1,xlat2,xlon2,epsil,deg2rad
real , dimension (: ) , allocatable :: xps,yps
real*8, dimension (: ) , allocatable :: xpaq,ypaq,
$ cxal,cxbl,cxcl,cxdl,cyal,cybl,cycl,cydl,
$ cxan,cxbn,cxcn,cxdn,cyan,cybn,cycn,cydn
real*8 xpxext(0:dimgx), ypxext(0:dimgy)
data epsil /1.0e-5/
real*8 deg2rad_8,CLXXX_8,ONE_8
parameter ( CLXXX_8 = 180.0d0, ONE_8 = 1.0d0 )
*-----------------------------------------------------------------------
*
nvar = 11
if (P_pbl_schsl_S.eq.'ISBA') nvar = 13
allocate (geop_name(nvar))
*
geop_name (1) = 'MGEN'
geop_name (2) = 'Z0EN'
geop_name (3) = 'LHTGEN'
geop_name (4) = 'DHDXEN'
geop_name (5) = 'DHDYEN'
geop_name (6) = 'DHDXDYEN'
geop_name (7) = 'GLACEN'
geop_name (8) = 'VEGINDEN'
geop_name (9) = 'VEGFEN'
geop_name(10) = 'MF'
geop_name(11) = 'MT'
if (P_pbl_schsl_S.eq.'ISBA') then
geop_name (12) = 'SANDEN'
geop_name (13) = 'CLAYEN'
endif
*
do id =1,nvar
do gid=1,P_bgeo_top
if (listgeonm(1,gid).eq.geop_name(id)) listgeonm(2,gid) = 'NIL'
end do
end do
*
fn = trim(Path_input_S)//'/LAM_geophy/'//trim(prefgeo)
*
unf = 91
open (unf,file=trim(fn)//'_gfilemap.txt',access='SEQUENTIAL',
$ status='OLD',iostat=err,form='FORMATTED')
if (err.ne.0) then
if (Lun_out.gt.0) write (Lun_out,1002) trim(fn)//'_gfilemap.txt'
return
else
if (Lun_out.gt.0) write (Lun_out,1000) trim(fn)//'_gfilemap.txt'
endif
*
deg2rad = acos(-1.0)/180.
inttyp = 'LINEAR'
interpo_L=.true.
if (Ptopo_myproc.ne.0) ier = fstopc('MSGLVL','SYSTEM',.false.)
*
do i=1,dimgx
xpxext(i) = G_xg_8(i)
end do
do i=1,dimgy
ypxext(i) = G_yg_8(i)
end do
xpxext(0) = xpxext(1) - (xpxext(2)-xpxext(1))
ypxext(0) = ypxext(1) - (ypxext(2)-ypxext(1))
*
unf2 = 0
*
errrot = 0
deg2rad_8 = acos( -ONE_8 ) / CLXXX_8
ier = nav_3df(unf,1.2,deg2rad_8)
call gem_stop ('geodata',ier)
nia = ifd_niaf - ifd_niad + 1
nja = ifd_njaf - ifd_njad + 1
close (unf)
*
do gid=1,P_bgeo_top
if (geonm(gid,1).eq.'MT') geonm(gid,2)='ME '
if (geonm(gid,1).eq.'MF') geonm(gid,2)='MF '
end do
do n=1,ifd_nf
if (ifd_needit(n)) then
ier = fnom (unf2,trim(fn)//'_'//ifd_fnext(n),'RND+OLD+R/O',0)
ier = fstouv (unf2,'RND')
*
* Use first file to establish geo-references
*
allocate ( xpaq(nia), ypaq(nja) )
key = fstinf(unf2,ni1,nj1,nk1,-1,' ',-1,-1,-1,' ','>>')
allocate (xps(ni1))
ier = fstluk ( xps, key, ni,nj1,nk1 )
key = fstinf(unf2,ni1,nj1,nk1,-1,' ',-1,-1,-1,' ','^^')
allocate (yps(nj1))
ier = fstluk ( yps, key, ni1,nj,nk1 )
do i=1,nia
xpaq(i) = xps(ifd_niad+i-1) * deg2rad
end do
do j=1,nja
ypaq(j) = yps(ifd_njad+j-1) * deg2rad
end do
deallocate (xps,yps)
*
call cxgaig ('E',g1o,g2o,g3o,g4o,Grd_xlat1,Grd_xlon1,
$ Grd_xlat2,Grd_xlon2)
ier= fstprm (key, DTE, DET, IPAS, ni1, nj1, nk1, BIT, DTY,
$ P1, P2, P3, TYP, VAR, LAB, GRD, G1, G2, G3, G4,
$ SWA, LNG, DLF, UBC, EX1, EX2, EX3)
if (Lun_debug_L) then
write(Lun_out,*)
$ 'geodata: g1,g2,g3,g4 should be:',g1o,g2o,g3o,g4o
write(Lun_out,*) 'ni1=',ni1,'nj1=',nj1,'p1=',p1,
$ 'p2=',p2,'p3=',p3
endif
if (g1.ne.g1o.or.g2.ne.g2o.or.g3.ne.g3o.or.g4.ne.g4o) then
if (Lun_out.gt.0) then
write(Lun_out,*) 'Grid rotation from',trim(fn),' is not the same as target grid'
write(Lun_out,*)
$ 'geodata: g1,g2,g3,g4',g1,g2,g3,g4, 'should be:',g1o,g2o,g3o,g4o
endif
call gem_stop ('geodata',-1)
else
if (nia.eq.dimgx.and.nja.eq.dimgy) then
interpo_L = samegrid(unf2,nia,nja,p1,p2,p3,
$ g1o,g2o,g3o,g4o,xpxext(1),ypxext(1))
if (.not.interpo_L) inttyp='NEAREST'
endif
endif
if (Lun_debug_L)
$ write(Lun_out,*)'interpo_L=',interpo_L, 'errtot=',errtot
ier = fstfrm (unf2)
ier = fclos (unf2)
goto 57
endif
enddo
*
57 if ((errrot.lt.0).and.(Ptopo_myproc.eq.0)) write (6,1001)
call gem_stop('GEODATA',errrot)
* Check tic tacs to see if they are the same
*
allocate (idxl(l_ni), idyl(l_nj), idxn(l_ni), idyn(l_nj))
allocate (cxal(l_ni),cxbl(l_ni),cxcl(l_ni),cxdl(l_ni),
$ cyal(l_nj),cybl(l_nj),cycl(l_nj),cydl(l_nj),
$ cxan(l_ni),cxbn(l_ni),cxcn(l_ni),cxdn(l_ni),
$ cyan(l_nj),cybn(l_nj),cycn(l_nj),cydn(l_nj))
*
* for linear interpolation
*
call grid_to_grid_coef (xpxext(l_i0),l_ni,xpaq,
$ nia,idxl,cxal,cxbl,cxcl,cxdl,inttyp)
call grid_to_grid_coef (ypxext(l_j0),l_nj,ypaq,
$ nja,idyl,cyal,cybl,cycl,cydl,inttyp)
*
i0 = 1
j0 = 1
in = l_ni
jn = l_nj
ni1 = in - i0 + 1
nj1 = jn - j0 + 1
if (Lun_debug_L)
$ write(Lun_out,*)
$ 'geodata: ni1=',ni1,'nj1=',nj1,'l_i0=',l_i0,'l_j0=',l_j0
call grid_to_grid_coef
$ (xpxext(l_i0),ni1,xpaq,nia,idxl,cxal,cxbl,cxcl,cxdl,'LINEAR')
call grid_to_grid_coef
$ (ypxext(l_j0),nj1,ypaq,nja,idyl,cyal,cybl,cycl,cydl,'LINEAR')
call grid_to_grid_coef
$ (xpxext(l_i0),ni1,xpaq,nia,idxn,cxan,cxbn,cxcn,cxdn,'NEAREST')
call grid_to_grid_coef
$ (ypxext(l_j0),nj1,ypaq,nja,idyn,cyan,cybn,cycn,cydn,'NEAREST')
*
do 101 id=1,nvar
location = -1
do gid=1,P_bgeo_top
if (geonm(gid,1).eq.geop_name(id)) location = gid
end do
if (location.lt.0) goto 101
offg = geopar(location,1)
mul = geopar(location,3)
varname = geonm (location,2)
h_inttyp = inttyp
*
if ( (geop_name(id).eq.'VEGINDEN').or.
$ (geop_name(id).eq.'VEGFEN' ) ) h_inttyp = 'NEAREST'
*
err = 0
if (h_inttyp.eq.'LINEAR') then
err = fstrhint (geofld(offg),varname,ni1,nj1,mul,
$ nia,nja,idxl,idyl,cxal,cxbl,cxcl,cxdl,
$ cyal,cybl,cycl,cydl,h_inttyp,fn)
else
err = fstrhint (geofld(offg),varname,ni1,nj1,mul,
$ nia,nja,idxn,idyn,cxan,cxbn,cxcn,cxdn,
$ cyan,cybn,cycn,cydn,h_inttyp,fn)
endif
if (err.eq.0) listgeonm(2,location) = 'OK'
101 continue
*
** Post treatment
*
do gid=1,p_bgeo_top
if (geonm(gid,1).eq.'DLATEN') lai = geopar(gid,1)
if (geonm(gid,1).eq.'DLATEN') listgeonm(2,gid) = 'OK'
if (geonm(gid,1).eq.'DLONEN') loi = geopar(gid,1)
if (geonm(gid,1).eq.'DLONEN') listgeonm(2,gid) = 'OK'
if (geonm(gid,1).eq.'MGEN' ) mgi = geopar(gid,1)
if (geonm(gid,1).eq.'Z0EN' ) z0i = geopar(gid,1)
if (geonm(gid,1).eq.'LHTGEN') lhi = geopar(gid,1)
if (geonm(gid,1).eq.'GLACEN') gai = geopar(gid,1)
if (geonm(gid,1).eq.'MT' ) mti = geopar(gid,1)
if (geonm(gid,1).eq.'MF' ) mfi = geopar(gid,1)
c if (geonm(gid,1).eq.'MF' ) listgeonm(2,gid) = 'OK'
end do
*
call cxgaig ('E',g1,g2,g3,g4,Grd_xlat1,Grd_xlon1,
$ Grd_xlat2,Grd_xlon2)
gid = ezgdef_fmem (ni1,nj1,'Z','E',g1,g2,g3,g4,
$ Geomn_longs(l_i0),Geomn_latgs(l_j0))
err = gdll (gid,geofld(lai),geofld(loi))
err = gdrls (gid)
*
do i=1,ni1*nj1
geofld(mfi +i-1) = max(0.,geofld(mfi+i-1))
geofld(mti +i-1) = geofld(mti+i-1)
geofld(mgi +i-1) = min(max(0.,geofld(mgi +i-1)),1.)
geofld(gai +i-1) = min(max(0.,geofld(gai +i-1)),1.)
geofld(lhi +i-1) = max(0.,geofld(lhi+i-1))
geofld(z0i +i-1) = exp(geofld(z0i+i-1))
geofld(lai +i-1) = geofld(lai +i-1) * deg2rad
geofld(loi +i-1) = geofld(loi +i-1) * deg2rad
end do
*
deallocate (idxl,idyl,cxal,cxbl,cxcl,cxdl,cyal,cybl,cycl,cydl,
$ idxn,idyn,cxan,cxbn,cxcn,cxdn,cyan,cybn,cycn,cydn,
$ xpaq,ypaq,geop_name)
*
if (Ptopo_myproc.ne.0) ier = fstopc('MSGLVL','INFORM',.false.)
*
1000 format (4X,'GEODATA: geophy file description from ',A/)
1001 format (/' INPUT DATA NOT ON SAME GRID ROTATION AS MODEL ',
$ '- ABORT IN geodata -'/)
1002 format (4X,'GEODATA: problem with opening geophy file: ',A/)
*
*-----------------------------------------------------------------------
*
return
end
*
integer function fstrhint (f,nv,ni,nj,nk,nia,nja,idx,idy,cxa,cxb,,2
$ cxc,cxd,cya,cyb,cyc,cyd,inttyp,path)
implicit none
*
character* (*) nv,inttyp,path
integer ni,nj,nk,nia,nja,idx(*),idy(*)
real f(ni*nj,*)
real*8 cxa(*),cxb(*),cxc(*),cxd(*),cya(*),cyb(*),cyc(*),cyd(*)
*
#include "filename.cdk"
#include "ifd.cdk"
*
integer filsfc
external filsfc
integer fnom,fstouv,fstfrm,fclos
character*512 fn
integer k,n,ier,unf,ofi,ofj,i,j
real wk1(nia*nja)
*
*-----------------------------------------------------------------------
*
fstrhint = 0
unf = 0
*
wk1 = 0.
*
do k=1,nk
*
do n=1,ifd_nf
if (ifd_needit(n)) then
fn = trim(path)//'_'//ifd_fnext(n)
ier = fnom (unf,fn,'RND+OLD+R/O',0)
ier = fstouv (unf,'RND')
ofi = ifd_minx(n)-1
ofj = ifd_miny(n)-1
fstrhint = filsfc (wk1,nv,ifd_niad,ifd_niaf,ifd_njad,ifd_njaf,
$ k,nk,unf,ofi,ofj)
ier = fstfrm (unf)
ier = fclos (unf)
endif
end do
*
call hinterpo (f(1,k),ni,nj,wk1,nia,nja,1,
$ idx,idy,cxa,cxb,cxc,cxd,cya,cyb,cyc,cyd,inttyp)
*
end do
*
*-----------------------------------------------------------------------
*
return
end
*
integer function filsfc ( f,nv,n1,n2,n3,n4,ki,nk,unf,ofi,ofj ) 1
implicit none
#include "lun.cdk"
*
character* (*) nv
integer n1,n2,n3,n4,ki,nk,unf,ofi,ofj
real f(n1:n2,n3:n4)
*
integer fstinf,fstluk
external fstinf,fstluk
*
character*8 dum
integer key,ni1,nj1,nk1,ip1,ier,i,j
real, dimension (:,:), allocatable :: tr1
*
*-----------------------------------------------------------------------
*
filsfc = -1
*
ip1 = 0
if (nk.gt.1) call convip ( ip1, real(ki), 3, 1, dum, .false.)
if (nv.eq.'ME') then
call convip ( ip1, 0.0,3,1,dum,.false.)
endif
key = fstinf(unf,ni1,nj1,nk1,-1,' ',ip1,-1,-1,' ',nv)
*
if (key.ge.0) then
*
allocate (tr1(ni1,nj1))
ier = fstluk ( tr1, key, ni1,nj1,nk1 )
if (ier.ge.0) then
do j=1,nj1
do i=1,ni1
f(ofi+i,ofj+j) = tr1(i,j)
end do
end do
filsfc = 0
endif
deallocate (tr1)
*
endif
*
*-----------------------------------------------------------------------
*
return
end