!-------------------------------------- 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 CSIMOBS1 1,10
#if defined (DOC)
*
***s/r CSE1 - Create a set of simulated observations
* . Control at level 1
*
*
*Author : P. Gauthier *ARMA/AES May 8, 1995
*Revision:
* P. KOCLAS CMC/CMSV June 98
* - Y2K conversion
* S. Pellerin *ARMA/SMC May 2000
* - Logical unit clean up
*
*
* -------------------
** Purpose: to simulate observations by using a model state
* . to which noise is simulated and added to the
* . synthetic observation. This configuration can also
* . be employed to transfer observation in grid format
* . to a CMA format (NCONF/100 = 4)
*Arguments
* -NONE-
#endif
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdimo.cdk"
#include "comlun.cdk"
#include "comgdpar.cdk"
#include "compost.cdk"
C
INTEGER IERR, IULSTATE, IULCMA, IENS, JENS, jo
C
C* RPN Standard files parameters
C
REAL*8 ZDEET
INTEGER FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF, FSTINL
INTEGER INI,INJ,INK, INPAS, INBITS, IDATYP, IDEET
+ ,IP1,IP2,IP3,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3
INTEGER ILISTE(100),IDATE(100),IDATV(100),IDIMAX,INFON,IFSTRUN,IHH
REAL*8 DHEURES
CHARACTER*1 CLTYPVAR,CLGRTYP
CHARACTER*2 CLNOMVAR
CHARACTER*8 CLETIKET
EXTERNAL FNOM, FSTOUV, FSTFRM, FCLOS, FSTPRM, FSTINF,FSTINL
C
WRITE(NULOUT,FMT=9000)
9000 FORMAT(//,3(" *****************"),/,6X
S ," CSIMOBS1- Creation of simulated observations",/
S ,3(" *****************"),/
S ," -- Revised version 6.09 --")
C
*
* 1. Set-up of miscellaneous parameters and open files
*
100 CONTINUE
C
IULSTATE = 56
IULCMA = 57
IDIMAX = 100
C
CALL READNML('NAMGDPAR',IERR)
*
IERR = FNOM (IULSTATE,'FSTOBS','RND',0)
IF(IERR.GE.0)THEN
IERR = FSTOUV(IULSTATE,'RND')
ELSE
CALL ABORT3D(NULOUT,'CSIMOBS1')
END IF
*
*
* 1.1 Determine the number of model states to be processed
* . and find out the related parameters
*
110 CONTINUE
IERR = FSTINL (IULSTATE,INI,INJ,INK
S ,-1,CETIKETN,-1,-1,-1,' '
S ,'DU',ILISTE,INFON,IDIMAX)
WRITE(NULOUT,9110)INFON
9110 FORMAT(//,4X,"Ensemble of ",I4," cases")
IENS = INFON
*
C
CALL READNML('NAMGDPAR',IERR)
DO JENS = 1, IENS
IERR = FSTPRM(ILISTE(JENS),IDATE(JENS),IDEET,INPAS
+ ,INI,INJ,INK, INBITS, IDATYP
+ ,IP1,IP2,IP3,CLTYPVAR,CLNOMVAR,CLETIKET,CLGRTYP
+ ,IG1,IG2,IG3,IG4,ISWA,ILENGTH,IDLTF
+ ,IUBC,IEXTR1,IEXTR2,IEXTR3)
DHEURES = DBLE(INPAS*IDEET/3600)
*
CALL INCDATR(IDATV(JENS),IDATE(JENS),DHEURES)
CALL NEWDATE(IDATV(JENS),IFSTRUN,IHH,-3)
WRITE(NULOUT,9111)JENS, IFSTRUN,IHH
END DO
9111 FORMAT(5X,"Case No. ",I3,5x,"Date and time: ",I10,5x,I8)
*
* 3. Start processing the model states
*
300 CONTINUE
DO 301 JENS = 1, 1
*
* . 3.1 Read in the model state
*
CTYPVARN = CLTYPVAR
NSTAMPN = IDATE(JENS)
CALL GETFST(IULSTATE,'G','N')
NSTAMP = NSTAMPN
CALL POSTPROC(NULSTD,JENS,'GRID','OBSO3 ')
*
* . 3.2. Define the observations arrays (ROBHDR and ROBDATA)
*
320 CONTINUE
*
CALL CSIMOBS2(NSTAMPN)
IERR = FNOM (IULCMA,'CMAFILE','RND',0)
IF(IERR.GE.0)THEN
IERR = FSTOUV(IULCMA,'RND')
ELSE
CALL ABORT3D(NULOUT,'CSIMOBS1')
END IF
*
CALL WRITECMA(IULCMA)
* CALL READCMA(IULCMA)
*
DO JO=1, NOBTOT,1000
CALL PRNTHDR(JO,NULOUT)
CALL PRNTBDY(JO,NULOUT)
END DO
*
* . 3.3 Write the data arrays on a RPN standard file
*
330 CONTINUE
301 CONTINUE
*
* 9. Close all files
*
900 CONTINUE
IERR = FSTFRM(IULSTATE)
IERR = FCLOS (IULSTATE)
RETURN
END