!-------------------------------------- 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 GENINCR_2 1,28
#if defined (DOC)
*
***s/r GENINCR- To derive increment in terms of the analysis
* . variables for a single element
*
*
*Author : P. Gauthier *ARMA/AES March 31, 1998
*Revision:
* 001 M. Buehner May 2008
* - New version of GENINCR adapted for new PtoT approach
* with localization for Tb correlations (NANALVAR=4)
*
*Arguments
*
#endif
IMPLICIT NONE
*implicits
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comgem.cdk"
#include "comgd0.cdk"
#include "comgd1.cdk"
#include "comsp.cdk"
#include "compost.cdk"
#include "comgdpar.cdk"
#include "localpost.cdk"
#include "rpnstd.cdk"
#include "comspg.cdk"
#include "comcst.cdk"
#include "comleg.cdk"
*
*
* Local variables
*
*
INTEGER ILON, JLEV, JLON, JLAT, JLA, jk,jk1
REAL*8 ZCORIOLIS, ZDAM, ZGEOP
REAL*8 DLA2, DL1SA2
LOGICAL LLINBAL
INTEGER ILEN,ILEN2,JM,JN,ILA
CHARACTER*8 CLBALETIK
C
C 0. Allocate local arrays and initialize to zero
C
* Initialization of localpost.cdk
*
ILEN = NI*NFLEV*NJ
ILEN2= NI*NJ
CALL HPALLOC(PXPP,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PXQQ,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PXCC,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PXUC,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PXQR,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PXDD,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PXGP,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PXGB,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PXTP,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PXTTB,MAX(1,ILEN),IERR,8)
CALL HPALLOC(PXLPP,MAX(1,ILEN2),IERR,8)
cjmb
CALL HPALLOC(PXGZB,MAX(1,ILEN),IERR,8)
*
CALL ZERO(ILEN,ZQQ(1,1,1))
CALL ZERO(ILEN,ZQR(1,1,1))
CALL ZERO(ILEN,ZPP(1,1,1))
CALL ZERO(ILEN,ZDD(1,1,1))
CALL ZERO(ILEN,ZCC(1,1,1))
CALL ZERO(ILEN,ZUC(1,1,1))
CALL ZERO(ILEN,ZGP(1,1,1))
CALL ZERO(ILEN,ZGB(1,1,1))
CALL ZERO(ILEN,ZTP(1,1,1))
CALL ZERO(ILEN,ZTTB(1,1,1))
CALL ZERO(ILEN2,ZLPP(1,1,1))
cjmb
CALL ZERO(ILEN,ZGZB(1,1,1))
c
CALL READNML('NAMGDPAR',IERR)
CALL READNML('NAMCVA',IERR)
CALL READNML('NAMCSE1',IERR)
C
C 0. Read in the balance operators
C
CALL READPTOT
*
* 1. Read the model state
*
CTYPVARA = 'E'
CALL GETFST(NINMPG,'G','A',-1)
c CALL GETPARAM(NINMPG)
*
c
c Normalize by local stddev
c
if(.true.) then
DLA2 = DBLE(RA)*DBLE(RA)
DL1SA2 = 1.D0/DLA2
c
call readstd3d
c transform u,v to psi,chi
CALL GDSP
DO JK = 1, NFLEV
DO JLA = 1, NLA
SPVOR(JLA,1,JK) = SPVOR(JLA,1,JK) * DLA2*R1SNP1(JLA)
SPVOR(JLA,2,JK) = SPVOR(JLA,2,JK) * DLA2*R1SNP1(JLA)
SPDIV(JLA,1,JK) = SPDIV(JLA,1,JK) * DLA2*R1SNP1(JLA)
SPDIV(JLA,2,JK) = SPDIV(JLA,2,JK) * DLA2*R1SNP1(JLA)
END DO
END DO
c apply spectral filter
c DO JN = (NTRUNC-10),NTRUNC
c DO JM = 0, JN
c ILA = NIND(JM) + JN - JM
c DO JK = 1, NKSDIM
c SP(ILA,1,JK)=0.0
c SP(ILA,2,JK)=0.0
c ENDDO
c ENDDO
c ENDDO
CALL SPEREE(NKSDIM,SP,GD
S ,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NFLEV
IF(rgsiguu3d(JLON,JK1,JLAT).gt.0) THEN
UT0(JLON,JK1,JLAT) = UT0(JLON,JK1,JLAT) /
+ rgsiguu3d(JLON,JK1,JLAT)
ELSE
UT0(JLON,JK1,JLAT) = 0.0
WRITE(NULOUT,*) "rgsiguu3d NON-POSITIVE:",
+ rgsiguu3d(JLON,JK1,JLAT)
ENDIF
IF(rgsigvv3d(JLON,JK1,JLAT).gt.0) THEN
VT0(JLON,JK1,JLAT) = VT0(JLON,JK1,JLAT) /
+ rgsigvv3d(JLON,JK1,JLAT)
ELSE
VT0(JLON,JK1,JLAT) = 0.0
WRITE(NULOUT,*) "rgsigvv3d NON-POSITIVE:",
+ rgsigvv3d(JLON,JK1,JLAT)
ENDIF
IF(rgsigtt3d(JLON,JK1,JLAT).gt.0) THEN
TT0(JLON,JK1,JLAT) = TT0(JLON,JK1,JLAT) /
+ rgsigtt3d(JLON,JK1,JLAT)
ELSE
TT0(JLON,JK1,JLAT) = 0.0
WRITE(NULOUT,*) "rgsigtt3d NON-POSITIVE:",
+ rgsigtt3d(JLON,JK1,JLAT)
ENDIF
ENDDO
IF(rgsigps3d(JLON,1,JLAT).gt.0) THEN
GPS0(JLON,1,JLAT) = GPS0(JLON,1,JLAT) /
+ rgsigps3d(JLON,1,JLAT)
ELSE
GPS0(JLON,1,JLAT) = 0.0
WRITE(NULOUT,*) "rgsigps3d NON-POSITIVE:",
+ rgsigps3d(JLON,1,JLAT)
ENDIF
ENDDO
ENDDO
c convert back to u,v
CALL REESPE(NKSDIM,SP,GD,NLA
S ,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
DO JLEV = 1, NFLEV
DO JLA = 1, NLA
SPVOR(JLA,1,JLEV) = SPVOR(JLA,1,JLEV)*DL1SA2*RNNP1(JLA)
SPVOR(JLA,2,JLEV) = SPVOR(JLA,2,JLEV)*DL1SA2*RNNP1(JLA)
SPDIV(JLA,1,JLEV) = SPDIV(JLA,1,JLEV)*DL1SA2*RNNP1(JLA)
SPDIV(JLA,2,JLEV) = SPDIV(JLA,2,JLEV)*DL1SA2*RNNP1(JLA)
ENDDO
ENDDO
CALL SPGD
else
CALL REESPE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
CALL SPEREE(NKSDIM,SP,GD,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
endif
CALL GETPARAM(NINMPG)
C
C call subroutine to generate Psi, Chi_b, T_b, ps_b (in ut1,vt1,tt1,gps1)
C -->>input is vorticity (in spvor)
C
CALL BTLNPSR
C
C full T,Ps are still in tt0,gps0
C put unbalanced T,Ps into ZTP,ZLPP
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JLEV = 1, NFLEV
ZTP(JLON,JLEV,JLAT) = TT0(JLON,JLEV,JLAT)
S - TT1(JLON,JLEV,JLAT)
ZTTB(JLON,JLEV,JLAT) = TT1(JLON,JLEV,JLAT)
ENDDO
ZLPP(JLON,1,JLAT) = GPS0(JLON,1,JLAT)
+ - GPS1(JLON,1,JLAT)
END DO
END DO
DO JLEV = 1, NFLEV
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
C put PSI,CHI into ZPP,ZCC
ZPP(JLON,JLEV,JLAT)= UT0(JLON,JLEV,JLAT)
ZCC(JLON,JLEV,JLAT)= VT0(JLON,JLEV,JLAT)
C calculate unbalanced CHI in ZUC
ZUC(JLON,JLEV,JLAT)= VT0(JLON,JLEV,JLAT)
+ -VT1(JLON,JLEV,JLAT)
cjmb
ZGZB(JLON,JLEV,JLAT)= GZ1(JLON,JLEV,JLAT)
END DO
END DO
END DO
C
C put Ps_b in gps0, P_b in gz0, T_b in tt0 (overwriting full fields
C from original file)
cbue CALL TRANSFER('GD10')
c
c multiply by std3d again
c
c
c Undo Normalization by local stddev for variables being output
c
if(.true.) then
c
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
DO JK1 = 1, NFLEV
ZPP(JLON,JK1,JLAT) = ZPP(JLON,JK1,JLAT) *
+ rgsiguu3d(JLON,JK1,JLAT)
ZUC(JLON,JK1,JLAT) = ZUC(JLON,JK1,JLAT) *
+ rgsigvv3d(JLON,JK1,JLAT)
ZTP(JLON,JK1,JLAT) = ZTP(JLON,JK1,JLAT) *
+ rgsigtt3d(JLON,JK1,JLAT)
ZTTB(JLON,JK1,JLAT)= ZTTB(JLON,JK1,JLAT) *
+ rgsigtt3d(JLON,JK1,JLAT)
ZGZB(JLON,JK1,JLAT) = ZGZB(JLON,JK1,JLAT) *
+ rgsiguu3d(JLON,JK1,JLAT)
TT0(JLON,JK1,JLAT) = TT0(JLON,JK1,JLAT) *
+ rgsigtt3d(JLON,JK1,JLAT)
ENDDO
ZLPP(JLON,1,JLAT) = ZLPP(JLON,1,JLAT) *
+ rgsigps3d(JLON,1,JLAT)
ENDDO
ENDDO
endif
*
* 3. Write everything out to std_file
*
CALL SUPOST
NIP2 = IP2
NIG1 = IG1
NIG2 = IG2
NIG3 = IG3
NIG4 = IG4
NDEET = IDEET
NPAS = IPAS
NSTAMP = IDATE(1)
CGRTYP = CLGRTYP
NPAK = -INBITS
CVARPOST =CLTYPVAR
CALL POSTPROC(NULSTD,IP3,'GRID',CLETIKET)
*
* 4. Deallocate local arrays
* . (contained in localpost.cdk)
*
CALL HPDEALLC(PXPP,IERR,1)
CALL HPDEALLC(PXQQ,IERR,1)
CALL HPDEALLC(PXCC,IERR,1)
CALL HPDEALLC(PXUC,IERR,1)
CALL HPDEALLC(PXQR,IERR,1)
CALL HPDEALLC(PXDD,IERR,1)
CALL HPDEALLC(PXGP,IERR,1)
CALL HPDEALLC(PXGB,IERR,1)
CALL HPDEALLC(PXTP,IERR,1)
CALL HPDEALLC(PXTTB,IERR,1)
CALL HPDEALLC(PXLPP,IERR,1)
*
RETURN
END