*IF DEF,OCEAN EXTRAP.2
C *****************************COPYRIGHT****************************** EXTRAP.3
C (c) CROWN COPYRIGHT 1996, METEOROLOGICAL OFFICE, All Rights Reserved. EXTRAP.4
C EXTRAP.5
C Use, duplication or disclosure of this code is subject to the EXTRAP.6
C restrictions as set forth in the contract. EXTRAP.7
C EXTRAP.8
C Meteorological Office EXTRAP.9
C London Road EXTRAP.10
C BRACKNELL EXTRAP.11
C Berkshire UK EXTRAP.12
C RG12 2SZ EXTRAP.13
C EXTRAP.14
C If no contract has been raised with this copy of the code, the use, EXTRAP.15
C duplication or disclosure of it is strictly prohibited. Permission EXTRAP.16
C to do so must first be obtained in writing from the Head of Numerical EXTRAP.17
C Modelling at the above address. EXTRAP.18
C ******************************COPYRIGHT****************************** EXTRAP.19
C*LL EXTRAP.20
CLL Subroutine EXTRAP EXTRAP.21
CLL Author: C.M.Roberts EXTRAP.22
CLL Date : 22 May 1996 EXTRAP.23
CLL EXTRAP.24
CLL Written for version 4.1 of UM Jun 11 1996 C. Roberts EXTRAP.25
CLL Version Date Comments GSH1F403.13
CLL 4.3 17/04/97 Tidy DEFS and code so that blank source is no GSH1F403.14
CLL produced (A. Brady) GSH1F403.15
CLL EXTRAP.26
CLL This routine extrapolates density at the surface and bottom EXTRAP.27
CLL of the ocean. It forms part of the changes required for EXTRAP.28
CLL the Gent and McWilliams scheme. EXTRAP.29
CLL It is called from BLOKINIT and IPDCOFCL EXTRAP.30
CLL EXTRAP.31
CLL External documentation: EXTRAP.32
CLL Gent, P.R. and McWilliams, J.C. 1990 'Isopycnal Mixing in EXTRAP.33
CLL Ocean Circulation Models,' J. Phys. Oceanogr. 20, 150. EXTRAP.34
CLLEND EXTRAP.35
SUBROUTINE EXTRAP 2EXTRAP.36
& (imt,imtm1,kmp1,km,fxe, EXTRAP.37
& kmtx,kmtxp,dzz,dzz2rq,dz2rq, EXTRAP.38
& tempa,tempb,rrzp,drhob1p,drhob2p ORH3F403.40
& ) EXTRAP.40
IMPLICIT NONE EXTRAP.41
INTEGER EXTRAP.42
& imt,imtm1,kmp1,km EXTRAP.43
&, kmtx(imt) ! IN No of levels at T points EXTRAP.44
&, kmtxp(imt) ! IN and at row to north EXTRAP.45
REAL EXTRAP.46
& fxe ! IN local constant EXTRAP.47
&, dzz(kmp1) ! IN Spacing between layer centres EXTRAP.48
&, dz2rq(imt,km),dzz2rq(imt,km) EXTRAP.49
&, tempa(imt,kmp1) ! IN workspace EXTRAP.50
&, tempb(imt,kmp1) ! IN workspace EXTRAP.51
&, rrzp(imt,kmp1) ! IN delta-rho in z dirn, row J+1 ,top face EXTRAP.52
C except (*,1) which is at level of T points EXTRAP.53
REAL EXTRAP.54
& drhob1p(IMT) ! OUT extrapolated density gradient at the bottom EXTRAP.55
C of column i+1/2, row j+1 (relative to T grid) EXTRAP.56
REAL EXTRAP.57
& drhob2p(IMT,2) ! OUT normalised density for row j+1, EXTRAP.58
C (*,1) at level one less than min(kmtp(i),kmtpp(i)) EXTRAP.59
C (*,2) at level min(kmtp(i),kmtpp(i)) EXTRAP.60
INTEGER EXTRAP.61
& k,i EXTRAP.62
REAL EXTRAP.63
& rloc1, rloc2, rloc3, rloc4 ! Local temporary variables EXTRAP.64
C declare the variables to be updated row by row EXTRAP.66
do i=1,imt EXTRAP.67
drhob1p(i)=0. EXTRAP.68
drhob2p(i,1)=0. EXTRAP.69
drhob2p(i,2)=0. EXTRAP.70
enddo EXTRAP.71
C extrapolate to find density gradient at k=1 on tracer levels EXTRAP.72
k = 1 EXTRAP.73
rloc1 = dzz(k)+dzz(k+1) EXTRAP.74
do i=1,imt EXTRAP.75
rloc2 = 2.*dzz2rq(i,k+1)*(tempa(i,k)*rloc1-tempa(i,k+1)*dzz(k)) EXTRAP.76
rrzp(i,k) = (rloc2-0.5*(tempa(i,k+1)+tempa(i,k))) EXTRAP.77
enddo EXTRAP.78
do i=1,imtm1 EXTRAP.79
k=min(kmtx(i),kmtx(i+1)) EXTRAP.80
if (k .ne. 0) then EXTRAP.81
rloc1=dzz(k)+dzz(k+1) EXTRAP.82
if (mod(k,2).eq.0) then EXTRAP.83
rloc2=0.5*(tempa(i,k-1)+tempa(i+1,k-1)) EXTRAP.84
rloc3=0.5*(tempa(i,k)+ tempa(i+1,k)) EXTRAP.85
else EXTRAP.86
rloc2=0.5*(tempb(i,k-1)+tempb(i+1,k-1)) EXTRAP.87
rloc3=0.5*(tempb(i,k)+ tempb(i+1,k)) EXTRAP.88
endif EXTRAP.89
rloc4=2.*dzz2rq(i,k)*(rloc3*rloc1-rloc2*dzz(k+1)) EXTRAP.90
drhob1p(i)=2.*dz2rq(i,k)*(0.5*(rloc2+rloc3)-rloc4)*fxe EXTRAP.91
endif EXTRAP.92
enddo EXTRAP.93
do i=1,imt EXTRAP.94
k=min(kmtx(i),kmtxp(i)) EXTRAP.95
if (k.ne.0) then EXTRAP.96
if (mod(k,2).eq.0) then EXTRAP.97
drhob2p(i,1)=tempa(i,k-1) EXTRAP.98
drhob2p(i,2)=tempa(i,k) EXTRAP.99
else EXTRAP.100
drhob2p(i,1)=tempb(i,k-1) EXTRAP.101
drhob2p(i,2)=tempb(i,k) EXTRAP.102
endif EXTRAP.103
endif EXTRAP.104
enddo EXTRAP.105
return EXTRAP.107
end EXTRAP.108
*ENDIF EXTRAP.109