!copyright (C) 2001 MSC-RPN COMM %%%RPNPHY%%%
***S/P LIN_DIFVER1_TL
*
SUBROUTINE LIN_DIFVER1_TL (DB, DSIZ, F, FSIZ, V, VSIZ, 1,4
+ G, ESPG, SELOC,
+ TAU, KOUNT, TRNCH, N, NK, STACK)
*
*
#include "impnone.cdk"
*
INTEGER DSIZ,FSIZ,VSIZ,KOUNT,TRNCH,N,NK,STACK,IERROR,ESPG
REAL DB(DSIZ),F(FSIZ),V(VSIZ),G(ESPG)
REAL SELOC(N,NK)
REAL TAU
*
*
*Author
* Stephane Laroche - Janvier 2002
*
*Revisions
* 001 S. Laroche - TLM of LIN_DIFVER1
*
*
*Object
* to perform the implicit vertical diffusion
*
*Arguments
* - Input/Output -
* DB dynamic bus
* F field for permanent physics variables
* V volatile bus
* DSIZ dimension of DB
* FSIZ dimension of F
* VSIZ dimension of V
* G physics work space
* ESPG dimension of G
*
* - Output -
* TL L tendency
*
* - Input -
* SELOC staggered sigma levels
* TAU timestep * factdt * facdifv
* see common block "options"
* KOUNT timestep number
* TRNCH row number
* N horizontal dimension
* NK vertical dimension
* STACK task number
*
**
EXTERNAL LIN_DIFF_VERT1_TL
*
INTEGER J,K
REAL gsrt,RSG
*
#include "indx_sfc.cdk"
#include "consphy.cdk"
#include "options.cdk"
#include "phy_macros_f.h"
#include "phybus.cdk"
#include "stk.cdk"
*
************************************************************************
* AUTOMATIC ARRAYS
************************************************************************
*
*
AUTOMATIC ( KMSG , REAL , (N,NK ) )
AUTOMATIC ( KTSG , REAL , (N,NK ) )
AUTOMATIC ( BMSG , REAL , (N ) )
AUTOMATIC ( BTSG , REAL , (N ) )
AUTOMATIC ( KMSGM , REAL , (N,NK ) )
AUTOMATIC ( KTSGM , REAL , (N,NK ) )
AUTOMATIC ( BMSGM , REAL , (N ) )
AUTOMATIC ( BTSGM , REAL , (N ) )
*
*
************************************************************************
*
* POINTEURS POUR ALLOCATION DYNAMIQUE
REAL A,B,C,D,R1,R2,R3,R4,R5,R6,R7,R8,R9
REAL ZERO1,ZERO2
REAL AQ, LSCP
REAL GAM0
POINTER (PAA, A(N,NK)),(PAB, B(N,NK)),(PAC, C(N,NK)),(PAD, D(N,NK))
POINTER (PAR1, R1(N,NK)),(PAR2,R2(N,NK)),(PAR3,R3(N,NK)),(PAR4,R4(N,NK))
POINTER (PAR5, R5(N,NK)),(PAR6,R6(N,NK)),(PAR7,R7(N,NK)),(PAR8,R8(N,NK))
POINTER (PAR9, R9(N,NK))
POINTER (PAZERO1,ZERO1(N,NK)), (PAZERO2,ZERO2(N,NK))
POINTER (IAQ, AQ(N))
POINTER (IGAM0, GAM0(N,NK+1))
*
* POINTEURS POUR CHAMPS DEJA DEFINIS DANS LES BUS
REAL TU, TV, TT, TQ, UU, VV
REAL T, Q, SG, SPONMOD
REAL U5, V5, T5, Q5
POINTER ( TU_ , TU (N,NK))
POINTER ( TV_ , TV (N,NK))
POINTER ( TT_ , TT (N,NK))
POINTER ( TQ_ , TQ (N,NK))
POINTER ( UU_ , UU (N,NK))
POINTER ( VV_ , VV (N,NK))
POINTER ( T _ , T (N,NK))
POINTER ( Q _ , Q (N,NK))
POINTER ( SG_ , SG (N,NK))
POINTER ( SP_ , SPONMOD (N ))
POINTER ( U5_ , U5 (N,NK))
POINTER ( V5_ , V5 (N,NK))
POINTER ( T5_ , T5 (N,NK))
POINTER ( Q5_ , Q5 (N,NK))
*
integer jk
* fonction-formule
jk(j,k) = (k-1)*n + j - 1
*
*---------------------------------------------------------------------
*
IF(IFLUVERT.EQ.0) RETURN
*
* EQUIVALENCES AVEC CHAMPS DEJA INCLUS DANS LES BUS
TU_ = LOC(V (UDIFV ))
TV_ = LOC(V (VDIFV ))
TT_ = LOC(V (TDIFV ))
TQ_ = LOC(V (QDIFV ))
UU_ = LOC(DB(UPLUS ))
VV_ = LOC(DB(VPLUS ))
T _ = LOC(DB(TPLUS ))
Q _ = LOC(DB(HUPLUS ))
SP_ = LOC(DB(EPONMOD))
SG_ = LOC(DB(SIGM ))
U5_ = LOC(DB(UTRAJP ))
V5_ = LOC(DB(VTRAJP ))
T5_ = LOC(DB(TTRAJP ))
Q5_ = LOC(DB(HUTRAJP))
*
* INITIALISATION DU SYSTEME DE GESTION DE L'ESPACE DE TRAVAIL
STK_INITA(G,ESPG)
*
* ALLOCATION DES POINTEURS
STK_ALLOC(IAQ , N )
STK_ALLOC(PAA , N*NK )
STK_ALLOC(PAB , N*NK )
STK_ALLOC(PAC , N*NK )
STK_ALLOC(PAD , N*NK )
STK_ALLOC(PAR1 , N*NK )
STK_ALLOC(PAR2 , N*NK )
STK_ALLOC(PAR3 , N*NK )
STK_ALLOC(PAR4 , N*NK )
STK_ALLOC(PAR5 , N*NK )
STK_ALLOC(PAR6 , N*NK )
STK_ALLOC(PAR7 , N*NK )
STK_ALLOC(PAR8 , N*NK )
STK_ALLOC(PAR9 , N*NK )
STK_ALLOC(PAZERO1 , N*NK )
STK_ALLOC(PAZERO2 , N*NK )
STK_ALLOC(IGAM0 , N*(NK+1) )
*
RSG = (GRAV/RGASD)
*
******START TRAJECTORY *************************************************
*
DO K=1,NK-1
DO J=1,N
GAM0(J,K) = RSG*SELOC(J,K)/V(TVE+jk(J,K))
V(GTE+JK(J,K)) = V(GTE+JK(J,K))/GAM0(J,K)
V(GQ +JK(J,K)) = V(GQ +JK(J,K))/GAM0(J,K)
KMSGM(J,K) = F(KMM+JK(J,K))*GAM0(J,K)**2
KTSGM(J,K) = F(KTM+JK(J,K))*GAM0(J,K)**2
END DO
END DO
*
*
DO J=1,N
AQ(J)=-RSG/(F(TSURF+J-1)*(1. +
+ DELTA * F(QSURF+ (indx_agrege-1)*N + J-1)))
BMSGM(J) = F(BMM +J-1)*AQ(J)
BTSGM(J) = F(BTM +J-1)*AQ(J)
END DO
*
*
* DIFFUSION VERTICALE IMPLICITE (VERTICAL SPONGE)
*
gsrt = grav/(rgasd*250.)
DO K=1,NK
DO J=1,N
IF (SPONMOD(J)*EPONGE(K).GT.0.0) THEN
F(KMM+JK(J,K)) = SPONMOD(J)*EPONGE(K)
KMSGM(J,K) = MAX( KMSGM(J,K),
+ F(KMM+JK(J,K))*(seloc(j,k)*gsrt)**2 )
ENDIF
END DO
END DO
*
*
******END TRAJECTORY **************************************************
*
*
*
DO K=1,NK-1
DO J=1,N
GAM0(J,K) = RSG*SELOC(J,K)/V(TVE+jk(J,K))
KMSG(J,K) = V(KM +JK(J,K))*GAM0(J,K)**2
KTSG(J,K) = V(KT +JK(J,K))*GAM0(J,K)**2
END DO
END DO
*
*
DO J=1,N
AQ(J)=-RSG/(F(TSURF+J-1)*(1. +
+ DELTA * F(QSURF+ (indx_agrege-1)*N + J-1)))
BMSG(J) = V(BM +J-1)*AQ(J)
BTSG(J) = V(BT +J-1)*AQ(J)
V(ALFAT+J-1) = V(ALFAT+J-1)*AQ(J)
V(ALFAQ+J-1) = V(ALFAQ+J-1)*AQ(J)
END DO
*
*
*
* DIFFUSE U
*
DO K=1,NK
DO J=1,N
ZERO1(J,K) = 0.0
ZERO2(J,K) = 0.0
END DO
END DO
*
CALL LIN_DIFF_VERT1_TL(TU,UU,KMSG,ZERO1,ZERO2,BMSG,SG,SELOC,
$ TAU,1.,A,B,C,D,N,NK,
$ U5,KMSGM,R3,R4,R5,R6,R7,R8,R9,BMSGM)
*
*
* DIFFUSE V
*
DO K=1,NK
DO J=1,N
ZERO1(J,K) = 0.0
ZERO2(J,K) = 0.0
END DO
END DO
*
CALL LIN_DIFF_VERT1_TL(TV,VV,KMSG,ZERO1,ZERO2,BMSG,SG,SELOC,
$ TAU,1.,A,B,C,D,N,NK,
$ V5,KMSGM,R3,R4,R5,R6,R7,R8,R9,BMSGM)
*
*
* DIFFUSE MOISTURE
*
*
CALL LIN_DIFF_VERT1_TL(TQ,Q,KTSG,V(GQ),V(ALFAQ),BTSG,SG,SELOC,
$ TAU,1.,A,B,C,D,N,NK,
$ Q5,KTSGM,R3,R4,R5,R6,R7,R8,R9,BTSGM)
*
*
* DIFFUSE TEMPERATURE
*
*
CALL LIN_DIFF_VERT1_TL(TT,T,KTSG,V(GTE),V(ALFAT),BTSG,SG,SELOC,
$ TAU,1.,A,B,C,D,N,NK,
$ T5,KTSGM,R3,R4,R5,R6,R7,R8,R9,BTSGM)
*
*
RETURN
END