!-------------------------------------- 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 SOBSHUMSAT 1
#if defined (DOC)
*
***s/r SOBSHUMSAT
*
*Author : P. Koclas *CMC/AES October 1998
*Revision:
* C. Charette *ARMA/AES Jan 2000
* - Added llprint for diagnostics
* P. KOCLAS CMC/CMDA Jan 2000
* -MODIFIY HEADER FLAG IN CASE OF REJECT
* C. Charette *ARMA/AES MAR2000
* - Remove setting of qc flags 6 and 9
* C. Charette *ARMA/AES OCT2000
* - Remove displacement of accepted observation to the model
C surface pressure when the observed pressure is greater than
C the model surface pressure.
*
*
** Purpose:
* Refuse elements which are too far away from the surface.
* Replace the pressure of elements which are slightly below
* the model surface by the pressure of the trial field.
*
*Arguments:
*
* none
#endif
IMPLICIT NONE
*implicits
#include "comlun.cdk"
#include "comdimo.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "commvohr.cdk"
#include "cvcord.cdk"
#include "comnumbr.cdk"
*
INTEGER JPINEL
PARAMETER(JPINEL=1)
INTEGER J,JD,JF,JOBS,JDATA,IOBS1,IOBS2,IBAD,IFLG
LOGICAL LLNOIR,LLPRINT
REAL*8 ZVAL,ZDIFF
INTEGER ITYP,IDATA,IDATEND
INTEGER ILEM,ICRIT,IELHU,IBEGIN,ILAST
INTEGER ILISTEL(JPINEL)
INTEGER IKOUNTREA(JPINEL),IKOUNTREJ(JPINEL),IKOUNTT
REAL*8 RLISTCRIT(JPINEL)
ccc DATA ILISTEL/12192/
DATA RLISTCRIT/50./
C
C
ILISTEL(1) = NEES
IELHU = ILISTEL(1)
LLPRINT = .FALSE.
ccc LLPRINT = .TRUE.
C
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) ' SUBROUTINE SOBSHUMSAT '
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) '****************************************************'
WRITE(NULOUT,222)'ELEMENTS ', ( ILISTEL(J),J=1,jpinel)
WRITE(NULOUT,223)'REJECTION BOUNDARY(HPA) ', (RLISTCRIT(J),J=1,jpinel)
WRITE(NULOUT,* ) '****************************************************'
WRITE(NULOUT,* ) ' '
C
C SET COUNTERS TO ZERO
C
DO J=1,JPINEL
IKOUNTREJ(J)=0
IKOUNTREA(J)=0
END DO
IKOUNTT=0
C
C LOOP OVER OBSERVATION FILES
C
DO JF = 1,NFILES
IF ( (CFAMTYP(JF) .EQ. 'HU') .AND. (NBEGINTYP(JF) .GT. 0) ) THEN
IBEGIN=NBEGINTYP(JF)
ILAST=NENDTYP(JF)
IOBS1=MOBDATA(NCMOBS,NBEGINTYP(JF))
IOBS2=MOBDATA(NCMOBS,NENDTYP(JF))
WRITE(NULOUT,*)' FAMILY = ',CFAMTYP(JF)
C
C
DO JOBS=IOBS1,IOBS2
C
IDATA = MOBHDR(NCMRLN,JOBS)
IDATEND = MOBHDR(NCMNLV,JOBS) + IDATA - 1
C
C REJECT DATA TOO FAR BELOW MODEL OROGRAPHY
C
DO JDATA= IDATA, IDATEND
IKOUNTT=IKOUNTT+1
ZVAL=ROBDATA8(NCMPPP,JDATA)
cjmb ZDIFF= (ZVAL- GOMPSHR(1,JOBS) )/100.
cjmb Surface pressure artificially modified to account
cjmb for difference in rejections caused by 32 bits
cjmb conversion (MRBCVT) of observed pressure.
cjmb (Same modification in VOBSLYRS or previously VLAYERS)
ZDIFF= (ZVAL- (GOMPSHR(1,JOBS)+ 0.01D0) )/100.
IF(LLPRINT) THEN
WRITE(NULOUT,*) 'SOBSHUMSAT:zval,psg,zdiff'
& ,ZVAL,GOMPSHR(1,JOBS),ZDIFF
ENDIF
IF ( ZDIFF .GT. 0. ) THEN
ZVAL=ROBDATA8(NCMVAR,JDATA)
ITYP=MOBDATA(NCMVNM,JDATA)
DO J=1,JPINEL
ICRIT=RLISTCRIT(J)
ILEM=ILISTEL(J)
IF ( ITYP .EQ. ILEM ) THEN
IF ( ZDIFF .LE. ICRIT) THEN
IKOUNTREA(J)=IKOUNTREA(J)+1
ccc ROBDATA8(NCMPPP,JDATA)=GOMPSHR(1,JOBS)
IF(LLPRINT) THEN
WRITE(NULOUT,224) ' Keep OBS below sfc ',jobs,ITYP
& ,CSTNID(JOBS),ROBDATA8(NCMPPP,JDATA),ZDIFF
ENDIF
ELSE
IF(LLPRINT) THEN
WRITE(NULOUT,224) 'Rej OBS below sfc ',jobs,ITYP
& ,CSTNID(JOBS),ROBDATA8(NCMPPP,JDATA),ZDIFF
ENDIF
MOBDATA(NCMASS,JDATA)=0
IKOUNTREJ(J)=IKOUNTREJ(J)+1
MOBDATA(NCMFLG,JDATA)=
& ibset( MOBDATA(NCMFLG,JDATA) , 18 )
ENDIF
ENDIF
END DO
ENDIF
END DO
C
END DO
C
C
WRITE(NULOUT,* ) ' '
WRITE(NULOUT,* ) '*****************************************************'
WRITE(NULOUT,222 )'ELEMENTS ',( ILISTEL(J),J=1,JPINEL)
WRITE(NULOUT,222)'ACCEPTED below sfc ',(IKOUNTREA(J),J=1,JPINEL)
WRITE(NULOUT,222)'REJECTED below sfc ',(IKOUNTREJ(J),J=1,JPINEL)
WRITE(NULOUT,* ) '*****************************************************'
WRITE(NULOUT,* ) ' '
222 FORMAT(2x,a29,5(2x,i5))
223 FORMAT(2x,a29,5(2x,f5.0))
224 FORMAT(2x,a20,2x,I6,2X,I5,2x,A9,2x,2(2x,f9.2))
C
ENDIF
END DO
C
IKOUNTT=0
DO JDATA=1,NDATA
IF ( MOBDATA(NCMASS,JDATA) .EQ. 1) IKOUNTT=IKOUNTT+1
END DO
WRITE(NULOUT,'(1X," NUMBER OF DATA ASSIMILATED BY 3D-VAR "
& ,"AFTER ADJUSTMENTS:",i10)')IKOUNTT
WRITE(NULOUT,* ) ' '
RETURN
END