!-------------------------------------- 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 SUCOVO 1,27
#if defined (DOC)
*
*s/r SUCOVO -SET OBSERVATION ERROR
*
*Author : P. Koclas *CMC/AES April 1996
*Revision:
* . S. Pellerin *ARMA/AES Sept 97.
* - Change from TT to GZ states variable
* - Control of the different model state of the 3Dvar
* through COMSTATE, COMSTATEC and COMSTNUM common
* blocks variables (comstate.cdk).
* . S. Pellerin *ARMA/AES June 98.
* - Bug fix to the opening of stat file
* Now the logical unit NULSTAT is specified and binded to
* the stat file in sulun.
* . C. Charette *ARMA/AES Sept 98.
* - Pressure levels in Pascal (nilv,nislv,nihulv)
* - No more dependence on the vector vlev
* from the namelist
* . P. Koclas *CMC/CMDA June 99.
* - Y2K
* . P. Koclas *CMC/CMDA dec 99.
* - Lowered ERRORS FOR ACARS ADS TEMPERATURES
* - Code for upper air temperature observation errors.
* . R. Sarrazin *CMC/CMDA Feb 2000
* - change the obs errors
* . C. Charette *ARMA/AES jun 2000.
* - Added surface elements
* 11215,11216,12004,12203,10004,10051
* - Added table of observation errors std for sfc elements
* Based on values from ECMWF Tech. Memo no.241
* JM Belanger CMDA/SMC Oct 2000
* . 32 bits conversion
* (obs error variances as double precision constants)
* . R. Sarrazin *CMC/CMDA Jul 2001
* - change the obs errors of satwinds
* . C. Charette *ARMA/AES Dec 2001.
* - Added idburp 34,37,38,159,sucovo.ftn__Version1,162 in IDLISTUA
* JM Belanger CMDA/SMC Dec 2003
* . Set observation error std dev for Quisckat
* (codtyp = 254)
* . R. Sarrazin *CMC March 2004.
* - initialisation of xstdevlv for satwinds errors
* . R. Sarrazin *CMC July 2008.
* - change errors of satwinds
* R. Sarrazin, Nov 2006
* - include ES error values for AI family
*
** Purpose:
* -initialize observation error standard deviations
* and vertical error correlation matrices
*
*Arguments
* none
*
#endif
C
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "comcst.cdk"
#include "comnumbr.cdk"
#include "comstato.cdk"
*
C
REAL*8 ZEIGENV(JPRLEV),ZEIGEN(JPRLEV,JPRLEV),ZEIGMIN,ZALPHA
REAL*8 ZPROJ(JPRLEV,JPRLEV)
REAL*8 ZVCOR(JPRLEV,JPRLEV),UVCOR(JPRLEV,JPRLEV),
$ ESVCOR(JPRLEV,JPRLEV)
REAL*8 PHISTD(JPRLEV,JPBANDS),USTD(JPRLEV,JPBANDS),
$ ESSTD(JPRLEV,JPBANDS),TTSTD(JPRLEV,JPBANDS)
REAL*8 DZCOR(JPSALEV,JPSALEV)
REAL*8 HUCOR(JPHLEV ,JPHLEV)
*
INTEGER IDUM,IERR,IKEY,JTYP
INTEGER INI,INJ,INK,IDATE,ISTAMP,IDT,INP
INTEGER IP1,IP2,IP3
INTEGER IJ,JI,J
REAL*8 DHEURES
CHARACTER*1 CTYPVAR,CGRTYP
CHARACTER*2 CNOMVAR
CHARACTER*8 CETIKET,CETIKETV
CHARACTER*1 CTVAR
CHARACTER*2 CNVAR
LOGICAL LLPRESNT,LLOK,LLPROB,LLTT
INTEGER FSTLIR,VFSTLIR,FSTPRM
EXTERNAL FSTLIR,VFSTLIR,FSTPRM
C
INTEGER JPMXIDUA
PARAMETER (JPMXIDUA=23)
INTEGER IDLISTUA(JPMXIDUA)
DATA IDLISTUA/ 32, 33, 34, 35, 36, 37, 38, 135, 136, 137, 138
& ,139, 140 ,141 ,142 ,150, 151, 152, 153
& ,159, 160, 161, 162 /
C
INTEGER JLEV,JBAND,JN,JELM,JID,IID
INTEGER ILYR,ILEMU,ILEMV,ILEMGZ,ILEMTT,ILEMES
INTEGER ILEMUS,ILEMVS,ILEMTS,ILEMESS,ILEMPS,ILEMPN
REAL*8 ZLYR, ZLEV, ZCONGZ
INTEGER IFIND
C
C
C AIREP : ASDAR : SATOB
C ---------------------
C STANDARD DEVIATIONS TABLES (FROM OI CODE:DORES)
C -----------------------------------------------------
C Kts**2 Dam**2 DEG**2 DEG**2
C
DATA (XSTDEV(J,1),J=1,5)/25.0D0,100.0D0,-5000.D0,4.50D0,-5000.D0/
DATA (XSTDEV(J,2),J=1,5)/36.0D0,49.0D0,-5000.D0,3.00D0,9.0D0/
DATA (XSTDEV(J,3),J=1,5)/25.0D0,36.0D0,-5000.D0,1.50D0,5.0D0/
DATA (XSTDEV(J,4),J=1,5)/49.D0,49.D0, .36D0, 2.25D0, 9.0D0/
C
DATA (XSTDEVLV(J,1),J=1,10)/2.5D0,2.5D0,3.0D0,4.0D0,4.5D0,
& 5.0D0,5.5D0,5.5D0,5.5D0,6.0D0/
DATA (XSTDEVLV(J,2),J=1,10)/1000.0D0,850.0D0,700.0D0,500.0D0,
& 400.0D0,300.0D0,250.0D0,200.0D0,
& 150.0D0,100.0D0/
C
C CONVERSION FACTORS:
C
C TO GEOPOTENTIAL
C ---------------
ZCONGZ=RG
C ---------------
C
C*0. DEFAULT VALUES
C ----------------
C
ILEMGZ=IFIND ( NEGZ )
ILEMU=IFIND ( NEUU )
ILEMV=IFIND ( NEVV )
ILEMTT=IFIND ( NETT )
ILEMES=IFIND ( NEES )
C
ILEMUS=IFIND ( NEUS )
ILEMVS=IFIND ( NEVS )
ILEMTS=IFIND ( NETS )
ILEMESS=IFIND( NESS )
ILEMPS=IFIND ( NEPS )
ILEMPN=IFIND ( NEPN )
C
DO JELM =1,JPNBRELEM
DO JID =1,JPIDBRP
XSFCOBERR(JELM,1,JID) = -1
END DO
END DO
C
DO JBAND =1,JPBANDS
DO JLEV =1,JPRLEV
IF(ILEMU .NE. -1) XOSTDEV( ILEMU, JLEV,JBAND)= 2.235764D0
IF(ILEMV .NE. -1) XOSTDEV( ILEMV, JLEV,JBAND)= 2.235764D0
IF(ILEMGZ .NE. -1) XOSTDEV( ILEMGZ,JLEV,JBAND)= 0.75D0
IF(ILEMTT .NE. -1) XOSTDEV( ILEMTT,JLEV,JBAND)= .82462113D0
IF(ILEMES .NE. -1) XOSTDEV( ILEMES,JLEV,JBAND)= 3.00D0
END DO
END DO
C
C The following std(us,vs,ts,ps,pn) are taken or are derived from
C ECMWF Tech. Memo no.241
C "The ECMWF implementation of three dimensional variational
C assimilation Part I: Formulation" (P.Courtier and al. 1997)
C Units are: US,VS---> M/S
C TS ---> K
C ESS ---> K
C PS,PN---> PA
C We assume that the values for wind in the ECMWF document are
C for the wind vector. We want values for the wind component.
DO JELM =1,JPNBRELEM
IF(ILEMUS .NE. -1 .AND. ILEMVS .NE. -1) THEN
XSFCOBERR( ILEMUS,1,12) = 3.0D0/SQRT(2.0D0)
XSFCOBERR( ILEMVS,1,12) = 3.0D0/SQRT(2.0D0)
XSFCOBERR( ILEMUS,1,13) = 3.0D0/SQRT(2.0D0)
XSFCOBERR( ILEMVS,1,13) = 3.0D0/SQRT(2.0D0)
XSFCOBERR( ILEMUS,1,14) = 2.4D0/SQRT(2.0D0)
XSFCOBERR( ILEMVS,1,14) = 2.4D0/SQRT(2.0D0)
XSFCOBERR( ILEMUS,1,18) = 2.4D0/SQRT(2.0D0)
XSFCOBERR( ILEMVS,1,18) = 2.4D0/SQRT(2.0D0)
XSFCOBERR( ILEMUS,1,145)= 3.0D0/SQRT(2.0D0)
XSFCOBERR( ILEMVS,1,145) = 3.0D0/SQRT(2.0D0)
XSFCOBERR( ILEMUS,1,146) = 3.0D0/SQRT(2.0D0)
XSFCOBERR( ILEMVS,1,146) = 3.0D0/SQRT(2.0D0)
XSFCOBERR( ILEMUS,1,147) = 2.4D0/SQRT(2.0D0)
XSFCOBERR( ILEMVS,1,147) = 2.4D0/SQRT(2.0D0)
XSFCOBERR( ILEMUS,1,254) = 2.4D0/SQRT(2.0D0)
XSFCOBERR( ILEMVS,1,254) = 2.4D0/SQRT(2.0D0)
DO JID =1,JPMXIDUA
IID = IDLISTUA(JID)
XSFCOBERR( ILEMUS,1,IID) = 3.0D0/SQRT(2.0D0)
XSFCOBERR( ILEMVS,1,IID) = 3.0D0/SQRT(2.0D0)
END DO
ENDIF
IF(ILEMTS .NE. -1 ) THEN
XSFCOBERR( ILEMTS,1,12) = 2.0D0
XSFCOBERR( ILEMTS,1,13) = 1.8D0
XSFCOBERR( ILEMTS,1,14) = 1.8D0
XSFCOBERR( ILEMTS,1,18) = 1.8D0
XSFCOBERR( ILEMTS,1,145)= 1.8D0
XSFCOBERR( ILEMTS,1,146)= 2.0D0
XSFCOBERR( ILEMTS,1,147)= 1.8D0
DO JID =1,JPMXIDUA
IID = IDLISTUA(JID)
XSFCOBERR( ILEMTS,1,IID) = 1.8D0
END DO
ENDIF
IF(ILEMESS .NE. -1 ) THEN
XSFCOBERR( ILEMESS,1,12) = 3.0D0
XSFCOBERR( ILEMESS,1,13) = 3.0D0
XSFCOBERR( ILEMESS,1,14) = 3.0D0
XSFCOBERR( ILEMESS,1,18) = 3.0D0
XSFCOBERR( ILEMESS,1,145)= 3.0D0
XSFCOBERR( ILEMESS,1,146)= 3.0D0
XSFCOBERR( ILEMESS,1,147)= 3.0D0
DO JID =1,JPMXIDUA
IID = IDLISTUA(JID)
XSFCOBERR( ILEMESS,1,IID) = 3.0D0
END DO
ENDIF
IF(ILEMPS .NE. -1 ) THEN
ccc XSFCOBERR( ILEMPS,1,12) = SQRT((0.7*0.7)/(0.8*0.8))*100.
XSFCOBERR( ILEMPS,1,12) =
$ SQRT((0.6D0*0.6D0)/(0.8D0*0.8D0))*100.D0
XSFCOBERR( ILEMPS,1,13) =
$ SQRT((1.4D0*1.4D0)/(0.8D0*0.8D0))*100.D0
XSFCOBERR( ILEMPS,1,14) =
$ SQRT((1.15D0*1.15D0)/(0.8D0*0.8D0))*100.D0
XSFCOBERR( ILEMPS,1,18) =
$ SQRT((1.15D0*1.15D0)/(0.8D0*0.8D0))*100.D0
XSFCOBERR( ILEMPS,1,145)=
$ SQRT((1.4D0*1.4D0)/(0.8D0*0.8D0))*100.D0
ccc XSFCOBERR( ILEMPS,1,146)= SQRT((0.7*0.7)/(0.8*0.8))*100.
XSFCOBERR( ILEMPS,1,146)=
$ SQRT((0.6D0*0.6D0)/(0.8D0*0.8D0))*100.D0
XSFCOBERR( ILEMPS,1,147)=
$ SQRT((1.4D0*1.4D0)/(0.8D0*0.8D0))*100.D0
DO JID =1,JPMXIDUA
IID = IDLISTUA(JID)
XSFCOBERR( ILEMPS,1,IID) =
$ SQRT((0.7D0*0.7D0)/(0.8D0*0.8D0))*100.D0
END DO
ENDIF
IF(ILEMPN .NE. -1 ) THEN
XSFCOBERR( ILEMPN,1,12) =
$ SQRT((0.7D0*0.7D0)/(0.8D0*0.8D0))*100.D0
XSFCOBERR( ILEMPN,1,13) =
$ SQRT((1.4D0*1.4D0)/(0.8D0*0.8D0))*100.D0
XSFCOBERR( ILEMPN,1,14) =
$ SQRT((1.15D0*1.15D0)/(0.8D0*0.8D0))*100.D0
XSFCOBERR( ILEMPN,1,18) =
$ SQRT((1.15D0*1.15D0)/(0.8D0*0.8D0))*100.D0
XSFCOBERR( ILEMPN,1,145)=
$ SQRT((1.4D0*1.4D0)/(0.8D0*0.8D0))*100.D0
XSFCOBERR( ILEMPN,1,146)=
$ SQRT((0.7D0*0.7D0)/(0.8D0*0.8D0))*100.D0
XSFCOBERR( ILEMPN,1,147)=
$ SQRT((1.4D0*1.4D0)/(0.8D0*0.8D0))*100.D0
DO JID =1,JPMXIDUA
IID = IDLISTUA(JID)
XSFCOBERR( ILEMPN,1,IID) =
$ SQRT((0.7D0*0.7D0)/(0.8D0*0.8D0))*100.D0
END DO
ENDIF
END DO
LLPROB=.FALSE.
LLTT = .TRUE.
IP1=-1
IP2=-1
IP3=1
C
C*1. READ LEVELS FROM FILE
C ---------------------
C
100 CONTINUE
C
CETIKET='RAOBOERR'
CTYPVAR='K'
CNOMVAR='LV'
IKEY=FSTLIR(NILV,NULSTAT,INI,INJ,INK,-1,CETIKET,IP1,IP2,IP3,
+ CTYPVAR,CNOMVAR)
LLPRESNT = (IKEY .GE. 0)
if(llpresnt) then
IERR = FSTPRM (IKEY,ISTAMP,IDT,INP,INI,INJ,INK,IDUM,IDUM,
+ IDUM,IDUM,IDUM,CTVAR,CNVAR,CETIKET,CGRTYP,IDUM,
+ IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM)
C
DHEURES = DBLE(INP*IDT/3600)
CALL INCDATR(IDATE,ISTAMP,DHEURES)
C
DO JLEV = 1,JPRLEV
NILV(JLEV) = NILV(JLEV)*RMBTPA
END DO
C
C SORT LEVELS SO THAT THEY ARE STORED IN INCREASING ORDER
C FOR 3D-VAR
C
C ========================
CALL ISORT(NILV,JPRLEV)
C ========================
C
C ------------------------------------------------------------
C READ DATA FROM STATISTICS FILE
C ------------------------------------------------------------
C -----------
CTYPVAR='O'
C -----------
C
CNOMVAR='GZ'
CETIKET='RAOBSTD'
IERR=VFSTLIR(PHISTD,NULSTAT,INI,INJ,INK,IDATE,CETIKET,IP1,IP2,IP3
+ ,CTYPVAR,CNOMVAR)
LLPRESNT = (IERR .GE. 0)
CETIKET='RAOBVCOR'
IERR=VFSTLIR(ZVCOR,NULSTAT,INI,INJ,INK,IDATE,CETIKET,IP1,IP2,IP3
+ ,CTYPVAR,CNOMVAR)
LLPRESNT = (IERR .GE. 0) .AND. LLPRESNT
C
CNOMVAR='TT'
CETIKET='RAOBSTD'
IERR=VFSTLIR(TTSTD,NULSTAT,INI,INJ,INK,IDATE,CETIKET,IP1,IP2,IP3
+ ,CTYPVAR,CNOMVAR)
IF ( IERR .LT. 0 ) LLTT=.FALSE.
C
CNOMVAR='ES'
CETIKET='RAOBSTD'
IERR=VFSTLIR(ESSTD,NULSTAT,INI,INJ,INK,IDATE,CETIKET,IP1,IP2,IP3
+ ,CTYPVAR,CNOMVAR)
LLPRESNT = (IERR .GE. 0) .AND. LLPRESNT
CETIKET='RAOBVCOR'
IERR=VFSTLIR(ESVCOR,NULSTAT,INI,INJ,INK,IDATE,CETIKET,IP1,IP2,IP3
+ ,CTYPVAR,CNOMVAR)
LLPRESNT = (IERR .GE. 0) .AND. LLPRESNT
C
C
CNOMVAR='UU'
CETIKET='RAOBSTD'
IERR=VFSTLIR(USTD,NULSTAT,INI,INJ,INK,IDATE,CETIKET,IP1,IP2,IP3
+ ,CTYPVAR,CNOMVAR)
LLPRESNT = (IERR .GE. 0) .AND. LLPRESNT
CETIKET='RAOBVCOR'
IERR=VFSTLIR(UVCOR,NULSTAT,INI,INJ,INK,IDATE,CETIKET,IP1,IP2,IP3
+ ,CTYPVAR,CNOMVAR)
LLPRESNT = (IERR .GE. 0) .AND. LLPRESNT
endif
C ------------------------------------------------------------
C
C
C -------------------------------------
C FILTER AND FILL CORRELATION MATRICES
C -------------------------------------
C
CALL ZERO(JPMAXILEV*JPMAXILEV*JPCORBANDS,GZOBSCOR)
CALL ZERO(JPMAXILEV*JPMAXILEV*JPCORBANDS,ESOBSCOR)
CALL ZERO(JPMAXILEV*JPMAXILEV*JPCORBANDS,UUOBSCOR)
if(llpresnt) then
DO JBAND =1,JPCORBANDS
WRITE(NULOUT,*) " "
WRITE(NULOUT,*) " -----------------------------"
WRITE(NULOUT,*) " BAND NUMBER IS : ",JBAND
WRITE(NULOUT,*) " -----------------------------"
WRITE(NULOUT,*) " "
C
C FILTER THE MATRICES "TO REMOVE SINGULARITIES..."
C
C 1. GEOPOTENTIAL
C ------------
ZEIGMIN=0.2
ZALPHA=0.1
WRITE(NULOUT,*) " filtering GZ correlation matrix"
CALL FILTMATRIX(ZVCOR,ZPROJ,ZEIGEN,ZEIGENV,
& JPRLEV,ZEIGMIN,ZALPHA)
C
C 2. T-Td
C -----
ZEIGMIN=0.0
ZALPHA=0.0
WRITE(NULOUT,*) " filtering ES correlation matrix"
CALL FILTMATRIX(ESVCOR,ZPROJ,ZEIGEN,ZEIGENV,
& JPRLEV,ZEIGMIN,ZALPHA)
C
DO JI=1,JPRLEV
DO J=1,JPRLEV
GZOBSCOR(JI,J,JBAND)= ZVCOR(JI,J)
ESOBSCOR(JI,J,JBAND)=ESVCOR(JI,J)
UUOBSCOR(JI,J,JBAND)= UVCOR(JI,J)
END DO
END DO
END DO
endif
C
C -------------------------------------------------------------------
C -------------------------------------
C PRINT FINAL CORRELATION MATRICES
C -------------------------------------
C
DO JBAND =1,JPCORBANDS
WRITE(NULOUT,*) " "
WRITE(NULOUT,*) " -----------------------------"
WRITE(NULOUT,*) " BAND NUMBER IS : ",JBAND
WRITE(NULOUT,*) " -----------------------------"
WRITE(NULOUT,*) " "
WRITE(NULOUT,*) " GZ correlation matrix"
WRITE(NULOUT,*) " -------------------------------------------------"
WRITE(NULOUT,1245)( (GZOBSCOR(JI,J,JBAND),JI=1,JPRLEV),J=1,JPRLEV)
WRITE(NULOUT,*) " -------------------------------------------------"
C
C -------------------------------------------------------------------
C
WRITE(NULOUT,*) " UU-VV correlation matrix"
WRITE(NULOUT,*) " -------------------------------------------------"
WRITE(NULOUT,1245)( (UUOBSCOR(JI,J,JBAND),JI=1,JPRLEV),J=1,JPRLEV)
WRITE(NULOUT,*) " -------------------------------------------------"
C
C -------------------------------------------------------------------
C
WRITE(NULOUT,*) " T-Td correlation matrix"
WRITE(NULOUT,*) " -------------------------------------------------"
WRITE(NULOUT,1245)( (ESOBSCOR(JI,J,JBAND),JI=1,JPRLEV),J=1,JPRLEV)
WRITE(NULOUT,*) " -------------------------------------------------"
END DO
C
C
C*3. Initialize observation standard deviation errors
C -------------------------------------------------------------------
C
LLOK= ( LLPRESNT .AND. ( ILEMU .NE. -1 ) )
& .AND. ( LLPRESNT .AND. ( ILEMV .NE. -1 ) )
& .AND. ( LLPRESNT .AND. ( ILEMES.NE. -1 ) )
& .AND. ( LLPRESNT .AND. ( ILEMGZ.NE. -1 ) )
C
IF ( LLOK ) THEN
C
C COMPUTE OBSERVATION STANDARD DEVIATION ERRORS
C
DO JBAND =1,JPBANDS
DO JLEV =1,JPRLEV
ILYR=0
ZLEV=FLOAT(NILV(JLEV))
DO JN =1,JPRLEV
ZLYR=SIGN(1.0D0,(ZLEV- FLOAT(NILV(JN)) ) )
ILYR=ILYR + MAX(0.0D0,ZLYR)
END DO
*pik
XOSTDEV(ILEMGZ,ILYR,JBAND)= RG*PHISTD(ILYR,JBAND)
XOSTDEV(ILEMU, ILYR,JBAND)= USTD(ILYR,JBAND)
XOSTDEV(ILEMV, ILYR,JBAND)= USTD(ILYR,JBAND)
XOSTDEV(ILEMES,ILYR,JBAND)= ESSTD(ILYR,JBAND)
IF( LLTT ) THEN
XOSTDEV(ILEMTT,ILYR,JBAND)= TTSTD(ILYR,JBAND)
ELSE
write(nulout,*) ' DEFAULT VALUES FOR TT RAOB OBS ERRORS'
ENDIF
*pik
END DO
END DO
ELSE
LLPROB=.TRUE.
WRITE(NULOUT,*)" DEFAULT VALUES ARE USED FOR RAOBS ERRORS "
ENDIF
C
C
IF ( .NOT. LLPROB ) THEN
WRITE(NULOUT,*)" ----------------- "
WRITE(NULOUT,*)" SUBROUTINE ERROBS:"
WRITE(NULOUT,*)" RAOBS ERRORS SET "
WRITE(NULOUT,*)" ----------------- "
ELSE
WRITE(NULOUT,*)" ------------------------------- "
WRITE(NULOUT,*)" SUBROUTINE ERROBS:"
WRITE(NULOUT,*)" PROBLEM WITH STATISTICS FILE "
WRITE(NULOUT,*)" DEFAULT VALUES FOR RAOBS ERRORS "
WRITE(NULOUT,*)" ------------------------------- "
ENDIF
C
C================================================================
C
C SATEM OBSERVATION ERRORS
C
C================================================================
C
IP1=-1
IP2=-1
IP3=1
C
C
C*1. READ LEVELS FROM FILE
C ---------------------
C
CTYPVAR='K'
CNOMVAR='LV'
CETIKET='SATMOERR'
IKEY=FSTLIR(NISLV,NULSTAT,INI,INJ,INK,-1,CETIKET,IP1,IP2,IP3,
+ CTYPVAR,CNOMVAR)
LLPRESNT = (IKEY .GE. 0)
IERR = FSTPRM (IKEY,ISTAMP,IDT,INP,INI,INJ,INK,IDUM,IDUM,
+ IDUM,IDUM,IDUM,CTVAR,CNVAR,CETIKET,CGRTYP,IDUM,
+ IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM,IDUM)
C
DO JLEV = 1,JPSATLV
NISLV(JLEV) =NISLV(JLEV)*RMBTPA
END DO
C
C =========================
CALL ISORT(NISLV,JPSATLV)
C =========================
C
CTYPVAR='O'
CNOMVAR='DZ'
IP3=7
DO JTYP =1,JPNTYP
IF ( JTYP .EQ. 1) THEN
CETIKET= 'STMCLRCR'
CETIKETV='STMCLRST'
ELSE
CETIKET= 'STMCLOCR'
CETIKETV='STMCLOST'
ENDIF
C-----------------------------------------------------------------------
IKEY=VFSTLIR(DZCOR,NULSTAT,INI,INJ,INK,IDATE,CETIKET,IP1,IP2,IP3
+ ,CTYPVAR,CNOMVAR)
LLPRESNT = (IKEY .GE. 0) .AND. LLPRESNT
LLOK =LLPRESNT .AND. (INI.EQ.JPSALEV) .AND.(INJ.EQ.JPSALEV)
IKEY=VFSTLIR(XSATDEV(1,JTYP),NULSTAT,INI,INJ,INK,IDATE,CETIKETV
+ ,IP1,IP2,IP3,CTYPVAR,CNOMVAR)
LLOK = (IKEY .GE. 0) .AND. LLOK
C-----------------------------------------------------------------------
C
IF ( LLOK ) THEN
C
C MOVE INTO FULL CORRELATION MATRIX
C
DO J = 1, JPSALEV
DO JI=1,JPSALEV
DZOBSCOR(JI,J,JTYP) = DZCOR(JI,J)
END DO
END DO
WRITE(NULOUT,*)" correlation matrix for satems with TYPE:",CETIKET
WRITE(NULOUT,*)" ------------------------------------------------"
WRITE(NULOUT,1244)((DZOBSCOR(JI,J,JTYP),JI=1,JPSALEV),J=1,JPSALEV)
WRITE(NULOUT,*)" ------------------------------------------------"
ELSE
LLPROB=.TRUE.
WRITE(NULOUT,*) " PROBLEM WITH SATEM STATISTICS "
ENDIF
END DO
C
C=======================================================================
C
C HUMSAT CORRELATION MATRIX (7x7 matrix )
C STORED FROM 300-1000 MB
C
C JPHLEV = 7
C================================================================
C
C
C
C*1. READ LEVELS FROM FILE
C ---------------------
C
CTYPVAR='K'
CNOMVAR='LV'
CETIKET='HUMOERR '
IP1=-1
IP2=-1
IP3=-1
IKEY=FSTLIR(NIHULV,NULSTAT,INI,INJ,INK,-1,CETIKET,IP1,IP2,IP3,
+ CTYPVAR,CNOMVAR)
LLPRESNT = (IKEY .GE. 0)
C
DO JLEV = 1,JPHLEV
NIHULV(JLEV) = NIHULV(JLEV)*RMBTPA
END DO
C-----------------------------------------------------------------------
CTYPVAR='O'
CNOMVAR='ES'
CETIKET='HUMVCOR '
IKEY=VFSTLIR(HUCOR,NULSTAT,INI,INJ,INK,IDATE,CETIKET,IP1,IP2,IP3
+ ,CTYPVAR,CNOMVAR)
LLOK =LLPRESNT .AND. (INI.EQ.JPHLEV) .AND.(INJ.EQ.JPHLEV)
LLOK = (IKEY .GE. 0) .AND. LLOK
C-----------------------------------------------------------------------
C
C MOVE INTO FULL CORRELATION MATRIX
C
IF ( LLOK) THEN
CALL ZERO(JPMAXILEV*JPMAXILEV,HUOBSCOR)
DO J = 1, JPHLEV
DO JI=1,JPHLEV
HUOBSCOR(JI,J) = HUCOR(JI,J)
END DO
END DO
WRITE(NULOUT,*) " correlation matrix for humsat "
WRITE(NULOUT,*)" ------------------------------------------------"
WRITE(NULOUT,1244)( (HUOBSCOR(JI,J),JI=1,JPHLEV),J=1,JPHLEV)
WRITE(NULOUT,*)" ------------------------------------------------"
ELSE
LLPROB=.TRUE.
WRITE(NULOUT,*) " PROBLEM WITH HUMSAT STATISTICS "
ENDIF
C
IF ( .NOT. LLPROB ) THEN
WRITE(NULOUT,*)" ----------------------- "
WRITE(NULOUT,*)" SUBROUTINE SUCOVO:"
WRITE(NULOUT,*)" OBSERVATION ERRORS SET "
WRITE(NULOUT,*)" ----------------------- "
ELSE
WRITE(NULOUT,*)" ------------------------------- "
WRITE(NULOUT,*)" SUBROUTINE SUCOVO:"
WRITE(NULOUT,*)" PROBLEM WITH STATISTICS FILE "
WRITE(NULOUT,*)" DEFAULT VALUES FOR RAOBS ERRORS "
WRITE(NULOUT,*)" ------------------------------- "
ENDIF
C
1244 FORMAT( 7(1x,f5.2))
1245 FORMAT(16(1x,f5.2))
RETURN
END