!-------------------------------------- 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 SPA2SP 17,13
#if defined (DOC)
*
***s/r SPA2SP - Convert analysis variables to model state variables
* .
* Purpose
* . To revert from the analysis variables to the model state variables
* . as defined in spectral space
* . IMPORTANT: before a call to SPA2SP, the fields SPVOR and SPDIV
* . may contain PSI and CHI. This will eventually become
* . the default option
*Author : P. Gauthier *ARMA/AES March 25, 1996
* .
*Revision:
* . P. Gauthier *ARMA/AES August 5, 1996
* . Redefine the balance relationship and reformulate the
* . analysis variable in terms of PSI and CHI instead of
* . vorticity and divergence.
* . S. Pellerin *ARMA/AES Sept 97.
* - Control of the different model state of the 3Dvar
* through COMSTATE, COMSTATEC and COMSTNUM common
* blocks variables (comstate.cdk).
* . M. Buehner November 97
* . Introduce transformation for new definition of control
* . vector that reduces background covariances to the identity
* . matrix (for NANALVAR=3)
* . M. Buehner jul 98
* . Introduce direct use of grid-point (PSI,CHI)
* . background std-dev errors
*
* . L. Fillion *ARMA/AES 20 jul 1998
* . New version with (T,lnps)u as analysis variables
* C. Charette *ARMA/AES Nov 1998
* - Changed LDIVBAL to LBALDIV
* C. Charette *ARMA/AES 8 dec 1998
* - Added new parameters to call bmass
* C. Charette *ARMA/AES 8 dec 1999
* - Define variable ILON in section 320
* JM Belanger CMDA/SMC Aug 2000
* . 32 bits conversion
* (MXMA8, replace 2.0 by REAL*8 in SQRT)
* M. Buehner *ARMA/SMC April 2002
* - Added option to leave analysis in unbalanced variables (LDOBAL)
* P. Koclas CMC Apr 2003
* - changed loop nesting order and call to mxmaop insted of mxma8 for ibm conversion
* M. Buehner *ARMA/SMC October 2004
* - changed damplibg to 3D and to be after balance operator
* L. Fillion *ARMA/EC 12 Jun 2009 - Update and validate option ldobal .false.
#endif
C
IMPLICIT NONE
#include "pardim.cdk"
#include "comdim.cdk"
#include "comlun.cdk"
#include "comcst.cdk"
#include "comgem.cdk"
#include "comleg.cdk"
#include "comcva.cdk"
#include "comsp.cdk"
#include "comspg.cdk"
#include "comgd0.cdk"
#include "compstat.cdk"
#include "comcorr.cdk"
#include "comcse1.cdk"
#include "comstate.cdk"
INTEGER ILEN
INTEGER JN,JM,JK,ILA,jk1,jk2
! REAL*8 ZSP(NKSDIM,2,0:NTRUNC),ZSP2(NKSDIM,2,0:NTRUNC),SQ2
! POINTER(PXZSP,ZSP), (PXZSP2,ZSP2)
REAL*8 SQ2
REAL*8 , ALLOCATABLE,DIMENSION(:,:,:) :: ZSP, ZSP2
INTEGER ILENSP, ILENGD, IERR
S , ILON, JLEV, JLON, JLAT, JLA, IULOUT
REAL*8 Z1MNU2, ZSQRTNU2, ZCORIOLIS
REAL*8 ZGDPSI(NIBEG:NIEND,NFLEV,NJBEG:NJEND)
S ,ZGDCHI(NIBEG:NIEND,NFLEV,NJBEG:NJEND)
REAL*8 DLZSOMME, DLDSOMME, DLA2, DL1SA2, DLFACT
S ,DLNORMPSI, DLNORMCHI
POINTER (PXGDPSI,ZGDPSI),(PXGDCHI,ZGDCHI)
!
INTEGER :: JN0,INS,JNS,NTRUNCHF
INTEGER :: thdid,numthd,omp_get_thread_num,omp_get_num_threads
cjmb
real*8 two
data two /2.0D0/
*-----------------------------------------------------------------
C
C 1. Create local arrays for CHI and PSI if needed
C
100 CONTINUE
C
C . 1.1 Case where the analysis variable is X - Xb
C . (SPA2SP = Identity)
C
110 CONTINUE
IF(NANALVAR.EQ.0) THEN
RETURN
END IF
C
C . 1.2 Memory allocation
C
C
IF(NANALVAR.GE.2) THEN
ILENGD = (NJEND-NJBEG+1)*NFLEV*(NIEND-NIBEG+1)
CALL HPALLOC(PXGDPSI,MAX(1,ILENGD),IERR,8)
CALL HPALLOC(PXGDCHI,MAX(1,ILENGD),IERR,8)
END IF
C
C 2. Previous way of implementing the multivariate analysis
C . (based on the linar balance relationship)
C
200 CONTINUE
IF(NANALVAR.EQ.1) THEN
201 CONTINUE
IF(CFGERR.EQ.'S') THEN
CALL FGERR('M')
CALL PROJI(.TRUE.)
END IF
IF(CFGERR.EQ.'G') THEN
CALL FGERR('O')
CALL SPGD
CALL FGERR('M')
CALL GDSP
CALL PROJI(.TRUE.)
END IF
RETURN
END IF
C
C 3. Formulation using PSI and CHI
C
300 CONTINUE
c
c 3.0 Multiply by EIGENCOR to add in vert corr (scale/rotate)
IF(NANALVAR.EQ.3) THEN
SQ2=sqrt(two)
NTRUNCHF=NTRUNC/2
!$OMP PARALLEL PRIVATE(thdid,numthd,JN,JM,JK,ILA,INS,JN0,JNS,zsp2,zsp)
thdid=omp_get_thread_num()
numthd=omp_get_num_threads()
ALLOCATE(ZSP(NKSDIM,2,0:NTRUNC))
ALLOCATE(ZSP2(NKSDIM,2,0:NTRUNC))
DO JN0 = thdid,NTRUNCHF,numthd
INS=1
IF(JN0 == (NTRUNC-JN0))INS=0
DO 222 JNS=0,INS
JN=(1-JNS)*JN0+JNS*(NTRUNC-JN0)
C
C* Transfer Dx from global to working array
C
DO JM = 0, JN
ILA = NIND(JM) + JN - JM
DO JK = 1, NKSDIM
ZSP(JK,1,JM) = SP(ILA,1,JK)
ZSP(JK,2,JM) = SP(ILA,2,JK)
END DO
END DO
C
C* Compute (CORNS(NKSDIM,NKSDIM,JN) * ZSP)
C
CALL MXMAOP(CORNS(1,1,JN,1),1,NKSDIM,ZSP(1,1,0),1,NKSDIM
+ ,ZSP2(1,1,0),1,NKSDIM,NKSDIM,NKSDIM,2*(JN+1))
C
C* Transfer from working array to global array
C
ILA = NIND(0) +JN
DO JK = 1, NKSDIM
SP(ILA,1,JK) = ZSP2(JK,1,0)*SQ2
SP(ILA,2,JK) = ZSP2(JK,2,0)*SQ2
END DO
DO JM = 1, JN
ILA = NIND(JM) +JN - JM
DO JK = 1, NKSDIM
SP(ILA,1,JK) = ZSP2(JK,1,JM)
SP(ILA,2,JK) = ZSP2(JK,2,JM)
END DO
END DO
C
DO JK=1,NKSDIM
DO ILA=1,NTRUNC+1
SP(ILA,2,JK)=0.0
ENDDO
ENDDO
C
222 CONTINUE
END DO
DEALLOCATE(zsp)
DEALLOCATE(zsp2)
!$OMP END PARALLEL
endif
C
C . 3.1 Transform PSI and CHI and the other variables
C . to physical space
C
310 CONTINUE
DLA2 = DBLE(RA)*DBLE(RA)
DL1SA2 = 1.D0/DLA2
C
CALL SPEREE(NKSDIM,SP,GD
S ,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
C
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLEV = 1, NFLEV
DO JLON = 1, ILON
ZGDPSI(JLON,JLEV,JLAT)= UT0(JLON,JLEV,JLAT)
ZGDCHI(JLON,JLEV,JLAT)= VT0(JLON,JLEV,JLAT)
END DO
END DO
END DO
C
C . 3.2 Multiply by the background error variances
C
IF(LUSE3DSTD) THEN
write(nulout,*) '*****USING STD3D*****'
DO JLAT = 1, NJ
DO JLEV = 1, NFLEV
ILON = NILON(JLAT)
DO JLON = 1, ILON
ZGDPSI(JLON,JLEV,JLAT)=
+ ZGDPSI(JLON,JLEV,JLAT)*RGSIGUU3D(JLON,JLEV,JLAT)
ZGDCHI(JLON,JLEV,JLAT)=
+ ZGDCHI(JLON,JLEV,JLAT)*RGSIGVV3D(JLON,JLEV,JLAT)
TT0(JLON,JLEV,JLAT)=
+ TT0(JLON,JLEV,JLAT)*RGSIGTT3D(JLON,JLEV,JLAT)
Q0(JLON,JLEV,JLAT)=
+ Q0(JLON,JLEV,JLAT)*RGSIGQ3D(JLON,JLEV,JLAT)
END DO
END DO
END DO
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
GPS0(JLON,1,JLAT)=
+ GPS0(JLON,1,JLAT)*RGSIGPS3D(JLON,1,JLAT)
END DO
END DO
IF(nsexist(nstg).eq.1) THEN
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLON = 1, ILON
GTG0(JLON,1,JLAT)=
+ GTG0(JLON,1,JLAT)*RGSIGTG3D(JLON,1,JLAT)
END DO
END DO
ENDIF
ELSE
320 CONTINUE
CALL FGERR('M')
cpik
!$OMP PARALLEL DO PRIVATE(DLNORMPSI,DLNORMCHI,ILON,JLEV,JLAT,JLON)
DO JLEV = 1, NFLEV
DO JLAT = 1, NJ
DLNORMPSI = RGSIGUU(JLAT,JLEV)
DLNORMCHI = RGSIGVV(JLAT,JLEV)
ILON = NILON(JLAT)
DO JLON = 1, ILON
ZGDPSI(JLON,JLEV,JLAT)
S = ZGDPSI(JLON,JLEV,JLAT)*DLNORMPSI
ZGDCHI(JLON,JLEV,JLAT)
S = ZGDCHI(JLON,JLEV,JLAT)*DLNORMCHI
END DO
END DO
END DO
!$OMP END PARALLEL DO
ENDIF
C
C Check if mass-wind balance is switched on
C
IF(LDOBAL) THEN
C
C . 3.3 Obtain the full mass field (GZ or TT)
C
call bmass(zgdpsi,zgdchi,nibeg,niend,njbeg,njend,nflev)
IF(LBALDIV) THEN
CALL DIVBAL(zgdpsi,zgdchi)
ENDIF
ENDIF
C
C . 3.4 Spectral transform all fields
C
340 CONTINUE
DO JLAT = 1, NJ
ILON = NILON(JLAT)
DO JLEV = 1, NFLEV
DO JLON = 1, ILON
UT0(JLON,JLEV,JLAT) = ZGDPSI(JLON,JLEV,JLAT)
VT0(JLON,JLEV,JLAT) = ZGDCHI(JLON,JLEV,JLAT)
END DO
END DO
END DO
C
C Apply 3D amplification factor after constructing full variables
C
DO JLAT = 1, NJ
DO JLEV = 1, NKGDIM
DO JLON = 1, NI
GD(JLON,JLEV,JLAT)=
+ GD(JLON,JLEV,JLAT)*damplibg(JLON,JLEV,JLAT)
END DO
END DO
END DO
C
CALL REESPE(NKSDIM,SP,GD
S ,NLA,NIBEG,NIEND,NJBEG,NJEND,NKSDIM)
C
C . 3.5 Rederive the vorticity and divergence from PSI and CHI
C
!$OMP PARALLEL DO
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)
END DO
END DO
!$OMP END PARALLEL DO
C
C 9. Deallocate local arrays
C
900 CONTINUE
IF(NANALVAR.GE.2) THEN
CALL HPDEALLC(PXGDPSI,IERR,1)
CALL HPDEALLC(PXGDCHI,IERR,1)
ENDIF
C
RETURN
END