!copyright (C) 2001 MSC-RPN COMM %%%RPNPHY%%%
***S/P DIFVER6
*
SUBROUTINE DIFVER6 (DB, DSIZ, F, FSIZ, V, VSIZ, 1,35
+ G, ESPG, TL, 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 TL(N,NK),SELOC(N,NK)
REAL TAU
*
*Author
* J. Cote (Oct 1984)
*
*Revision
* 001 B. Bilodeau (Spring 1994) - New physics interface.
* Change name from POSTIMP (SEF model) to DIFVER.
* 002 R. Sarrazin, J. Mailhot and B. Bilodeau (Jan 1996) -
* Bug fixes for time-series extraction of "KM"
* Change name from DIFVER to DIFVER2.
* 003 M. Desgagne (Oct 1995) - Unified physics interface.
* Change name from DIFVER2 to DIFVER3.
* 004 B. Bilodeau (Sept 96) - Install the new memory
* management system (STK).
* 005 B. Bilodeau (Nov 96) - Replace common block pntclp by
* common block turbus
* 006 C. Girard (Feb 1996) - New option ISHLCVT, diffusion
* of temperature and cloud water.
* 007 G. Pellerin (mars 97) - New calling sequence and change
* name to difver4.
* 008 Y. Delage and B. Bilodeau (Jul 97)
* Move FQ calculation from flxsurf to difver
* 009 M. Desgagne (Spring 97) - Diffuse W
* 010 M. Roch (Nov 1997) - Introduce sponge modulation factor
* 011 S. Belair (June 1998) - Turulent fluxes as output
* (subroutine ATMFLUX)
* 012 J. Mailhot (Oct 1998) - New SURFACE interface and
* change name to DIFVER5
* 013 B. Bilodeau (Nov 1998) - Merge phyexe and param4
* 014 B. Bilodeau (Dec 1999) - NSLOFLUX
* 015 B. Bilodeau (Nov 2000) - New comdeck phybus.cdk
* 016 B. Bilodeau (Aug 2001) - Add call to CTMDIAG and
* change name to difver6
* 017 J. Mailhot (May 2000) - Changes to add MOISTKE option (ifluvert=3)
* 018 J. Mailhot (Jun 2000) - Changes to add mixed-phase mode in
* MOISTKE option (ifluvert=3)
* 019 J. Mailhot (Oct 2000) - New calling sequence and
* change name to DIFVER6
* 020 B. Dugas (Nov 2001) - Save the USTRESS and VSTRESS vector
* components as well as their module FQ
* 021 B. Bilodeau (Mar 2002) - HU tendency=0 if wet=.false.
* 022 B. Bilodeau (Mar 2002) - Eliminate unit conversion for
* KM, KT, BM and BT
* 023 J. Mailhot (Avr 2002) - New calling sequence and
* change name to BAKTOTQ1
* 024 J. Mailhot (Feb 2003) - MOISTKE option based on implicit clouds only
* Change call to baktotq2
*
* 025 A-M. Leduc (Jan 2003) - ISHLCVT becomes ISHLCVT(1)
* 026 A. Plante (Jun 2003) - IBM conversion
* - divisions replaced by reciprocals (call to vsrec from massvp4 library)
* 027 F. Lemay (Spring 2003) - use average of BT for implicit boundary condition
*
*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 -
* TU U tendency
* TV V tendency
* TT T tendency
* TQ Q tendency
* TL L tendency
* T temperature
* UU x component of the wind
* VV y component of the wind
* Q specific humidity
* QL liquid water
* PS surface pressure
* TM temperature at time t-dt
*
* - Input -
* SG sigma levels
* SELOC staggered sigma levels
* SPONMOD sponge modulation factor
* TAU timestep * factdt * facdifv
* see common block "options"
* KOUNT timestep number
* TRNCH row number
* N horizontal dimension
* NK vertical dimension
* STACK task number
*
**
*
EXTERNAL DIFUVDFJ,SERXST,SERGET,MZONXST
EXTERNAL DIFUVDF, ATMFLUX
EXTERNAL BAKTOTQ2, FICEMXP
*
REAL HEURSER,DQ,gsrt,rhortvsg,mrhocmu
REAL tplusnk,qplusnk,uplusnk,vplusnk
INTEGER J,K
LOGICAL shconly
REAL MAXIMUM, MINIMUM, 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 ( RGAM0, REAL , (N,NK ) )
*
*
************************************************************************
* POINTEURS POUR ALLOCATION DYNAMIQUE
REAL A,C,D,R,R1,R2,ZERO
REAL AQ, BQ, SE, SIG, LSCP
REAL UFLUX, VFLUX, TFLUX, QFLUX, GAM0, FSLOFLX
REAL QCLOCAL, FICELOCAL
POINTER (PAA, A(N)), (PAC,C(N,NK)),( PAD,D(N,NK)), (PAR,R(N,NK))
POINTER (PAR1, R1(N,NK)), (PAR2,R2(N,NK)), (PAZERO,ZERO(N,NK))
POINTER (IAQ, AQ(N)), (IBQ, BQ(N)), (ISE, SE (NK)), (ISIG,SIG(NK))
POINTER ( IUFLUX , UFLUX (N,NK+1) )
POINTER ( IVFLUX , VFLUX (N,NK+1) )
POINTER ( ITFLUX , TFLUX (N,NK+1) )
POINTER ( IQFLUX , QFLUX (N,NK+1) )
POINTER ( IGAM0 , GAM0 (N,NK+1) )
POINTER ( IFSLOFLX , FSLOFLX (N ) )
POINTER ( IQCLOCAL , QCLOCAL (N,NK ) )
POINTER ( IFICELOCAL, FICELOCAL(N,NK ) )
*
* POINTEURS POUR CHAMPS DEJA DEFINIS DANS LES BUS
REAL TU, TV, TW, TT, TQ, UU, VV, W
REAL T, Q, QL, SG, PS, SPONMOD, TM
POINTER ( TU_ , TU (N,NK))
POINTER ( TV_ , TV (N,NK))
POINTER ( TW_ , TW (N,NK))
POINTER ( TT_ , TT (N,NK))
POINTER ( TQ_ , TQ (N,NK))
POINTER ( UU_ , UU (N,NK))
POINTER ( VV_ , VV (N,NK))
POINTER ( W _ , W (N,NK))
POINTER ( T _ , T (N,NK))
POINTER ( Q _ , Q (N,NK))
POINTER ( QL_ , QL (N,NK))
POINTER ( SG_ , SG (N,NK))
POINTER ( TM_ , TM (N,NK))
POINTER ( PS_ , PS (N ))
POINTER ( SP_ , SPONMOD (N ))
*
DATA shconly /.TRUE./
SAVE shconly
*
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 ))
TW_ = LOC(V (WDIFV ))
TT_ = LOC(V (TDIFV ))
TQ_ = LOC(V (QDIFV ))
UU_ = LOC(DB(UPLUS ))
VV_ = LOC(DB(VPLUS ))
W _ = LOC(DB(OMEGAP ))
T _ = LOC(DB(TPLUS ))
Q _ = LOC(DB(HUPLUS ))
QL_ = LOC(DB(QCPLUS ))
SP_ = LOC(DB(EPONMOD))
SG_ = LOC(DB(SIGM ))
TM_ = LOC(DB(TMOINS ))
PS_ = LOC(DB(PMOINS ))
*
* INITIALISATION DU SYSTEME DE GESTION DE L'ESPACE DE TRAVAIL
STK_INITA(G,ESPG)
*
*
* ALLOCATION DES POINTEURS
STK_ALLOC(PAA , N )
STK_ALLOC(IAQ , N )
STK_ALLOC(IBQ , N )
STK_ALLOC(ISE , NK )
STK_ALLOC(ISIG , NK )
STK_ALLOC(PAC , N*NK )
STK_ALLOC(PAD , N*NK )
STK_ALLOC(PAR , N*NK )
STK_ALLOC(PAR1 , N*NK )
STK_ALLOC(PAR2 , N*NK )
STK_ALLOC(PAZERO , N*NK )
STK_ALLOC(IUFLUX , N*(NK+1) )
STK_ALLOC(IVFLUX , N*(NK+1) )
STK_ALLOC(ITFLUX , N*(NK+1) )
STK_ALLOC(IQFLUX , N*(NK+1) )
STK_ALLOC(IGAM0 , N*(NK+1) )
STK_ALLOC(IFSLOFLX , N )
STK_ALLOC(IQCLOCAL , N*NK )
STK_ALLOC(IFICELOCAL, N*NK )
*
*
* normalization factors for vertical diffusion in sigma coordinates
*
RSG = (GRAV/RGASD)
DO K=1,NK-1
*VDIR NODEP
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
CALL VSREC(RGAM0,GAM0,N*(NK-1))
DO K=1,NK-1
*VDIR NODEP
DO J=1,N
V(GTE+JK(J,K)) = V(GTE+JK(J,K))*RGAM0(J,K)
V(GQ +JK(J,K)) = V(GQ +JK(J,K))*RGAM0(J,K)
V(GQL+JK(J,K)) = V(GQL+JK(J,K))*RGAM0(J,K)
END DO
END DO
*
* "SLOW START"
*
DO J=1,N
FSLOFLX(J) = 1.
END DO
*
IF (NSLOFLUX.GT.0) THEN
DO J=1,N
* OVER THE CONTINENT, WE PERFORM A SLOW START FOR
* FLUXES "FC" AND "FV" UNTIL TIMESTEP "NSLOFLUX",
* BECAUSE OF IMBALANCES BETWEEN ANALYSES OF TEMPERATURE
* AT THE GROUND AND JUST ABOVE THE SURFACE.
IF (F(MG+J-1).GT.0.5) THEN
* MAX IS USED TO AVOID DIVISION BY ZERO
FSLOFLX(J) = (FLOAT(KOUNT-1))/MAX(FLOAT(NSLOFLUX),1.)
IF (KOUNT.EQ.0) FSLOFLX(J) = 0.0
ENDIF
END DO
ENDIF
*
*
*VDIR NODEP
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 + (indx_agrege-1)*N +J-1)*AQ(J)
V(ALFAT+J-1) = V(ALFAT+J-1)*AQ(J)*FSLOFLX(J)
V(ALFAQ+J-1) = V(ALFAQ+J-1)*AQ(J)*FSLOFLX(J)
END DO
*
*
DO K=1,NK+1
DO J=1,N
GAM0(J,K) = 0.0
END DO
END DO
*
DO K=1,NK
SE (K) = SELOC(1,K)
SIG(K) = SG (1,K)
END DO
*
* DIFFUSION VERTICALE IMPLICITE
*
gsrt = grav/(rgasd*250.)
DO 1 K=1,NK
*VDIR NODEP
DO 1 J=1,N
ZERO(J,K)=0.
* couche eponge
IF (SPONMOD(J)*EPONGE(K).GT.0.0) THEN
V(KM+JK(J,K)) = SPONMOD(J)*EPONGE(K)
KMSG(J,K) = MAX( KMSG(J,K),
+ V(KM+JK(J,K)) * (seloc(j,k)*gsrt)**2 )
ENDIF
1 CONTINUE
*
* DIFFUSE U
*
CALL DIFUVDFJ(TU,UU,KMSG,ZERO,ZERO,ZERO,BMSG,SG,SEloc,TAU,
+ 1,1.,C,D,R,R1,N,N,N,NK)
*
CALL ATMFLUX(UFLUX,UU,TU,KMSG,GAM0,ZERO(1,NK),
1 BMSG,PS,T,Q,TAU,SG,
1 SELOC,C,D,0,N,NK,TRNCH)
*
*
* DIFFUSE V
*
CALL DIFUVDFJ(TV,VV,KMSG,ZERO,ZERO,ZERO,BMSG,SG,SEloc,TAU,
+ 1,1.,C,D,R,R1,N,N,N,NK)
*
CALL ATMFLUX(VFLUX,VV,TV,KMSG,GAM0,ZERO(1,NK),
1 BMSG,PS,T,Q,TAU,SG,
1 SELOC,C,D,1,N,NK,TRNCH)
*
*
* DIFFUSE W (OMEGAP)
*
if (diffuw) then
CALL DIFUVDFJ(TW,W,KMSG,ZERO,ZERO,ZERO,ZERO,SG,SEloc,TAU,
+ 1,1.,C,D,R,R1,N,N,N,NK)
endif
*
* DIFFUSE MOISTURE
*
IF(EVAP) THEN
DO J=1,N
AQ(J) = V(ALFAQ+J-1)
BQ(J) = BTSG(J)
END DO
*
ELSE
*
* LA CLE 'EVAP' EST VALIDE POUR PARAMETRAGES CLEF ET SIMPLIFIES
* METTRE TERMES DE SURFACE A ZERO
DO J=1,N
AQ(J) = 0.0
BQ(J) = 0.0
END DO
*
ENDIF
*
IF(IFLUVERT.EQ.3) THEN
* diffuse conservative variable qw
*
* QCBL contains the implicit cloud water from previous time step.
DO K=1,NK
DO J=1,N
QCLOCAL(J,K) = MAX( 0.0 , F(QCBL+JK(J,K)) )
Q(J,K) = Q(J,K) + MAX( 0.0 , QCLOCAL(J,K) )
END DO
END DO
*
ENDIF
*
CALL DIFUVDFJ(TQ,Q,KTSG,V(GQ),ZERO,AQ,BQ,SG,SEloc,TAU,
+ 1,1.,C,D,R,R1,N,N,N,NK)
*
IF (.NOT.WET) THEN
DO J=1,N*NK
TQ(J,1) = 0.0
END DO
ENDIF
*
CALL ATMFLUX(QFLUX,Q,TQ,KTSG,GAM0,
1 AQ,BQ,PS,T,Q,TAU,SG,
1 SELOC,C,D,2,N,NK,TRNCH)
*
*
*
* DIFFUSE L'EAU LIQUIDE OPTIONNELLEMENT
*
if( ISHLCVT(1).eq.4 ) then
*
DO J=1,N
BQ(J) = 0.
END DO
*
CALL DIFUVDFJ(TL,QL,KTSG,V(GQL),ZERO,ZERO,BQ,SG,SEloc,TAU,
+ 1,1.,C,D,R,R1,N,N,N,NK)
*
endif
*
* DIFFUSE TEMPERATURE
*
IF (CHAUF) THEN
DO J=1,N
AQ(J) = V(ALFAT+J-1)
BQ(J) = BTSG(J)
END DO
*
ELSE
*
* LA CLE 'CHAUF' EST VALIDE POUR PARAMETRAGES CLEF ET SIMPLIFIES
* METTRE TERMES DE SURFACE A ZERO
DO J=1,N
AQ(J) = 0.0
BQ(J) = 0.0
END DO
*
ENDIF
*
*
IF(IFLUVERT.EQ.3) THEN
* diffuse conservative variable thetal
*
CALL FICEMXP(FICELOCAL,R1,R2,TM,N,N,NK)
DO K=1,NK
DO J=1,N
* copy current T in R2 for later use in BAKTOTQ
R2(J,K) = T(J,K)
T(J,K) = T(J,K)
1 - ((CHLC+FICELOCAL(J,K)*CHLF)/CPD)
1 *MAX( 0.0 , QCLOCAL(J,K) )
T(J,K) = T(J,K) * SG(J,K)**(-CAPPA)
END DO
END DO
ENDIF
*
CALL DIFUVDFJ(TT,T,KTSG,V(GTE),ZERO,AQ,BQ,SG,SEloc,TAU,
+ 1,1.,C,D,R,R1,N,N,N,NK)
*
*
IF(IFLUVERT.EQ.3) THEN
* back to non-conservative variables T and Q
* and their tendencies
*
CALL BAKTOTQ2 (T, Q, QCLOCAL, R2, SG, PS, TM, FICELOCAL,
1 TT, TQ, TL, V(TVE), F(QCBL),
1 F(FNN), F(FN), F(ZN), F(ZD),
1 TAU, N, N, NK)
*
*
ENDIF
*
*
* Counter-gradient term = -g/cp
* because temperature is used in
* subroutine DIFUVDF (instead of
* potential temperature).
*
DO K=1,NK+1
DO J=1,N
GAM0(J,K) = -GRAV/CPD
END DO
END DO
*
CALL ATMFLUX(TFLUX,T,TT,KTSG,GAM0,
1 AQ,BQ,
1 PS,T,Q,TAU,SG,SELOC,C,D,3,N,NK,TRNCH)
*
*
* DIFFUSE AVEC CONDENSATION OPTIONNELLEMENT
*
IF( ISHLCVT(1).eq.4 ) THEN
*
* soit avec condensation seulement
*
* lscp permet de convertir les variables du type
* ps*dq/dt en flux d'energie (W/m2)
lscp = chlc/cpd
*
if( shconly ) then
*
DO k = 1, NK
DO j = 1, N
DQ = min(TL(j,k),-QL(j,k)/TAU)+QL(j,k)/TAU
TQ(j,k) = TQ(j,k) + DQ
TL(j,k) = max( TL(j,k) , - QL(j,k)/TAU )
TT(j,k) = TT(j,k) - lscp*DQ
END DO
END DO
*
else
*
* soit avec condensation/evaporation
*
DO k = 1, NK
DO j = 1, N
DQ = TL(j,k)
TQ(j,k) = TQ(j,k) + DQ
TL(j,k) = 0.0
TT(j,k) = TT(j,k) - lscp*DQ
END DO
END DO
endif
*
ENDIF
*
* CALCUL FINAL DU BILAN DE SURFACE
*
*VDIR NODEP
do j = 1, n
rhortvsg = ps(j)/grav
mrhocmu = ps(j)/grav*bmsg(j)
tplusnk = t (j,nk)+tau*tt(j,nk)
qplusnk = q (j,nk)+tau*tq(j,nk)
uplusnk = uu(j,nk)+tau*tu(j,nk)
vplusnk = vv(j,nk)+tau*tv(j,nk)
*
* RECALCULER LES FLUX PARTOUT
*
* USTRESS et VSTRESS sont calcules apres diffusion car
* on utilise toujours une formulation implicite pour
* la condition aux limites de surface pour les vents.
* Par contre, la formulation est explicite pour
* la temperature et l'humidite.
* A noter que, puisque la formulation est explicite,
* on agrege les flux FC et FV dans le sous-programme
* AGREGE; on pourrait aussi les calculer ici en tout
* temps, mais on ne le fait que pendant le "depart lent".
* Si on utilisait une formulation implicite pour
* FC et FV, il faudrait que ces derniers soient
* toujours calcules ici.
*
IF (NSLOFLUX.GT.0.AND.KOUNT.LE.NSLOFLUX) THEN
v(fc+(indx_agrege-1)*N+j-1) = CPD * rhortvsg *
$ (v(alfat+j-1)+btsg(j)*tplusnk)
v(fv+(indx_agrege-1)*N+j-1) = CHLC * rhortvsg *
$ (v(alfaq+j-1)+btsg(j)*qplusnk)
ENDIF
*
v(ustress+j-1) = -mrhocmu*uplusnk
v(vstress+j-1) = -mrhocmu*vplusnk
f(fq+j-1) = -mrhocmu*sqrt(uplusnk**2 + vplusnk**2)
*
IF (.NOT.CHAUF) v(FC+(indx_agrege-1)*N+j-1) = 0.0
IF (.NOT.EVAP ) v(FV+(indx_agrege-1)*N+j-1) = 0.0
*
A(j) = f(FDSI+j-1)*f(EPSTFN+j-1)/STEFAN
V(FNSI+J-1) = A(j)-f(EPSTFN+j-1)*f(TSRAD+j-1)**4
V(FL +J-1) = V(FNSI +j-1) +
$ f(FDSS +j-1) -
$ V(FV+(indx_agrege-1)*n+j-1) -
$ V(FC+(indx_agrege-1)*n+j-1)
enddo
*
* DIAGNOSTICS
*
CALL SERGET ('HEURE', HEURSER, 1, IERROR )
CALL SERXST ( TU, 'TU', TRNCH, N, 0.0, 1.0, -1 )
CALL SERXST ( TV , 'TV', TRNCH, N, 0.0, 1.0, -1 )
CALL MVZNXST(TU,TV,'TU','TV',TRNCH, N, 1., -1, stack )
*
CALL SERXST ( TT, 'TF', TRNCH, N, 0.0, 1.0, -1 )
CALL MZONXST ( TT, 'TF', TRNCH, N, HEURSER,PS, -2, stack )
CALL SERXST ( TQ, 'QF', TRNCH, N, 0.0, 1.0, -1 )
CALL MZONXST ( TQ, 'QF', TRNCH, N, HEURSER,PS, -2, stack )
CALL SERXST ( TL, 'LF', TRNCH, N, 0.0, 1.0, -1 )
CALL MZONXST ( TL, 'LF', TRNCH, N, HEURSER,PS, -2, stack )
*
CALL SERXST (F(FQ), 'FQ', TRNCH, N, 0., 1., -1 )
CALL MZONXST (F(FQ), 'FQ', TRNCH, N, HEURSER,1., -1, stack )
*
CALL SERXST (V(FC+(indx_soil -1)*N), 'F4', TRNCH, N, 0., 1., -1 )
CALL MZONXST (V(FC+(indx_soil -1)*N), 'F4', TRNCH, N, HEURSER,1., -1, stack )
CALL SERXST (V(FC+(indx_glacier-1)*N), 'F5', TRNCH, N, 0., 1., -1 )
CALL MZONXST (V(FC+(indx_glacier-1)*N), 'F5', TRNCH, N, HEURSER,1., -1, stack )
CALL SERXST (V(FC+(indx_water -1)*N), 'F6', TRNCH, N, 0., 1., -1 )
CALL MZONXST (V(FC+(indx_water -1)*N), 'F6', TRNCH, N, HEURSER,1., -1, stack )
CALL SERXST (V(FC+(indx_ice -1)*N), 'F7', TRNCH, N, 0., 1., -1 )
CALL MZONXST (V(FC+(indx_ice -1)*N), 'F7', TRNCH, N, HEURSER,1., -1, stack )
CALL SERXST (V(FC+(indx_agrege -1)*N), 'FC', TRNCH, N, 0., 1., -1 )
CALL MZONXST (V(FC+(indx_agrege -1)*N), 'FC', TRNCH, N, HEURSER,1., -1, stack )
*
CALL SERXST (V(FV+(indx_soil -1)*N), 'H4', TRNCH, N, 0., 1., -1 )
CALL MZONXST (V(FV+(indx_soil -1)*N), 'H4', TRNCH, N, HEURSER,1., -1, stack )
CALL SERXST (V(FV+(indx_glacier-1)*N), 'H5', TRNCH, N, 0., 1., -1 )
CALL MZONXST (V(FV+(indx_glacier-1)*N), 'H5', TRNCH, N, HEURSER,1., -1, stack )
CALL SERXST (V(FV+(indx_water -1)*N), 'H6', TRNCH, N, 0., 1., -1 )
CALL MZONXST (V(FV+(indx_water -1)*N), 'H6', TRNCH, N, HEURSER,1., -1, stack )
CALL SERXST (V(FV+(indx_ice -1)*N), 'H7', TRNCH, N, 0., 1., -1 )
CALL MZONXST (V(FV+(indx_ice -1)*N), 'H7', TRNCH, N, HEURSER,1., -1, stack )
CALL SERXST (V(FV+(indx_agrege -1)*N), 'FV', TRNCH, N, 0., 1., -1 )
CALL MZONXST (V(FV+(indx_agrege -1)*N), 'FV', TRNCH, N, HEURSER,1., -1, stack )
*
CALL SERXST ( A, 'FI', TRNCH, N, 0., 1., -1 )
CALL MZONXST ( A, 'FI', TRNCH, N, HEURSER,1., -1, stack )
CALL SERXST (V(FNSI),'SI', TRNCH, N, 0.,1.,-1 )
CALL MZONXST (V(FNSI),'SI', TRNCH, N, HEURSER,1., -1, stack )
CALL SERXST (V(FL) ,'FL', TRNCH, N, 0., 1., -1 )
CALL MZONXST (V(FL) ,'FL', TRNCH, N, HEURSER,1., -1, stack )
*
*
* KM ET KT DEFINIS AU NIVEAU NK POUR LES DIAGNOSTICS
*VDIR NODEP
DO J=1,N
V(KM+jk(J,NK )) = V(KM+jk(J,NK-1))
V(KT+jk(J,NK )) = V(KT+jk(J,NK-1))
END DO
*
* DIAGNOSTICS POUR LE MODELE CTM
IF (IFLUVERT.EQ.2.OR.IFLUVERT.EQ.3) THEN
CALL CTMDIAG(DB,F,V,DSIZ,FSIZ,VSIZ,N,NK)
CALL SERXST ( v(ue), 'UE', TRNCH, N, 0.0, 1.0, -1 )
ENDIF
*
*
CALL SERXST ( V(KM), 'KM', TRNCH, N, 0.0, 1.0, -1 )
CALL MZONXST ( V(KM), 'KM', TRNCH, N, HEURSER,1.0, -1, stack )
CALL SERXST ( V(KT), 'KT', TRNCH, N, 0.0, 1.0, -1 )
CALL MZONXST ( V(KT), 'KT', TRNCH, N, HEURSER,1.0, -1, stack )
*
*
* RELACHEMENT DES POINTEURS
STK_DEALL(PAA)
STK_FREE
*
RETURN
END