!-------------------------------------- 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 oda_Hgo 1,3
use modmask
, only : lmaskgo
USE modfgat,only : istepobs,nobs_go,nobtag_go
#if defined (DOC)
*
* Purpose: Compute simulated GOES observations from profiled model increments.
* It returns Hdx in ROBDATA8(NCMOMA,*)
*
* Author : N. Wagneur *CMDA/MSC May 2001
*
* Revision:
* S. Pellerin *ARMA/SMC May 2000
* - Fix for F90 conversion
* S. Pellerin ARMA, January 2009
* - Rename the subroutine acording to ODA naming convention
* - Use of mask to process only assimilated data
* - Recoding to compute only Hdx instead of Jo=sum([Hdx-d]/sigma)
* Bin He - ARMA/MRB - Oct. 2011,
* - 4Dvar optimization.
*
#endif
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comdimo.cdk"
#include "comoabdy.cdk"
#include "comoahdr.cdk"
#include "comoba.cdk"
#include "commvo.cdk"
#include "cparamgoes.cdk"
#include "comjacgoes.cdk"
*
REAL*8 PTBTL(JPNB,NOBGOES)
REAL*8 ZPS (NOBGOES)
REAL*8 ZTG (NOBGOES)
REAL*8 ZVLEV(NFLEV,NOBGOES)
REAL*8 ZT (NFLEV,NOBGOES)
REAL*8 ZLQ (NFLEV,NOBGOES)
REAL*8 DELX(2*(NFLEV+1),1)
REAL*8 JAC(JPNB,2*(NFLEV+1)),ZTBTL(JPNB,1)
C
INTEGER J, JCH, I, ISAT, JOFF, IO, JF, ISATON
INTEGER IBEGIN, IBEGINOB, ILAST, ILASTOB,IER
INTEGER K, NKX
INTEGER KNPF, KNCHPF, INCHPF
INTEGER JO,iobs, JDATA, IDATA, IDATEND, IDATYP
INTEGER JK, JN, ICHN, IPROCES, JL, INDX
INTEGER ILANSEA, INDXREG, INDXCLD, INUMCHN
INTEGER KLENPF,KNAV,KNSAV,KNSSV,KNCV
C
INTEGER KSURF(JPPFGO)
INTEGER KCHAN(JPCHPFGO),KPROF(JPCHPFGO)
INTEGER KCHNESDIS(JPCHPFGO)
INTEGER MFAIL(JPNB,NOBGOES),MDATA(JPNB,NOBGOES)
INTEGER IPTOBS(JPPFGO)
INTEGER IPTCHPF(JPPFGO,JPCHGO)
INTEGER IPTREG(JPPFGO)
INTEGER IPTCLD(JPPFGO)
INTEGER ISCANPOS(JPPFGO)
INTEGER ISATZEN(JPPFGO)
INTEGER INOBSCH(0:JPCHGO,JPNSATGO)
INTEGER IFAIL(JPPFGO,JPNSATGO)
C
INTEGER JJ,istep,intobs
INTEGER ISRCHEQ, MRFVOI, MRFCLS
EXTERNAL ISRCHEQ, MRFVOI, MRFCLS
EXTERNAL INITRT, SETRT
EXTERNAL LINTV2, EXTRAP
!
IF(nobs_go(istepobs) ==0 ) RETURN
C
C* 1. Initialization
C . --------------
C
JJ=0
intobs=0
if(istepobs>1) then
do istep=1,istepobs-1
intobs=intobs+nobs_go(istep)
enddo
endif
C
C
C* 2. Computation of (HX - Z)/SIGMA for GOES data only
C . ------------------------------------------------
C
DO J = 1, nobs_go(istepobs)
DO I = 1, JPNB
PTBTL(I,J) = 0.D0
ENDDO
ENDDO
C
C** Loop over all satellites specified by user
C
DO J = 1, nobs_go(istepobs)
iobs=nobtag_go(j,istepobs)
C
C* . 2.1 Extract general information for this observation point
C . ------------------------------------------------------
C
ZPS (J) = GOMPS(1,iobs)
ZTG (J) = GOMTGR(1,iobs)
ZT (1:NFLEV,J) = GOMT(1:NFLEV,iobs)
ZLQ (1:NFLEV,J) = GOMQ(1:NFLEV,iobs)
enddo
C
C
C* . 2.6 Tangeant linear of RT model
C . ---------------------------
C
C* Multiplication de matrice (essayer MXMA8)
C* La temperature de brillance lineraire tangente :
C* TBTL = dTB/dX * DX ( ou HX par la suite )
C
C* Le a taille du vecteur d'etat X pour cet operateur est
C* deux fois le nombre de niveaux sur la grille d'analyse
C* pour T et q, plus un pour PS et un pour TG
C
NKX = 2 * (NFLEV+1)
C
DO J = 1, nobs_go(istepobs)
JJ=J + intobs
DO K = 1, NFLEV
DELX(K,1) = ZT(K,J)
DELX(K+(NFLEV+1),1) = ZLQ(K,J)
ENDDO
DELX((NFLEV+1),1) = ZTG(J)
DELX(NKX,1) = ZPS(J)
DO K = 1, NKX
DO I = 1, JPNB
JAC(I,K) = HJACMSCFAST(JJ,K,I)
ENDDO
ENDDO
C
CALL MPROD2(JAC,DELX,ZTBTL,JPNB,NKX,1,JPNB,NKX,JPNB)
DO I = 1, JPNB
PTBTL(I,J) = ZTBTL(I,1)
ENDDO
C
ENDDO
C
C* . 2.7 Extract GOES observations of clear radiance (brightness
c temps.)
C . ----------------------------------------------------------
c -----
C
DO J = 1, nobs_go(istepobs)
MFAIL(1:JPNB,J) = 1
MDATA(1:JPNB,J) = 0
ENDDO
C
C* Boucle sur les Observations GOES dans le CMA
C
DO JN = 1, nobs_go(istepobs)
IO = nobtag_go(JN,istepobs)
IDATA = MOBHDR(NCMRLN,IO)
IDATEND = MOBHDR(NCMNLV,IO)+IDATA - 1
C
C* Loop through data. Extract and store temporarily
c brightness temps.
C
DO JDATA = IDATA, IDATEND
if(lmaskgo(jdata)) then
ICHN = NINT(ROBDATA8(NCMPPP,JDATA))
MDATA (ICHN,JN) = JDATA
MFAIL (ICHN,JN) = 0
ENDIF
enddo
enddo
C
DO J = 1, nobs_go(istepobs)
DO I = 1, JPNB
IF (MDATA(I,J) .NE. 0 ) THEN
ROBDATA8(NCMOMA,MDATA(I,J)) = PTBTL(I,J)
ENDIF
ENDDO
ENDDO
C
RETURN
END