!-------------------------------------- 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 INITGDG2(POUT,PIN,KNI,KNJ,KNK,KIG2,CDVAR) 20
*
#if defined (DOC)
*
***s/r INITGDG2 - Transfer input grid-point trial fields (from RPN file)
* to analysis grid fields.
* WARNING!!!!!!!!!! :This also involves a transformation from true winds to wind images.
*
*Author : Luc Fillion *RPN/AES - 3 Nov 98
*Revision:
* C. Charette *ARMA/AES Nov 1998
* - Fix branch when kig2=0
* S. Pellerin *ARMA/SMC May 2000
* - 3D Transfer variable
* Luc Fillion *ARMA/EC - 10 Apr. 2007: Add warning comment above.
* Luc Fillion *ARMA/EC - 20 Apr. 2007: Enforce kig2 = 1 always in grd_typ='LU' mode.
* Luc Fillion *ARMA/EC - Update to v_10_0_3.
*
*Arguments
* i : PIN(KNI,KNJ,knk) : field to be transferred
* i : KNI, KNJ,KNK : equivalent to NI, NJ. Used to dimension PTRANS
* i : KIG2 : grid type according to the parameter IG2 of the
* RPN standard files.
* i : CDVAR : variable type being transfer
*
* o : POUT(KNI,KNK,KNJ) : field to be filled
*
#endif
*
IMPLICIT NONE
C
*
*IMPLICITS
#include "pardim.cdk"
#include "comdim.cdk"
#include "comcst.cdk"
#include "comphy.cdk"
#include "comgem.cdk"
#include "comgrd_param.cdk"
*
INTEGER KNI, KNJ,KNK,KIG2
CHARACTER*2 CDVAR
REAL*8 PIN(KNI,KNJ,knk), POUT(KNI,KNK,KNJ)
C
CHARACTER*2 CLVAR
INTEGER JI, JJ,jlev
REAL*8 ZCON
*
**
CLVAR=CDVAR
if(grd_typ.eq.'LU') kig2 = 1
C
C* 1. Input field is stored from North to South
C
100 continue
IF(KIG2.EQ.1) THEN
IF(CLVAR.EQ.'UU') THEN
do jlev = 1,knk
do jj = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj) = CONIMA(JJ)*pin(JI,JJ,JLEV)*RMSKNT
END DO
END DO
enddo
elseif(CLVAR.EQ.'VV') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj) = CONIMA(JJ)*pin(JI,JJ,JLEV)*RMSKNT
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'CC') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj) = pin(JI,JJ,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'PP') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj) = pin(JI,JJ,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'GP') THEN
ZCON = 10.*RG
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj) = pin(JI,JJ,JLEV)*ZCON
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'GB') THEN
ZCON = 10.*RG
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj) = pin(JI,JJ,JLEV)*ZCON
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'TT') THEN
ZCON = TCDK
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)=pin(JI,JJ,JLEV) +ZCON
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'UT') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)=pin(JI,JJ,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'VT') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)=pin(JI,JJ,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'GZ') THEN
ZCON = 10.*RG
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)=pin(JI,JJ,JLEV)*ZCON
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'ES') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)=pin(JI,JJ,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'LQ') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)=pin(JI,JJ,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'HU') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)= max(pin(JI,JJ,JLEV),rminhu)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'O3') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)=pin(JI,JJ,JLEV)
enddo
enddo
enddo
ELSEIF(CLVAR.EQ.'TR') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)=pin(JI,JJ,JLEV)
enddo
enddo
enddo
ELSEIF(CLVAR.EQ.'P0') THEN
zcon = 1.e2
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)=zcon*pin(JI,JJ,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'PT') THEN
zcon = 1.e2
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)= anint(zcon*pin(JI,JJ,JLEV))
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'LP') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)=pin(JI,JJ,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'UP') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)=pin(JI,JJ,JLEV)
END DO
END DO
enddo
END IF
C
ELSEIF(KIG2.EQ.0) THEN
C
C* 2. Input field is stored from South to North
C
200 CONTINUE
C
IF(CLVAR.EQ.'UU') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ) = CONIMA(JJ)*RMSKNT
S *PIN(JI,KNJ-JJ+1,jlev)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'VV') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ) = CONIMA(JJ)*RMSKNT
S *PIN(JI,KNJ-JJ+1,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'CC') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ) = PIN(JI,KNJ-JJ+1,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'PP') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ) = PIN(JI,KNJ-JJ+1,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'TT') THEN
ZCON = TCDK
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV) + ZCON
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'UT') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'VT') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'GZ') THEN
ZCON = 10.*RG
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV)*ZCON
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'GP') THEN
ZCON = 10.*RG
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV)*ZCON
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'GB') THEN
ZCON = 10.*RG
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV)*ZCON
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'ES') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'HU') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)= max(PIN(JI,KNJ-JJ+1,JLEV),rminhu)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'LQ') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV)
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'O3') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV)
enddo
enddo
enddo
ELSEIF(CLVAR.EQ.'TR') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV)
enddo
enddo
enddo
ELSEIF(CLVAR.EQ.'P0') THEN
zcon = 1.e2
if('cvcord'.eq.'PRESS') zcon = 1.0
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,jlev,JJ)=PIN(JI,KNJ-JJ+1,JLEV)*zcon
ENDDO
ENDDO
enddo
ELSEIF(CLVAR.EQ.'PT') THEN
zcon = 1.e2
if('cvcord'.eq.'PRESS') zcon = 1.0
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
pout(ji,jlev,jj)= anint(zcon*pin(JI,JJ,JLEV))
END DO
END DO
enddo
ELSEIF(CLVAR.EQ.'LP') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV)
enddo
enddo
enddo
ELSEIF(CLVAR.EQ.'UP') THEN
DO JLEV = 1,KNK
DO JJ = 1, KNJ
DO JI = 1, KNI
POUT(JI,JLEV,JJ)=PIN(JI,KNJ-JJ+1,JLEV)
enddo
enddo
enddo
END IF
C
END IF
C
RETURN
END