!-------------------------------------- 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,2
use modmask
, only : lmaskgo
#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)
*
#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,NGOES)
REAL*8 ZT (NFLEV,NGOES)
REAL*8 ZLQ (NFLEV,NGOES)
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, 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,NGOES),MDATA(JPNB,NGOES)
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 ISRCHEQ, MRFVOI, MRFCLS
EXTERNAL ISRCHEQ, MRFVOI, MRFCLS
EXTERNAL INITRT, SETRT
EXTERNAL LINTV2, EXTRAP
C
C* 1. Initialization
C . --------------
C
if(nobgoes.eq.0) return
C
C
C* 2. Computation of (HX - Z)/SIGMA for GOES data only
C . ------------------------------------------------
C
DO J = 1, NGOES
DO I = 1, JPNB
PTBTL(I,J) = 0.D0
ENDDO
ENDDO
C
C** Loop over all satellites specified by user
C
DO J = 1, NGOES
C
C
C* . 2.1 Extract general information for this observation point
C . ------------------------------------------------------
C
ZPS (J) = GOMPS(1,MJOGO(J))
ZTG (J) = GOMTGR(1,MJOGO(J))
DO I = 1, NFLEV
ZT (I,J) = GOMT(I,MJOGO(J))
ZLQ (I,J) = GOMQ(I,MJOGO(J))
ENDDO
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, NGOES
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(J,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, NGOES
DO I = 1, JPNB
MFAIL(I,J) = 1
MDATA(I,J) = 0
ENDDO
ENDDO
C
C* Boucle sur les Observations GOES dans le CMA
C
DO JN = 1, NGOES
IO = MJOGO(JN)
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, NGOES
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