!-------------------------------------- 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 SU1OBS 1,11
use mod4dv
, only : l4dvar
#if defined (DOC)
*
***s/r SU1OBS - Set-up for single obs experiments and to print diagnostics
* at the analysis grip point nearest to the desired lat-lon
* position.
*
*
*Author : C. Charette *ARMA/AES November 1998
*Revision:
* P. KOCLAS CMC October 1999
* Z1OBSLA Real*8 ( for call to isrchila on pollux)
* P. Gauthier *ARMA/MSC March 2003
! Generalization to include the (N+1) obs.
! experiment
* C. Charette - ARMA/SMC - Sep. 2004
* - Added variable LVLNEAR
* L. Fillion - ARMA/EC - 17 Jul 2009.
* - Introduce lcva_3db.
*
* -------------------
** Purpose:
* - Set-up for single obs experiments and to print diagnostics
* at the analysis grip point nearest to the desired lat-lon
* position. Single obs experiments are initialized by setting
* the variable LONEOBS = .TRUE. and NCONF=901 in the namelist.
* Diagnostics at the analysis grid point nearest to the desired
* lat-lon can be obtained at any time during the execution. It
* controlled by the variable LLPRINT in the routines involved.
*
* .
#endif
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comcst.cdk"
#include "comlun.cdk"
#include "comct0.cdk"
#include "comleg.cdk"
#include "com1obs.cdk"
#include "comcva.cdk"
#include "cominterp.cdk"
#include "comvfiles.cdk"
*
include 'prof_f.h'
c
INTEGER IERR,ISRCHILA,IHDL,ISTAT,prof_wrrec
REAL*8 Z1OBSLA
REAL*8 ZLAT1,ZLAT2,zlonrad
character (len=128) :: clprof
c
c Initialization of interpolation parameters
c
write(nulout,fmt='(//,4x,A)')'SU1OBS- Set-up for single obs experiments'
lvintbgstat = .false.
lhintdelhu = .true.
c
call readnml('NAMINTERP',IERR)
WRITE(NULOUT,'(3X,"- reading the namelist NAMCVA in ONEOBS")')
CALL READNML('NAMCVA',IERR)
C
C Set up stats, and other things (some unnecessary)
C
if(nconf.ne.141) then
call sucva(nulout)
end if
c
c Read in scaling factors to adjust obs error std dev in cma
c
if(ntunestats.eq.5) then
call rdtunebgobs
endif
C
C* 1. Default values
C
100 CONTINUE
C
LONEOBS = .FALSE.
LVLNEAR = .TRUE.
R1OBSLA = 50.0
R1OBSLO = 330.0
R1OBSLV = 1020.0
R1OBSINO = 1.0
R1OBSOER = 5.15
C1OBSTP = 'UU'
C1OBSBG = 'FGUESS'
C
C * . 1.2 Read the NAMELIST NAM1OBS to modify them
C . ---------------------------------------
120 CONTINUE
WRITE(NULOUT,FMT=9120)
9120 FORMAT(3X,'- reading the namelist NAM1OBS in SU1OBS')
C
CALL READNML('NAM1OBS',IERR)
C
C * . 1.2 Calculate indexes of nearest analysis grid point
C and vertical level
C . ---------------------------------------
C Longitude
call srchlon(NI1OBSLO,zlonrad,R1OBSLO)
C
C Latitude
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
C
C * . 1.4 Print the content of this NAMELIST
C
130 CONTINUE
WRITE(NULOUT,FMT=9130)C1OBSTP,C1OBSBG,LONEOBS,LVLNEAR
S ,R1OBSLA,R1OBSLO,R1OBSLV,R1OBSOER,R1OBSINO
S ,NI1OBSLA,NI1OBSLO
9130 FORMAT(8x,'--Parameters used for the single obs experiment'
S ,8x,' or to print diagnostics when applicable'
S ,' (read in NAM1OBS)'
S ,/,4X,'Type of observation (single obs) : ',2X,A2
S ,/,4X,'Type of background field : ',2X,A8
S ,/,4X,'Test to start single obs exp : ',2X,L1
S ,/,4X,'Test to move obs to nearest level: ',2X,L1
S ,/,4X,'Latitude desired (-90 to 90) : ',2X,F6.2
S ,/,4X,'Longitude desired (0 to 360) : ',2X,F6.2
S ,/,4X,'Vertical level desired (mb) : ',2X,F6.2
S ,/,4X,'Std deviation obs error : ',2X,F6.2
S ,/,4X,'Size of the innovation : ',2X,F6.2
S ,/,4X,'Index of grid point nearest to latitude :',2X,i5
S ,/,4X,'Index of grid point nearest to longitude :',2X,i5)
C
WRITE(NULOUT,*)'Index of the nearest eta level to R1OBSLV= '
S ,R1OBSLV
WRITE(NULOUT,*)'WILL BE CALCULATED BY THE ROUTINE ONEOBS '
c
c For 4dvar job only write out number of segments and simulation number in init file
IF(L4DVAR.and.(.not.lcva_3db)) THEN
nsim3d=1
write(nulout,*) 'IN SU1OBS: WRITING INIT.PROF FILE'
clprof = trim(CEXC4DV) // '/init.prof'
ihdl = prof_open(clprof,'WRITE','FILE')
istat = prof_pvar(ihdl,1,prm_stob)
istat = prof_pvar(ihdl,nsim3d,prm_rstr)
istat = prof_wrrec(ihdl)
istat = prof_close(ihdl)
ENDIF
C
C
RETURN
END