| 1 |
|
| 2 |
#include "ctrparam.h" |
| 3 |
|
| 4 |
! ========================================================== |
| 5 |
! |
| 6 |
! SURFACE.F: THIS SUBROUTINE CALCULATES THE SURFACE FLUXES |
| 7 |
! WHICH INCLUDE SENSIBLE HEAT, EVAPORATION, |
| 8 |
! THERMAL RADIATION, AND MOMENTUM DRAG. IT ALSO |
| 9 |
! CALCULATES INSTANTANEOUSLY SURFACE TEMPERATURE, |
| 10 |
! SURFACE SPECIFIC HUMIDITY, AND SURFACE WIND |
| 11 |
! COMPONENTS. |
| 12 |
! |
| 13 |
! ---------------------------------------------------------- |
| 14 |
! |
| 15 |
! Author of Chemistry Modules: Chien Wang |
| 16 |
! |
| 17 |
! ---------------------------------------------------------- |
| 18 |
! |
| 19 |
! Revision History: |
| 20 |
! |
| 21 |
! When Who What |
| 22 |
! ---- ---------- ------- |
| 23 |
! 073100 Chien Wang repack based on CliChem3 and add cpp |
| 24 |
! 092301 Chien Wang add bc and oc |
| 25 |
! |
| 26 |
! ========================================================== |
| 27 |
|
| 28 |
SUBROUTINE SURFCE 5801. |
| 29 |
|
| 30 |
C**** 5802. |
| 31 |
C**** THIS SUBROUTINE CALCULATES THE SURFACE FLUXES WHICH INCLUDE 5803. |
| 32 |
C**** SENSIBLE HEAT, EVAPORATION, THERMAL RADIATION, AND MOMENTUM 5804. |
| 33 |
C**** DRAG. IT ALSO CALCULATES INSTANTANEOUSLY SURFACE TEMPERATURE, 5805. |
| 34 |
C**** SURFACE SPECIFIC HUMIDITY, AND SURFACE WIND COMPONENTS. 5806. |
| 35 |
C**** 5807. |
| 36 |
|
| 37 |
#if ( defined CPL_CHEM ) |
| 38 |
! |
| 39 |
#include "chem_para" |
| 40 |
#include "chem_com" |
| 41 |
! |
| 42 |
#endif |
| 43 |
|
| 44 |
#include "BD2G04.COM" |
| 45 |
|
| 46 |
#if ( defined CLM ) |
| 47 |
#include "CLM.COM" |
| 48 |
#endif |
| 49 |
|
| 50 |
COMMON/SPEC2/KM,KINC,COEK,C3LAND(IO0,JM0),C3OICE(IO0,JM0) 5808.1 |
| 51 |
* ,C3LICE(IO0,JM0),WMGE(IO0,JM0),TSSFC(1,JM0,4) 5808.2 |
| 52 |
COMMON U,V,T,P,Q 5809. |
| 53 |
COMMON/WORK1/CONV(IM0,JM0,LM0),PK(IM0,JM0,LM0),PREC(IM0,JM0), |
| 54 |
& TPREC(IM0,JM0), 5810. |
| 55 |
* COSZ1(IO0,JM0) 5811. |
| 56 |
COMMON/WORK2/UT(IM0,JM0,LM0),VT(IM0,JM0,LM0),DU1(IO0,JM0), |
| 57 |
& DV1(IO0,JM0), 5812. |
| 58 |
* RA(8),ID(8),UMS(8) 5813. |
| 59 |
COMMON/WORK3/E0(IO0,JM0,4),E1(IO0,JM0,4),EVAPOR(IO0,JM0,4), 5814. |
| 60 |
* TGRND(IO0,JM0,4) 5814.1 |
| 61 |
COMMON/RDATA/ROUGHL(IO0,JM0) 5815. |
| 62 |
DIMENSION SINI(72),COSI(72) 5816. |
| 63 |
DIMENSION WMGMINO(JM0) |
| 64 |
LOGICAL POLE,PRNT,HPRNT |
| 65 |
common/conprn/HPRNT |
| 66 |
common/TSUR/TSURFC(JM0,0:13),TSURFT(JM0),TSURFD(JM0),DTEMSR(JM0) |
| 67 |
common/SURRAD/TRSURF(JM0,4),SRSURF(JM0,4) |
| 68 |
c REAL*8 B,TGV,TKV,TSV0,TSV1,TSV 5818. |
| 69 |
COMMON/CWMG/WMGEA(JM0),NWMGEA(JM0),CHAVER(JM0),DTAV(JM0),DQAV(JM0) |
| 70 |
& ,Z0AV(JM0),WSAV(JM0),WS0AV(JM0),TAUAV(JM0) |
| 71 |
C |
| 72 |
#if ( defined OCEAN_3D || defined ML_2D) |
| 73 |
#include "AGRID.COM" |
| 74 |
#endif |
| 75 |
c |
| 76 |
DATA RVAP/461.5/ 5819. |
| 77 |
DATA SHV/0./,SHW/4185./,SHI/2060./,RHOW/1000./,RHOI/916.6/, 5820. |
| 78 |
* ALAMI/2.1762/,STBO/.5672573E-7/,TF/273.16/,TFO/-1.56/ 5821. |
| 79 |
DATA Z1I/.1/,Z2LI/2.9/,Z1E/.1/,Z2E/4./,RHOS/91.66/,ALAMS/.35/ 5822. |
| 80 |
DIMENSION AROUGH(20),BROUGH(20),CROUGH(20),DROUGH(20),EROUGH(20) 5823. |
| 81 |
DATA AROUGH/16.59,13.99,10.4,7.35,5.241,3.926,3.126,2.632,2.319, 5824. |
| 82 |
*2.116,1.982,1.893,1.832,1.788,1.757,1.733,1.714,1.699,1.687,1.677/5825. |
| 83 |
DATA BROUGH/3.245,1.733,0.8481,0.3899,0.1832,0.9026E-1,0.4622E-1, 5826. |
| 84 |
* .241E-1,.1254E-1,.6414E-2,.3199E-2,.1549E-2,.7275E-3,.3319E-3, 5827. |
| 85 |
* .1474E-3,.6392E-4,.2713E-4,.1130E-4,.4630E-5,.1868E-5/ 5828. |
| 86 |
DATA CROUGH/5.111,3.088,1.682,.9239,.5626,.3994,.3282,.3017,.299 5829. |
| 87 |
*,.3114,.3324,.3587,.3881,.4186,.4492,.4792,.5082,.5361,.5627, 5830. |
| 88 |
* .5882/ 5831. |
| 89 |
DATA DROUGH/1.24,1.02,0.806,0.682,0.661,0.771,0.797,0.895,0.994, 5832. |
| 90 |
* 1.09,1.18,1.27,1.35,1.43,1.50,1.58,1.65,1.71,1.78,1.84/ 5833. |
| 91 |
DATA EROUGH/0.128,0.130,0.141,0.174,0.238,0.330,0.438,0.550,0.660,5834. |
| 92 |
* 0.766,0.866,0.962,1.05,1.14,1.22,1.30,1.37,1.45,1.52,1.58/ 5835. |
| 93 |
QSAT(TM,PR,QLH)=3.797915*EXP(QLH*(7.93252E-6-2.166847E-3/TM))/PR 5836. |
| 94 |
DLQSDT(TM,QLH)=QLH*2.166847E-3/(TM*TM) |
| 95 |
c TLOG(Z0)=ALOG(.36*SQRTT/(FMAG*Z0))+2.302585*ROUGH-.08 5837. |
| 96 |
DATA IFIRST/1/ 5838. |
| 97 |
ROSNOW(X)=0.54*X/LOG(1.+0.54*X/275.) |
| 98 |
ALSNOW(X)=2.8E-6*X**2 |
| 99 |
C**** 5839. |
| 100 |
C**** FDATA 2 LAND COVERAGE (1) 5840. |
| 101 |
C**** 3 RATIO OF LAND ICE COVERAGE TO LAND COVERAGE (1) 5841. |
| 102 |
C**** 5842. |
| 103 |
C**** ODATA 1 OCEAN TEMPERATURE (C) 5843. |
| 104 |
C**** 2 RATIO OF OCEAN ICE COVERAGE TO WATER COVERAGE (1) 5844. |
| 105 |
C**** 3 OCEAN ICE AMOUNT OF SECOND LAYER (KG/M**2) 5845. |
| 106 |
C**** 5846. |
| 107 |
C**** GDATA 1 OCEAN ICE SNOW AMOUNT (KG/M**2) 5847. |
| 108 |
C**** 2 EARTH SNOW AMOUNT (KG/M**2) 5848. |
| 109 |
C**** 3 OCEAN ICE TEMPERATURE OF FIRST LAYER (C) 5849. |
| 110 |
C**** 4 EARTH TEMPERATURE OF FIRST LAYER (C) 5850. |
| 111 |
C**** 5 EARTH WATER OF FIRST LAYER (KG/M**2) 5851. |
| 112 |
C**** 6 EARTH ICE OF FIRST LAYER (KG/M**2) 5852. |
| 113 |
C**** 7 OCEAN ICE TEMPERATURE OF SECOND LAYER (C) 5853. |
| 114 |
C**** 8 EARTH TEMPERATURE OF SECOND LAYER (C) 5854. |
| 115 |
C**** 9 EARTH WATER OF SECOND LAYER (KG/M**2) 5855. |
| 116 |
C**** 10 EARTH ICE OF SECOND LAYER (KG/M**2) 5856. |
| 117 |
C**** 12 LAND ICE SNOW AMOUNT (KG/M**2) 5857. |
| 118 |
C**** 13 LAND ICE TEMPERATURE OF FIRST LAYER (C) 5858. |
| 119 |
C**** 14 LAND ICE TEMPERATURE OF SECOND LAYER (C) 5859. |
| 120 |
C**** 5860. |
| 121 |
C**** BLDATA 1 COMPOSITE SURFACE WIND MAGNITUDE (M/S) 5861. |
| 122 |
C**** 2 COMPOSITE SURFACE AIR TEMPERATURE (K) 5862. |
| 123 |
C**** 3 COMPOSITE SURFACE AIR SPECIFIC HUMIDITY (1) 5863. |
| 124 |
C**** 4 LAYER TO WHICH DRY CONVECTION MIXES (1) 5864. |
| 125 |
C**** 5 SURFACE MOMENTUM TRANSFER (TAU) OCEAN 5865. |
| 126 |
C**** 6 COMPOSITE SURFACE U WIND 5866. |
| 127 |
C**** 7 COMPOSITE SURFACE V WIND 5867. |
| 128 |
C**** 8 COMPOSITE SURFACE MOMENTUM TRANSFER (TAU) 5868. |
| 129 |
C**** 5869. |
| 130 |
C**** VDATA 9 WATER FIELD CAPACITY OF FIRST LAYER (KG/M**2) 5870. |
| 131 |
C**** 10 WATER FIELD CAPACITY OF SECOND LAYER (KG/M**2) 5871. |
| 132 |
C**** 5872. |
| 133 |
C**** ROUGHL LOG(ZGS/ROUGHNESS LENGTH) (LOGARITHM TO BASE 10) 5873. |
| 134 |
C**** ROUGHL will be ROUGHNESS LENGTH |
| 135 |
C**** 5874. |
| 136 |
c print *,'surface TAU=',TAU |
| 137 |
NSTEPS=NSURF*NSTEP/NDYN 5875. |
| 138 |
IF(IFIRST.NE.1) GO TO 50 5876. |
| 139 |
print *,' SURFACE CORSR=',CORSR |
| 140 |
print *,' ZGS=30 m for LAND ' |
| 141 |
IFIRST=0 5877. |
| 142 |
WMGMINL = 5.0 |
| 143 |
print *,'WMGMIN 4 LAND=',WMGMINL |
| 144 |
print *,'over land WMG=max(WMG0,WMGMIN)' |
| 145 |
WMGM0=8.0 |
| 146 |
WMGM45=25. |
| 147 |
print *,' WMGM0=', WMGM0,' WMGM45=',WMGM45 |
| 148 |
WMGMAV=0.5*( WMGM0+WMGM45) |
| 149 |
DWGM=0.5*( WMGM0-WMGM45) |
| 150 |
do j = 1,jm0 |
| 151 |
rhrad = 3.14159*(-90.+4.*(j-1))/180. |
| 152 |
WMGMINO(j) = WMGMAV+DWGM*cos(4.*rhrad) |
| 153 |
enddo |
| 154 |
print *,'WMGMIN 4 OCEAN is a function of latitude' |
| 155 |
print 258,(WMGMINO(J),J=1,JM) |
| 156 |
print *,' WMGE' |
| 157 |
print 258,(WMGE(1,J),J=1,JM) |
| 158 |
258 format(12f5.1) |
| 159 |
! print *,'ODATA(1,7,2)=',ODATA(1,7,2) |
| 160 |
COEFSN=100./ROSNOW(10.) |
| 161 |
COEFSN=1. |
| 162 |
print *,' COEFSN=',COEFSN |
| 163 |
do 2567 J=1,JM |
| 164 |
NWMGEA(J)=0 |
| 165 |
WMGEA(J)=0. |
| 166 |
CHAVER(J)=0. |
| 167 |
DTAV(J)=0. |
| 168 |
DQAV(J)=0. |
| 169 |
Z0AV(J)=0. |
| 170 |
WSAV(J)=0. |
| 171 |
WS0AV(J)=0. |
| 172 |
TAUAV(J)=0. |
| 173 |
2567 CONTINUE |
| 174 |
READ (519) ((ROUGHL(I,J),I=1,IO),J=1,JM) 5878. |
| 175 |
c DO 10 J=2,JMM1 5878.01 |
| 176 |
C ************* |
| 177 |
DO 10 J=1,JM |
| 178 |
C ************* |
| 179 |
ILAND=0. |
| 180 |
SUM1=0. 5878.02 |
| 181 |
CONT1=0. 5878.03 |
| 182 |
CONT2=0. |
| 183 |
DO 11 I=1,IO 5878.04 |
| 184 |
PLAND=C3LAND(I,J) 5878.05 |
| 185 |
CONT1=CONT1+PLAND 5878.06 |
| 186 |
ROUGHL(I,J)=10**(log10(30.)-ROUGHL(I,J)) |
| 187 |
C**** ROUGHL IS NOW ROUGHNESS LENGTH |
| 188 |
11 SUM1=SUM1+PLAND*ROUGHL(I,J) 5878.07 |
| 189 |
IF(CONT1.LE.0.) GO TO 10 5878.08 |
| 190 |
SUM1=SUM1/CONT1 5878.09 |
| 191 |
DO 12 I=1,IO 5878.1 |
| 192 |
12 ROUGHL(I,J)=SUM1 5878.11 |
| 193 |
10 CONTINUE 5878.12 |
| 194 |
C SRCORX=1. 5878.13 |
| 195 |
CIAX=0.3 |
| 196 |
print *,' surfacen CIAX=',CIAX |
| 197 |
print *,' QS=Q1, TS=T1' |
| 198 |
print *,' WS=sqrt(0.75*W1+WGEM) ' |
| 199 |
print *,' ROUGHL' |
| 200 |
print *,(ROUGHL(1,J),J=1,jm) |
| 201 |
REWIND 519 5879. |
| 202 |
LBLMM1=LBLM-1 5880. |
| 203 |
IQ1=IM/4+1 5881. |
| 204 |
IQ2=IM/2+1 5882. |
| 205 |
IQ3=3*IM/4+1 5883. |
| 206 |
DTSURF=NDYN*DT/NSURF 5884. |
| 207 |
print *,' DTSURF=',DTSURF |
| 208 |
DTSRCE=DT*NDYN 5885. |
| 209 |
SHA=RGAS/KAPA 5886. |
| 210 |
RVX=0. 5887. |
| 211 |
ACE1I=Z1I*RHOI 5888. |
| 212 |
HC1I=ACE1I*SHI 5889. |
| 213 |
HC2LI=Z2LI*RHOI*SHI 5890. |
| 214 |
HC1DE=Z1E*1129950. 5891. |
| 215 |
HC2DE=Z2E*1129950.+3.5*.125*RHOW*3100. 5892. |
| 216 |
Z1IBYL=Z1I/ALAMI 5893. |
| 217 |
Z2LI3L=Z2LI/(3.*ALAMI) 5894. |
| 218 |
BYRSL=1./(RHOS*ALAMS) 5895. |
| 219 |
ZS1CO=.5*DSIG(1)*RGAS/GRAV 5896. |
| 220 |
P1000K=EXPBYK(1000.) 5897. |
| 221 |
COEFS=GRAV/(100.*DSIG(1)) 5898. |
| 222 |
COEF1=(1.-SIG(2))/DSIGO(1) 5899. |
| 223 |
COEF2=(SIG(1)-1.)/DSIGO(1) 5900. |
| 224 |
DO 20 I=1,IM 5901. |
| 225 |
SINI(I)=SIN((I-1)*TWOPI/FIM) 5902. |
| 226 |
20 COSI(I)=COS((I-1)*TWOPI/FIM) 5903. |
| 227 |
50 S0=S0X*1367./RSDIST 5904. |
| 228 |
BYS0=RSDIST/1367. 5905. |
| 229 |
C**** ZERO OUT ENERGY AND EVAPORATION FOR GROUND AND INITIALIZE TGRND 5906. |
| 230 |
DO 70 J=1,JM 5907. |
| 231 |
DO 70 I=1,IM 5908. |
| 232 |
TGRND(I,J,2)=GDATA(I,J,3) 5909. |
| 233 |
TGRND(I,J,3)=GDATA(I,J,13) 5910. |
| 234 |
TGRND(I,J,4)=GDATA(I,J,4) 5911. |
| 235 |
DO 70 K=1,12 5912. |
| 236 |
70 E0(I,J,K)=0. 5913. |
| 237 |
IHOUR=1.5+TOFDAY 5914. |
| 238 |
C**** 5915. |
| 239 |
C**** OUTSIDE LOOP OVER TIME STEPS, EXECUTED NSURF TIMES EVERY HOUR 5916. |
| 240 |
C**** 5917. |
| 241 |
DO 9000 NS=1,NSURF 5918. |
| 242 |
MODDSF=MOD(NSTEPS+NS-1,NDASF) 5919. |
| 243 |
IF(MODDSF.EQ.0) IDACC(3)=IDACC(3)+1 5920. |
| 244 |
MODD6=MOD(IDAY+NS,NSURF) 5921. |
| 245 |
C**** ZERO OUT LAYER 1 WIND INCREMENTS 5922. |
| 246 |
DO 60 J=1,JM 5923. |
| 247 |
DO 60 I=1,IM 5924. |
| 248 |
DU1(I,J)=0. 5925. |
| 249 |
60 DV1(I,J)=0. 5926. |
| 250 |
C**** 5927. |
| 251 |
C**** OUTSIDE LOOP OVER J AND I, EXECUTED ONCE FOR EACH GRID POINT 5928. |
| 252 |
C**** 5929. |
| 253 |
JPR=-7 |
| 254 |
DO 7000 J=1,JM 5930. |
| 255 |
PRNT=j.eq.8 |
| 256 |
PRNT=.FALSE. |
| 257 |
if(PRNT)then |
| 258 |
if(ns.eq.1)then |
| 259 |
write(78,*) ,' ' |
| 260 |
write(78,*) ,'TAU=',TAU |
| 261 |
endif |
| 262 |
write(78,*),'NS=',ns |
| 263 |
endif |
| 264 |
HEMI=1. 5931. |
| 265 |
IF(J.LE.JM/2) HEMI=-1. 5932. |
| 266 |
FCOR=2.*OMEGA*SINP(J) 5933. |
| 267 |
FMAG=FCOR*HEMI 5934. |
| 268 |
ROOT2F=SQRT(2.*FMAG) 5935. |
| 269 |
IF(J.EQ.1) GO TO 80 5936. |
| 270 |
IF(J.EQ.JM) GO TO 90 5937. |
| 271 |
WMG0=.5*(WMGE(1,J)+WMGE(1,J+1))+.001 5937.5 |
| 272 |
POLE=.FALSE. 5938. |
| 273 |
IMAX=IM 5939. |
| 274 |
GO TO 100 5940. |
| 275 |
C**** CONDITIONS AT THE SOUTH POLE 5941. |
| 276 |
80 POLE=.TRUE. 5942. |
| 277 |
IMAX=1 5943. |
| 278 |
JVPO=2 5944. |
| 279 |
RAPO=2.*RAPVN(1) 5945. |
| 280 |
U1=.25*(U(1,2,1)+V(IQ1,2,1)-U(IQ2,2,1)-V(IQ3,2,1)) 5946. |
| 281 |
V1=.25*(V(1,2,1)-U(IQ1,2,1)-V(IQ2,2,1)+U(IQ3,2,1)) 5947. |
| 282 |
WMG0=WMGE(1,2)+.001 5947.5 |
| 283 |
GO TO 100 5948. |
| 284 |
C**** CONDITIONS AT THE NORTH POLE 5949. |
| 285 |
90 POLE=.TRUE. 5950. |
| 286 |
IMAX=1 5951. |
| 287 |
JVPO=JM 5952. |
| 288 |
RAPO=2.*RAPVS(JM) 5953. |
| 289 |
U1=.25*(U(1,JM,1)-V(IQ1,JM,1)-U(IQ2,JM,1)+V(IQ3,JM,1)) 5954. |
| 290 |
V1=.25*(V(1,JM,1)+U(IQ1,JM,1)-V(IQ2,JM,1)-U(IQ3,JM,1)) 5955. |
| 291 |
WMG0=WMGE(1,JM)+.001 5955.5 |
| 292 |
C**** ZERO OUT SURFACE DIAGNOSTICS WHICH WILL BE SUMMED OVER LONGITUDE 5956. |
| 293 |
100 ATRHDT=0. 5957. |
| 294 |
BTRHDT=0. 5958. |
| 295 |
CTRHDT=0. 5959. |
| 296 |
ASHDT=0. 5960. |
| 297 |
BSHDT=0. 5961. |
| 298 |
CSHDT=0. 5962. |
| 299 |
AEVHDT=0. 5963. |
| 300 |
BEVHDT=0. 5964. |
| 301 |
CEVHDT=0. 5965. |
| 302 |
ATS=0. 5966. |
| 303 |
BTS=0. 5967. |
| 304 |
CTS=0. 5968. |
| 305 |
AT2=0. 5966. |
| 306 |
BT2=0. 5967. |
| 307 |
CT2=0. 5968. |
| 308 |
ATAUL=0. |
| 309 |
ATAUF=0. |
| 310 |
BTAUL=0. |
| 311 |
BTAUF=0. |
| 312 |
CTAUL=0. |
| 313 |
CTAUF=0. |
| 314 |
AWS=0. |
| 315 |
BWS=0. |
| 316 |
CWS=0. |
| 317 |
AWMG=0. |
| 318 |
BWMG=0. |
| 319 |
CWMG=0. |
| 320 |
ACH=0. |
| 321 |
BCH=0. |
| 322 |
CCH=0. |
| 323 |
IM1=IM 5969. |
| 324 |
#if ( defined CLM ) |
| 325 |
if(NS.eq.1)then |
| 326 |
tsl4clm(j)=0.0 |
| 327 |
qs4clm(j)=0.0 |
| 328 |
ps4clm(j)=0.0 |
| 329 |
ws4clm(j)=0.0 |
| 330 |
us4clm(j)=0.0 |
| 331 |
vs4clm(j)=0.0 |
| 332 |
endif |
| 333 |
#endif |
| 334 |
DO 6000 I=1,IMAX 5970. |
| 335 |
C**** 5971. |
| 336 |
C**** DETERMINE SURFACE CONDITIONS 5972. |
| 337 |
C**** 5973. |
| 338 |
PLAND=FDATA(I,J,2) 5974. |
| 339 |
PWATER=1.-PLAND 5975. |
| 340 |
PLICE=FDATA(I,J,3)*PLAND 5976. |
| 341 |
PEARTH=PLAND-PLICE 5977. |
| 342 |
POICE=ODATA(I,J,2)*PWATER 5978. |
| 343 |
POCEAN=PWATER-POICE 5979. |
| 344 |
if(POCEAN.LE.1.E-5)then |
| 345 |
POCEAN=0. |
| 346 |
POICE=PWATER |
| 347 |
endif |
| 348 |
TTOFR=PEARTH+PLICE+POICE+POCEAN |
| 349 |
if(abs(TTOFR-1).gt.1.e-3)then |
| 350 |
print *,' From surface TTOFR=',TTOFR |
| 351 |
print *,' J=',J,' PLAND=',PLAND,' POCEAN=',POCEAN |
| 352 |
print *,'POICE=',POICE,' ODATA(I,J,2)=',ODATA(I,J,2) |
| 353 |
stop |
| 354 |
end if |
| 355 |
SP=P(I,J) 5980. |
| 356 |
PS=SP+PTOP 5981. |
| 357 |
PSK=EXPBYK(PS) 5982. |
| 358 |
P1=SIG(1)*SP+PTOP 5983. |
| 359 |
P1K=EXPBYK(P1) 5984. |
| 360 |
WSOLD=BLDATA(I,J,1) 5985. |
| 361 |
USOLD=BLDATA(I,J,6) 5986. |
| 362 |
VSOLD=BLDATA(I,J,7) 5987. |
| 363 |
TOLD=BLDATA(I,J,8) 5988. |
| 364 |
SQRTT=SQRT(TOLD) 5989. |
| 365 |
GKBYFW=.1296*GRAV/(FCOR*FMAG*WSOLD+1.E-20) 5990. |
| 366 |
COSWS=GKBYFW*USOLD 5991. |
| 367 |
SINWS=GKBYFW*VSOLD 5992. |
| 368 |
IF(POLE) GO TO 1200 5993. |
| 369 |
U1=.25*(U(IM1,J,1)+U(I,J,1)+U(IM1,J+1,1)+U(I,J+1,1)) 5994. |
| 370 |
V1=.25*(V(IM1,J,1)+V(I,J,1)+V(IM1,J+1,1)+V(I,J+1,1)) 5995. |
| 371 |
if(J.eq.JPR.or.J.eq.-12)then |
| 372 |
print *,' J=',J |
| 373 |
print *,'TAU=',TAU,' NS=',NS,' ITYPE=',ITYPE |
| 374 |
print *,'U(I,J,1)=',U(I,J,1),' V(I,J,1)=',V(I,J,1) |
| 375 |
print *,'U(I,J+1,1)=',U(I,J+1,1),' V(I,J+1,1)=',V(I,J+1,1) |
| 376 |
print *,'U(IM1,J,1)=',U(IM1,J,1),' V(IM1,J,1)=',V(IM1,J,1) |
| 377 |
print *,'U(IM1,J+1,1)=',U(IM1,J+1,1), |
| 378 |
& ' V(IM1,J+1,1)=',V(IM1,J+1,1) |
| 379 |
endif |
| 380 |
1200 TH1=T(I,J,1) 5996. |
| 381 |
Q1=Q(I,J,1) 5997. |
| 382 |
DTH1=0.0 |
| 383 |
DQQ1=0.0 |
| 384 |
THV1=TH1*(1.+Q1*RVX) 5998. |
| 385 |
c SRHEAT=SRHR(I,J,1)*COSZ1(I,J)*SRCOR 5999. |
| 386 |
c SRHDT=SRHEAT*DTSURF 6000. |
| 387 |
RMBYA=100.*SP*DSIG(1)/GRAV 6001. |
| 388 |
C**** ZERO OUT QUANTITIES TO BE SUMMED OVER SURFACE TYPES 6002. |
| 389 |
USS=0. 6003. |
| 390 |
VSS=0. 6004. |
| 391 |
WSS=0. 6005. |
| 392 |
TSS=0. 6006. |
| 393 |
QSS=0. 6007. |
| 394 |
TAUS=0. 6008. |
| 395 |
SINAPS=0. 6009. |
| 396 |
COSAPS=0. 6010. |
| 397 |
JR=J |
| 398 |
DXYPJ=DXYP(J) 6012. |
| 399 |
TG1S=0. 6013. |
| 400 |
QGS=0. 6014. |
| 401 |
BETAS=0. 6015. |
| 402 |
TRHDTS=0. 6016. |
| 403 |
SHDTS=0. 6017. |
| 404 |
EVHDTS=0. 6018. |
| 405 |
UGS=0. 6019. |
| 406 |
VGS=0. 6020. |
| 407 |
WGS=0. 6021. |
| 408 |
USRS=0. 6022. |
| 409 |
VSRS=0. 6023. |
| 410 |
RIS1S=0. 6024. |
| 411 |
RIGSS=0. 6025. |
| 412 |
CDMS=0. 6026. |
| 413 |
CDHS=0. 6027. |
| 414 |
DGSS=0. 6028. |
| 415 |
EDS1S=0. 6029. |
| 416 |
PPBLS=0. 6030. |
| 417 |
EVAPS=0. 6031. |
| 418 |
C**** 6032. |
| 419 |
IF(POCEAN.LE.0.) GO TO 2200 6033. |
| 420 |
C**** 6034. |
| 421 |
C**** OCEAN 6035. |
| 422 |
C**** 6036. |
| 423 |
ITYPE=1 6037. |
| 424 |
PTYPE=POCEAN 6038. |
| 425 |
c formula charnoka |
| 426 |
TOCEAN=BLDATA(I,J,5) |
| 427 |
ROUGH=MAX(0.018*TOCEAN/GRAV,1.5E-4) |
| 428 |
c ROUGH=MAX(0.035*TOCEAN/GRAV,2.5E-4) used in 008.03 |
| 429 |
ZGS=10. 6041. |
| 430 |
! WMGMIN=8. |
| 431 |
WMGMIN=WMGMINO(J) |
| 432 |
NGRNDZ=1 6043. |
| 433 |
TG1=ODATA(I,J,1) 6044. |
| 434 |
BETA=1. 6045. |
| 435 |
ELHX=LHE 6046. |
| 436 |
TRHT0=TRSURF(J,1) |
| 437 |
SRHEAT=SRSURF(J,1)*COSZ1(I,J)*SRCOR |
| 438 |
GO TO 3000 6047. |
| 439 |
C**** 6048. |
| 440 |
2200 IF(POICE.LE.0.) GO TO 2400 6049. |
| 441 |
C**** 6050. |
| 442 |
C**** OCEAN ICE 6051. |
| 443 |
C**** 6052. |
| 444 |
ITYPE=2 6053. |
| 445 |
PTYPE=POICE 6054. |
| 446 |
NGRNDZ=NGRND 6055. |
| 447 |
SNOW=GDATA(I,J,1) 6056. |
| 448 |
TG1=TGRND(I,J,2) 6057. |
| 449 |
TG2=GDATA(I,J,7) 6058. |
| 450 |
ACE2=ODATA(I,J,3) 6059. |
| 451 |
Z2=ACE2/RHOI 6060. |
| 452 |
Z2BY4L=Z2/(4.*ALAMI) 6061. |
| 453 |
if (SNOW.gt.10.)then |
| 454 |
RHOS0=ROSNOW(SNOW) |
| 455 |
else |
| 456 |
RHOS0=275. |
| 457 |
endif |
| 458 |
RHOS=COEFSN*RHOS0 |
| 459 |
ALAMS=ALSNOW(RHOS0) |
| 460 |
BYRSL=1./(RHOS*ALAMS) |
| 461 |
c Z1BY6L=(Z1IBYL+SNOW*BYRSL)*.1666667 6062. |
| 462 |
c CDTERM=1.5*TG2-.5*TFO 6063. |
| 463 |
CDTERM=TG2 |
| 464 |
c CDENOM=1./(2.*Z1BY6L+Z2BY4L) 6064. |
| 465 |
Z1BY2L=(Z1IBYL+SNOW*BYRSL)*0.5 |
| 466 |
CDENOM=1./(Z1BY2L+2.*Z2BY4L) |
| 467 |
ROUGH=10**(log10(10.)-4.37) |
| 468 |
ZGS=10. 6067. |
| 469 |
! WMGMIN=8. |
| 470 |
WMGMIN=WMGMINO(J) |
| 471 |
HC1=HC1I+SNOW*SHI 6069. |
| 472 |
BETA=1. 6070. |
| 473 |
ELHX=LHS 6071. |
| 474 |
TRHT0=TRSURF(J,3) |
| 475 |
SRHEAT=SRSURF(J,3)*COSZ1(I,J)*SRCOR |
| 476 |
GO TO 3000 6072. |
| 477 |
C**** 6073. |
| 478 |
2400 IF(PLAND.LE.0.) GO TO 5000 6074. |
| 479 |
NGRNDZ=NGRND 6075. |
| 480 |
ROUGH=ROUGHL(I,J) 6076. |
| 481 |
ZGS=30. 6078. |
| 482 |
WMGMIN=WMGMINL |
| 483 |
TRHT0=TRSURF(J,2) |
| 484 |
SRHEAT=SRSURF(J,2)*COSZ1(I,J)*SRCOR |
| 485 |
IF(PLICE.LE.0.) GO TO 2600 6080. |
| 486 |
C**** 6081. |
| 487 |
C**** LAND ICE 6082. |
| 488 |
C**** 6083. |
| 489 |
ITYPE=3 6084. |
| 490 |
PTYPE=PLICE 6085. |
| 491 |
SNOW=GDATA(I,J,12) 6086. |
| 492 |
TG1=TGRND(I,J,3) 6087. |
| 493 |
TG2=GDATA(I,J,14) 6088. |
| 494 |
if (SNOW.gt.10.)then |
| 495 |
RHOS0=ROSNOW(SNOW) |
| 496 |
else |
| 497 |
RHOS0=275. |
| 498 |
endif |
| 499 |
RHOS=COEFSN*RHOS0 |
| 500 |
ALAMS=ALSNOW(RHOS0) |
| 501 |
BYRSL=1./(RHOS*ALAMS) |
| 502 |
c Z1BY6L=(Z1IBYL+SNOW*BYRSL)*.1666667 6089. |
| 503 |
CDTERM=TG2 6090. |
| 504 |
c CDENOM=1./(2.*Z1BY6L+Z2LI3L) 6091. |
| 505 |
Z1BY2L=(Z1IBYL+SNOW*BYRSL)*0.5 |
| 506 |
CDENOM=1./(Z1BY2L+3.*Z2LI3L/2.) |
| 507 |
HC1=HC1I+SNOW*SHI 6092. |
| 508 |
BETA=1. 6093. |
| 509 |
ELHX=LHS 6094. |
| 510 |
GO TO 3000 6095. |
| 511 |
C**** 6096. |
| 512 |
2600 IF(PEARTH.LE.0.) GO TO 5000 6097. |
| 513 |
C**** 6098. |
| 514 |
C**** EARTH 6099. |
| 515 |
C**** 6100. |
| 516 |
ITYPE=4 6101. |
| 517 |
PTYPE=PEARTH 6102. |
| 518 |
SNOW=GDATA(I,J,2) 6103. |
| 519 |
TG1=TGRND(I,J,4) 6104. |
| 520 |
WTR1=GDATA(I,J,5) 6105. |
| 521 |
ACE1=GDATA(I,J,6) 6106. |
| 522 |
TG2=GDATA(I,J,8) 6107. |
| 523 |
WTR2=GDATA(I,J,9) 6108. |
| 524 |
ACE2=GDATA(I,J,10) 6109. |
| 525 |
WFC1=VDATA(I,J,9) 6110. |
| 526 |
WFC2=VDATA(I,J,10) 6111. |
| 527 |
WTR1DRY=0.025*WFC1 |
| 528 |
HC1=HC1DE+WTR1*SHW+(ACE1+SNOW)*SHI 6112. |
| 529 |
ALAM1D=2.+.5*(1.+2.*WTR1/WFC1) 6113. |
| 530 |
ALAM2D=4. 6114. |
| 531 |
RMULCH=1. 6115. |
| 532 |
IF((SINP(J).GT..5).AND.(JDAY-91)*(273-JDAY).LT.0) RMULCH=.25 6116. |
| 533 |
IF((SINP(J).LT.-.5).AND.(JDAY-91)*(273-JDAY).GE.0) RMULCH=.25 6117. |
| 534 |
ALAM1V=RMULCH*(.4185+1.2555*WTR1/WFC1+ALAMI*ACE1/(Z1E*RHOI)) 6118. |
| 535 |
ALAM3V=.8370 6119. |
| 536 |
IF(TG2.LT.0.) ALAM3V=.4185+ALAMI*.15 6120. |
| 537 |
ALAM2V=.125*(.4185+1.2555*WTR2/WFC2+ALAMI*ACE2/(5.*Z1E*RHOI)) 6121. |
| 538 |
* +.875*ALAM3V 6122. |
| 539 |
ALAM1E=VDATA(I,J,1)*ALAM1D+(1.-VDATA(I,J,1))*ALAM1V 6123. |
| 540 |
ALAM2E=VDATA(I,J,1)*ALAM2D+(1.-VDATA(I,J,1))*ALAM2V 6124. |
| 541 |
if (SNOW.gt.10.)then |
| 542 |
RHOS0=ROSNOW(SNOW) |
| 543 |
else |
| 544 |
RHOS0=275. |
| 545 |
endif |
| 546 |
RHOS=COEFSN*RHOS0 |
| 547 |
ALAMS=ALSNOW(RHOS0) |
| 548 |
BYRSL=1./(RHOS*ALAMS) |
| 549 |
c Z1BY6L=(Z1E/ALAM1E+SNOW*BYRSL)*.1666667 6125. |
| 550 |
Z1BY2L=(Z1E/ALAM1E+SNOW*BYRSL)*0.5 |
| 551 |
CDTERM=TG2 6126. |
| 552 |
c CDENOM=1./(2.*Z1BY6L+Z2E/(3.*ALAM2E)) 6127. |
| 553 |
CDENOM=1./(Z1BY2L+Z2E/(2.*ALAM2E)) |
| 554 |
BETA=1. 6128. |
| 555 |
ELHX=LHS 6129. |
| 556 |
IF(SNOW.GT.0.) GO TO 3000 6130. |
| 557 |
BETA=(WTR1+ACE1)/WFC1 6131. |
| 558 |
BETA=max(((WTR1+ACE1-WTR1DRY)/WFC1),0.0) |
| 559 |
PFROZN=ACE1/(WTR1+ACE1+1.E-20) 6132. |
| 560 |
ELHX=LHE+LHM*PFROZN 6133. |
| 561 |
HC2E=HC2DE+WTR2*SHW+ACE2*SHI |
| 562 |
C**** 6134. |
| 563 |
C**** BOUNDARY LAYER INTERACTION 6135. |
| 564 |
C**** 6136. |
| 565 |
3000 continue |
| 566 |
SRHDT=SRHEAT*DTSURF |
| 567 |
TKV=THV1*PSK 6137. |
| 568 |
ZS1=ZS1CO*TKV*SP/PS 6138. |
| 569 |
P1=SIG(1)*SP+PTOP 6139. |
| 570 |
DTGRND=DTSURF/NGRNDZ 6143. |
| 571 |
SHDT=0. 6144. |
| 572 |
EVHDT=0. 6145. |
| 573 |
TRHDT=0. 6146. |
| 574 |
F1DT=0. 6147. |
| 575 |
C**** LOOP OVER GROUND TIME STEPS 6148. |
| 576 |
DO 3600 NG=1,NGRNDZ 6149. |
| 577 |
TG=TG1+TF 6150. |
| 578 |
QG=QSAT(TG,PS,ELHX) 6151. |
| 579 |
TGV=TG*(1.+QG*RVX) 6152. |
| 580 |
W1=SQRT(U1*U1+V1*V1) |
| 581 |
WS0=W1 |
| 582 |
c WS=SQRT(W1*W1+0.8*WMG) |
| 583 |
! WMG=WMG0+WMGMIN |
| 584 |
! 07/17/2006 |
| 585 |
if(ITYPE.le.2)then |
| 586 |
WMG=WMG0+WMGMIN |
| 587 |
else |
| 588 |
WMG=max(WMG0,WMGMIN) |
| 589 |
endif |
| 590 |
! 07/17/2006 |
| 591 |
WS=SQRT((0.75*W1)**2+WMG) |
| 592 |
if(J.eq.JPR)then |
| 593 |
print *,' ' |
| 594 |
print *,'TAU=',TAU,' NS=',NS,' ITYPE=',ITYPE |
| 595 |
print *,'TG=',TG,' QG=',QG |
| 596 |
print *,'RVX=',RVX,' TG1=',TG1 |
| 597 |
endif |
| 598 |
|
| 599 |
#if ( defined CPL_OCEANCO2 || defined OCEAN_3D) |
| 600 |
if(ITYPE.eq.1)then |
| 601 |
NWMGEA(J)=NWMGEA(J)+1 |
| 602 |
WSAV(J)=WSAV(J)+WS |
| 603 |
end if |
| 604 |
#endif |
| 605 |
|
| 606 |
WG=WS |
| 607 |
THS=TH1 |
| 608 |
QS=Q1 |
| 609 |
TSV=THS*PSK |
| 610 |
Z0=ROUGH |
| 611 |
ROUGH=log10(ZGS/ROUGH) |
| 612 |
CDN=.0231/(ROUGH*ROUGH) |
| 613 |
c if(ITYPE.eq.1)then |
| 614 |
c CDN=.00075+.000067*WSOLD |
| 615 |
c ROUGH=7.126-1.068*LOG(WSOLD+1.E-12) |
| 616 |
c endif |
| 617 |
LR=ROUGH*2.-.5 |
| 618 |
IF(LR.GT.20) LR=20 |
| 619 |
IF(LR.LT.1) LR=1 |
| 620 |
RIGS=ZGS*GRAV*(TSV-TGV)/(TGV*WS*WS) |
| 621 |
SINAP=0. |
| 622 |
COSAP=1. |
| 623 |
IF(RIGS.LE.0) THEN |
| 624 |
C surface layer has unstable stratification |
| 625 |
CIA=TWOPI*0.0625/(1.+WS*CIAX) |
| 626 |
DM=SQRT((1.-AROUGH(LR)*RIGS)*(1.-BROUGH(LR)*RIGS)/ |
| 627 |
* (1.-CROUGH(LR)*RIGS)) |
| 628 |
DH=1.35*SQRT((1.-DROUGH(LR)*RIGS)/(1.-EROUGH(LR)*RIGS)) |
| 629 |
ELSE |
| 630 |
C surface layer has stable stratification |
| 631 |
CIA=TWOPI*(0.09375-0.03125/(1.+4*RIGS**2))/(1.+WS*CIAX) |
| 632 |
DM=1./(1.+(11.238+89.9*RIGS)*RIGS) |
| 633 |
DH=1.35/(1.+1.93*RIGS) |
| 634 |
END IF |
| 635 |
CDH=CDN*DM*DH |
| 636 |
if(J.eq.JPR)then |
| 637 |
print *,'TAU=',TAU,' NS=',NS,' ITYPE=',ITYPE |
| 638 |
print *,'WS=',WS,' ZGS=',ZGS |
| 639 |
print *,'DM=',DM,' DH=',DH |
| 640 |
print *,'RIGS=',RIGS,' TGV=',TGV |
| 641 |
endif |
| 642 |
USR=COS(CIA) |
| 643 |
VSR=SIN(CIA)*HEMI |
| 644 |
UG=U1 |
| 645 |
VG=V1 |
| 646 |
US=(USR*UG-VSR*VG) |
| 647 |
VS=(VSR*UG+USR*VG) |
| 648 |
RCDHWS=CDH*WS*100.*PS/(RGAS*TSV) |
| 649 |
if(J.eq.JPR)then |
| 650 |
c print *,' ' |
| 651 |
print *,'TAU=',TAU,' NS=',NS,' ITYPE=',ITYPE |
| 652 |
print *,'CDH=',CDH,' RGAS=',RGAS |
| 653 |
print *,'PS=',PS,' TSV=',TSV |
| 654 |
print *,'WS=',WS,' RCDHWS=',RCDHWS |
| 655 |
endif |
| 656 |
TS=TSV/(1.+QS*RVX) 6467. |
| 657 |
QSATS=QSAT(TS,PS,ELHX) 6468. |
| 658 |
c dLQS/dTs |
| 659 |
DLQSDTS=DLQSDT(TS,ELHX) |
| 660 |
c dLQS/dTs |
| 661 |
IF(QS.LE.QSATS) GO TO 3500 6469. |
| 662 |
DQSSDT=QSATS*ELHX/(RVAP*TS*TS) 6470. |
| 663 |
X=(QS-QSATS)/(DQSSDT+(SHA/ELHX)) 6471. |
| 664 |
TS=TS+X 6472. |
| 665 |
QS=QS+X*(SHA/ELHX) 6473. |
| 666 |
C**** CALCULATE RHOS*CDM*WS AND RHOS*CDH*WS 6474. |
| 667 |
3500 CDM=CDN*DM 6475. |
| 668 |
RCDMWS=CDM*WS*100.*PS/(RGAS*TS) 6476. |
| 669 |
C**** CALCULATE FLUXES OF SENSIBLE HEAT, LATENT HEAT, THERMAL 6478. |
| 670 |
C**** RADIATION, AND CONDUCTION HEAT (WATTS/M**2) 6479. |
| 671 |
SHEAT=SHA*RCDHWS*(TS-TG) 6480. |
| 672 |
BETAUP=BETA 6481. |
| 673 |
IF(QS.GT.QG) BETAUP=1. 6482. |
| 674 |
EVHEAT=(LHE+TG1*SHV)*BETAUP*RCDHWS*(QS-QG) 6483. |
| 675 |
c TRHEAT=TRHR(I,J,1)-STBO*(TG*TG)*(TG*TG) 6484. |
| 676 |
TRHEAT=TRHT0-STBO*(TG*TG)*(TG*TG) |
| 677 |
#if ( defined CLM ) |
| 678 |
if(NS.eq.1)then |
| 679 |
if(ITYPE.EQ.4.or.ITYPE.EQ.3)then |
| 680 |
tsl4clm(j)=tsl4clm(j)+TS*PTYPE/PLAND |
| 681 |
qs4clm(j)=qs4clm(j)+QS*PTYPE/PLAND |
| 682 |
ps4clm(j)=ps4clm(j)+PS*PTYPE/PLAND |
| 683 |
ws4clm(j)=ws4clm(j)+WS*PTYPE/PLAND |
| 684 |
us4clm(j)=us4clm(j)+US*PTYPE/PLAND |
| 685 |
vs4clm(j)=vs4clm(j)+VS*PTYPE/PLAND |
| 686 |
endif |
| 687 |
endif |
| 688 |
#endif |
| 689 |
if(J.eq.JPR)then |
| 690 |
c print *,' ' |
| 691 |
print *,'TAU=',TAU,' NS=',NS,' ITYPE=',ITYPE |
| 692 |
print *,'TRHT0=',TRHT0,' STBO=',STBO |
| 693 |
print *,'TG=',TG,' TS=',TS |
| 694 |
print *,'TRHEAT=',TRHEAT |
| 695 |
print *,'SHA=',SHA,' RCDHWS=',RCDHWS |
| 696 |
print *,'SHEAT=',SHEAT |
| 697 |
endif |
| 698 |
TG1OLD=TG1 |
| 699 |
SHEATOLD=SHEAT |
| 700 |
#if ( defined OCEAN_3D ) |
| 701 |
IF(ITYPE.EQ.1 .or. ITYPE.EQ.2) GO TO 3620 |
| 702 |
#else |
| 703 |
IF(ITYPE.EQ.1) GO TO 3620 6485. |
| 704 |
#endif |
| 705 |
C**** CALCULATE FLUXES USING IMPLICIT TIME STEP FOR NON-OCEAN POINTS 6486. |
| 706 |
F0=SRHEAT+TRHEAT+SHEAT+EVHEAT 6487. |
| 707 |
c F1=(TG1-CDTERM-F0*Z1BY6L)*CDENOM 6488. |
| 708 |
F1=(TG1-CDTERM)*CDENOM |
| 709 |
DSHDTG=-RCDHWS*SHA |
| 710 |
DQGDTG=QG*ELHX/(RVAP*TG*TG) 6490. |
| 711 |
DEVDTG=-RCDHWS*LHE*BETAUP*DQGDTG |
| 712 |
DTRDTG=-4.*STBO*TG*TG*TG 6492. |
| 713 |
DF0DTG=DSHDTG+DEVDTG+DTRDTG 6493. |
| 714 |
c DFDTG=DF0DTG-(1.-DF0DTG*Z1BY6L)*CDENOM 6493.5 |
| 715 |
DFDTG=DF0DTG-CDENOM |
| 716 |
c DF1DTG=(1.-DF0DTG*Z1BY6L)*CDENOM |
| 717 |
DF1DTG=CDENOM |
| 718 |
DTG=(F0-F1)*DTGRND/(HC1-DTGRND*DFDTG) 6494. |
| 719 |
SHDT=SHDT+DTGRND*(SHEAT+DTG*DSHDTG) 6495. |
| 720 |
EVHDT=EVHDT+DTGRND*(EVHEAT+DTG*DEVDTG) 6496. |
| 721 |
TRHDT=TRHDT+DTGRND*(TRHEAT+DTG*DTRDTG) 6497. |
| 722 |
TG1=TG1+DTG |
| 723 |
c F1DT=F1DT+DTGRND*(TG1-CDTERM-(F0+DTG*DF0DTG)*Z1BY6L)*CDENOM 6498. |
| 724 |
F1DT=F1DT+DTGRND*(TG1-CDTERM)*CDENOM |
| 725 |
DU1(I,J)=DU1(I,J)+PTYPE*DTGRND*RCDMWS*US*COEFS/SP 6499. |
| 726 |
DV1(I,J)=DV1(I,J)+PTYPE*DTGRND*RCDMWS*VS*COEFS/SP 6500. |
| 727 |
c TG1=TG1+DTG 6501. |
| 728 |
3600 CONTINUE 6502. |
| 729 |
GO TO 3700 6503. |
| 730 |
C**** CALCULATE FLUXES USING EXPLICIT TIME STEP FOR OCEAN POINTS 6504. |
| 731 |
3620 SHDT=DTSURF*SHEAT 6505. |
| 732 |
EVHDT=DTSURF*EVHEAT 6506. |
| 733 |
TRHDT=DTSURF*TRHEAT 6507. |
| 734 |
DU1(I,J)=DU1(I,J)+PTYPE*DTSURF*RCDMWS*US*COEFS/SP 6508. |
| 735 |
DV1(I,J)=DV1(I,J)+PTYPE*DTSURF*RCDMWS*VS*COEFS/SP 6509. |
| 736 |
3700 CONTINUE |
| 737 |
EPS=1.D-8 |
| 738 |
c print *,'FROM SURFACE NS=',NS |
| 739 |
c print *,'J=',J,' ITYPE=',ITYPE |
| 740 |
c print *,RCDMWS,WS |
| 741 |
WWS=max(W1,1.D-4) |
| 742 |
c RO=SP*100/(RGAS*TG) |
| 743 |
c print *,'RO=',RO |
| 744 |
c USTAR=SQRT(RCDMWS*WS/RO) |
| 745 |
c TSTAR=SHEATOLD/(0.35*1007.*RO*USTAR) |
| 746 |
c ALPHAH=DH |
| 747 |
c TT2M=TG+TSTAR/ALPHAH*LOG(2.0/Z0) |
| 748 |
c TT2M=TG+TSTAR/ALPHAH*LOG(ZGS/Z0) |
| 749 |
c print *,'RIGS=',RIGS,' Z0=',Z0 |
| 750 |
c print *,'CDN=',CDN |
| 751 |
c print *,'H=',SHDT/DTSURF,' TGM=',RCDMWS*WS |
| 752 |
c print *,' SHEATOLD=',SHEATOLD |
| 753 |
c print *,' USTAR=',USTAR,' TSTAR=',TSTAR |
| 754 |
c print *,' ALPHAH=',ALPHAH,' TT2M=',TT2M |
| 755 |
c print *,' TT2M=',TT2M |
| 756 |
ZTEM=ZGS |
| 757 |
ZTEM=2.0 |
| 758 |
c print *,'ZTEM=',ZTEM |
| 759 |
CALL TZM(T2M,TH2M,ZTEM,Z0,ZGS,SP,TG,TS,RIGS,WS, |
| 760 |
& -SHEATOLD,RCDMWS*WS,LR,EPS) |
| 761 |
c print *,'FROM SURFACE' |
| 762 |
c print *,'TS=',TS,' TG=',TG |
| 763 |
c print *,' T2M=',T2M,' TH2M=',TH2M |
| 764 |
F0DT=CORSR*SRHDT+TRHDT+SHDT+EVHDT 6510. |
| 765 |
if(J.eq.JPR)then |
| 766 |
print *,'TAU=',TAU,' NS=',NS,' ITYPE=',ITYPE |
| 767 |
print *,'DTSURF=',DTSURF,' CORSR=',CORSR |
| 768 |
print *,'SRHDT=',SRHDT,' TRHDT=',TRHDT |
| 769 |
print *,'SHDT=',SHDT,' EVHDT=',EVHDT |
| 770 |
print *,'F0DT=',F0DT |
| 771 |
print *,'US=',US,' VS=',VS |
| 772 |
print *,'COEFS=',COEFS,' SP=',SP |
| 773 |
endif |
| 774 |
c print *,'From surface ',TAU,CORSR,SRHDT,TRHDT,SHDT,EVHDT |
| 775 |
C**** CALCULATE EVAPORATION 6511. |
| 776 |
CCC DQ1=EVHDT/((LHE+TG1*SHV)*RMBYA) 6512. |
| 777 |
DQ1=EVHDT/(ELHX*RMBYA) |
| 778 |
IF(DQ1*PTYPE.LE.Q1) GO TO 3720 6513. |
| 779 |
DQ1=Q1/PTYPE 6514. |
| 780 |
CCC EVHDT=DQ1*(LHE+TG1*SHV)*RMBYA 6515. |
| 781 |
EVHDT=DQ1*ELHX*RMBYA |
| 782 |
3720 EVAP=-DQ1*RMBYA 6516. |
| 783 |
C**** ACCUMULATE SURFACE FLUXES AND PROGNOSTIC AND DIAGNOSTIC QUANTITIES6517. |
| 784 |
E0(I,J,ITYPE)=E0(I,J,ITYPE)+F0DT 6518. |
| 785 |
E1(I,J,ITYPE)=E1(I,J,ITYPE)+F1DT 6519. |
| 786 |
EVAPOR(I,J,ITYPE)=EVAPOR(I,J,ITYPE)+EVAP 6520. |
| 787 |
if(PRNT)then |
| 788 |
c write(78,*) ,' ' |
| 789 |
c write(78,*) ,'TAU=',TAU |
| 790 |
write(78,*) ,'J=',j,' ITYPE=',ITYPE,' PTYPE=',PTYPE |
| 791 |
write(78,*) ,'TS=',TS,' TG=',TG,' QS=',QS |
| 792 |
write(78,*) ,'TG1=',TG1,' TG1OLD=',TG1OLD |
| 793 |
write(78,*) ,'TG2=',TG2 |
| 794 |
write(78,*) ,'SHEAT=',SHEAT,' EVHEAT=',EVHEAT |
| 795 |
write(78,*) ,'TRHEAT=',TRHEAT,' SRHEAT=',SRHEAT |
| 796 |
write(78,*) ,'EVAP mm/day=',24.*3600.*EVAP/DTSURF |
| 797 |
write(78,*) ,'EVAP=',EVAP, |
| 798 |
& ' F0DT=',F0DT/DTSURF,' F1DT=',F1DT/DTSURF |
| 799 |
endif |
| 800 |
#if ( defined OCEAN_3D || defined ML_2D ) |
| 801 |
C For ocean model |
| 802 |
c if(NS.eq.2)then |
| 803 |
#if ( defined ML_2D ) |
| 804 |
if(ITYPE.eq.1)then |
| 805 |
#endif |
| 806 |
C DNetHeat by DTG |
| 807 |
DSHDTG=-RCDHWS*SHA |
| 808 |
DQGDTG=QG*ELHX/(RVAP*TG*TG) |
| 809 |
DEVDTG=-RCDHWS*LHE*BETAUP*DQGDTG |
| 810 |
DTRDTG=-4.*STBO*TG*TG*TG |
| 811 |
DF0DTG=DSHDTG+DEVDTG+DTRDTG |
| 812 |
if(EVHEAT.lt.0.0)then |
| 813 |
DEVDTGEQ=EVHEAT*DLQSDTS |
| 814 |
else |
| 815 |
DEVDTGEQ=0.0 |
| 816 |
endif |
| 817 |
C DNetHeat by DTG |
| 818 |
#if ( defined OCEAN_3D ) |
| 819 |
if(ITYPE.eq.1)then |
| 820 |
#endif |
| 821 |
dhfodtg(j)=dhfodtg(j)+DF0DTG |
| 822 |
devodtg(j)=devodtg(j)-DEVDTG/LHE |
| 823 |
dhfodtgeq(j)=dhfodtgeq(j)+DEVDTGEQ |
| 824 |
devodtgeq(j)=devodtgeq(j)-DEVDTGEQ/LHE |
| 825 |
evao(j)=evao(j)+EVAP |
| 826 |
hfluxo(j)=hfluxo(j)+F0DT |
| 827 |
naveo(j)=naveo(j)+1 |
| 828 |
endif |
| 829 |
if(ITYPE.eq.2)then |
| 830 |
evai(j)=evai(j)+EVAP |
| 831 |
hfluxi(j)=hfluxi(j)+F0DT |
| 832 |
dhfidtg(j)=dhfidtg(j)+DF0DTG |
| 833 |
devidtg(j)=devidtg(j)-DEVDTG/LHE |
| 834 |
dhfidtgeq(j)=dhfidtgeq(j)+DEVDTGEQ |
| 835 |
devidtgeq(j)=devidtgeq(j)-DEVDTGEQ/LHE |
| 836 |
c tairi(j)=tairi(j)+TS |
| 837 |
navei(j)=navei(j)+1 |
| 838 |
endif |
| 839 |
c endif ! NS |
| 840 |
tauu(j)=tauu(j)+RCDMWS*US*PTYPE |
| 841 |
tauv(j)=tauv(j)+RCDMWS*VS*PTYPE |
| 842 |
C For ocean model |
| 843 |
#endif |
| 844 |
TGRND(I,J,ITYPE)=TG1 6521. |
| 845 |
TSSFC(I,J,ITYPE)=TS 6521.5 |
| 846 |
|
| 847 |
c TH1=TH1-SHDT*PTYPE/(SHA*RMBYA*P1K) 6522. |
| 848 |
c Q1=Q1-DQ1*PTYPE 6523. |
| 849 |
|
| 850 |
DTH1=DTH1-SHDT*PTYPE/(SHA*RMBYA*P1K) |
| 851 |
DQQ1=DQQ1-DQ1*PTYPE |
| 852 |
|
| 853 |
USS=USS+US*PTYPE 6524. |
| 854 |
VSS=VSS+VS*PTYPE 6525. |
| 855 |
WSS=WSS+WS*PTYPE 6526. |
| 856 |
TSS=TSS+TS*PTYPE 6527. |
| 857 |
QSS=QSS+QS*PTYPE 6528. |
| 858 |
TAUS=TAUS+CDM*WS*W1*PTYPE 6529. |
| 859 |
SINAPS=SINAPS+SINAP*PTYPE 6530. |
| 860 |
COSAPS=COSAPS+COSAP*PTYPE 6531. |
| 861 |
TG1S=TG1S+TG1*PTYPE 6532. |
| 862 |
QGS=QGS+QG*PTYPE 6533. |
| 863 |
BETAS=BETAS+BETA*PTYPE 6534. |
| 864 |
TRHDTS=TRHDTS+TRHDT*PTYPE 6535. |
| 865 |
SHDTS=SHDTS+SHDT*PTYPE 6536. |
| 866 |
EVHDTS=EVHDTS+EVHDT*PTYPE 6537. |
| 867 |
UGS=UGS+UG*PTYPE 6538. |
| 868 |
VGS=VGS+VG*PTYPE 6539. |
| 869 |
WGS=WGS+WG*PTYPE 6540. |
| 870 |
USRS=USRS+USR*PTYPE 6541. |
| 871 |
VSRS=VSRS+VSR*PTYPE 6542. |
| 872 |
c RIS1S=RIS1S+RIS1*PTYPE 6543. |
| 873 |
RIGSS=RIGSS+RIGS*PTYPE 6544. |
| 874 |
CDMS=CDMS+CDM*PTYPE 6545. |
| 875 |
CDHS=CDHS+CDH*PTYPE 6546. |
| 876 |
c DGSS=DGSS+DGS*PTYPE 6547. |
| 877 |
c EDS1S=EDS1S+EDS1*PTYPE 6548. |
| 878 |
c PPBLS=PPBLS+PPBL*PTYPE 6549. |
| 879 |
EVAPS=EVAPS+EVAP*PTYPE 6550. |
| 880 |
GO TO (4000,4100,4400,4600),ITYPE 6551. |
| 881 |
C**** 6552. |
| 882 |
C**** OCEAN 6553. |
| 883 |
C**** 6554. |
| 884 |
4000 ASHDT=ASHDT+SHDT*POCEAN 6555. |
| 885 |
AEVHDT=AEVHDT+EVHDT*POCEAN 6556. |
| 886 |
ATRHDT=ATRHDT+TRHDT*POCEAN 6557. |
| 887 |
ATS=ATS+(TS-TF)*POCEAN 6558. |
| 888 |
AT2=AT2+(TH2M-TF)*POCEAN |
| 889 |
BLDATA(I,J,5)=CDM*WS*W1 |
| 890 |
ATAUL=ATAUL+RCDMWS*US*POCEAN |
| 891 |
ATAUF=ATAUF+RCDMWS*VS*POCEAN |
| 892 |
AWS=AWS+WS*POCEAN |
| 893 |
AWMG=AWMG+SQRT(WMG)*POCEAN |
| 894 |
ACH=ACH+RCDHWS*POCEAN |
| 895 |
GO TO 2200 6559. |
| 896 |
C**** 6560. |
| 897 |
C**** OCEAN ICE 6561. |
| 898 |
C**** 6562. |
| 899 |
4100 CSHDT=CSHDT+SHDT*POICE 6563. |
| 900 |
CEVHDT=CEVHDT+EVHDT*POICE 6564. |
| 901 |
CTRHDT=CTRHDT+TRHDT*POICE 6565. |
| 902 |
CTS=CTS+(TS-TF)*POICE 6566. |
| 903 |
CT2=CT2+(TH2M-TF)*POICE 6566. |
| 904 |
CTAUL=CTAUL+RCDMWS*US*POICE |
| 905 |
CTAUF=CTAUF+RCDMWS*VS*POICE |
| 906 |
CWS=CWS+WS*POICE |
| 907 |
CWMG=CWMG+SQRT(WMG)*POICE |
| 908 |
CCH=CCH+RCDHWS*POICE |
| 909 |
GO TO 2400 6567. |
| 910 |
C**** 6568. |
| 911 |
C**** LAND ICE 6569. |
| 912 |
C**** 6570. |
| 913 |
4400 BSHDT=BSHDT+SHDT*PLICE 6571. |
| 914 |
BEVHDT=BEVHDT+EVHDT*PLICE 6572. |
| 915 |
BTRHDT=BTRHDT+TRHDT*PLICE 6573. |
| 916 |
BTS=BTS+(TS-TF)*PLICE 6574. |
| 917 |
BT2=BT2+(TH2M-TF)*PLICE |
| 918 |
BTAUL=BTAUL+RCDMWS*US*PLICE |
| 919 |
BTAUF=BTAUF+RCDMWS*VS*PLICE |
| 920 |
BWS=BWS+WS*PLICE |
| 921 |
BWMG=BWMG+SQRT(WMG)*PLICE |
| 922 |
BCH=BCH+RCDHWS*PLICE |
| 923 |
GO TO 2600 6575. |
| 924 |
C**** 6576. |
| 925 |
C**** EARTH 6577. |
| 926 |
C**** 6578. |
| 927 |
4600 BSHDT=BSHDT+SHDT*PEARTH 6579. |
| 928 |
BEVHDT=BEVHDT+EVHDT*PEARTH 6580. |
| 929 |
BTRHDT=BTRHDT+TRHDT*PEARTH 6581. |
| 930 |
BTS=BTS+(TS-TF)*PEARTH 6582. |
| 931 |
BT2=BT2+(TH2M-TF)*PEARTH |
| 932 |
BTAUL=BTAUL+RCDMWS*US*PEARTH |
| 933 |
BTAUF=BTAUF+RCDMWS*VS*PEARTH |
| 934 |
BWS=BWS+WS*PEARTH |
| 935 |
BWMG=BWMG+SQRT(WMG)*PEARTH |
| 936 |
BCH=BCH+RCDHWS*PEARTH |
| 937 |
C**** NON-OCEAN POINTS WHICH ARE NOT MELTING OR FREEZING WATER USE 6583. |
| 938 |
C**** IMPLICIT TIME STEPS 6584. |
| 939 |
C**** 6585. |
| 940 |
C**** UPDATE SURFACE AND FIRST LAYER QUANTITIES 6586. |
| 941 |
C**** 6587. |
| 942 |
5000 CONTINUE |
| 943 |
T(I,J,1)=TH1 6588. |
| 944 |
& +DTH1 |
| 945 |
Q(I,J,1)=Q1 6589. |
| 946 |
& +DQQ1 |
| 947 |
BLDATA(I,J,1)=WSS 6590. |
| 948 |
BLDATA(I,J,2)=TSS 6591. |
| 949 |
BLDATA(I,J,3)=QSS 6592. |
| 950 |
BLDATA(I,J,6)=USS 6593. |
| 951 |
BLDATA(I,J,7)=VSS 6594. |
| 952 |
BLDATA(I,J,8)=TAUS 6595. |
| 953 |
c print *,j,T(I,J,1),Q(I,J,1) |
| 954 |
c print *,(TGRND(I,J,k),k=1,4) |
| 955 |
c print *,(EVAPOR(I,J,k),k=1,4) |
| 956 |
c print *,(E0(I,J,k),k=1,4) |
| 957 |
c print *,(E1(I,J,k),k=1,4) |
| 958 |
c print *,j,DU1(1,j),DV1(1,j) |
| 959 |
C**** 6596. |
| 960 |
C**** ACCUMULATE DIAGNOSTICS 6597. |
| 961 |
C**** 6598. |
| 962 |
C**** QUANTITIES ACCUMULATED FOR REGIONS IN DIAG1 6599. |
| 963 |
IF(JR.EQ.JM) GO TO 5700 6600. |
| 964 |
DJ(JR,9)=DJ(JR,9)+TRHDTS*DXYPJ 6601. |
| 965 |
DJ(JR,13)=DJ(JR,13)+SHDTS*DXYPJ 6602. |
| 966 |
DJ(JR,14)=DJ(JR,14)+EVHDTS*DXYPJ 6603. |
| 967 |
DJ(JR,19)=DJ(JR,19)+EVAPS*DXYPJ 6604. |
| 968 |
IF(MODDSF.NE.0) GO TO 5700 6605. |
| 969 |
DJ(JR,23)=DJ(JR,23)+(TSS-TF)*DXYPJ 6606. |
| 970 |
5700 CONTINUE |
| 971 |
6000 IM1=I 6662. |
| 972 |
C**** QUANTITIES ACCUMULATED FOR SURFACE TYPE TABLES IN DIAG1 6663. |
| 973 |
AJ(J,9)=AJ(J,9)+ATRHDT 6664. |
| 974 |
BJ(J,9)=BJ(J,9)+BTRHDT 6665. |
| 975 |
CJ(J,9)=CJ(J,9)+CTRHDT 6666. |
| 976 |
AJ(J,13)=AJ(J,13)+ASHDT 6667. |
| 977 |
BJ(J,13)=BJ(J,13)+BSHDT 6668. |
| 978 |
CJ(J,13)=CJ(J,13)+CSHDT 6669. |
| 979 |
AJ(J,14)=AJ(J,14)+AEVHDT 6670. |
| 980 |
BJ(J,14)=BJ(J,14)+BEVHDT 6671. |
| 981 |
CJ(J,14)=CJ(J,14)+CEVHDT 6672. |
| 982 |
AJ(J,32)=AJ(J,32)+ATAUL |
| 983 |
BJ(J,32)=BJ(J,32)+BTAUL |
| 984 |
CJ(J,32)=CJ(J,32)+CTAUL |
| 985 |
AJ(J,33)=AJ(J,33)+ATAUF |
| 986 |
BJ(J,33)=BJ(J,33)+BTAUF |
| 987 |
CJ(J,33)=CJ(J,33)+CTAUF |
| 988 |
AJ(J,37)=AJ(J,37)+AWS |
| 989 |
BJ(J,37)=BJ(J,37)+BWS |
| 990 |
CJ(J,37)=CJ(J,37)+CWS |
| 991 |
AJ(J,28)=AJ(J,28)+AWMG |
| 992 |
BJ(J,28)=BJ(J,28)+BWMG |
| 993 |
CJ(J,28)=CJ(J,28)+CWMG |
| 994 |
AJ(J,38)=AJ(J,38)+ATAUL/NSURF |
| 995 |
BJ(J,38)=BJ(J,38)+BTAUL/NSURF |
| 996 |
CJ(J,38)=CJ(J,38)+CTAUL/NSURF |
| 997 |
IF(MODDSF.NE.0) GO TO 7000 6673. |
| 998 |
AJ(J,23)=AJ(J,23)+ATS 6674. |
| 999 |
BJ(J,23)=BJ(J,23)+BTS 6675. |
| 1000 |
CJ(J,23)=CJ(J,23)+CTS 6676. |
| 1001 |
AJ(J,26)=AJ(J,26)+AT2 6674. |
| 1002 |
BJ(J,26)=BJ(J,26)+BT2 6675. |
| 1003 |
CJ(J,26)=CJ(J,26)+CT2 6676. |
| 1004 |
c print *,j,'ATS=',ATS,' AT2=',AT2 |
| 1005 |
c print *,'BLDATA' |
| 1006 |
c print *,(BLDATA(1,j,k),k=1,3) |
| 1007 |
c print *,(BLDATA(1,j,k),k=6,8) |
| 1008 |
|
| 1009 |
7000 CONTINUE 6677. |
| 1010 |
C**** 6678. |
| 1011 |
C**** ADD IN SURFACE FRICTION TO FIRST LAYER WIND 6679. |
| 1012 |
C**** 6680. |
| 1013 |
DO 7600 I=1,IM 6681. |
| 1014 |
U(I,2,1)=U(I,2,1)-2.*(DU1(1,1)*COSI(I)-DV1(1,1)*SINI(I))*RAPVN(1) 6682. |
| 1015 |
V(I,2,1)=V(I,2,1)-2.*(DV1(1,1)*COSI(I)+DU1(1,1)*SINI(I))*RAPVN(1) 6683. |
| 1016 |
U(I,JM,1)=U(I,JM,1) 6684. |
| 1017 |
* -2.*(DU1(1,JM)*COSI(I)+DV1(1,JM)*SINI(I))*RAPVS(JM) 6685. |
| 1018 |
7600 V(I,JM,1)=V(I,JM,1) 6686. |
| 1019 |
* -2.*(DV1(1,JM)*COSI(I)-DU1(1,JM)*SINI(I))*RAPVS(JM) 6687. |
| 1020 |
DO 7700 J=2,JMM1 6688. |
| 1021 |
I=IM 6689. |
| 1022 |
DO 7700 IP1=1,IM 6690. |
| 1023 |
if(J.eq.JPR.or.J.eq.-12)then |
| 1024 |
print *,' J=',J,' before' |
| 1025 |
print *,'U(I,J,1)=',U(I,J,1),' V(I,J,1)=',V(I,J,1) |
| 1026 |
print *,'U(I,J+1,1)=',U(I,J+1,1),' V(I,J+1,1)=',V(I,J+1,1) |
| 1027 |
print *,'DU1(I,J)=',DU1(I,J),' DU1(IP1,J)=',DU1(IP1,J) |
| 1028 |
endif |
| 1029 |
U(I,J,1)=U(I,J,1)-(DU1(I,J)+DU1(IP1,J))*RAPVS(J) 6691. |
| 1030 |
V(I,J,1)=V(I,J,1)-(DV1(I,J)+DV1(IP1,J))*RAPVS(J) 6692. |
| 1031 |
U(I,J+1,1)=U(I,J+1,1)-(DU1(I,J)+DU1(IP1,J))*RAPVN(J) 6693. |
| 1032 |
V(I,J+1,1)=V(I,J+1,1)-(DV1(I,J)+DV1(IP1,J))*RAPVN(J) 6694. |
| 1033 |
if(J.eq.JPR.or.J.eq.-12)then |
| 1034 |
print *,' J=',J,' after' |
| 1035 |
print *,'U(I,J,1)=',U(I,J,1),' V(I,J,1)=',V(I,J,1) |
| 1036 |
print *,'U(I,J+1,1)=',U(I,J+1,1),' V(I,J+1,1)=',V(I,J+1,1) |
| 1037 |
print *,'DU1(I,J)=',DU1(I,J),' DU1(IP1,J)=',DU1(IP1,J) |
| 1038 |
endif |
| 1039 |
7700 I=IP1 6695. |
| 1040 |
c print *,'U V' |
| 1041 |
c do j=1,jm |
| 1042 |
c print *,j,U(I,J,1),v(I,J,1) |
| 1043 |
c enddo |
| 1044 |
C**** 6696. |
| 1045 |
C**** DRY CONVECTION ORIGINATING FROM THE FIRST LAYER 6697. |
| 1046 |
C**** 6698. |
| 1047 |
C**** LOAD U,V INTO UT,VT. UT,VT WILL BE FIXED DURING DRY CONVECTION 6699. |
| 1048 |
C**** WHILE U,V WILL BE UPDATED. 6700. |
| 1049 |
DO 8050 L=1,LM 6701. |
| 1050 |
DO 8050 J=2,JM 6702. |
| 1051 |
DO 8050 I=1,IM 6703. |
| 1052 |
UT(I,J,L)=U(I,J,L) 6704. |
| 1053 |
8050 VT(I,J,L)=V(I,J,L) 6705. |
| 1054 |
C**** OUTSIDE LOOPS OVER J AND I 6706. |
| 1055 |
DO 8500 J=1,JM 6707. |
| 1056 |
POLE=.FALSE. 6708. |
| 1057 |
IF(J.EQ.1.OR.J.EQ.JM) POLE=.TRUE. 6709. |
| 1058 |
IMAX=IM 6710. |
| 1059 |
IF(POLE) IMAX=IM 6711. |
| 1060 |
DO 8120 K=1,2 6712. |
| 1061 |
RA(K)=RAPVS(J) 6713. |
| 1062 |
8120 RA(K+2)=RAPVN(J) 6714. |
| 1063 |
IM1=IM 6715. |
| 1064 |
DO 8500 I=1,IMAX 6716. |
| 1065 |
BLDATA(I,J,4)=1. 6717. |
| 1066 |
IF(T(I,J,1)*(1.+Q(I,J,1)*RVX).LE. 6718. |
| 1067 |
* T(I,J,2)*(1.+Q(I,J,2)*RVX)) GO TO 8500 6719. |
| 1068 |
C**** MIX HEAT AND MOISTURE THROUGHOUT THE BOUNDARY LAYER 6720. |
| 1069 |
PKMS=PK(I,J,1)*DSIG(1)+PK(I,J,2)*DSIG(2) 6721. |
| 1070 |
THPKMS=T(I,J,1)*(PK(I,J,1)*DSIG(1))+T(I,J,2)*(PK(I,J,2)*DSIG(2)) 6722. |
| 1071 |
QMS=Q(I,J,1)*DSIG(1)+Q(I,J,2)*DSIG(2) 6723. |
| 1072 |
TVMS=T(I,J,1)*(1.+Q(I,J,1)*RVX)*(PK(I,J,1)*DSIG(1)) 6724. |
| 1073 |
* +T(I,J,2)*(1.+Q(I,J,2)*RVX)*(PK(I,J,2)*DSIG(2)) 6725. |
| 1074 |
THETA=TVMS/PKMS 6726. |
| 1075 |
|
| 1076 |
#if ( defined CPL_CHEM ) |
| 1077 |
! |
| 1078 |
! --- 03/23/95 |
| 1079 |
! |
| 1080 |
cfc11ms = cfc11(i,j,1)*dsig(1) + cfc11(i,j,2)*dsig(2) |
| 1081 |
|
| 1082 |
cfc12ms = cfc12(i,j,1)*dsig(1) + cfc12(i,j,2)*dsig(2) |
| 1083 |
|
| 1084 |
xn2oms = xn2o (i,j,1)*dsig(1) + xn2o (i,j,2)*dsig(2) |
| 1085 |
|
| 1086 |
o3ms = o3 (i,j,1)*dsig(1) + o3 (i,j,2)*dsig(2) |
| 1087 |
|
| 1088 |
coms = co (i,j,1)*dsig(1) + co (i,j,2)*dsig(2) |
| 1089 |
|
| 1090 |
zco2ms = zco2 (i,j,1)*dsig(1) + zco2 (i,j,2)*dsig(2) |
| 1091 |
|
| 1092 |
xnoms = xno (i,j,1)*dsig(1) + xno (i,j,2)*dsig(2) |
| 1093 |
|
| 1094 |
xno2ms = xno2 (i,j,1)*dsig(1) + xno2 (i,j,2)*dsig(2) |
| 1095 |
|
| 1096 |
xn2o5ms = xn2o5(i,j,1)*dsig(1) + xn2o5(i,j,2)*dsig(2) |
| 1097 |
|
| 1098 |
hno3ms = hno3 (i,j,1)*dsig(1) + hno3 (i,j,2)*dsig(2) |
| 1099 |
|
| 1100 |
ch4ms = ch4 (i,j,1)*dsig(1) + ch4 (i,j,2)*dsig(2) |
| 1101 |
|
| 1102 |
ch2oms = ch2o (i,j,1)*dsig(1) + ch2o (i,j,2)*dsig(2) |
| 1103 |
|
| 1104 |
so2ms = so2 (i,j,1)*dsig(1) + so2 (i,j,2)*dsig(2) |
| 1105 |
|
| 1106 |
h2so4ms = h2so4(i,j,1)*dsig(1) + h2so4(i,j,2)*dsig(2) |
| 1107 |
|
| 1108 |
! === if hfc, pfc, and sf6 are included: |
| 1109 |
#ifdef INC_3GASES |
| 1110 |
! === 032698 |
| 1111 |
hfc134ams = hfc134a(i,j,1)*dsig(1) |
| 1112 |
& + hfc134a(i,j,2)*dsig(2) |
| 1113 |
|
| 1114 |
pfcms = pfc(i,j,1)*dsig(1) |
| 1115 |
& + pfc(i,j,2)*dsig(2) |
| 1116 |
|
| 1117 |
sf6ms = sf6(i,j,1)*dsig(1) |
| 1118 |
& + sf6(i,j,2)*dsig(2) |
| 1119 |
! === |
| 1120 |
#endif |
| 1121 |
|
| 1122 |
bcms = bcarbon (i,j,1)*dsig(1) + bcarbon (i,j,2)*dsig(2) |
| 1123 |
ocms = ocarbon (i,j,1)*dsig(1) + ocarbon (i,j,2)*dsig(2) |
| 1124 |
|
| 1125 |
c 062295 |
| 1126 |
c h2o2ms = h2o2 (i,j,1)*dsig(1) + h2o2 (i,j,2)*dsig(2) |
| 1127 |
|
| 1128 |
! |
| 1129 |
#endif |
| 1130 |
|
| 1131 |
DO 8140 L=3,LM 6727. |
| 1132 |
IF(THETA.LT.T(I,J,L)*(1.+Q(I,J,L)*RVX)) GO TO 8160 6728. |
| 1133 |
PKMS=PKMS+(PK(I,J,L)*DSIG(L)) 6729. |
| 1134 |
THPKMS=THPKMS+T(I,J,L)*(PK(I,J,L)*DSIG(L)) 6730. |
| 1135 |
QMS=QMS+Q(I,J,L)*DSIG(L) 6731. |
| 1136 |
TVMS=TVMS+T(I,J,L)*(1.+Q(I,J,L)*RVX)*(PK(I,J,L)*DSIG(L)) 6732. |
| 1137 |
|
| 1138 |
#if ( defined CPL_CHEM ) |
| 1139 |
! |
| 1140 |
! --- 03/23/95 |
| 1141 |
! |
| 1142 |
cfc11ms = cfc11ms + cfc11(i,j,l)*dsig(l) |
| 1143 |
|
| 1144 |
cfc12ms = cfc12ms + cfc12(i,j,l)*dsig(l) |
| 1145 |
|
| 1146 |
xn2oms = xn2oms + xn2o (i,j,l)*dsig(l) |
| 1147 |
|
| 1148 |
o3ms = o3ms + o3 (i,j,l)*dsig(l) |
| 1149 |
|
| 1150 |
coms = coms + co (i,j,l)*dsig(l) |
| 1151 |
|
| 1152 |
zco2ms = zco2ms + zco2 (i,j,l)*dsig(l) |
| 1153 |
|
| 1154 |
xnoms = xnoms + xno (i,j,l)*dsig(l) |
| 1155 |
|
| 1156 |
xno2ms = xno2ms + xno2 (i,j,l)*dsig(l) |
| 1157 |
|
| 1158 |
xn2o5ms = xn2o5ms + xn2o5(i,j,l)*dsig(l) |
| 1159 |
|
| 1160 |
hno3ms = hno3ms + hno3 (i,j,l)*dsig(l) |
| 1161 |
|
| 1162 |
ch4ms = ch4ms + ch4 (i,j,l)*dsig(l) |
| 1163 |
|
| 1164 |
ch2oms = ch2oms + ch2o (i,j,l)*dsig(l) |
| 1165 |
|
| 1166 |
so2ms = so2ms + so2 (i,j,l)*dsig(l) |
| 1167 |
|
| 1168 |
h2so4ms = h2so4ms + h2so4(i,j,l)*dsig(l) |
| 1169 |
|
| 1170 |
! === if hfc, pfc, and sf6 are included: |
| 1171 |
#ifdef INC_3GASES |
| 1172 |
! === 032698 |
| 1173 |
hfc134ams = hfc134ams |
| 1174 |
& + hfc134a(i,j,l)*dsig(l) |
| 1175 |
|
| 1176 |
pfcms = pfcms |
| 1177 |
& + pfc(i,j,l)*dsig(l) |
| 1178 |
|
| 1179 |
sf6ms = sf6ms |
| 1180 |
& + sf6(i,j,l)*dsig(l) |
| 1181 |
! === |
| 1182 |
#endif |
| 1183 |
|
| 1184 |
bcms = bcms + bcarbon (i,j,l)*dsig(l) |
| 1185 |
ocms = ocms + ocarbon (i,j,l)*dsig(l) |
| 1186 |
|
| 1187 |
c 062295 |
| 1188 |
c h2o2ms = h2o2ms + h2o2 (i,j,l)*dsig(l) |
| 1189 |
! |
| 1190 |
#endif |
| 1191 |
|
| 1192 |
8140 THETA=TVMS/PKMS 6733. |
| 1193 |
L=LM+1 6734. |
| 1194 |
8160 LMAX=L-1 6735. |
| 1195 |
RDSIGS=1./(SIGE(1)-SIGE(LMAX+1)) 6736. |
| 1196 |
THM=THPKMS/PKMS 6737. |
| 1197 |
QMS=QMS*RDSIGS 6738. |
| 1198 |
|
| 1199 |
#if ( defined CPL_CHEM ) |
| 1200 |
! |
| 1201 |
! --- 03/23/95 |
| 1202 |
! |
| 1203 |
cfc11ms = cfc11ms*rdsigs |
| 1204 |
|
| 1205 |
cfc12ms = cfc12ms*rdsigs |
| 1206 |
|
| 1207 |
xn2oms = xn2oms *rdsigs |
| 1208 |
|
| 1209 |
o3ms = o3ms *rdsigs |
| 1210 |
|
| 1211 |
coms = coms *rdsigs |
| 1212 |
|
| 1213 |
zco2ms = zco2ms *rdsigs |
| 1214 |
|
| 1215 |
xnoms = xnoms *rdsigs |
| 1216 |
|
| 1217 |
xno2ms = xno2ms *rdsigs |
| 1218 |
|
| 1219 |
xn2o5ms = xn2o5ms*rdsigs |
| 1220 |
|
| 1221 |
hno3ms = hno3ms *rdsigs |
| 1222 |
|
| 1223 |
ch4ms = ch4ms *rdsigs |
| 1224 |
|
| 1225 |
ch2oms = ch2oms *rdsigs |
| 1226 |
|
| 1227 |
so2ms = so2ms *rdsigs |
| 1228 |
|
| 1229 |
h2so4ms = h2so4ms*rdsigs |
| 1230 |
|
| 1231 |
! === if hfc, pfc, and sf6 are included: |
| 1232 |
#ifdef INC_3GASES |
| 1233 |
! === 032698 |
| 1234 |
hfc134ams = hfc134ams*rdsigs |
| 1235 |
|
| 1236 |
pfcms = pfcms*rdsigs |
| 1237 |
|
| 1238 |
sf6ms = sf6ms*rdsigs |
| 1239 |
! === |
| 1240 |
#endif |
| 1241 |
|
| 1242 |
bcms = bcms*rdsigs |
| 1243 |
ocms = ocms*rdsigs |
| 1244 |
|
| 1245 |
c 062295 |
| 1246 |
c h2o2ms = h2o2ms*rdsigs |
| 1247 |
c |
| 1248 |
! |
| 1249 |
#endif |
| 1250 |
|
| 1251 |
BLDATA(I,J,4)=LMAX 6739. |
| 1252 |
DO 8180 L=1,LMAX 6740. |
| 1253 |
AJL(J,L,12)=AJL(J,L,12)+(THM-T(I,J,L))*PK(I,J,L)*P(I,J) 6741. |
| 1254 |
T(I,J,L)=THM 6742. |
| 1255 |
|
| 1256 |
#if ( defined CPL_CHEM ) |
| 1257 |
! |
| 1258 |
! --- 03/23/95 |
| 1259 |
! |
| 1260 |
cfc11(i,j,l) = cfc11ms |
| 1261 |
|
| 1262 |
cfc12(i,j,l) = cfc12ms |
| 1263 |
|
| 1264 |
xn2o(i,j,l) = xn2oms |
| 1265 |
|
| 1266 |
o3(i,j,l) = o3ms |
| 1267 |
|
| 1268 |
co(i,j,l) = coms |
| 1269 |
|
| 1270 |
zco2(i,j,l) = zco2ms |
| 1271 |
|
| 1272 |
xno(i,j,l) = xnoms |
| 1273 |
|
| 1274 |
xno2(i,j,l) = xno2ms |
| 1275 |
|
| 1276 |
xn2o5(i,j,l) = xn2o5ms |
| 1277 |
|
| 1278 |
hno3(i,j,l) = hno3ms |
| 1279 |
|
| 1280 |
ch4(i,j,l) = ch4ms |
| 1281 |
|
| 1282 |
ch2o(i,j,l) = ch2oms |
| 1283 |
|
| 1284 |
so2(i,j,l) = so2ms |
| 1285 |
|
| 1286 |
h2so4(i,j,l) = h2so4ms |
| 1287 |
|
| 1288 |
! === if hfc, pfc, and sf6 are included: |
| 1289 |
#ifdef INC_3GASES |
| 1290 |
! === 032698 |
| 1291 |
hfc134a(i,j,l) = hfc134ams |
| 1292 |
|
| 1293 |
pfc(i,j,l) = pfcms |
| 1294 |
|
| 1295 |
sf6(i,j,l) = sf6ms |
| 1296 |
! === |
| 1297 |
#endif |
| 1298 |
|
| 1299 |
bcarbon(i,j,l) = bcms |
| 1300 |
ocarbon(i,j,l) = ocms |
| 1301 |
|
| 1302 |
c 062295 |
| 1303 |
c h2o2(i,j,l) = h2o2ms |
| 1304 |
c |
| 1305 |
! |
| 1306 |
#endif |
| 1307 |
|
| 1308 |
8180 Q(I,J,L)=QMS 6743. |
| 1309 |
IF(POLE) GO TO 8300 6744. |
| 1310 |
C**** MIX MOMENTUM THROUGHOUT THE BOUNDARY LAYER AT NON-POLAR GRID BOXES6745. |
| 1311 |
ID(1)=I+(J-1)*IM 6748. |
| 1312 |
ID(2)=ID(1)+IM*JM*LM 6749. |
| 1313 |
ID(3)=I+J*IM 6752. |
| 1314 |
ID(4)=ID(3)+IM*JM*LM 6753. |
| 1315 |
if(J.eq.JPR)then |
| 1316 |
print *,'ID for J=',j |
| 1317 |
print *,(ID(k),k=1,4) |
| 1318 |
print *,'RA for J=',j |
| 1319 |
print *,(RA(k),k=1,4) |
| 1320 |
endif |
| 1321 |
DO 8240 K=1,4 6754. |
| 1322 |
UMS(K)=0. 6755. |
| 1323 |
DO 8220 L=1,LMAX 6756. |
| 1324 |
8220 UMS(K)=UMS(K)+UT(ID(K),1,L)*DSIG(L) 6757. |
| 1325 |
8240 UMS(K)=UMS(K)*RDSIGS 6758. |
| 1326 |
DO 8260 L=1,LMAX 6759. |
| 1327 |
AJL(J,L,38)=AJL(J,L,38)+(UMS(1)-UT(I,J,L))*.5* 6760. |
| 1328 |
* P(I,J)*RA(1) 6761. |
| 1329 |
AJL(J+1,L,38)=AJL(J+1,L,38)+(UMS(3)- 6762. |
| 1330 |
* UT(I,J+1,L))*P(I,J)*RA(3)*.5 6763. |
| 1331 |
DO 8260 K=1,4 6764. |
| 1332 |
if(J.eq.JPR)then |
| 1333 |
print *,'L=',L,' K=',K |
| 1334 |
print *,'ID(K)=',ID(K),' RA(K)=',RA(K) |
| 1335 |
print *,'UMS(K)=',UMS(K),' UT(ID(K),1,L)=',UT(ID(K),1,L) |
| 1336 |
endif |
| 1337 |
8260 U(ID(K),1,L)=U(ID(K),1,L)+(UMS(K)-UT(ID(K),1,L))*RA(K) 6765. |
| 1338 |
GO TO 8400 6766. |
| 1339 |
C**** MIX MOMENTUM THROUGHOUT THE BOUNDARY LAYER AT POLAR GRID BOXES 6767. |
| 1340 |
8300 JVPO=2 6768. |
| 1341 |
IF(J.EQ.JM) JVPO=JM 6769. |
| 1342 |
RAPO=2.*RAPVN(1) 6770. |
| 1343 |
DO 8360 IPO=1,IM 6771. |
| 1344 |
UMSPO=0. 6772. |
| 1345 |
VMSPO=0. 6773. |
| 1346 |
DO 8320 L=1,LMAX 6774. |
| 1347 |
UMSPO=UMSPO+UT(IPO,JVPO,L)*DSIG(L) 6775. |
| 1348 |
8320 VMSPO=VMSPO+VT(IPO,JVPO,L)*DSIG(L) 6776. |
| 1349 |
UMSPO=UMSPO*RDSIGS 6777. |
| 1350 |
VMSPO=VMSPO*RDSIGS 6778. |
| 1351 |
DO 8340 L=1,LMAX 6779. |
| 1352 |
U(IPO,JVPO,L)=U(IPO,JVPO,L)+(UMSPO-UT(IPO,JVPO,L))*RAPO 6780. |
| 1353 |
V(IPO,JVPO,L)=V(IPO,JVPO,L)+(VMSPO-VT(IPO,JVPO,L))*RAPO 6781. |
| 1354 |
8340 AJL(JVPO,L,38)=AJL(JVPO,L,38) 6782. |
| 1355 |
* +(UMSPO-UT(IPO,JVPO,L))*P(1,J)*RAPO 6783. |
| 1356 |
8360 CONTINUE 6784. |
| 1357 |
C**** ACCUMULATE BOUNDARY LAYER DIAGNOSTICS 6785. |
| 1358 |
8400 IF(MODD6.NE.0) GO TO 8500 6786. |
| 1359 |
DO 8420 KR=1,4 6787. |
| 1360 |
IF(I.EQ.IJD6(1,KR).AND.J.EQ.IJD6(2,KR)) GO TO 8440 6788. |
| 1361 |
8420 CONTINUE 6789. |
| 1362 |
GO TO 8500 6790. |
| 1363 |
8440 ADAILY(IHOUR,47,KR)=ADAILY(IHOUR,47,KR)+1. 6791. |
| 1364 |
ADAILY(IHOUR,48,KR)=ADAILY(IHOUR,48,KR)+LMAX 6792. |
| 1365 |
8500 IM1=I 6793. |
| 1366 |
do j=1,jm |
| 1367 |
I=1 |
| 1368 |
if(J.eq.JPR.or.J.eq.-12)then |
| 1369 |
print *,' J=',J,' after dry convection' |
| 1370 |
print *,'U(I,J,1)=',U(I,J,1),' V(I,J,1)=',V(I,J,1) |
| 1371 |
print *,'U(I,J+1,1)=',U(I,J+1,1),' V(I,J+1,1)=',V(I,J+1,1) |
| 1372 |
endif |
| 1373 |
enddo |
| 1374 |
9000 CONTINUE 6794. |
| 1375 |
do 9001 J=1,JM |
| 1376 |
TSURFD(J)=TSURFD(J)+(BLDATA(1,J,2)-273.16)/24. |
| 1377 |
9001 continue |
| 1378 |
c write (935) ,ps4clm, |
| 1379 |
c & tsl4clm, |
| 1380 |
c & qs4clm,ws4clm |
| 1381 |
c & ,us4clm,vs4clm |
| 1382 |
RETURN 6795. |
| 1383 |
990 FORMAT ('0PPBL',3I4,14F8.2) 6818. |
| 1384 |
991 FORMAT ('0SURFACE ',4I4,5F10.4,3F11.7) 6819. |
| 1385 |
992 FORMAT ('0',I2,10F10.4/23X,4F10.4,10X,2F10.4/ 6820. |
| 1386 |
* 33X,3F10.4,10X,2F10.4) 6821. |
| 1387 |
993 FORMAT ('0',I2,10F10.4/23X,7F10.4/33X,7F10.4) 6822. |
| 1388 |
994 FORMAT ('0',I2,11F10.4) 6823. |
| 1389 |
END 6824. |
Parent Directory
| 
Revision Log
| 
Revision Graph