!-------------------------------------- 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 suobs_sim 1,9
!
#if defined (DOC)
!
!**s/r suobs_sim -
!
! Author: Luc Fillion - ARMA/EC - May 2008
!Revision:
! Luc Fillion - ARMA/EC - Oct 2009 - Introduce rotated global analysis grid option.
! Luc Fillion - ARMA/EC - 19 May 2010 - Introduce mbin1obs.
!
!* Purpose:
!
! Arguments
!
#endif
!
IMPLICIT NONE
*implicits
#include "taglam4d.cdk"
#include "pardim.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comlun.cdk"
#include "comct0.cdk"
#include "comleg.cdk"
#include "comgem.cdk"
#include "comgd0.cdk"
#include "comcst.cdk"
#include "comoahdr.cdk"
#include "comoabdy.cdk"
#include "comoba.cdk"
#include "commvo.cdk"
#include "comgrd_param.cdk"
#include "comgrd.cdk"
#include "comgdpar.cdk"
#include "com1obs.cdk"
#include "comsim.cdk"
#include "comgemla.cdk"
!
! Arguments
!
integer ji,jj
integer ig1tic,ig2tic,ig3tic,ig4tic
integer igdid,ier,ikey,ji,jj,ilatrot
integer gdxyfll,ier,isrchila
real xpti(1), ypti(1), xlati(1), xloni(1) ! real*4 for RPN subs...
real*8 Z1OBSLA,ZLAT1,ZLAT2,zlonrad
REAL*8 ZLAT,zlon,zdlon
REAL zlat_4,zlon_4,zx,zy
real zxlon1_4,zxlat1_4,zxlon2_4,zxlat2_4
real ax(ni),ay(nj)
!
INTEGER ezgdef_fmem,gdxyfll,ezqkdef
!
!!
nobtot = 1
!
!*1. Default values
! --------------
!
LONEOBS = .FALSE.
LVLNEAR = .TRUE.
R1OBSLA = 50.0
R1OBSLO = 330.0
R1OBSLV = 1020.0
R1OBSINO = 1.0
R1OBSOER = 5.15
C1OBSTP = 'UU'
C1OBSBG = 'FGUESS'
mbin1obs = 1
!
!*2. Read the NAMELIST NAM1OBS to modify them
! ----------------------------------------
!
WRITE(NULOUT,FMT=9120)
9120 FORMAT(3X,'- reading the namelist NAM1OBS in SUOBS_SIM')
!
CALL READNML('NAM1OBS',ier)
write(nulout,*) 'suobs:_sim: after NAM1OBS: mbin1obs = ',mbin1obs
!
LVLNEAR = .true. ! made compulsory here
!
!*3. Determine horizontal position of the observation w.r.t. the analysis grid
! N.B.: Obs vertical level specified within lobsppp_1obs (and adj) from namelist nam1obs
! --------------------------------------------------------------------------------------
!
if(grd_typ.eq.'LU') then
if(r1obsla.lt.0) then ! (x,y) gridpoint index provided directly on lam grid
ypti(1) = abs(nint(r1obsla))
xpti(1) = abs(nint(r1obslo))
call gdllfxy(ngid_an, xlati(1), xloni(1), xpti(1), ypti(1), 1)
write(nulout,*) 'suobs_sim: Computed xlati, xloni=',xlati, xloni
else
xlati(1) = r1obsla
xloni(1) = r1obslo
write(nulout,*) 'suobs_sim: xlati, xloni=',xlati, xloni
ier = gdxyfll(ngid_an, xpti, ypti, xlati, xloni, 1)
endif
write(nulout,*) 'suobs_sim: ngid_an = ',ngid_an
write(nulout,*) 'suobs_sim: xpti(1),ypti(1)=',xpti(1),ypti(1)
write(nulout,*) 'suobs_sim: mni_in,mnj_in=',mni_in,mnj_in
write(nulout,*) 'suobs_sim: mjobsbufn=', mjobsbufn
write(nulout,*) 'suobs_sim: mjobsbufs=', mjobsbufs
write(nulout,*) 'suobs_sim: miobsbufe=', miobsbufe
write(nulout,*) 'suobs_sim: miobsbufw=', miobsbufw
!
mlonobs = xpti(1)
mlatobs = ypti(1)
write(nulout,*) 'suobs_sim: Reinitialization of mlonobs = ',mlonobs
write(nulout,*) 'suobs_sim: Reinitialization of mlatobs = ',mlatobs
!
if (xpti(1).lt.miobsbufw.or.
& xpti(1).ge.(mni_in-miobsbufe+1)) then
write(nulout,*) 'suobs:sim: mni_in-miobsbufe+1=',mni_in-miobsbufe+1
call abort3d(nulout,'suobs_sim: Simulated Obs. X-Coord. not inside domain!')
else if (ypti(1).lt.mjobsbufs.or.
& ypti(1).ge.(mnj_in-mjobsbufn+1)) then
write(nulout,*) 'suobs:sim: mnj_in-mjobsbufn+1=',mnj_in-mjobsbufn+1
call abort3d(nulout,'suobs_sim: Simulated Obs. Y-Coord. not inside domain!')
call abort3d(nulout,'suobs_sim: Simulated Obs. Longitude not inside domain!')
endif
!
robhdr(ncmtla,1)=ypti(1)
robhdr(ncmtlo,1)=xpti(1)
robhdr(ncmlat,1)=r1obsla*rdeg2rad
robhdr(ncmlon,1)=r1obslo*rdeg2rad
!
write(nulout,*) 'suobs_sim: ncmtla,ncmtlo=',ncmtla,ncmtlo
write(nulout,*) 'suobs_sim: robhdr(ncmtla,1) = ', robhdr(ncmtla,1)
write(nulout,*) 'suobs_sim: robhdr(ncmtlo,1) = ', robhdr(ncmtlo,1)
else
if(grd_roule) then
!
zxlon1_4 = grd_xlon1
zxlat1_4 = grd_xlat1
zxlon2_4 = grd_xlon2
zxlat2_4 = grd_xlat2
write(nulout,*) 'suobs_sim: 1: zxlon1_4 =',zxlon1_4
write(nulout,*) 'suobs_sim: 1: zxlat1_4 =',zxlat1_4
write(nulout,*) 'suobs_sim: 1: zxlon2_4 =',zxlon2_4
write(nulout,*) 'suobs_sim: 1: zxlat2_4 =',zxlat2_4
!
do ji=1,ni
ax(ji)=grd_x_8(ji)
enddo
do jj=1,nj
ay(jj)=grd_y_8(jj)
enddo
!
call cxgaig('E',ig1tic,ig2tic,ig3tic,ig4tic,
& zxlat1_4,zxlon1_4,zxlat2_4,zxlon2_4)
!
call cigaxg('E', zxlat1_4, zxlon1_4, zxlat2_4, zxlon2_4,
& ig1tic,ig2tic,ig3tic,ig4tic)
!
write(nulout,*) 'suobs_sim: 2: zxlon1_4 =',zxlon1_4
write(nulout,*) 'suobs_sim: 2: zxlat1_4 =',zxlat1_4
write(nulout,*) 'suobs_sim: 2: zxlon2_4 =',zxlon2_4
write(nulout,*) 'suobs_sim: 2: zxlat2_4 =',zxlat2_4
!
igdid = ezgdef_fmem(ni,nj,'Z','E',ig1tic, ig2tic,ig3tic,ig4tic,
& ax,ay)
!
zlat=R1OBSLA
zlon=R1OBSLO
zlat_4=zlat
zlon_4=zlon
write(nulout,*) 'suobs_sim: zlat_4, zlon_4=',
& zlat_4, zlon_4
ier = gdxyfll(igdid,zx,zy,zlat_4,zlon_4,1) ! Input (lat,lon) must be real earth (lat,lon)!!!
write(nulout,*) 'suobs_sim: zx, zy = ',zx,zy
call gdllfxy(igdid, zlat_4,zlon_4, zx, zy, 1)
write(nulout,*) 'suobs_sim: recovered REAL zlat_4, zlon_4=',
& zlat_4, zlon_4
!
robhdr(ncmtla,1)=real(nj)+1-zy ! i.e. x-y coordinates of Obs on transformed sphere ready for later interpolation
robhdr(ncmtlo,1)=zx
mlonobs = zx
mlatobs = zy
else
call srchlon(NI1OBSLO,zlonrad,R1OBSLO)
Z1OBSLA=R1OBSLA*2.0*RPI/360.0
ZLAT1=RLATI(ISRCHILA(Z1OBSLA)+1)
ZLAT2=RLATI(ISRCHILA(Z1OBSLA))
if(abs(ZLAT1-Z1OBSLA).lt.abs(ZLAT2-Z1OBSLA)) then
NI1OBSLA = ISRCHILA(Z1OBSLA)+1
else
NI1OBSLA = ISRCHILA(Z1OBSLA)
endif
mlonobs = NI1OBSLO
mlatobs = NI1OBSLA
mobhdr(ncmtla,1)=NI1OBSLA ! integer used here as opposed to real in lam4d ;i.e. robhdr
mobhdr(ncmtlo,1)=NI1OBSLO ! integer used here as opposed to real in lam4d ;i.e. robhdr
endif
!
write(nulout,*) 'suobs_sim: Reinitialization of mlonobs = ',mlonobs
write(nulout,*) 'suobs_sim: Reinitialization of mlatobs = ',mlatobs
!
robhdr(ncmlat,1)=R1OBSLA*rdeg2rad
robhdr(ncmlon,1)=R1OBSLO*rdeg2rad
write(nulout,*) 'suobs_sim: ncmlat,ncmlon=',ncmlat,ncmlon
write(nulout,*) 'suobs_sim: robhdr(ncmlat,1) = ', robhdr(ncmlat,1)
write(nulout,*) 'suobs_sim: robhdr(ncmlon,1) = ', robhdr(ncmlon,1)
write(nulout,*) 'suobs_sim: mobhdr(ncmtla,1) = ', mobhdr(ncmtla,1)
write(nulout,*) 'suobs_sim: mobhdr(ncmtlo,1) = ', mobhdr(ncmtlo,1)
endif
!
return
end