!copyright (C) 2001 MSC-RPN COMM %%%RPNPHY%%%
***S/P GWD4
#include "phy_macros_f.h"
SUBROUTINE GWD4 ( F, SIZEF, U, V, T, P, S, 1,4
$ RUG, RVG, TAU, KOUNT, TRNCH, N, M, NK,
$ ITASK)
*
#include "impnone.cdk"
INTEGER ITASK, SIZEF, TRNCH, N, M, NK, KOUNT
REAL F(SIZEF)
REAL U(M,NK),V(M,NK),T(M,NK),P(M),S(N,NK)
REAL RUG(N,NK),RVG(N,NK)
REAL TAU
*
*Author
* J.Mailhot RPN(May1990)
*
*Revision
* 001 B. Bilodeau (Mar 1991)
* Extraction of GU and of GV with MVZNXST
* 002 N. Brunet (May91)
* New version of thermodynamic functions
* and file of constants
* 003 B. Bilodeau (July 1991)- Adaptation to UNIX
* 004 R. Benoit (August 1993)- Local Sigma
* 005 B. Bilodeau (May 1994) - New physics interface
* 006 B. Bilodeau (Nov 95) - Implement "STK" memory allocation
* 007 M. Desgagne (Oct 1995) - New interface
* 008 L. Lefaivre (Nov 1995) - GWDRAG option extended to gwdfx95
* (1995 formulation of McFarlane)
* 009 B. Bilodeau (Nov 96) - Replace common block pntclp by
* common block gwdbus
* 010 B. Bilodeau (Nov 2000) - New comdeck phybus.cdk
* 011 B. Bilodeau and B. Dugas (Feb/Jun 2001) - Automatic arrays
* 012 A. Zadra (Jun 2001) - New blocking parameterization
* 013 N. Brunet (Jul 2001) - Adaptation of blocking code
* to global model
*
*Object
* to model the gravity wave drag
*
*Arguments
*
* - Input/Output -
* F field of permanent physics variables
* SIZEF dimension of F
* U U component of wind as input
* U component of wind modified by the gravity wave
* drag as output
* V V component of wind as input
* V component of wind modified by the gravity wave
* drag as output
*
* - Input -
* T virtual temperature
* S local sigma levels
* - Output -
* RUG gravity wave drag tendency on the U component of real
* wind
* RVG gravity wave drag tendency on the V component of real
* wind
*
* - Input -
* TAU timestep times a factor: 1 for two time-level models
* 2 for three time-level models
* TRNCH index of the vertical plane(NI*NK) for which the
* calculations are done.
* N horizontal dimension
* M 1st dimension of U,V,T
* NK vertical dimension
* ITASK number for multi-tasking
*
*Notes
* This routine needs at least:
* ( 12*NK + 12 )*N + 3*NK words in dynamic allocation
* +3*nk -"- for local sigma
* +2*nk -"- for gather on s, sh
* - 3*nk s1,s2,s3 change from 1d to 2d
*
*IMPLICITES
*
#include "options.cdk"
#include "phybus.cdk"
#include "consphy.cdk"
*
*MODULES
*
* ROUTINES DE GESTION DE MEMOIRE
*
EXTERNAL SERGET
*
* ROUTINES D'EXTRACTION DE SERIES TEMPORELLES
*
EXTERNAL SERXST
EXTERNAL MVZNXST
*
* ROUTINES DU "GRAVITY WAVE DRAG"
*
EXTERNAL GWDFX95A, SGOFLX2
*
* UTILITAIRES
*
*
**
*
************************************************************************
* AUTOMATIC ARRAYS
************************************************************************
*
AUTOMATIC ( LAND , REAL*8 , (N ) )
AUTOMATIC ( LAUNCH , REAL*8 , (N ) )
AUTOMATIC ( SXX8 , REAL*8 , (N ) )
AUTOMATIC ( SYY8 , REAL*8 , (N ) )
AUTOMATIC ( SXY8 , REAL*8 , (N ) )
AUTOMATIC ( TT , REAL*8 , (N,NK) )
AUTOMATIC ( TE , REAL*8 , (N,NK) )
AUTOMATIC ( UU , REAL*8 , (N,NK) )
AUTOMATIC ( VV , REAL*8 , (N,NK) )
AUTOMATIC ( PP , REAL*8 , (N ) )
AUTOMATIC ( SIGMA , REAL*8 , (N,NK) )
AUTOMATIC ( S1 , REAL*8 , (N,NK) )
AUTOMATIC ( S2 , REAL*8 , (N,NK) )
AUTOMATIC ( S3 , REAL*8 , (N,NK) )
AUTOMATIC ( UTENDGW , REAL*8 , (N,NK) )
AUTOMATIC ( VTENDGW , REAL*8 , (N,NK) )
*
************************************************************************
*
INTEGER I,J,K,IS
LOGICAL ENVELOP,DAMPFAC,BLOCKING
*
*--------------------------------------------------------------------
*
ENVELOP = .TRUE.
DAMPFAC = .FALSE.
BLOCKING = .TRUE.
*
*
* TT - TEMPERATURE AUX NIVEAUX PLEINS
* UU - COMPOSANTE U DU VENT (VENT REEL)
* VV - COMPOSANTE V DU VENT (VENT REEL)
DO 100 K=1,NK
*VDIR NODEP
DO 100 J=1,N
TT(J,K) = T(J,K)
UU(J,K) = U(J,K)
VV(J,K) = V(J,K)
100 CONTINUE
*VDIR NODEP
DO 105 J=1,N
PP(J) = P(J)
105 CONTINUE
*
* POINTEUR POUR LA ROUTINE DE GWD : -1 = CONTINENT
* 0 = OCEAN
*
DO 110 J=1,N
LAND(J) = - ABS( NINT( f(MG+J-1) ) )
110 CONTINUE
*
* s1, s2, s3 => 2d
*
*
* S1 - DEMI-NIVEAUX
* S2 - NIVEAUX PLEINS
* S3 - DEMI-NIVEAUX
*
DO 120 K=1 ,NK-1
CDIR$ IVDEP
*VDIR NODEP
do 120 j=1,n
S1(J,K)=0.5*(S(J,K)+S(J,K+1))
S3(J,K)=S1(J,K)**CAPPA
S2(J,K)=S(J,K)**CAPPA
120 CONTINUE
*
CDIR$ IVDEP
*VDIR NODEP
DO 121 J=1,N
S1(J,NK)=0.5*(S(J,NK)+1.)
S3(J,NK)=S1(J,NK)**CAPPA
S2(J,NK)=S(J,NK)**CAPPA
121 CONTINUE
*
* TE - TEMPERATURE AUX DEMI-NIVEAUX
*
DO 130 K=1 ,NK-1
CDIR$ IVDEP
*VDIR NODEP
DO 130 J=1 ,N
TE(J,K) = 0.5*( TT(J,K) + TT(J,K+1) )
130 CONTINUE
*
CDIR$ IVDEP
*VDIR NODEP
DO 140 J=1,N
TE(J,NK) = 2.0*TT(J,NK) - TT(J,NK-1)
140 CONTINUE
*
*
*
DO I=1,N
LAUNCH(I) = F(LHTG+I-1)
SXX8(I) = F(dhdx+I-1)
SYY8(I) = F(dhdy+I-1)
SXY8(I) = F(dhdxdy+I-1)
END DO
*
*
DO K=1,NK
DO J=1,N
SIGMA(J,K) = S(J,K)
END DO
END DO
*
IF(GWDRAG.EQ.'GWD95') THEN
*
CALL GWDFX95A (UU, VV, TE, TT, LAUNCH, LAND,
$ SIGMA, S2, S1, S3, UTENDGW, VTENDGW,
$ GRAV, RGASD, TAU, NK, 1, N, N,
$ DAMPFAC, ENVELOP, NK,
$ TAUFAC )
ELSE IF(GWDRAG.EQ.'GWD86') THEN
*
CALL SGOFLX2 (UU, VV, TE, TT, LAUNCH, LAND,
$ SIGMA, S2, S1, S3, UTENDGW, VTENDGW,
$ GRAV, RGASD, TAU, NK, 1, N, N,
$ DAMPFAC, ENVELOP, NK,
$ TAUFAC, PP, BLOCKING,
$ SXX8, SYY8, SXY8)
*
ENDIF
*
*
DO 200 K=1,NK
CDIR$ IVDEP
*VDIR NODEP
DO 200 J=1,N
RUG(J,K) = UTENDGW(J,K)
RVG(J,K) = VTENDGW(J,K)
U (J,K) = UU(J,K)
V (J,K) = VV(J,K)
200 CONTINUE
*
CALL SERXST( RUG, 'GU', TRNCH, N, 0.0, 1.0, -1)
CALL SERXST( RVG, 'GV', TRNCH, N, 0.0, 1.0, -1)
CALL MVZNXST(RUG,RVG,'GU','GV',TRNCH,N,1.0,-1,ITASK)
*
RETURN
END