/[MITgcm]/MITgcm_contrib/jscott/igsm/src/sur4clm.F
ViewVC logotype

Contents of /MITgcm_contrib/jscott/igsm/src/sur4clm.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph


Revision 1.1 - (show annotations) (download)
Fri Aug 11 19:35:32 2006 UTC (18 years, 11 months ago) by jscott
Branch: MAIN
atm2d package

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 SUR4CLM
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 CLM )
38 #if ( defined CPL_CHEM )
39 !
40 #include "chem_para"
41 #include "chem_com"
42 !
43 #endif
44
45 #include "BD2G04.COM"
46
47 #include "CLM.COM"
48
49 COMMON/SPEC2/KM,KINC,COEK,C3LAND(IO0,JM0),C3OICE(IO0,JM0) 5808.1
50 * ,C3LICE(IO0,JM0),WMGE(IO0,JM0),TSSFC(1,JM0,4) 5808.2
51 COMMON U,V,T,P,Q 5809.
52 COMMON/WORK1/CONV(IM0,JM0,LM0),PK(IM0,JM0,LM0),PREC(IM0,JM0),
53 & TPREC(IM0,JM0), 5810.
54 * COSZ1(IO0,JM0) 5811.
55 COMMON/WORK2/UT(IM0,JM0,LM0),VT(IM0,JM0,LM0),DU1(IO0,JM0),
56 & DV1(IO0,JM0), 5812.
57 * RA(8),ID(8),UMS(8) 5813.
58 COMMON/WORK3/E0(IO0,JM0,4),E1(IO0,JM0,4),EVAPOR(IO0,JM0,4), 5814.
59 * TGRND(IO0,JM0,4) 5814.1
60 COMMON/RDATA/ROUGHL(IO0,JM0) 5815.
61 LOGICAL POLE,PRNT,HPRNT
62 common/conprn/HPRNT
63 common/TSUR/TSURFC(JM0,0:13),TSURFT(JM0),TSURFD(JM0),DTEMSR(JM0)
64 common/SURRAD/TRSURF(JM0,4),SRSURF(JM0,4)
65 c REAL*8 B,TGV,TKV,TSV0,TSV1,TSV 5818.
66 integer IQ1,IQ2,IQ3
67 COMMON/CWMG/WMGEA(JM0),NWMGEA(JM0),CHAVER(JM0),DTAV(JM0),DQAV(JM0)
68 & ,Z0AV(JM0),WSAV(JM0),WS0AV(JM0),TAUAV(JM0)
69 C
70 COMMON/SURFLAND/ DUL1(JM0),DVL1(JM0),DT1L(JM0),DQ1L(JM0),
71 & WSSL(JM0),T2ML(JM0),
72 & TSSL(JM0),QSSL(JM0),USSL(JM0),VSSL(JM0),TAUSL(JM0),BLJ(JM0,50)
73 & ,ELHTG(JM0),SHTG(JM0),TAUXG(JM0),TAUYG(JM0)
74 c
75 DATA RVAP/461.5/ 5819.
76 DATA SHV/0./,SHW/4185./,SHI/2060./,RHOW/1000./,RHOI/916.6/, 5820.
77 * ALAMI/2.1762/,STBO/.5672573E-7/,TF/273.16/,TFO/-1.56/ 5821.
78 DATA Z1I/.1/,Z2LI/2.9/,Z1E/.1/,Z2E/4./,RHOS/91.66/,ALAMS/.35/ 5822.
79 QSAT(TM,PR,QLH)=3.797915*EXP(QLH*(7.93252E-6-2.166847E-3/TM))/PR 5836.
80 DLQSDT(TM,QLH)=QLH*2.166847E-3/(TM*TM)
81 DATA IFIRST/1/ 5838.
82 ROSNOW(X)=0.54*X/LOG(1.+0.54*X/275.)
83 ALSNOW(X)=2.8E-6*X**2
84 C**** 5839.
85 C**** FDATA 2 LAND COVERAGE (1) 5840.
86 C**** 3 RATIO OF LAND ICE COVERAGE TO LAND COVERAGE (1) 5841.
87 C**** 5842.
88 C**** ODATA 1 OCEAN TEMPERATURE (C) 5843.
89 C**** 2 RATIO OF OCEAN ICE COVERAGE TO WATER COVERAGE (1) 5844.
90 C**** 3 OCEAN ICE AMOUNT OF SECOND LAYER (KG/M**2) 5845.
91 C**** 5846.
92 C**** GDATA 1 OCEAN ICE SNOW AMOUNT (KG/M**2) 5847.
93 C**** 2 EARTH SNOW AMOUNT (KG/M**2) 5848.
94 C**** 3 OCEAN ICE TEMPERATURE OF FIRST LAYER (C) 5849.
95 C**** 4 EARTH TEMPERATURE OF FIRST LAYER (C) 5850.
96 C**** 5 EARTH WATER OF FIRST LAYER (KG/M**2) 5851.
97 C**** 6 EARTH ICE OF FIRST LAYER (KG/M**2) 5852.
98 C**** 7 OCEAN ICE TEMPERATURE OF SECOND LAYER (C) 5853.
99 C**** 8 EARTH TEMPERATURE OF SECOND LAYER (C) 5854.
100 C**** 9 EARTH WATER OF SECOND LAYER (KG/M**2) 5855.
101 C**** 10 EARTH ICE OF SECOND LAYER (KG/M**2) 5856.
102 C**** 12 LAND ICE SNOW AMOUNT (KG/M**2) 5857.
103 C**** 13 LAND ICE TEMPERATURE OF FIRST LAYER (C) 5858.
104 C**** 14 LAND ICE TEMPERATURE OF SECOND LAYER (C) 5859.
105 C**** 5860.
106 C**** BLDATA 1 COMPOSITE SURFACE WIND MAGNITUDE (M/S) 5861.
107 C**** 2 COMPOSITE SURFACE AIR TEMPERATURE (K) 5862.
108 C**** 3 COMPOSITE SURFACE AIR SPECIFIC HUMIDITY (1) 5863.
109 C**** 4 LAYER TO WHICH DRY CONVECTION MIXES (1) 5864.
110 C**** 5 FREE 5865.
111 C**** 6 COMPOSITE SURFACE U WIND 5866.
112 C**** 7 COMPOSITE SURFACE V WIND 5867.
113 C**** 8 COMPOSITE SURFACE MOMENTUM TRANSFER (TAU) 5868.
114 C**** 5869.
115 C**** VDATA 9 WATER FIELD CAPACITY OF FIRST LAYER (KG/M**2) 5870.
116 C**** 10 WATER FIELD CAPACITY OF SECOND LAYER (KG/M**2) 5871.
117 C**** 5872.
118 C**** 5874.
119 save
120 c print *,'sur4clm TAU=',TAU
121 NSTEPS=NSURF*NSTEP/NDYN 5875.
122 IF(IFIRST.NE.1) GO TO 50 5876.
123 print *,' SURFACE FOR CLM'
124 print *,' ZGS=30 m for LAND '
125 WMGMIN=8.
126 print *,'WMGMIN 4 LAND=',WMGMIN
127 IFIRST=0 5877.
128 print *,' WMGE'
129 print 258,(WMGE(1,J)+WMGMIN,J=1,JM)
130 258 format(12f5.1)
131 C SRCORX=1. 5878.13
132 CIAX=0.3
133 print *,' surfacen CIAX=',CIAX
134 print *,' QS=Q1, TS=T1'
135 print *,' WS=sqrt(0.75*W1+WGEM) '
136 IQ1=IM/4+1 5881.
137 IQ2=IM/2+1 5882.
138 IQ3=3*IM/4+1 5883.
139 DTSURF=NDYN*DT/NSURF 5884.
140 print *,' DTSURF=',DTSURF
141 DTSRCE=DT*NDYN 5885.
142 SHA=RGAS/KAPA 5886.
143 RVX=0. 5887.
144 50 CONTINUE
145 C**** ZERO OUT ENERGY AND EVAPORATION FOR GROUND AND INITIALIZE TGRND 5906.
146 DO 70 J=1,JM 5907.
147 DO 70 I=1,IM 5908.
148 TGRND(I,J,3)=GDATA(I,J,13) 5910.
149 TGRND(I,J,4)=GDATA(I,J,4) 5911.
150 70 CONTINUE
151 c print *,'After 70'
152 IHOUR=1.5+TOFDAY 5914.
153 C**** 5915.
154 C**** OUTSIDE LOOP OVER TIME STEPS, EXECUTED NSURF TIMES EVERY HOUR 5916.
155 C**** 5917.
156 C**** 5927.
157 C**** OUTSIDE LOOP OVER J AND I, EXECUTED ONCE FOR EACH GRID POINT 5928.
158 C**** 5929.
159 JPR=-7
160 DO 7000 J=1,JM 5930.
161 c print *,'After 7000 J=',J
162 c print *,IQ3
163 PRNT=.FALSE.
164 HEMI=1. 5931.
165 IF(J.LE.JM/2) HEMI=-1. 5932.
166 IF(J.EQ.1) GO TO 80 5936.
167 IF(J.EQ.JM) GO TO 90 5937.
168 WMG0=.5*(WMGE(1,J)+WMGE(1,J+1))+.001 5937.5
169 POLE=.FALSE. 5938.
170 IMAX=IM 5939.
171 GO TO 100 5940.
172 C**** CONDITIONS AT THE SOUTH POLE 5941.
173 80 POLE=.TRUE. 5942.
174 c print *,'After 80'
175 c print *,IQ1,IQ2,IQ3
176 IMAX=1 5943.
177 JVPO=2 5944.
178 RAPO=2.*RAPVN(1) 5945.
179 c print *,' RAPO=', RAPO
180 c II1=IQ1
181 c II2=IQ2
182 c II3=IQ3
183 c print *,II1,II2,II3
184 c print *,' III=',III
185 c print *,' U(IQ3,2,1)=',U(IQ3,2,1)
186 U1=.25*(U(1,2,1)+V(IQ1,2,1)-U(IQ2,2,1)-V(IQ3,2,1)) 5946.
187 V1=.25*(V(1,2,1)-U(IQ1,2,1)-V(IQ2,2,1)+U(IQ3,2,1)) 5947.
188 WMG0=WMGE(1,2) 5947.5
189 GO TO 100 5948.
190 C**** CONDITIONS AT THE NORTH POLE 5949.
191 90 POLE=.TRUE. 5950.
192 IMAX=1 5951.
193 JVPO=JM 5952.
194 RAPO=2.*RAPVS(JM) 5953.
195 U1=.25*(U(1,JM,1)-V(IQ1,JM,1)-U(IQ2,JM,1)+V(IQ3,JM,1)) 5954.
196 V1=.25*(V(1,JM,1)+U(IQ1,JM,1)-V(IQ2,JM,1)-U(IQ3,JM,1)) 5955.
197 WMG0=WMGE(1,JM) 5955.5
198 C**** ZERO OUT SURFACE DIAGNOSTICS WHICH WILL BE SUMMED OVER LONGITUDE 5956.
199 100 CONTINUE
200 c print *,'After 100'
201 BTS=0.
202 BWS=0.
203 BWMG=0.
204 IM1=IM 5969.
205 tsl4clm(j)=0.0
206 qs4clm(j)=0.0
207 ps4clm(j)=0.0
208 ws4clm(j)=0.0
209 us4clm(j)=0.0
210 vs4clm(j)=0.0
211 DO 6000 I=1,IMAX 5970.
212 C**** 5971.
213 C**** DETERMINE SURFACE CONDITIONS 5972.
214 C**** 5973.
215 PLAND=FDATA(I,J,2) 5974.
216 PWATER=1.-PLAND 5975.
217 PLICE=FDATA(I,J,3)*PLAND 5976.
218 PEARTH=PLAND-PLICE 5977.
219 POICE=ODATA(I,J,2)*PWATER 5978.
220 POCEAN=PWATER-POICE 5979.
221 if(POCEAN.LE.1.E-5)then
222 POCEAN=0.
223 POICE=PWATER
224 endif
225 TTOFR=PEARTH+PLICE+POICE+POCEAN
226 if(abs(TTOFR-1).gt.1.e-3)then
227 print *,' From surface TTOFR=',TTOFR
228 print *,' J=',J,' PLAND=',PLAND,' POCEAN=',POCEAN
229 print *,'POICE=',POICE,' ODATA(I,J,2)=',ODATA(I,J,2)
230 stop
231 end if
232 SP=P(I,J) 5980.
233 PS=SP+PTOP 5981.
234 PSK=EXPBYK(PS) 5982.
235 P1=SIG(1)*SP+PTOP 5983.
236 P1K=EXPBYK(P1) 5984.
237 IF(POLE) GO TO 1200 5993.
238 U1=.25*(U(IM1,J,1)+U(I,J,1)+U(IM1,J+1,1)+U(I,J+1,1)) 5994.
239 V1=.25*(V(IM1,J,1)+V(I,J,1)+V(IM1,J+1,1)+V(I,J+1,1)) 5995.
240 1200 TH1=T(I,J,1) 5996.
241 Q1=Q(I,J,1) 5997.
242 THV1=TH1*(1.+Q1*RVX) 5998.
243 C**** ZERO OUT QUANTITIES TO BE SUMMED OVER SURFACE TYPES 6002.
244 USS=0. 6003.
245 VSS=0. 6004.
246 WSS=0. 6005.
247 TSS=0. 6006.
248 QSS=0. 6007.
249 C**** 6032.
250 2400 IF(PLAND.LE.0.) GO TO 5000 6074.
251 ZGS=30. 6078.
252 IF(PLICE.LE.0.) GO TO 2600 6080.
253 C**** 6081.
254 C**** LAND ICE 6082.
255 C**** 6083.
256 ITYPE=3 6084.
257 PTYPE=PLICE 6085.
258 TG1=TGRND(I,J,3) 6087.
259 c ELHX=LHS 6094.
260 if (TG1.le.0.0)ELHX=LHS
261 if (TG1.gt.0.0)ELHX=LHE
262 GO TO 3000 6095.
263 C**** 6096.
264 2600 IF(PEARTH.LE.0.) GO TO 5000 6097.
265 C**** 6098.
266 C**** EARTH 6099.
267 C**** 6100.
268 ITYPE=4 6101.
269 PTYPE=PEARTH 6102.
270 TG1=TGRND(I,J,4) 6104.
271 if (TG1.le.0.0)ELHX=LHS
272 if (TG1.gt.0.0)ELHX=LHE
273 C**** 6134.
274 C**** BOUNDARY LAYER INTERACTION 6135.
275 C**** 6136.
276 3000 continue
277 if(J.eq.JPR)then
278 print *,' after 3000'
279 print *,'TAU=',TAU,' NS=',NS,' ITYPE=',ITYPE
280 print *,'CDH=',CDH,' RGAS=',RGAS
281 print *,'U1=',U1,' V1=',V1
282 print *,'WMGO=',WMGO
283 endif
284 TKV=THV1*PSK 6137.
285 C**** LOOP OVER GROUND TIME STEPS 6148.
286 TG=TG1+TF 6150.
287 QG=QSAT(TG,PS,ELHX) 6151.
288 TGV=TG*(1.+QG*RVX) 6152.
289 UG=0.75*U1
290 VG=0.75*V1
291 W1=SQRT(UG*UG+VG*VG)
292 WMG=WMG0+WMGMIN
293 WS=SQRT(W1**2+WMG)
294 RW=1.0
295 if(W1.ne.0.0)RW=WS/W1
296 THS=TH1
297 QS=Q1
298 TSV=THS*PSK
299 RIGS=ZGS*GRAV*(TSV-TGV)/(TGV*WS*WS)
300 IF(RIGS.LE.0) THEN
301 C surface layer has unstable stratification
302 CIA=TWOPI*0.0625/(1.+WS*CIAX)
303 ELSE
304 C surface layer has stable stratification
305 CIA=TWOPI*(0.09375-0.03125/(1.+4*RIGS**2))/(1.+WS*CIAX)
306 END IF
307 if(J.eq.JPR)then
308 print *,'TAU=',TAU,' NS=',NS,' ITYPE=',ITYPE
309 print *,'WS=',WS,' ZGS=',ZGS
310 print *,'RIGS=',RIGS,' TGV=',TGV
311 endif
312 USR=COS(CIA)
313 VSR=SIN(CIA)*HEMI
314 US=(USR*UG-VSR*VG)
315 VS=(VSR*UG+USR*VG)
316 if(J.eq.JPR)then
317 c print *,' '
318 print *,'TAU=',TAU,' NS=',NS,' ITYPE=',ITYPE
319 print *,'CDH=',CDH,' RGAS=',RGAS
320 print *,'PS=',PS,' TSV=',TSV
321 print *,'WS=',WS
322 endif
323 TS=TSV/(1.+QS*RVX) 6467.
324 c QSATS=QSAT(TS,PS,ELHX) 6468.
325 c IF(QS.LE.QSATS) GO TO 3500 6469.
326 c DQSSDT=QSATS*ELHX/(RVAP*TS*TS) 6470.
327 c X=(QS-QSATS)/(DQSSDT+(SHA/ELHX)) 6471.
328 c TS=TS+X 6472.
329 c QS=QS+X*(SHA/ELHX) 6473.
330 c3500 CONTINUE
331
332 if(ITYPE.EQ.4.or.ITYPE.EQ.3)then
333 tsl4clm(j)=tsl4clm(j)+TS*PTYPE/PLAND
334 qs4clm(j)=qs4clm(j)+QS*PTYPE/PLAND
335 ps4clm(j)=ps4clm(j)+PS*PTYPE/PLAND
336 ws4clm(j)=ws4clm(j)+WS*PTYPE/PLAND
337 ! us4clm(j)=us4clm(j)+US*PTYPE/PLAND
338 ! vs4clm(j)=vs4clm(j)+VS*PTYPE/PLAND
339 us4clm(j)=us4clm(j)+RW*US*PTYPE/PLAND
340 vs4clm(j)=vs4clm(j)+RW*VS*PTYPE/PLAND
341 endif
342
343 TSSFC(I,J,ITYPE)=TS 6521.5
344 USS=USS+US*PTYPE 6524.
345 VSS=VSS+VS*PTYPE 6525.
346 WSS=WSS+WS*PTYPE 6526.
347 TSS=TSS+TS*PTYPE 6527.
348 QSS=QSS+QS*PTYPE 6528.
349 GO TO (5000,5000,4400,4600),ITYPE 6551.
350 C**** 6552.
351 C**** LAND ICE 6569.
352 C**** 6570.
353 4400 CONTINUE
354 BTS=BTS+(TS-TF)*PLICE 6574.
355 BWS=BWS+WS*PLICE
356 BWMG=BWMG+SQRT(WMG)*PLICE
357 GO TO 2600 6575.
358 C**** 6576.
359 C**** EARTH 6577.
360 C**** 6578.
361 4600 CONTINUE
362 BTS=BTS+(TS-TF)*PEARTH 6582.
363 BWS=BWS+WS*PEARTH
364 BWMG=BWMG+SQRT(WMG)*PEARTH
365
366 C**** NON-OCEAN POINTS WHICH ARE NOT MELTING OR FREEZING WATER USE 6583.
367 C**** IMPLICIT TIME STEPS 6584.
368 C**** 6585.
369 C**** UPDATE SURFACE AND FIRST LAYER QUANTITIES 6586.
370 C**** 6587.
371 5000 CONTINUE
372 C**** 6596.
373 C**** ACCUMULATE DIAGNOSTICS 6597.
374 C**** 6598.
375 6000 IM1=I 6662.
376 WSSL(J)=WSS
377 TSSL(J)=TSS
378 QSSL(J)=QSS
379 USSL(J)=USS
380 VSSL(J)=VSS
381 C**** QUANTITIES ACCUMULATED FOR SURFACE TYPE TABLES IN DIAG1 6663.
382 BLJ(J,37)=BWS
383 BLJ(J,28)=BWMG
384 BLJ(J,23)=BTS
385 7000 CONTINUE 6677.
386 C**** 6678.
387 #endif
388 RETURN 6795.
389 END 6824.

  ViewVC Help
Powered by ViewVC 1.1.22