!-------------------------------------- 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 --------------------------------------
***S/P DIFUVD4
*
SUBROUTINE DIFUVD4 (D, KU, GU, S, SK, TYPE, N, NK)
*
#include "impnone.cdk"
INTEGER N, NK
REAL KU(N,NK), GU(N,NK), S(n,NK), SK(n,NK)
CHARACTER TYPE*(*)
REAL D(N, NK)
*
*Author
* R. Benoit (Mar 89)
*
*Object
* to calculate a vertical derivative consistent with
* DIFUVDF; D/DS (KU*GU)
*
*Revisions
* 001 R. Benoit (Aug 93) Local sigma
* 002 M. Lepine (March 2003) - CVMG... Replacements
*
*Arguments
*
* - Output -
* D vertical derivative
*
* - Input -
* KU diffusion coefficient
* GU optional countergradient term
* S sigma levels for U
* SK sigma coordinates of diffusion coefficient levels
* TYPE type of variable for U ('U', 'UT', 'E')
* N number of columns to process
* NK vertical dimension
*
**
*
INTEGER I, K, NKX
REAL ST, SB, HM, HP, HD, KUM, KUP, SCK1
LOGICAL DEBUG
SAVE DEBUG
DATA DEBUG /.FALSE./
*
logical typeisut
*
sb(i)=sk(i,nk)
*
IF (DEBUG) THEN
PRINT *,' S/R DIFUVD4..TYPE,N,NK=',
% TYPE,N,NK
* PRINT *,' S=',S
* PRINT *,' SK=',SK
I=1
PRINT *,' KU(',I,',*)=',(K,KU(I,K),K=1,NK)
PRINT *,' GU(',I,',*)=',(K,GU(I,K),K=1,NK)
ENDIF
*
* ST=S(1)-0.5*(S(2)-S(1))
* SB=SK(NK)
*
typeisut=.false.
IF (TYPE(1:1).EQ.'U') THEN
NKX=NK
SCK1=1
IF (LEN(TYPE).GT.1) THEN
IF (TYPE(2:2).EQ.'T') THEN
SCK1=0
typeisut=.true.
* ST=S(1)
* ELSE
* PRINT *,' S/R DIFUVD4. TYPE INCONNU= ',TYPE,' STOP...'
* CALL QQEXIT(1)
ENDIF
ENDIF
ELSE IF (TYPE.EQ.'E') THEN
NKX=NK-1
ELSE
PRINT *,' S/R DIFUVD4. TYPE INCONNU= ',TYPE,' STOP...'
CALL QQEXIT(1)
ENDIF
*
* CONSTRUIRE LE TERME CONTRE-GRADIENT (DANS D)
*
IF (TYPE(1:1).EQ.'U') THEN
*
* K=1
*
HM=0
DO 10 I=1,N
HP=S(i,2)-S(i,1)
! HD=0.5*(S(i,1)+S(i,2))-ST(i)
if (typeisut) then
HD=0.5*(S(i,1)+S(i,2))-s(i,1)
else
HD=0.5*(S(i,1)+S(i,2))-
% (S(i,1)-0.5*(S(i,2)-S(i,1)))
endif
10 D(I,1)=SCK1*KU(I,1)*GU(I,1)/HD
*
* K=2...NK-1
*
DO 11 K=2,NK-1,1
DO 11 I=1,N
HM=S(i,K)-S(i,K-1)
HP=S(i,K+1)-S(i,K)
HD=0.5*(HM+HP)
11 D(I,K)=(KU(I,K)*GU(I,K)-KU(I,K-1)*GU(I,K-1))/HD
*
* K=NK
*
HP=0
DO 12 I=1,N
HM=S(i,NK)-S(i,NK-1)
HD=SB(i)-0.5*(S(i,NK-1)+S(i,NK))
12 D(I,NK)=(0-KU(I,NK-1)*GU(I,NK-1))/HD
ELSE
*
* TYPE='E'
*
* K=1
*
DO 13 I=1,N
HM=S(i,2)-S(i,1)
HP=SK(i,2)-SK(i,1)
HD=0.5*(SK(i,2)+SK(i,1)) -S(i,1)
KUM=0.5*KU(I,1)
KUP=0.5*(KU(I,1)+KU(I,2))
13 D(I,1)=(KUP*(GU(I,1)+GU(I,2))-KUM*GU(I,1))/(2*HD)
*
* K=2...NK-2
*
DO 14 K=2,NK-2,1
DO 14 I=1,N
HM=SK(i,K)-SK(i,K-1)
HP=SK(i,K+1)-SK(i,K)
HD=0.5*(HM+HP)
KUM=0.5*(KU(I,K-1)+KU(I,K))
KUP=0.5*(KU(I,K+1)+KU(I,K))
14 D(I,K)=(KUP*(GU(I,K)+GU(I,K+1))
% -KUM*(GU(I,K-1)+GU(I,K)))/(2*HD)
*
* K=NK-1=NKX
*
HP=0
DO 15 I=1,N
HM=SK(i,NK-1)-SK(i,NK-2)
HD=SB(i)-0.5*(SK(i,NK-1)+SK(i,NK-2))
KUM=0.5*(KU(I,NK-1)+KU(I,NK-2))
KUP=0
15 D(I,NKX)=(0-KUM*(GU(I,NK-1)+GU(I,NK-2)))/(2*HD) !NK=>NKX 14
*
ENDIF
*
RETURN
END