!-------------------------------------- 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 RTGOES(PTB,PRAD,PS,TT,Q,TS,ZENANG,ZLAT,TOTO3OBS, 2,2
* INK,EMIGN,ITYPE_SFC,NLX,PLEV,IDSATGO,KCNT,IMODE)
C
C**S/R *RTGOES* - Call to physical radiative transfer model.
C
C C. Charette - ARMA/SMC N. Wagner- CMC - Sep. 2004
C - Remove unused internal arrays. Reduce the size of
C internal arrays. Set do loops accordingly
C
C J. Halle - CMDA - Aug. 2005
C - bugfix: initialize to zero dimension ink+1 of drdt and drdq.
C Purpose.
C --------
C To compute multi-channel radiances and brightness
C temperatures for many profiles.
C
C** Interface.
C ----------
C CALL RTGOES(PTB,PRAD,PS,TT,Q,TS,ZENANG,ZLAT,TOTO3OBS,
C INK,EMIGN,ITYPE_SFC,NLX,PLEV,IDSATGO,KCNT,IMODE)
C INPUT:
C PS : Pressions de surface
C TT : Profils de temperatures
C Q : Profils d'humidotes specifiques
C TS : Temperatures du surface
C ZENANG : Angles du satellite
C ZLAT : Latitudes des points
C TOTO3OBS : Ozone totale des profils (si disponible)
C INK : Nombre de niveaux
C EMIGN : Emissivites de la surfaces
C ITYPE_SFC : Type de surface
C NLX : Nombre de profils
C PLEV : Pressions de niveaux des profils
C IDSATGO : Numero du satellite
C KCNT : Compteur du nombre de profils deja traites
C IMODE : Switch: 0 pas de calcul des Jacobiens, 1 oui.
C
C OUTPUT:
C PBT : Temperatures de Brillance
C PRAD : Radiances
C
C
C Method.
C -------
C See reference
C
C Externals.
C ----------
C rtmscrunprof : Initialise site specific data,
C and run radiation model.
C
C Reference.
C ----------
C Garand, L., D.S. Turner and C. Chouinard, and J. Halle, 1999:
C A Physical Formulation of Atmospheric Transmitance for
C the Massive Assimilaton of Satellite Infrared Radiances.
C
C Author.
C -------
C Nicolas Wagneur *CMC/MSC* Avril 2001
C
C Rvisions.
C ---------
C
C
C -----------------------------------------------------------------
IMPLICIT NONE
C
#include "comlun.cdk"
#include "cparamgoes.cdk"
#include "cominitrad.cdk"
#include "comgoes.cdk"
INTEGER IMODE,J,JB,JJ,JI,JJ0,JG,KSAT,KCNT
INTEGER NLX,INK,KNPF,IDSATGO,i,k,jl,KIERR
C
REAL*8 BT(JPNB, JPNLM),PTB(JPNB*JPNLM)
REAL*8 RAD(JPNB, JPNLM),PRAD(JPNB*JPNLM)
REAL*8 QGAS(JPNLM, INK, JPNGAS)
REAL*8 PLEV(JPNLM, INK)
REAL*8 SH(JPNLM, INK)
REAL*8 TT(JPNLM, INK)
REAL*8 Q(JPNLM, INK)
REAL*8 PS(JPNLM)
REAL*8 TS(JPNLM)
REAL*8 ZENANG(JPNLM)
REAL*8 SECAN(JPNLM)
REAL*8 ZLAT(JPNLM)
REAL*8 TOTO3OBS(JPNLM)
REAL*8 EMIGN(JPNLM,JPNB)
REAL*8 CFEXX(JPNLM,INK,JPNB)
REAL*8 CFE(JPNLM,INK,JPNB)
REAL*8 XX(JPNLM,JPNB)
REAL*8 XXE(JPNLM,JPNB)
REAL*8 ZPI
c
C
C variables de rtmscrunprof
REAL*8 DRDT(JPNLM,INK+1,JPNB)
REAL*8 DRDQ(JPNLM,INK+1,JPNB,JPNGAS)
REAL*8 DRDPS(JPNLM,JPNB)
REAL*8 DRDEMI(JPNLM,JPNB)
CHARACTER*6 CLSATNAM
c
INTEGER ITYPE_SFC(JPNLM)
INTEGER LISTPC(JPNB,JPNLM)
C
EXTERNAL RTMSCRUNPROF
C
C -----------------------------------------------------------------
C* 0.
C --- -- ------- ---------
KIERR = 0
ZPI = ACOS(-1.)
C -----------------------------------------------------------------
C* 1. SET UP PROFILE VARIABLES.
C --- -- ------- ---------
100 CONTINUE
C
C
C -----------------------------------------------------------------
C* 1.1 SET SATNAME
C --- -------
120 CONTINUE
IF ( IDSATGO .EQ. 8) CLSATNAM='GOES08'
IF ( IDSATGO .EQ. 9) CLSATNAM='GOES09'
IF ( IDSATGO .EQ. 10) CLSATNAM='GOES10'
IF ( IDSATGO .EQ. 11) CLSATNAM='GOES11'
IF ( IDSATGO .EQ. 12) CLSATNAM='GOES12'
IF ( IDSATGO .EQ. 13) CLSATNAM='GOES13'
IF ( IDSATGO .EQ. 14) CLSATNAM='GOES14'
IF ( IDSATGO .EQ. 15) CLSATNAM='GOES15'
C
C -----------------------------------------------------------------
C* 2. Sigma levels plus besoin.Mais humidite oui!
C -------------
200 CONTINUE
DO JJ = 1, INK
DO JI = 1, JPNLM
SH(JI,JJ) = 0.0
QGAS(JI,JJ,1) = Q(JI,JJ)
QGAS(JI,JJ,2) = 0.0
QGAS(JI,JJ,3) = 0.0
QGAS(JI,JJ,4) = 0.0
QGAS(JI,JJ,5) = 0.0
QGAS(JI,JJ,6) = 0.0
QGAS(JI,JJ,7) = 0.0
QGAS(JI,JJ,8) = 0.0
ENDDO
ENDDO
C
C -----------------------------------------------------------------
C* 3. Initialise a zero certain champs pas utilise
C dans ce mode.
C ------------------------------------
300 CONTINUE
DO JI = 1, JPNLM
DO JJ = 1, INK
DO JB = 1, JPNB
CFE (JI,JJ,JB) = 0.0
CFEXX (JI,JJ,JB) = 0.0
XXE (JI,JB) = 0.0
XX (JI,JB) = 0.0
ENDDO
ENDDO
ENDDO
DO JI = 1, JPNLM
DO JJ = 1, INK+1
DO JB = 1, JPNB
DRDT (JI,JJ,JB) = 0.0
DO JG = 1, JPNGAS
DRDQ(JI,JJ,JB,JG) = 0.0
ENDDO
ENDDO
ENDDO
ENDDO
DO JJ = 1, JPNLM
SECAN(JJ) = 1. / ( COS( ZENANG(JJ)*(ZPI/180.) ) )
TOTO3OBS(JJ) = 0.0
DO JB = 1, JPNB
BT (JB,JJ) = 0.0
DRDPS (JJ,JB) = 0.0
DRDEMI(JJ,JB) = 0.0
ENDDO
ENDDO
C
C -----------------------------------------------------------------
C* 4. Forward model.
C --------------
400 CONTINUE
C
C* Des initialisation a verifier ou a specifier pour sauver du temps
C
do jb = 1,JPnb
do jl = 1,JPnlm
listpc(jb,jl) = 1
enddo
enddo
C
C
CALL RTMSCRUNPROF (BT,DRDT,DRDQ,DRDPS,DRDEMI,CLSATNAM,NIB1,NIB2,
x NJULIAN,NMONTH,NIYEAR,NICLOUD,JPNLM,NLX,INK,INK+1,JPNB,NIPSFLAG,
x NEMIFLAG,NIASSIM,IMODE,LISTPC,ITYPE_SFC,NIGO,SECAN,ZLAT,SH,
x PLEV,CFE,TT,QGAS,PS,TS,EMIGN,XX,CFEXX,XXE,NKBIAS,NKTUNE,KIERR)
C
IF ( KIERR .NE. 0 ) THEN
CALL ABORT3D ( NULOUT,'RTMSCINITRAD ')
ENDIF
C
J = 0
DO JJ = 1, NLX
DO JB =1, JPNB
J = J + 1
PTB(J) = BT(JB,JJ)
cnwa PRAD(J) = PRAD(JB,JJ)
ENDDO
ENDDO
C
C -----------------------------------------------------------------
C
C* 5. Storage of Jacobians
C --------------------
500 CONTINUE
C
C
IF ( IMODE .EQ. 1 ) THEN
CALL FILLJACGOES (DRDT,DRDQ,DRDPS,Q,NLX,KCNT)
ENDIF
C
RETURN
END