!-------------------------------------- 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 --------------------------------------
!
*DECK LINBAL
SUBROUTINE LINBAL ( KOPT, LDFPLAN ) 10
C
C
***s/r LINBAL - APPLY THE LINEAR BALANCE EQUATION TO THE VORTICITY
C FIELD TO CONSTRUCT A GEOPOTENTIAL PERTURBATION.
C N.B.: IT CAN BE APPLIED AT VERTICAL LEVELS FOR
C THE MASS FIELD VARIABLE PHI OR THE BAROCLINIC MASS
C VARIABLE P = PHI + RTBAR LN(PS) AND VERTICAL NORMAL MODES
C INSTEAD OF VERTICAL LEVELS.
C LINBAL IS SELF-ADJOINT (SEE NOTES ON 3DVAR AND SUB. TESTSP)
C
C AUTHOR: LUC FILLION - SEP 94
C
C REVISION: L. Fillion - ARMA/AES - Feb 95.
C - Include f-plane option and zero (0,0) output fields.
C REVISION: L. Fillion - ARMA/AES - Apr 95.
C - Include adjustable f-plane option via ZFPLAT
C REVISION: S. Pellerin *ARMA/AES Sept 97.
C - Change from TT to GZ state variables
C REVISION: L. Fillion - ARMA/AES - Oct 97.
C - Remove pardmode.cdk. Fields now allocated in suallo.
* S. Pellerin *ARMA/SMC May 2000
* - Fix for F90 conversion
C
C ARGUMENTS:
C
C KOPT: +1 : linear balance, takes SPVOR --> SPGZ
C : -1 : adjoint of the linear balance, takes SPGZ --> SPVOR
C
IMPLICIT NONE
*implicits
#include "comdim.cdk"
#include "comcst.cdk"
#include "comsp.cdk"
#include "comsp1.cdk"
C
LOGICAL LDFPLAN
INTEGER KOPT
C
INTEGER IA, IB, JI, JM, JLEV, IFLAG, IMAXJM
REAL*8 ZN, ZM, ZENM, ZENMP1, ZCON, ZFPLAT
*
**
C
C*0 ENSURE INPUT FIELD IS ZERO FOR SPECTRAL COMPONENT (0,0)
C -------------------------------------------------------
C
IFLAG = 0
DO 10 JLEV = 1, NFLEV
IF(KOPT.EQ.+1) THEN
IF(SPVOR1(1,1,JLEV).NE.0.) THEN
SPVOR1(1,1,JLEV) = 0.0
IFLAG = 1
ELSE IF(SPVOR1(1,2,JLEV).NE.0.) THEN
SPVOR1(1,2,JLEV) = 0.0
IFLAG = 1
ENDIF
ELSE IF(KOPT.EQ.-1) THEN
IF(SPGZ1(1,1,JLEV).NE.0.) THEN
SPGZ1(1,1,JLEV) = 0.0
IFLAG = 1
ELSE IF(SPGZ1(1,2,JLEV).NE.0.) THEN
SPGZ1(1,2,JLEV) = 0.0
IFLAG = 1
ENDIF
ENDIF
C IF(IFLAG.EQ.1) THEN
C WRITE(NULOUT,FMT='(/,8X,''(0,0) INPUT NOT ZERO'')')
C print *,' KOPT = ',KOPT
C WRITE(NULOUT,FMT='(/,8X,''PROGRAM STOPS IN LINBAL'')')
C CALL ABORT3D(NULOUT,'LINBAL')
C ENDIF
10 CONTINUE
C
C*1 INITIALIZE OUTPOUT FIELD TO ZERO
C --------------------------------
C
100 CONTINUE
DO 120 JLEV = 1, NFLEV
DO 110 JI = 1, NLA
IF(KOPT.EQ.+1) THEN
SPGZ(JI,1,JLEV) = 0.
SPGZ(JI,2,JLEV) = 0.
ELSE IF(KOPT.EQ.-1) THEN
SPVOR(JI,1,JLEV) = 0.
SPVOR(JI,2,JLEV) = 0.
ENDIF
110 CONTINUE
120 CONTINUE
C
C*2 LOOP OVER LEVELS AND ZONAL WAVENUMBERS
C N.B.: AT THE TIP OF THE TRIANGLE, NO CONTRIBUTIONS
C --------------------------------------------------
C
200 CONTINUE
IF(LDFPLAN) THEN
IMAXJM = NTRUNC
CCC ZFPLAT = 45.0
CCC ZFPLAT = 45.56
ZFPLAT = 44.07
ZCON = -2.*ROMEGA*SIN(ZFPLAT*RPI/180.)*RA**2
ELSE
IMAXJM = NTRUNC - 1
ZCON = -2.*ROMEGA*RA**2
ENDIF
DO 230 JLEV = 1, NFLEV
C
C THE BASE ADDRESS IA WILL POINT TO THE SPHERICAL HARMONIC
C COEFFICIENT (M,M), IN THE INPUT FIELD
C
IA = 1
DO 220 JM = 0, IMAXJM
IB = IA + NTRUNC - JM
cjmb
cjmb ZM = DBLE(JM)
ZM = 1.0D0*JM
C
IF(LDFPLAN) THEN
C F-PLANE CASE
ZN = ZM
DO 225 JI = IA, IB
IF(JI.NE.1) THEN
IF(KOPT.EQ.+1) THEN
SPGZ(JI,1,JLEV)=ZCON*SPVOR1(JI,1,JLEV)/(ZN*(ZN+1))
SPGZ(JI,2,JLEV)=ZCON*SPVOR1(JI,2,JLEV)/(ZN*(ZN+1))
ELSE IF(KOPT.EQ.-1) THEN
SPVOR(JI,1,JLEV)=ZCON*SPGZ1(JI,1,JLEV)/(ZN*(ZN+1))
SPVOR(JI,2,JLEV)=ZCON*SPGZ1(JI,2,JLEV)/(ZN*(ZN+1))
ENDIF
ENDIF
ZN = ZN+1
225 CONTINUE
IA = IB + 1
ELSE
C
C AT THE BASE, CONTRIBUTIONS FROM N+1 COEFF ONLY
C
ZN = ZM
ZENMP1 = SQRT ( ((ZN+1)**2-ZM**2)/(4.*(ZN+1)**2-1.) )
IF(KOPT.EQ.+1) THEN
SPGZ(IA,1,JLEV)=ZCON*SPVOR1(IA+1,1,JLEV)*ZENMP1/((ZN+1.0)**2)
SPGZ(IA,2,JLEV)=ZCON*SPVOR1(IA+1,2,JLEV)*ZENMP1/((ZN+1.0)**2)
ELSE IF(KOPT.EQ.-1) THEN
SPVOR(IA,1,JLEV)=ZCON*SPGZ1(IA+1,1,JLEV)*ZENMP1/((ZN+1.0)**2)
SPVOR(IA,2,JLEV)=ZCON*SPGZ1(IA+1,2,JLEV)*ZENMP1/((ZN+1.0)**2)
ENDIF
C
ZN = ZN+1
DO 210 JI = IA+1, IB-1
ZENM = SQRT ( (ZN**2-ZM**2)/(4.*ZN**2-1.) )
ZENMP1 = SQRT ( ((ZN+1)**2-ZM**2)/(4.*(ZN+1)**2-1.) )
IF(KOPT.EQ.+1) THEN
SPGZ(JI,1,JLEV)=SPVOR1(JI-1,1,JLEV)*ZENM/(ZN**2)
SPGZ(JI,2,JLEV)=SPVOR1(JI-1,2,JLEV)*ZENM/(ZN**2)
SPGZ(JI,1,JLEV)=ZCON*(SPGZ(JI,1,JLEV)+SPVOR1(JI+1,1,JLEV)
+ *ZENMP1/((ZN+1.0)**2))
SPGZ(JI,2,JLEV)=ZCON*(SPGZ(JI,2,JLEV)+SPVOR1(JI+1,2,JLEV)
+ *ZENMP1/((ZN+1.0)**2))
ELSE IF(KOPT.EQ.-1) THEN
SPVOR(JI,1,JLEV)=SPGZ1(JI-1,1,JLEV)*ZENM/(ZN**2)
SPVOR(JI,2,JLEV)=SPGZ1(JI-1,2,JLEV)*ZENM/(ZN**2)
SPVOR(JI,1,JLEV)=ZCON*(SPVOR(JI,1,JLEV)+SPGZ1(JI+1,1,JLEV)
+ *ZENMP1/((ZN+1.0)**2))
SPVOR(JI,2,JLEV)=ZCON*(SPVOR(JI,2,JLEV)+SPGZ1(JI+1,2,JLEV)
+ *ZENMP1/((ZN+1.0)**2))
ENDIF
ZN = ZN + 1.0
210 CONTINUE
C
C AT THE TOP, CONTRIBUTIONS FROM N-1 COEFF ONLY
C
ZENM = SQRT ( (ZN**2-ZM**2)/(4.*ZN**2-1.) )
IF(KOPT.EQ.+1) THEN
SPGZ(IB,1,JLEV) = ZCON*SPVOR1(IB-1,1,JLEV)*ZENM/(ZN**2)
SPGZ(IB,2,JLEV) = ZCON*SPVOR1(IB-1,2,JLEV)*ZENM/(ZN**2)
ELSE IF(KOPT.EQ.-1) THEN
SPVOR(IB,1,JLEV) = ZCON*SPGZ1(IB-1,1,JLEV)*ZENM/(ZN**2)
SPVOR(IB,2,JLEV) = ZCON*SPGZ1(IB-1,2,JLEV)*ZENM/(ZN**2)
ENDIF
IA = IB + 1
ENDIF
220 CONTINUE
230 CONTINUE
C
C*3 ENSURE CORRECT VALUE FOR MASS SPECTRAL-COEFFICIENT FOR M=N=0
C ------------------------------------------------------------
C
300 CONTINUE
DO 310 JLEV = 1, NFLEV
IF(KOPT.EQ.+1) THEN
SPGZ(1,1,JLEV) = 0.0
SPGZ(1,2,JLEV) = 0.0
ELSE IF(KOPT.EQ.-1) THEN
SPVOR(1,1,JLEV) = 0.0
SPVOR(1,2,JLEV) = 0.0
ENDIF
310 CONTINUE
C
C
RETURN
END