!-------------------------------------- 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 setsynthobs() 1,7
implicit none
!
! Global variables
!
#include "comlun.cdk"
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comleg.cdk"
#include "comcst.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "comnumbr.cdk"
#include "cparbrp.cdk"
#include "com1obs.cdk"
#include "cvcord.cdk"
!
! Local variables
!
integer :: ilon, ilat, ialt, idata, itime, idate, iobstype
c
INTEGER IERR,ISRCHILA,IHDL,ISTAT,prof_wrrec
REAL*8 Z1OBSLA
REAL*8 ZLAT1,ZLAT2,zlonrad
write(nulout,fmt='(//,8x,A)')'SYNTHOBS: reading synthetic observation'
!
! Read parameters characterizing this observation
!* 1. Default values
LONEOBS = .FALSE.
R1OBSLA = 50.0
R1OBSLO = 330.0
R1OBSLV = 1020.0
R1OBSINO = 1.0
R1OBSOER = 5.15
C1OBSTP = 'UU'
C1OBSBG = 'FGUESS'
NDATE1OBS = 20030106
NTIME1OBS = 1200
! 2. Read the NAMELIST NAM1OBS to modify them
!
WRITE(NULOUT,FMT='(3x,A)')'- reading the namelist NAM1OBS in SetSynthObs'
!
CALL READNML('NAM1OBS',IERR)
if (.not.loneobs) then
write(nulout,fmt='(/,8x,A)')'No synthetic observation is requested'
return
end if
!
! Incrementing NOBTOT and NDATA
!
nobtot = nobtot + 1
ndata = ndata + 1
IF ( NDATA .GE. NDATAMX .OR. NOBTOT .GE. NMXOBS ) THEN
WRITE(NULOUT,'(1x,"NDATA = ",I10," NDATAMX",I10)')
& NDATA, NDATAMX
WRITE(NULOUT,'(1x,"NOBTOT= ",I10," NMXOBS = ",I10)')
& NOBTOT, NMXOBS
call abort3d()
end if
C
C * . 1.2 Calculate indexes of nearest analysis grid point
C and vertical level
C . ---------------------------------------
! Longitude
!
call srchlon(NI1OBSLO,zlonrad,R1OBSLO)
!
! 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
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 (synthetic obs) : ',2X,A2
S ,/,4X,'Type of background field : ',2X,A8
S ,/,4X,'Test to start single obs exp : ',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
C Setting the BURP observation code
C
select case (c1obstp)
case('UU')
iobstype = nvnumb( 1)
case('VV')
iobstype = nvnumb( 2)
case('TT')
iobstype = nvnumb( 8)
case('TG')
iobstype = nvnumb(10)
case('US')
iobstype = nvnumb(12)
case('VS')
iobstype = nvnumb(13)
case('PS')
iobstype = 10004
case('PN')
iobstype = 10051
case default
iobstype = nvnumb(1)
end select
!
! Filling ROBHDR/MOBHDR
! (similar to what is done in BRPACMA)
ROBHDR(NCMLON,NOBTOT) = zlonrad
ROBHDR(NCMLAT,NOBTOT) = z1obsla
ROBHDR(NCMALT,NOBTOT) = 0.
ROBHDR(NCMTLO,NOBTOT) = zlonrad
ROBHDR(NCMTLA,NOBTOT) = z1obsla
MOBHDR(NCMNLV,NOBTOT) = 1
*
IF ( NOBTOT .EQ. 1) THEN
MOBHDR(NCMRLN,1)=1
ELSE
MOBHDR(NCMRLN,NOBTOT) = MOBHDR(NCMRLN,NOBTOT-1)
+ + MOBHDR(NCMNLV,NOBTOT-1)
ENDIF
!
! REMAINDER OF HEADER
!
MOBHDR(NCMONM,NOBTOT) = NOBTOT
MOBHDR(NCMBOX,NOBTOT) = -1
MOBHDR(NCMOTP,NOBTOT) = NVTYP
MOBHDR(NCMITY,NOBTOT) = -1
MOBHDR(NCMDAT,NOBTOT) = NDATE1OBS
MOBHDR(NCMETM,NOBTOT) = NTIME1OBS
MOBHDR(NCMSID,NOBTOT) = -1
MOBHDR(NCMSI2,NOBTOT) = -1
MOBHDR(NCMSI3,NOBTOT) = -1
MOBHDR(NCMOEC,NOBTOT) = -1
MOBHDR(NCMOFL,NOBTOT) = -1
MOBHDR(NCMST1,NOBTOT) = -1
!
! Filling ROBDATA/MOBDATA
! (similar to what is done in CMABDY)
ROBDATA8(NCMPPP,NDATA) = r1obslv*100.
ROBDATA8(NCMVAR,NDATA) = 1.
ROBDATA8(NCMOMF,NDATA) = r1obsino
ROBDATA8(NCMOMA,NDATA) = PPMIS
ROBDATA8(NCMOMI,NDATA) = PPMIS
ROBDATA (NCMFGE,NDATA) = PPMIS
ROBDATA8(NCMOER,NDATA) = r1obsoer
ROBDATA8(NCMPRL,NDATA) = PPMIS
!
MOBDATA(NCMVNM,NDATA) = iobstype
MOBDATA(NCMVCO,NDATA) = NVCORDTYP
MOBDATA(NCMFLG,NDATA) = -1
*
return
*
end subroutine setsynthobs