!copyright (C) 2001 MSC-RPN COMM %%%RPNPHY%%%
***S/P FORCE_RESTORE
*
#include "phy_macros_f.h"
subroutine force_restore 1,5
$ (
$ bus, bussiz,
$ ptsurf, ptsurfsiz,
$ kount, trnch,
$ n , m , nk , itask
$ )
*
#include "impnone.cdk"
*
integer bussiz,gsiz,kount,trnch,n,m,nk,itask
integer ptsurfsiz
integer ptsurf(ptsurfsiz)
real bus(bussiz)
*
*Author
* B. Bilodeau (March 1999)
*
*Revision
* 001 B. Bilodeau (Nov 2000) - New comdeck sfcbus.cdk
* 002 B. Bilodeau (Jan 2001) - Automatic arrays
* 003 B. Bilodeau (Aug 2001) - LOCBUS
* 004 J.-F. Mahfouf (Spring 2003) -
* add implicit boundary condition option for vert. diff.
* 005 B. Bilodeau (Mar 2004) - change indexing of BT
*
*Object
* this is the main subroutine for the "clef" (full physics)
* boundary layer scheme
*
*Arguments
*
* - input/output -
* BUS surface bus
*
* - input -
* BUSSIZ dimension of bus
*
* - input -
* TAU current timestep (usually less than delt for kount=1)
* KOUNT current timestep value
* TRNCH slice number
* N horizontal dimension
* M horizontal dimension of fields
* (not used for the moment)
* NK number of levels
* ITASK multi-tasking number
*
*Notes
* 1)it initializes and allocates the memory needed for the
* calculations.
* 2)it calculates the diagnostics related to boundary
* conditions (flxsrf)
* 3)it integrates force-restore equations (fcrest)
*
*
*implicites
*
#include "locbus.cdk"
INTEGER INDX_SFC, SURFLEN
PARAMETER (INDX_SFC = INDX_SOIL)
INTEGER QUELNIVO(MAXVARSURF)
*
#include "options.cdk"
*
#include "scfrst.cdk"
*
#include "clefcon.cdk"
*
#include "surfcon.cdk"
*
#include "consphy.cdk"
*
#include "machcon.cdk"
*
*modules
*
*
* routines clef
*
external stfrst4
external flxsurf2
external fcrest5
external inctphy
*
*
#include "biton.cdk"
**
*
*
real alpha,sc
real rho
integer i,j,k,ja,nnk
#include "vamin.cdk"
save alpha, vamin
*
data alpha / 1.0 /
*
************************************************************************
* AUTOMATIC ARRAYS
************************************************************************
*
AUTOMATIC ( A1MAX , REAL , (N ) )
AUTOMATIC ( A1MIN , REAL , (N ) )
AUTOMATIC ( A2P , REAL , (N ) )
AUTOMATIC ( AA1 , REAL , (N ) )
AUTOMATIC ( BA1 , REAL , (N ) )
AUTOMATIC ( C1 , REAL , (N ) )
AUTOMATIC ( C2 , REAL , (N ) )
AUTOMATIC ( D2P , REAL , (N ) )
AUTOMATIC ( WKI , REAL , (N ) )
AUTOMATIC ( WM , REAL , (N ) )
AUTOMATIC ( ZTN , REAL , (N ) )
AUTOMATIC ( ZUN , REAL , (N ) )
AUTOMATIC ( C3 , REAL , (N ) )
AUTOMATIC ( C4 , REAL , (N ) )
AUTOMATIC ( CLAT , REAL , (N ) )
AUTOMATIC ( RIA , REAL , (N ) )
AUTOMATIC ( P1 , REAL , (N ) )
AUTOMATIC ( P2 , REAL , (N ) )
AUTOMATIC ( P3 , REAL , (N ) )
AUTOMATIC ( P4 , REAL , (N ) )
AUTOMATIC ( P5 , REAL , (N ) )
AUTOMATIC ( P6 , REAL , (N ) )
AUTOMATIC ( P7 , REAL , (N ) )
AUTOMATIC ( WSWK , REAL , (N ) )
AUTOMATIC ( VA , REAL , (N ) )
AUTOMATIC ( TEMPO , REAL , (N*2 ) )
AUTOMATIC ( TT , REAL , (N*NK) )
AUTOMATIC ( QQ , REAL , (N*NK) )
*
************************************************************************
*
*
REAL ALVIS_SOL, CMU, CTU
REAL FC_SOL, FV_SOL
REAL HST_SOL, HU, ILMO_SOL
REAL QS, TH, TS, UU, VV
REAL Z0H, Z0M
REAL ZALFAQ, ZALFAT, ZPMOINS
REAL ZQDIAG, ZTDIAG, ZUDIAG, ZVDIAG
REAL ZTSM1, ZTSURF, ZTSRAD, ZZA
*
POINTER (IALVIS_SOL , ALVIS_SOL (1) )
POINTER (ICMU , CMU (1) )
POINTER (ICTU , CTU (1) )
POINTER (IFC _SOL , FC _SOL (1) )
POINTER (IFV _SOL , FV _SOL (1) )
POINTER (IHST _SOL , HST _SOL (1) )
POINTER (IHU , HU (1) )
POINTER (IILMO _SOL , ILMO _SOL (1) )
POINTER (IQS , QS (1) )
POINTER (ITH , TH (1) )
POINTER (ITS , TS (1) )
POINTER (IUU , UU (1) )
POINTER (IVV , VV (1) )
POINTER (IZ0H , Z0H (1) )
POINTER (IZ0M , Z0M (1) )
POINTER (IZALFAQ , ZALFAQ (1) )
POINTER (IZALFAT , ZALFAT (1) )
POINTER (IZPMOINS , ZPMOINS (1) )
POINTER (IZQDIAG , ZQDIAG (1) )
POINTER (IZTDIAG , ZTDIAG (1) )
POINTER (IZTSM1 , ZTSM1 (1) )
POINTER (IZTSURF , ZTSURF (1) )
POINTER (IZTSRAD , ZTSRAD (1) )
POINTER (IZUDIAG , ZUDIAG (1) )
POINTER (IZVDIAG , ZVDIAG (1) )
POINTER (IZZA , ZZA (1) )
*
integer ptr, x
*
integer ik
*
#include "zuzt.cdk"
*
#include "sfcbus.cdk"
*
#include "dintern.cdk"
#include "fintern.cdk"
*
#include "xptsurf.cdk"
*
*
ik(j,k) = (k-1)*n + j - 1
*
*
ja = n*(nk-1)
nnk = n*nk
*
surflen = m
*
*
* EQUIVALENCES
*
INIT_LOCBUS()
*
* Syntax of macro locbus (must be typed in CAPITAL letters):
* locbus (pointer, array_name_in_the_bus, level)
* If level=0, array chosen automatically as follows:
* 1) level = 1 if array has 1 level only (e.g. TSURF )
* 2) level = nk if array has nk levels (e.g. TMOINS)
* 3) level = indx_sfc if array has a level for each surface type (e.g. FC)
* 4) level has to be specified by user if array has more than one level
* that all "belong" to the same surface type (e.g. TSOIL)
*
LOCBUS (IALVIS_SOL, ALVIS , 0 )
LOCBUS (ICMU , BM , 0 )
LOCBUS (ICTU , BT , 0 )
LOCBUS (IFC _SOL , FC , 0 )
LOCBUS (IFV _SOL , FV , 0 )
LOCBUS (IHST_SOL , HST , 0 )
LOCBUS (IHU , HUMOINS, 0 )
LOCBUS (IILMO_SOL , ILMO , 0 )
LOCBUS (IQS , QSURF , 0 )
LOCBUS (ITH , THETAA , 0 )
LOCBUS (ITS , TSOIL , 1 )
LOCBUS (IUU , UMOINS , 0 )
LOCBUS (IVV , VMOINS , 0 )
LOCBUS (IZ0H , Z0T , 0 )
LOCBUS (IZ0M , Z0 , 0 )
LOCBUS (IZALFAQ , ALFAQ , 0 )
LOCBUS (IZALFAT , ALFAT , 0 )
LOCBUS (IZPMOINS , PMOINS , 0 )
LOCBUS (IZQDIAG , QDIAG , 0 )
LOCBUS (IZTDIAG , TDIAG , 0 )
LOCBUS (IZTSM1 , TSM1 , 0 )
LOCBUS (IZTSURF , TSURF , 0 )
LOCBUS (IZTSRAD , TSRAD , 0 )
LOCBUS (IZUDIAG , UDIAG , 0 )
LOCBUS (IZVDIAG , VDIAG , 0 )
LOCBUS (IZZA , ZA , 0 )
*
*
do j=1,n
zun(j) = zu
ztn(j) = zt
end do
*
call stfrst4 ( d2p, ba1, aa1, a1max, a1min,
+ wki, wm, a2p, c1, c2,
+ bus(x(qsurf,1,indx_soil)), bus(x(wsoil,1,2)),
+ bus(x(tsoil,1,1 )), bus(x(wsoil,1,1)),
+ bus(x(alvis,1,indx_soil)) ,bus(x(glsea,1,1)),
+ bus(x(snodp,1,indx_soil)), bus(x(cs ,1,1)),
+ bus(x(ks,1,1 )), bus(x(stomr,1,1)),
+ bus(x(vegindx,1,1 )), bus(x(dlat ,1,1)),
+ parsol(1), parsol(2), parsol(3),
+ parsol(4), parsol(5), parsol(6),
+ bus(x(humoins,1,nk)), bus(x(pmoins,1,1)),
+ delt, kount, n)
*
*
*
* ----------------
* flux de surface
* ----------------
*
*
do j=1,n
* old technique *** still valid ***
* calculating z0t on land from z0 and maximum=0.2
z0h(j) = min(z0m(j)/5. , 0.2)
*
va(j)=sqrt(max(vamin,uu(j)**2+vv(j)**2))
end do
*
* la hauteur du dernier niveau est 0.
call flxsurf2(bus(x(bm,1,1)),ctu,p6,
$ bus(x(ftemp,1,indx_soil)),
$ bus(x(fvap,1,indx_soil)), bus(x(ilmo,1,indx_soil)),
$ bus(x(ue2,1,indx_soil)),
$ bus(x(fcor,1,1)), bus(x(thetaa,1,1)),
$ bus(x(humoins,1,nk)),
$ bus(x(za,1,1)), va, bus(x(tsoil,1,1)),
$ bus(x(qsurf,1,indx_soil)), bus(x(hst,1,indx_soil)),
$ bus(x(z0,1,indx_soil)), bus(x(z0t,1,indx_soil)),
$ p1, p2, p3, p4, p5, p7, n )
*
*
* ------------------------------------------------
* prevision de ts ws wp qs ( force-restore )
* ------------------------------------------------
*
*
*
*
call fcrest5(bus(x(tsoil,1,1)), bus(x(wsoil,1,2)),
$ bus(x(wsoil,1,1)), bus(x(qsurf,1,indx_soil)),
$ bus(x(thetaa,1,1)), bus(x(humoins,1,nk)),
$ bus(x(sigm,1,1)), nk,
$ bus(x(pmoins,1,1)), bus(x(fdss,1,1)) ,
$ bus(x(tsoil,1,2)), bus(x(rt,1,1)), bus(x(fdsi,1,1)),
$ d2p, bus(x(z0t,1,indx_soil)), ba1,
$ aa1, a1max, a1min,
$ wki, wm, a2p,
$ c1, c2, bus(x(epstfn,1,1)),
$ ctu, ria, clat, c3, c4, wswk, alpha,
$ bus(x(alvis,1,indx_soil)), bus(x(glsea,1,1)),
$ bus(x(snodp,1,indx_soil)), bus(x(stomr,1,1)),
$ bus(x(vegindx,1,1)), n,tempo)
*
call diasurf1(ZUDIAG, ZVDIAG, ZTDIAG, ZQDIAG,
$ n,
$ bus(x(umoins,1,nk )),
$ bus(x(vmoins,1,nk )),
$ bus(x(tsoil ,1,1 )),
$ bus(x(qsurf ,1,indx_soil)),
$ bus(x(z0 ,1,indx_soil)),
$ bus(x(z0t ,1,indx_soil)),
$ bus(x(ilmo ,1,indx_soil)),
$ bus(x(za ,1,1 )),
$ bus(x(hst ,1,indx_soil)),
$ bus(x(ue2 ,1,indx_soil)),
$ bus(x(ftemp ,1,indx_soil)),
$ bus(x(fvap ,1,indx_soil)),
$ zun, ztn,
$ bus(x(dlat ,1,1 ))
$ )
*
*
*
*
*VDIR NODEP
DO J=1,N
*
ZTSM1 (J) = TS (J)
ZTSURF (J) = TS (J)
ZTSRAD (J) = TS (J)
*
ZALFAT (J) = - CTU(J) * ( TS(J)-TH(J) )
ZALFAQ (J) = - CTU(J) * ( QS(J)-HU(J) )
IF (.NOT.IMPFLX) CTU (J) = 0.
RHO = ZPMOINS(J)/(RGASD * ZTDIAG(J)*(1.+DELTA*ZQDIAG(J)))
FC _SOL(J) = -CPD *RHO*ZALFAT(J)
FV _SOL(J) = -CHLC*RHO*ZALFAQ(J)
IF (IMPFLX) THEN
ZALFAT (J) = - CTU(J) * TS(J)
ZALFAQ (J) = - CTU(J) * QS(J)
ENDIF
****
*
END DO
*
* FILL THE ARRAYS TO BE AGGREGATED LATER IN S/R AGREGE
CALL FILLAGG ( BUS, BUSSIZ, PTSURF, PTSURFSIZ, INDX_SOIL,
+ SURFLEN )
*
*
return
end