UPP (develop)
Loading...
Searching...
No Matches
SURFCE.f
Go to the documentation of this file.
1
76!--------------------------------------------------------------------
78 SUBROUTINE surfce
79
80!
81!
82! INCLUDE GRID DIMENSIONS. SET/DERIVE OTHER PARAMETERS.
83!
84 use vrbls4d, only: smoke, fv3dust, coarsepm, ebb
85 use vrbls3d, only: zint, pint, t, pmid, q, f_rimef
86 use vrbls2d, only: ths, qs, qvg, qv2m, tsnow, tg, smstav, smstot, &
87 cmc, sno, snoavg, psfcavg, t10avg, snonc, ivgtyp, &
88 si, potevp, dzice, qwbs, vegfrc, isltyp, pshltr, &
89 tshltr, qshltr, mrshltr, maxtshltr, mintshltr, &
90 maxrhshltr, minrhshltr, u10, psfcavg, v10, u10max, &
91 v10max, th10, t10m, q10, wspd10max, &
92 wspd10umax, wspd10vmax, prec, sr, &
93 cprate, avgcprate, avgprec, acprec, cuprec, ancprc, &
94 lspa, acsnow, acsnom, snowfall,ssroff, bgroff, &
95 runoff, pcp_bucket, rainnc_bucket, snow_bucket, &
96 snownc, tmax, graup_bucket, graupelnc, qrmax, sfclhx,&
97 rainc_bucket, sfcshx, subshx, snopcx, sfcuvx, &
98 sfcvx, smcwlt, suntime, pd, sfcux, sfcuxi, sfcvxi, sfcevp, z0, &
99 ustar, mdltaux, mdltauy, gtaux, gtauy, twbs, &
100 sfcexc, grnflx, islope, czmean, czen, rswin,akhsavg ,&
101 akmsavg, u10h, v10h,snfden,sndepac,qvl1, &
102 spduv10mean,swradmean,swnormmean,prate_max,fprate_max &
103 ,fieldcapa,edir,ecan,etrans,esnow,u10mean,v10mean, &
104 avgedir,avgecan,avgetrans,avgesnow,acgraup,acfrain, &
105 acond,maxqshltr,minqshltr,avgpotevp,avgprec_cont, &
106 avgcprate_cont,sst,pcp_bucket1,rainnc_bucket1, &
107 snow_bucket1, rainc_bucket1, graup_bucket1, &
108 frzrn_bucket, snow_acm, snow_bkt, &
109 shdmin, shdmax, lai, ch10,cd10,landfrac,paha,pahi, &
110 tecan,tetran,tedir,twa,ifi_apcp,xlaixy, &
111 smoke_ave,dust_ave,coarsepm_ave
112 use soil, only: stc, sllevel, sldpth, smc, sh2o
113 use masks, only: lmh, sm, sice, htm, gdlat, gdlon
114 use physcons_post,only: con_eps, con_epsm1
115 use params_mod, only: p1000, capa, h1m12, pq0, a2,a3, a4, h1, d00, d01,&
116 eps, oneps, d001, h99999, h100, small, h10e5, &
117 elocp, g, xlai, tfrz, rd
118 use ctlblk_mod, only: jsta, jend, lm, spval, grib, cfld, fld_info, &
119 datapd, nsoil, isf_surface_physics, tprec, ifmin,&
120 modelname, tmaxmin, pthresh, dtq2, dt, nphs, &
121 ifhr, prec_acc_dt, sdat, ihrst, jsta_2l, jend_2u,&
122 lp1, imp_physics, me, asrfc, tsrfc, pt, pdtop, &
123 mpi_comm_comp, im, jm, prec_acc_dt1, &
124 ista, iend, ista_2l, iend_2u
125 use rqstfld_mod, only: iget, lvls, id, iavblfld, lvlsxml
126 use grib2_module, only: read_grib2_head, read_grib2_sngle
127 use upp_physics, only: fpvsnew, calrh
128!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
129 implicit none
130!
131 include "mpif.h"
132!
133! IN NGM SUBROUTINE OUTPUT WE FIND THE FOLLOWING COMMENT.
134! "IF THE FOLLOWING THRESHOLD VALUES ARE CHANGED, CONTACT
135! TDL/SYNOPTIC-SCALE TECHNIQUES BRANCH (PAUL DALLAVALLE
136! AND JOHN JENSENIUS). THEY MAY BE USING IT IN ONE OF
137! THEIR PACKING CODES." THE THRESHOLD VALUE IS 0.01 INCH
138! OR 2.54E-4 METER. PRECIPITATION VALUES LESS THAN THIS
139! THRESHOLD ARE SET TO MINUS ONE TIMES THIS THRESHOLD.
140 real,PARAMETER :: PTRACE = 0.000254e0
141!
142! SET CELCIUS TO KELVIN AND SECOND TO HOUR CONVERSION.
143 integer,parameter :: nalg=5, nosoiltype=9
144 real, PARAMETER :: C2K = 273.15, sec2hr = 1./3600.
145!
146! DECLARE VARIABLES.
147!
148 integer, dimension(ista:iend,jsta:jend) :: nroots, iwx1
149 real, allocatable, dimension(:,:) :: zsfc, psfc, tsfc, qsfc, &
150 rhsfc, thsfc, dwpsfc, p1d, &
151 t1d, q1d, zwet, &
152 smcdry, smcmax,doms, domr, &
153 domip, domzr, rsmin, smcref,&
154 rcq, rct, rcsoil, gc, rcs
155
156 real, dimension(ista:iend,jsta:jend) :: evp
157 real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: egrid1, egrid2
158 real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: grid2
159 real, dimension(im,jm) :: grid1
160 real, dimension(ista_2l:iend_2u,jsta_2l:jend_2u) :: iceg
161! , ua, va
162 real, allocatable, dimension(:,:,:) :: sleet, rain, freezr, snow
163! real, dimension(im,jm,nalg) :: sleet, rain, freezr, snow
164
165!GSD
166 REAL totprcp, snowratio,t2,rainl
167
168!
169 integer I,J,IWX,ITMAXMIN,IFINCR,ISVALUE,II,JJ, &
170 itprec,itsrfc,l,ls,iveg,llmh, &
171 ivg,irtn,iseed, icat, cnt_snowratio(10),icnt_snow_rain_mixed
172
173 real RDTPHS,TLOW,TSFCK,QSAT,DTOP,DBOT,SNEQV,RRNUM,SFCPRS,SFCQ, &
174 rc,sfctmp,sncovr,factrs,solar, s,tk,tl,w,t2c,dlt,ape, &
175 qv,e,dwpt,dum1,dum2,dum3,dum1s,dum3s,dum21,dum216,es
176
177 character(len=256) :: ffgfile
178 character(len=256) :: arifile
179
180 logical file_exists, need_ifi
181
182 logical, parameter :: debugprint = .false.
183
184!****************************************************************************
185!
186! START SURFCE.
187!
188!
189!*** BLOCK 1. SURFACE BASED FIELDS.
190!
191! IF ANY OF THE FOLLOWING "SURFACE" FIELDS ARE REQUESTED,
192! WE NEED TO COMPUTE THE FIELDS FIRST.
193!
194 IF ( (iget(024)>0).OR.(iget(025)>0).OR. &
195 (iget(026)>0).OR.(iget(027)>0).OR. &
196 (iget(028)>0).OR.(iget(029)>0).OR. &
197 (iget(154)>0).OR. &
198 (iget(034)>0).OR.(iget(076)>0) ) THEN
199!
200 allocate(zsfc(ista:iend,jsta:jend), psfc(ista:iend,jsta:jend), tsfc(ista:iend,jsta:jend)&
201 ,rhsfc(ista:iend,jsta:jend), thsfc(ista:iend,jsta:jend), qsfc(ista:iend,jsta:jend))
202!$omp parallel do private(i,j,tsfck,qsat,es)
203 DO j=jsta,jend
204 DO i=ista,iend
205!
206! SCALE ARRAY FIS BY GI TO GET SURFACE HEIGHT.
207! ZSFC(I,J)=FIS(I,J)*GI
208
209! dong add missing value for zsfc
210 zsfc(i,j) = spval
211 IF(zint(i,j,lm+1) < spval) &
212 zsfc(i,j) = zint(i,j,lm+1)
213 psfc(i,j) = pint(i,j,nint(lmh(i,j))+1) ! SURFACE PRESSURE.
214!
215! SURFACE (SKIN) POTENTIAL TEMPERATURE AND TEMPERATURE.
216 thsfc(i,j) = ths(i,j)
217 tsfc(i,j) = spval
218 IF(thsfc(i,j) /= spval .and. psfc(i,j) /= spval) &
219 tsfc(i,j) = thsfc(i,j)*(psfc(i,j)/p1000)**capa
220!
221! SURFACE SPECIFIC HUMIDITY, RELATIVE HUMIDITY, AND DEWPOINT.
222! ADJUST SPECIFIC HUMIDITY IF RELATIVE HUMIDITY EXCEEDS 0.1 OR 1.0.
223
224! dong spfh sfc set missing value
225 qsfc(i,j) = spval
226 rhsfc(i,j) = spval
227 evp(i,j) = spval
228 IF(tsfc(i,j) < spval) then
229 IF(qs(i,j)<spval) qsfc(i,j) = max(h1m12,qs(i,j))
230 tsfck = tsfc(i,j)
231
232 IF(modelname == 'RAPR') THEN
233 qsat = max(0.0001,pq0/psfc(i,j)*exp(a2*(tsfck-a3)/(tsfck-a4)))
234 elseif (modelname == 'GFS') then
235 es = fpvsnew(tsfck)
236 qsat = con_eps*es/(psfc(i,j)+con_epsm1*es)
237 ELSE
238 qsat = pq0/psfc(i,j)*exp(a2*(tsfck-a3)/(tsfck-a4))
239 ENDIF
240 rhsfc(i,j) = max(d01, min(h1,qsfc(i,j)/qsat))
241
242 qsfc(i,j) = rhsfc(i,j)*qsat
243 rhsfc(i,j) = rhsfc(i,j) * 100.0
244 evp(i,j) = d001*psfc(i,j)*qsfc(i,j)/(eps+oneps*qsfc(i,j))
245 END IF !end TSFC
246!
247!mp ACCUMULATED NON-CONVECTIVE PRECIP.
248!mp IF(IGET(034)>0)THEN
249!mp IF(LVLS(1,IGET(034))>0)THEN
250
251! ACCUMULATED PRECIP (convective + non-convective)
252! IF(IGET(087) > 0)THEN
253! IF(LVLS(1,IGET(087)) > 0)THEN
254! write(6,*) 'acprec, ancprc, cuprec: ', ANCPRC(I,J)+CUPREC(I,J),
255! + ANCPRC(I,J),CUPREC(I,J)
256! ACPREC(I,J) = ANCPRC(I,J) + CUPREC(I,J) ???????
257! ENDIF
258! ENDIF
259
260 ENDDO
261 ENDDO
262!
263! INTERPOLATE/OUTPUT REQUESTED SURFACE FIELDS.
264!
265! SURFACE PRESSURE.
266 IF (iget(024)>0) THEN
267 if(grib == 'grib2') then
268 cfld = cfld+1
269 fld_info(cfld)%ifld = iavblfld(iget(024))
270!$omp parallel do private(i,j,ii,jj)
271 do j=1,jend-jsta+1
272 jj = jsta+j-1
273 do i=1,iend-ista+1
274 ii = ista+i-1
275 datapd(i,j,cfld) = psfc(ii,jj)
276 enddo
277 enddo
278 endif
279 ENDIF
280!
281! SURFACE HEIGHT.
282 IF (iget(025)>0) THEN
283!! CALL BOUND(GRID1,D00,H99999)
284 if(grib == 'grib2') then
285 cfld=cfld+1
286 fld_info(cfld)%ifld = iavblfld(iget(025))
287!$omp parallel do private(i,j,ii,jj)
288 do j=1,jend-jsta+1
289 jj = jsta+j-1
290 do i=1,iend-ista+1
291 ii = ista+i-1
292 datapd(i,j,cfld) = zsfc(ii,jj)
293 enddo
294 enddo
295 endif
296 ENDIF
297 if (allocated(zsfc)) deallocate(zsfc)
298 if (allocated(psfc)) deallocate(psfc)
299!
300! SURFACE (SKIN) TEMPERATURE.
301 IF (iget(026)>0) THEN
302 if(grib == 'grib2') then
303 cfld = cfld+1
304 fld_info(cfld)%ifld = iavblfld(iget(026))
305!$omp parallel do private(i,j,ii,jj)
306 do j=1,jend-jsta+1
307 jj = jsta+j-1
308 do i=1,iend-ista+1
309 ii = ista+i-1
310 datapd(i,j,cfld) = tsfc(ii,jj)
311 enddo
312 enddo
313 endif
314 ENDIF
315 if (allocated(tsfc)) deallocate(tsfc)
316!
317! SURFACE (SKIN) POTENTIAL TEMPERATURE.
318 IF (iget(027)>0) THEN
319 if(grib=='grib2') then
320 cfld=cfld+1
321 fld_info(cfld)%ifld=iavblfld(iget(027))
322!$omp parallel do private(i,j,ii,jj)
323 do j=1,jend-jsta+1
324 jj = jsta+j-1
325 do i=1,iend-ista+1
326 ii = ista+i-1
327 datapd(i,j,cfld) = thsfc(ii,jj)
328 enddo
329 enddo
330 endif
331 ENDIF
332 if (allocated(thsfc)) deallocate(thsfc)
333!
334! SURFACE SPECIFIC HUMIDITY.
335 IF (iget(028)>0) THEN
336 !CALL BOUND(GRID1,H1M12,H99999)
337 if(grib=='grib2') then
338 cfld=cfld+1
339 fld_info(cfld)%ifld=iavblfld(iget(028))
340!$omp parallel do private(i,j,ii,jj)
341 do j=1,jend-jsta+1
342 jj = jsta+j-1
343 do i=1,iend-ista+1
344 ii = ista+i-1
345 datapd(i,j,cfld) = qsfc(ii,jj)
346 enddo
347 enddo
348 endif
349 ENDIF
350 if (allocated(qsfc)) deallocate(qsfc)
351!
352! SURFACE DEWPOINT TEMPERATURE.
353 IF (iget(029)>0) THEN
354 allocate(dwpsfc(ista:iend,jsta:jend))
355 CALL dewpoint(evp,dwpsfc)
356 if(grib=='grib2') then
357 cfld=cfld+1
358 fld_info(cfld)%ifld=iavblfld(iget(029))
359!$omp parallel do private(i,j,ii,jj)
360 do j=1,jend-jsta+1
361 jj = jsta+j-1
362 do i=1,iend-ista+1
363 ii = ista+i-1
364 datapd(i,j,cfld) = dwpsfc(ii,jj)
365 enddo
366 enddo
367 endif
368 if (allocated(dwpsfc)) deallocate(dwpsfc)
369 ENDIF
370!
371! SURFACE RELATIVE HUMIDITY.
372 IF (iget(076)>0) THEN
373 if(grib=='grib2') then
374 cfld=cfld+1
375 fld_info(cfld)%ifld=iavblfld(iget(076))
376!$omp parallel do private(i,j,ii,jj)
377 do j=1,jend-jsta+1
378 jj = jsta+j-1
379 do i=1,iend-ista+1
380 ii = ista+i-1
381 if(rhsfc(ii,jj) /= spval) then
382 datapd(i,j,cfld) = max(h1,min(h100,rhsfc(ii,jj)))
383 else
384 datapd(i,j,cfld) = spval
385 endif
386 enddo
387 enddo
388 endif
389 ENDIF
390 if (allocated(rhsfc)) deallocate(rhsfc)
391!
392 ENDIF
393
394! ADDITIONAL SURFACE-SOIL LEVEL FIELDS.
395!
396! SURFACE MIXING RATIO
397 IF (iget(762)>0) THEN
398 if(grib=='grib2') then
399 cfld=cfld+1
400 fld_info(cfld)%ifld=iavblfld(iget(762))
401!$omp parallel do private(i,j,ii,jj)
402 do j=1,jend-jsta+1
403 jj = jsta+j-1
404 do i=1,iend-ista+1
405 ii = ista+i-1
406 datapd(i,j,cfld) = qvg(ii,jj)
407 enddo
408 enddo
409 endif
410 ENDIF
411!
412
413! SHELTER MIXING RATIO
414 IF (iget(760)>0) THEN
415 if(grib=='grib2') then
416 cfld=cfld+1
417 fld_info(cfld)%ifld=iavblfld(iget(760))
418!$omp parallel do private(i,j,ii,jj)
419 do j=1,jend-jsta+1
420 jj = jsta+j-1
421 do i=1,iend-ista+1
422 ii = ista+i-1
423 datapd(i,j,cfld) = qv2m(ii,jj)
424 enddo
425 enddo
426 endif
427 ENDIF
428
429! SNOW TEMERATURE
430 IF (iget(761)>0) THEN
431 if(grib=='grib2') then
432 cfld=cfld+1
433 fld_info(cfld)%ifld=iavblfld(iget(761))
434!$omp parallel do private(i,j,ii,jj)
435 do j=1,jend-jsta+1
436 jj = jsta+j-1
437 do i=1,iend-ista+1
438 ii = ista+i-1
439 datapd(i,j,cfld) = tsnow(ii,jj)
440 enddo
441 enddo
442 endif
443 ENDIF
444
445! DENSITY OF SNOWFALL
446 IF (iget(724)>0) THEN
447 if(grib=='grib2') then
448 cfld=cfld+1
449 fld_info(cfld)%ifld=iavblfld(iget(724))
450!$omp parallel do private(i,j,ii,jj)
451 do j=1,jend-jsta+1
452 jj = jsta+j-1
453 do i=1,iend-ista+1
454 ii = ista+i-1
455 datapd(i,j,cfld) = snfden(ii,jj)
456 enddo
457 enddo
458 endif
459 ENDIF
460
461! ACCUMULATED DEPTH OF SNOWFALL
462 IF (iget(725)>0) THEN
463 id(1:25) = 0
464 itprec = nint(tprec)
465!mp
466 IF(itprec /= 0) THEN
467 ifincr = mod(ifhr,itprec)
468 IF(ifmin >= 1)ifincr = mod(ifhr*60+ifmin,itprec*60)
469 ELSE
470 ifincr = 0
471 ENDIF
472!mp
473 id(18) = 0
474 id(19) = ifhr
475 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
476 id(20) = 4
477 IF (ifincr==0) THEN
478 id(18) = ifhr-itprec
479 ELSE
480 id(18) = ifhr-ifincr
481 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
482 ENDIF
483 IF (id(18)<0) id(18) = 0
484 if(grib=='grib2') then
485 cfld=cfld+1
486 fld_info(cfld)%ifld=iavblfld(iget(725))
487 fld_info(cfld)%ntrange=1
488 if(ifmin>1)then
489 fld_info(cfld)%tinvstat=ifhr*60+ifmin
490 else
491 fld_info(cfld)%tinvstat=ifhr
492 endif
493!$omp parallel do private(i,j,ii,jj)
494 do j=1,jend-jsta+1
495 jj = jsta+j-1
496 do i=1,iend-ista+1
497 ii = ista+i-1
498 if(sndepac(ii,jj)<spval) then
499 if(modelname=='FV3R') then
500 datapd(i,j,cfld) = sndepac(ii,jj)/(1e3)
501 else
502 datapd(i,j,cfld) = sndepac(ii,jj)
503 endif
504 else
505 datapd(i,j,cfld) = spval
506 endif
507 enddo
508 enddo
509 endif
510 ENDIF
511
512!
513! ADDITIONAL SURFACE-SOIL LEVEL FIELDS.
514!
515! print *,'in surf,nsoil=',nsoil,'iget(116)=',iget(116), &
516! 'lvls(116)=',LVLS(1:4,IGET(116)), &
517! 'sf_sfc_phys=',iSF_SURFACE_PHYSICS
518
519 DO l=1,nsoil
520! SOIL TEMPERATURE.
521 IF (iget(116)>0) THEN
522 IF (lvls(l,iget(116))>0) THEN
523 IF(isf_surface_physics==3)THEN
524 if(grib=='grib2') then
525 cfld=cfld+1
526 fld_info(cfld)%ifld=iavblfld(iget(116))
527 fld_info(cfld)%lvl=lvlsxml(l,iget(116))
528!$omp parallel do private(i,j,ii,jj)
529 do j=1,jend-jsta+1
530 jj = jsta+j-1
531 do i=1,iend-ista+1
532 ii = ista+i-1
533 datapd(i,j,cfld) = stc(ii,jj,l)
534 enddo
535 enddo
536 endif
537
538 ELSE
539
540 dtop = 0.
541 DO ls=1,l-1
542 dtop = dtop + sldpth(ls)
543 ENDDO
544 dbot = dtop + sldpth(l)
545 if(grib=='grib2') then
546 cfld=cfld+1
547 fld_info(cfld)%ifld=iavblfld(iget(116))
548 fld_info(cfld)%lvl=lvlsxml(l,iget(116))
549!$omp parallel do private(i,j,ii,jj)
550 do j=1,jend-jsta+1
551 jj = jsta+j-1
552 do i=1,iend-ista+1
553 ii = ista+i-1
554 datapd(i,j,cfld) = stc(ii,jj,l)
555 enddo
556 enddo
557 endif
558
559 ENDIF
560 ENDIF
561 ENDIF
562!
563! SOIL MOISTURE.
564 IF (iget(117)>0) THEN
565 IF (lvls(l,iget(117))>0) THEN
566 IF(isf_surface_physics==3)THEN
567 if(grib=='grib2') then
568 cfld=cfld+1
569 fld_info(cfld)%ifld=iavblfld(iget(117))
570 fld_info(cfld)%lvl=lvlsxml(l,iget(117))
571!$omp parallel do private(i,j,ii,jj)
572 do j=1,jend-jsta+1
573 jj = jsta+j-1
574 do i=1,iend-ista+1
575 ii = ista+i-1
576 datapd(i,j,cfld) = smc(ii,jj,l)
577 enddo
578 enddo
579 endif
580 ELSE
581 dtop = 0.
582 DO ls=1,l-1
583 dtop = dtop + sldpth(ls)
584 ENDDO
585 dbot = dtop + sldpth(l)
586 if(grib=='grib2') then
587 cfld=cfld+1
588 fld_info(cfld)%ifld=iavblfld(iget(117))
589 fld_info(cfld)%lvl=lvlsxml(l,iget(117))
590!$omp parallel do private(i,j,ii,jj)
591 do j=1,jend-jsta+1
592 jj = jsta+j-1
593 do i=1,iend-ista+1
594 ii = ista+i-1
595 datapd(i,j,cfld) = smc(ii,jj,l)
596 enddo
597 enddo
598 endif
599 ENDIF
600 ENDIF
601 ENDIF
602! ADD LIQUID SOIL MOISTURE
603 IF (iget(225)>0) THEN
604 IF (lvls(l,iget(225))>0) THEN
605 IF(isf_surface_physics==3)THEN
606 if(grib=='grib2') then
607 cfld=cfld+1
608 fld_info(cfld)%ifld=iavblfld(iget(225))
609 fld_info(cfld)%lvl=lvlsxml(l,iget(225))
610!$omp parallel do private(i,j,ii,jj)
611 do j=1,jend-jsta+1
612 jj = jsta+j-1
613 do i=1,iend-ista+1
614 ii = ista+i-1
615 datapd(i,j,cfld) = sh2o(ii,jj,l)
616 enddo
617 enddo
618 endif
619 ELSE
620 dtop = 0.
621 DO ls=1,l-1
622 dtop = dtop + sldpth(ls)
623 ENDDO
624 dbot = dtop + sldpth(l)
625 if(grib=='grib2') then
626 cfld=cfld+1
627 fld_info(cfld)%ifld=iavblfld(iget(225))
628 fld_info(cfld)%lvl=lvlsxml(l,iget(225))
629!$omp parallel do private(i,j,ii,jj)
630 do j=1,jend-jsta+1
631 jj = jsta+j-1
632 do i=1,iend-ista+1
633 ii = ista+i-1
634 datapd(i,j,cfld) = sh2o(ii,jj,l)
635 enddo
636 enddo
637 endif
638 ENDIF
639 ENDIF
640 ENDIF
641 ENDDO ! END OF NSOIL LOOP
642! -----------------
643!
644! BOTTOM SOIL TEMPERATURE.
645 IF (iget(115)>0.or.iget(571)>0) THEN
646 if(iget(115)>0) then
647 if(grib=='grib2') then
648 cfld=cfld+1
649 fld_info(cfld)%ifld=iavblfld(iget(115))
650!$omp parallel do private(i,j,ii,jj)
651 do j=1,jend-jsta+1
652 jj = jsta+j-1
653 do i=1,iend-ista+1
654 ii = ista+i-1
655 datapd(i,j,cfld) = tg(ii,jj)
656 enddo
657 enddo
658 endif
659 endif
660 if(iget(571)>0.and.grib=='grib2') then
661 cfld=cfld+1
662 fld_info(cfld)%ifld=iavblfld(iget(571))
663!$omp parallel do private(i,j,ii,jj)
664 do j=1,jend-jsta+1
665 jj = jsta+j-1
666 do i=1,iend-ista+1
667 ii = ista+i-1
668 datapd(i,j,cfld) = tg(ii,jj)
669 enddo
670 enddo
671 endif
672 ENDIF
673!
674! SOIL MOISTURE AVAILABILITY
675 IF (iget(171)>0) THEN
676!!$omp parallel do private(i,j)
677 DO j=jsta,jend
678 DO i=ista,iend
679 IF(smstav(i,j) /= spval)THEN
680 IF ( modelname == 'FV3R') THEN
681 grid1(i,j) = smstav(i,j)
682 ELSE
683 grid1(i,j) = smstav(i,j)*100.
684 ENDIF
685 ELSE
686 grid1(i,j) = 0.
687 ENDIF
688 ENDDO
689 ENDDO
690 if(grib=='grib2') then
691 cfld=cfld+1
692 fld_info(cfld)%ifld=iavblfld(iget(171))
693!$omp parallel do private(i,j,ii,jj)
694 do j=1,jend-jsta+1
695 jj = jsta+j-1
696 do i=1,iend-ista+1
697 ii = ista+i-1
698 datapd(i,j,cfld) = grid1(ii,jj)
699 enddo
700 enddo
701 endif
702 ENDIF
703!
704! TOTAL SOIL MOISTURE
705 IF (iget(036)>0) THEN
706!$omp parallel do private(i,j)
707 DO j=jsta,jend
708 DO i=ista,iend
709 IF(smstot(i,j)/=spval) THEN
710 IF(sm(i,j) > small .AND. sice(i,j) < small) THEN
711 grid1(i,j) = 1000.0 ! TEMPORY FIX TO MAKE SURE SMSTOT=1 FOR WATER
712 ELSE
713 grid1(i,j) = smstot(i,j)
714 END IF
715 ELSE
716 grid1(i,j) = 1000.0
717 ENDIF
718 ENDDO
719 ENDDO
720 if(grib=='grib2') then
721 cfld=cfld+1
722 fld_info(cfld)%ifld=iavblfld(iget(036))
723!$omp parallel do private(i,j,ii,jj)
724 do j=1,jend-jsta+1
725 jj = jsta+j-1
726 do i=1,iend-ista+1
727 ii = ista+i-1
728 datapd(i,j,cfld) = grid1(ii,jj)
729 enddo
730 enddo
731 endif
732 ENDIF
733!
734! TOTAL SOIL MOISTURE
735 IF (iget(713)>0) THEN
736!$omp parallel do private(i,j)
737 DO j=jsta,jend
738 DO i=ista,iend
739! IF(SMSTOT(I,J)/=SPVAL) THEN
740 grid1(i,j) = smstot(i,j)
741! ELSE
742! GRID1(I,J) = SPVAL
743! ENDIF
744 ENDDO
745 ENDDO
746 if(grib=='grib2') then
747 cfld=cfld+1
748 fld_info(cfld)%ifld=iavblfld(iget(713))
749!$omp parallel do private(i,j,ii,jj)
750 do j=1,jend-jsta+1
751 jj = jsta+j-1
752 do i=1,iend-ista+1
753 ii = ista+i-1
754 datapd(i,j,cfld) = grid1(ii,jj)
755 enddo
756 enddo
757 endif
758 ENDIF
759!
760! PLANT CANOPY SURFACE WATER.
761 IF ( iget(118)>0 ) THEN
762 IF(modelname == 'RAPR') THEN
763!$omp parallel do private(i,j)
764 DO j=jsta,jend
765 DO i=ista,iend
766 IF(cmc(i,j) /= spval) then
767 grid1(i,j) = cmc(i,j)
768 else
769 grid1(i,j) = spval
770 endif
771 ENDDO
772 ENDDO
773 else
774!$omp parallel do private(i,j)
775 DO j=jsta,jend
776 DO i=ista,iend
777 IF(cmc(i,j) /= spval) then
778 grid1(i,j) = cmc(i,j)*1000.
779 else
780 grid1(i,j) = spval
781 endif
782 ENDDO
783 ENDDO
784 endif
785 if(grib=='grib2') then
786 cfld=cfld+1
787 fld_info(cfld)%ifld=iavblfld(iget(118))
788!$omp parallel do private(i,j,ii,jj)
789 do j=1,jend-jsta+1
790 jj = jsta+j-1
791 do i=1,iend-ista+1
792 ii = ista+i-1
793 datapd(i,j,cfld) = grid1(ii,jj)
794 enddo
795 enddo
796 endif
797 ENDIF
798!
799! SNOW WATER EQUIVALENT.
800 IF ( iget(119)>0 ) THEN
801! GRID1 = SPVAL
802 if(grib=='grib2') then
803 cfld=cfld+1
804 fld_info(cfld)%ifld=iavblfld(iget(119))
805!$omp parallel do private(i,j,ii,jj)
806 do j=1,jend-jsta+1
807 jj = jsta+j-1
808 do i=1,iend-ista+1
809 ii = ista+i-1
810 datapd(i,j,cfld) = sno(ii,jj)
811 enddo
812 enddo
813 endiF
814 ENDIF
815!
816! Time averaged percent SNOW COVER (for AQ)
817 IF ( iget(500)>0 ) THEN
818! GRID1=SPVAL
819!$omp parallel do private(i,j)
820 DO j=jsta,jend
821 DO i=ista,iend
822! GRID1(I,J) = 100.*SNOAVG(I,J)
823 grid1(i,j) = snoavg(i,j)
824 if (snoavg(i,j) /= spval) grid1(i,j) = 100.*snoavg(i,j)
825 ENDDO
826 ENDDO
827 CALL bound(grid1,d00,h100)
828 id(1:25) = 0
829 itsrfc = nint(tsrfc)
830 IF(itsrfc /= 0) then
831 ifincr = mod(ifhr,itsrfc)
832 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
833 ELSE
834 ifincr = 0
835 endif
836 id(19) = ifhr
837 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
838 id(20) = 3
839 IF (ifincr==0) THEN
840 id(18) = ifhr-itsrfc
841 ELSE
842 id(18) = ifhr-ifincr
843 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
844 ENDIF
845 IF (id(18)<0) id(18) = 0
846 if(grib=='grib2') then
847 cfld=cfld+1
848 fld_info(cfld)%ifld=iavblfld(iget(500))
849 if(itsrfc>0) then
850 fld_info(cfld)%ntrange=1
851 else
852 fld_info(cfld)%ntrange=0
853 endif
854 fld_info(cfld)%tinvstat=ifhr-id(18)
855 ! fld_info(cfld)%ntrange=IFHR-ID(18)
856 ! fld_info(cfld)%tinvstat=1
857!$omp parallel do private(i,j,ii,jj)
858 do j=1,jend-jsta+1
859 jj = jsta+j-1
860 do i=1,iend-ista+1
861 ii = ista+i-1
862 datapd(i,j,cfld) = grid1(ii,jj)
863 enddo
864 enddo
865 endif
866 ENDIF
867
868! Time averaged surface pressure (for AQ)
869 IF ( iget(501)>0 ) THEN
870! GRID1 = SPVAL
871 id(1:25) = 0
872 id(19) = ifhr
873 IF (ifhr==0) THEN
874 id(18) = 0
875 ELSE
876 id(18) = ifhr - 1
877 ENDIF
878 id(20) = 3
879 itsrfc = nint(tsrfc)
880 if(grib=='grib2') then
881 cfld=cfld+1
882 fld_info(cfld)%ifld=iavblfld(iget(501))
883 if(itsrfc>0) then
884 fld_info(cfld)%ntrange=1
885 else
886 fld_info(cfld)%ntrange=0
887 endif
888 fld_info(cfld)%tinvstat=ifhr-id(18)
889!$omp parallel do private(i,j,ii,jj)
890 do j=1,jend-jsta+1
891 jj = jsta+j-1
892 do i=1,iend-ista+1
893 ii = ista+i-1
894 datapd(i,j,cfld) = psfcavg(ii,jj)
895 enddo
896 enddo
897 endif
898 ENDIF
899
900! Time averaged 10 m temperature (for AQ)
901 IF ( iget(502)>0 ) THEN
902! GRID1 = SPVAL
903 id(1:25) = 0
904 id(19) = ifhr
905 IF (ifhr==0) THEN
906 id(18) = 0
907 ELSE
908 id(18) = ifhr - 1
909 ENDIF
910 id(20) = 3
911 isvalue = 10
912 id(10) = mod(isvalue/256,256)
913 id(11) = mod(isvalue,256)
914 itsrfc = nint(tsrfc)
915 if(grib=='grib2') then
916 cfld=cfld+1
917 fld_info(cfld)%ifld=iavblfld(iget(502))
918 if(itsrfc>0) then
919 fld_info(cfld)%ntrange=1
920 else
921 fld_info(cfld)%ntrange=0
922 endif
923 fld_info(cfld)%tinvstat=ifhr-id(18)
924!$omp parallel do private(i,j,ii,jj)
925 do j=1,jend-jsta+1
926 jj = jsta+j-1
927 do i=1,iend-ista+1
928 ii = ista+i-1
929 datapd(i,j,cfld) = t10avg(ii,jj)
930 enddo
931 enddo
932 endif
933 ENDIF
934!
935! ACM GRID SCALE SNOW AND ICE
936 IF ( iget(244)>0 ) THEN
937!$omp parallel do private(i,j)
938 DO j=jsta,jend
939 DO i=ista,iend
940 grid1(i,j) = snonc(i,j)
941 ENDDO
942 ENDDO
943 id(1:25) = 0
944 itprec = nint(tprec)
945!mp
946 if (itprec /= 0) then
947 ifincr = mod(ifhr,itprec)
948 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
949 else
950 ifincr = 0
951 endif
952!mp
953 id(18) = 0
954 id(19) = ifhr
955 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
956 id(20) = 4
957 IF (ifincr==0) THEN
958 id(18) = ifhr-itprec
959 ELSE
960 id(18) = ifhr-ifincr
961 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
962 ENDIF
963 IF (id(18)<0) id(18) = 0
964
965 if(grib=='grib2') then
966 cfld=cfld+1
967 fld_info(cfld)%ifld=iavblfld(iget(244))
968 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
969 endif
970 ENDIF
971!
972! PERCENT SNOW COVER.
973 IF ( iget(120)>0 ) THEN
974 grid1=spval
975 DO j=jsta,jend
976 DO i=ista,iend
977! GRID1(I,J)=PCTSNO(I,J)
978 IF ( sno(i,j) /= spval ) THEN
979 sneqv = sno(i,j)
980 iveg = ivgtyp(i,j)
981 IF(iveg==0)iveg=7
982 CALL snfrac (sneqv,iveg,sncovr)
983 grid1(i,j) = sncovr*100.
984 ENDIF
985 ENDDO
986 ENDDO
987 CALL bound(grid1,d00,h100)
988 if(grib=='grib2') then
989 cfld=cfld+1
990 fld_info(cfld)%ifld=iavblfld(iget(120))
991!$omp parallel do private(i,j,ii,jj)
992 do j=1,jend-jsta+1
993 jj = jsta+j-1
994 do i=1,iend-ista+1
995 ii = ista+i-1
996 datapd(i,j,cfld) = grid1(ii,jj)
997 enddo
998 enddo
999 endif
1000 ENDIF
1001! ADD SNOW DEPTH
1002 IF ( iget(224)>0 ) THEN
1003 ii = (ista+iend)/2
1004 jj = (jsta+jend)/2
1005! GRID1=SPVAL
1006!$omp parallel do private(i,j)
1007 DO j=jsta,jend
1008 DO i=ista,iend
1009 grid1(i,j) = spval
1010 IF(si(i,j) /= spval) grid1(i,j) = si(i,j)*0.001 ! SI comes out of WRF in mm
1011 ENDDO
1012 ENDDO
1013! print*,'sample snow depth in GRIBIT= ',si(ii,jj)
1014 if(grib=='grib2') then
1015 cfld=cfld+1
1016 fld_info(cfld)%ifld=iavblfld(iget(224))
1017!$omp parallel do private(i,j,ii,jj)
1018 do j=1,jend-jsta+1
1019 jj = jsta+j-1
1020 do i=1,iend-ista+1
1021 ii = ista+i-1
1022 datapd(i,j,cfld) = grid1(ii,jj)
1023 enddo
1024 enddo
1025 endif
1026 ENDIF
1027! ADD POTENTIAL EVAPORATION
1028 IF ( iget(242)>0 ) THEN
1029 if(grib=='grib2') then
1030 cfld=cfld+1
1031 fld_info(cfld)%ifld=iavblfld(iget(242))
1032!$omp parallel do private(i,j,ii,jj)
1033 do j=1,jend-jsta+1
1034 jj = jsta+j-1
1035 do i=1,iend-ista+1
1036 ii = ista+i-1
1037 datapd(i,j,cfld) = potevp(ii,jj)
1038 enddo
1039 enddo
1040 endif
1041 ENDIF
1042! ADD ICE THICKNESS
1043 IF ( iget(349)>0 ) THEN
1044 if(grib=='grib2') then
1045 cfld=cfld+1
1046 fld_info(cfld)%ifld=iavblfld(iget(349))
1047!$omp parallel do private(i,j,ii,jj)
1048 do j=1,jend-jsta+1
1049 jj = jsta+j-1
1050 do i=1,iend-ista+1
1051 ii = ista+i-1
1052 datapd(i,j,cfld) = dzice(ii,jj)
1053 enddo
1054 enddo
1055 endif
1056 ENDIF
1057
1058! ADD EC,EDIR,ETRANS,ESNOW,SMCDRY,SMCMAX
1059! ONLY OUTPUT NEW LSM FIELDS FOR NMM AND ARW BECAUSE RSM USES OLD SOIL TYPES
1060 IF (modelname == 'NCAR'.OR. modelname == 'NMM' &
1061 .OR. modelname == 'FV3R' .OR. modelname == 'RAPR') THEN
1062! write(*,*)'in surf,isltyp=',maxval(isltyp(1:im,jsta:jend)), &
1063! minval(isltyp(1:im,jsta:jend)),'qwbs=',maxval(qwbs(1:im,jsta:jend)), &
1064! minval(qwbs(1:im,jsta:jend)),'potsvp=',maxval(potevp(1:im,jsta:jend)), &
1065! minval(potevp(1:im,jsta:jend)),'sno=',maxval(sno(1:im,jsta:jend)), &
1066! minval(sno(1:im,jsta:jend)),'vegfrc=',maxval(vegfrc(1:im,jsta:jend)), &
1067! minval(vegfrc(1:im,jsta:jend)), 'sh2o=',maxval(sh2o(1:im,jsta:jend,1)), &
1068! minval(sh2o(1:im,jsta:jend,1)),'cmc=',maxval(cmc(1:im,jsta:jend)), &
1069! minval(cmc(1:im,jsta:jend))
1070 IF ( iget(228)>0 .OR. iget(229)>0 &
1071 .OR.iget(230)>0 .OR. iget(231)>0 &
1072 .OR.iget(232)>0 .OR. iget(233)>0) THEN
1073
1074 allocate(smcdry(ista:iend,jsta:jend), &
1075 smcmax(ista:iend,jsta:jend))
1076 DO j=jsta,jend
1077 DO i=ista,iend
1078! ----------------------------------------------------------------------
1079! IF(QWBS(I,J)>0.001)print*,'NONZERO QWBS',i,j,QWBS(I,J)
1080! IF(abs(SM(I,J)-0.)<1.0E-5)THEN
1081! WRF ARW has no POTEVP field. So has to block out RAPR
1082 IF( (modelname/='RAPR') .AND. (abs(sm(i,j)-0.) < 1.0e-5) .AND. &
1083 & (abs(sice(i,j)-0.) < 1.0e-5) ) THEN
1084 CALL etcalc(qwbs(i,j),potevp(i,j),sno(i,j),vegfrc(i,j) &
1085 & , isltyp(i,j),sh2o(i,j,1:1),cmc(i,j) &
1086 & , ecan(i,j),edir(i,j),etrans(i,j),esnow(i,j) &
1087 & , smcdry(i,j),smcmax(i,j) )
1088 ELSE
1089 ecan(i,j) = 0.
1090 edir(i,j) = 0.
1091 etrans(i,j) = 0.
1092 esnow(i,j) = 0.
1093 smcdry(i,j) = 0.
1094 smcmax(i,j) = 0.
1095 ENDIF
1096 ENDDO
1097 ENDDO
1098
1099 IF ( iget(228)>0 )THEN
1100 if(grib=='grib2') then
1101 cfld=cfld+1
1102 fld_info(cfld)%ifld=iavblfld(iget(228))
1103!$omp parallel do private(i,j,ii,jj)
1104 do j=1,jend-jsta+1
1105 jj = jsta+j-1
1106 do i=1,iend-ista+1
1107 ii = ista+i-1
1108 datapd(i,j,cfld) = ecan(ii,jj)
1109 enddo
1110 enddo
1111 endiF
1112 ENDIF
1113
1114 IF ( iget(229)>0 )THEN
1115 if(grib=='grib2') then
1116 cfld=cfld+1
1117 fld_info(cfld)%ifld=iavblfld(iget(229))
1118!$omp parallel do private(i,j,ii,jj)
1119 do j=1,jend-jsta+1
1120 jj = jsta+j-1
1121 do i=1,iend-ista+1
1122 ii = ista+i-1
1123 datapd(i,j,cfld) = edir(ii,jj)
1124 enddo
1125 enddo
1126 endif
1127 ENDIF
1128
1129 IF ( iget(230)>0 )THEN
1130 if(grib=='grib2') then
1131 cfld=cfld+1
1132 fld_info(cfld)%ifld=iavblfld(iget(230))
1133 datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = etrans(ista:iend,jsta:jend)
1134 endif
1135 ENDIF
1136
1137 IF ( iget(231)>0 )THEN
1138 if(grib=='grib2') then
1139 cfld=cfld+1
1140 fld_info(cfld)%ifld=iavblfld(iget(231))
1141 datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = esnow(ista:iend,jsta:jend)
1142 endif
1143 ENDIF
1144
1145 IF ( iget(232)>0 )THEN
1146 if(grib=='grib2') then
1147 cfld=cfld+1
1148 fld_info(cfld)%ifld=iavblfld(iget(232))
1149!$omp parallel do private(i,j,ii,jj)
1150 do j=1,jend-jsta+1
1151 jj = jsta+j-1
1152 do i=1,iend-ista+1
1153 ii = ista+i-1
1154 datapd(i,j,cfld) = smcdry(ii,jj)
1155 enddo
1156 enddo
1157 endif
1158 ENDIF
1159
1160 IF ( iget(233)>0 )THEN
1161 if(grib=='grib2') then
1162 cfld=cfld+1
1163 fld_info(cfld)%ifld=iavblfld(iget(233))
1164!$omp parallel do private(i,j,ii,jj)
1165 do j=1,jend-jsta+1
1166 jj = jsta+j-1
1167 do i=1,iend-ista+1
1168 ii = ista+i-1
1169 datapd(i,j,cfld) = smcmax(ii,jj)
1170 enddo
1171 enddo
1172 endif
1173 ENDIF
1174
1175 ENDIF
1176! if (allocated(ecan)) deallocate(ecan)
1177! if (allocated(edir)) deallocate(edir)
1178! if (allocated(etrans)) deallocate(etrans)
1179! if (allocated(esnow)) deallocate(esnow)
1180 if (allocated(smcdry)) deallocate(smcdry)
1181 if (allocated(smcmax)) deallocate(smcmax)
1182
1183 END IF ! endif for ncar and nmm options
1184
1185 IF ( iget(512)>0 )THEN
1186 if(grib=='grib2') then
1187 cfld=cfld+1
1188 fld_info(cfld)%ifld=iavblfld(iget(512))
1189!$omp parallel do private(i,j,ii,jj)
1190 do j=1,jend-jsta+1
1191 jj = jsta+j-1
1192 do i=1,iend-ista+1
1193 ii = ista+i-1
1194 datapd(i,j,cfld) = acond(ii,jj)
1195 enddo
1196 enddo
1197 endiF
1198 ENDIF
1199
1200 IF ( iget(513)>0 )THEN
1201 id(1:25) = 0
1202 itsrfc = nint(tsrfc)
1203 IF(itsrfc /= 0) then
1204 ifincr = mod(ifhr,itsrfc)
1205 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
1206 ELSE
1207 ifincr = 0
1208 endif
1209 id(19) = ifhr
1210 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
1211 id(20) = 3
1212 IF (ifincr==0) THEN
1213 id(18) = ifhr-itsrfc
1214 ELSE
1215 id(18) = ifhr-ifincr
1216 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
1217 ENDIF
1218 IF (id(18)<0) id(18) = 0
1219 if(grib=='grib2') then
1220 cfld=cfld+1
1221 fld_info(cfld)%ifld=iavblfld(iget(513))
1222 if(itsrfc>0) then
1223 fld_info(cfld)%ntrange=1
1224 else
1225 fld_info(cfld)%ntrange=0
1226 endif
1227 fld_info(cfld)%tinvstat=ifhr-id(18)
1228!$omp parallel do private(i,j,ii,jj)
1229 do j=1,jend-jsta+1
1230 jj = jsta+j-1
1231 do i=1,iend-ista+1
1232 ii = ista+i-1
1233 datapd(i,j,cfld) = avgecan(ii,jj)
1234 enddo
1235 enddo
1236 endiF
1237 ENDIF
1238
1239 IF ( iget(514)>0 )THEN
1240 id(1:25) = 0
1241 itsrfc = nint(tsrfc)
1242 IF(itsrfc /= 0) then
1243 ifincr = mod(ifhr,itsrfc)
1244 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
1245 ELSE
1246 ifincr = 0
1247 endif
1248 id(19) = ifhr
1249 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
1250 id(20) = 3
1251 IF (ifincr==0) THEN
1252 id(18) = ifhr-itsrfc
1253 ELSE
1254 id(18) = ifhr-ifincr
1255 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
1256 ENDIF
1257 IF (id(18)<0) id(18) = 0
1258 if(grib=='grib2') then
1259 cfld=cfld+1
1260 fld_info(cfld)%ifld=iavblfld(iget(514))
1261 if(itsrfc>0) then
1262 fld_info(cfld)%ntrange=1
1263 else
1264 fld_info(cfld)%ntrange=0
1265 endif
1266 fld_info(cfld)%tinvstat=ifhr-id(18)
1267!$omp parallel do private(i,j,ii,jj)
1268 do j=1,jend-jsta+1
1269 jj = jsta+j-1
1270 do i=1,iend-ista+1
1271 ii = ista+i-1
1272 datapd(i,j,cfld) = avgedir(ii,jj)
1273 enddo
1274 enddo
1275 endif
1276 ENDIF
1277
1278 IF ( iget(515)>0 )THEN
1279 id(1:25) = 0
1280 itsrfc = nint(tsrfc)
1281 IF(itsrfc /= 0) then
1282 ifincr = mod(ifhr,itsrfc)
1283 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
1284 ELSE
1285 ifincr = 0
1286 endif
1287 id(19) = ifhr
1288 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
1289 id(20) = 3
1290 IF (ifincr==0) THEN
1291 id(18) = ifhr-itsrfc
1292 ELSE
1293 id(18) = ifhr-ifincr
1294 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
1295 ENDIF
1296 IF (id(18)<0) id(18) = 0
1297 if(grib=='grib2') then
1298 cfld=cfld+1
1299 fld_info(cfld)%ifld=iavblfld(iget(515))
1300 if(itsrfc>0) then
1301 fld_info(cfld)%ntrange=1
1302 else
1303 fld_info(cfld)%ntrange=0
1304 endif
1305 fld_info(cfld)%tinvstat=ifhr-id(18)
1306 datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = avgetrans(ista:iend,jsta:jend)
1307 endif
1308 ENDIF
1309
1310 IF ( iget(516)>0 )THEN
1311 id(1:25) = 0
1312 itsrfc = nint(tsrfc)
1313 IF(itsrfc /= 0) then
1314 ifincr = mod(ifhr,itsrfc)
1315 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
1316 ELSE
1317 ifincr = 0
1318 endif
1319 id(19) = ifhr
1320 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
1321 id(20) = 3
1322 IF (ifincr==0) THEN
1323 id(18) = ifhr-itsrfc
1324 ELSE
1325 id(18) = ifhr-ifincr
1326 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
1327 ENDIF
1328 IF (id(18)<0) id(18) = 0
1329 if(grib=='grib2') then
1330 cfld=cfld+1
1331 fld_info(cfld)%ifld=iavblfld(iget(516))
1332 if(itsrfc>0) then
1333 fld_info(cfld)%ntrange=1
1334 else
1335 fld_info(cfld)%ntrange=0
1336 endif
1337 fld_info(cfld)%tinvstat=ifhr-id(18)
1338 datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = avgesnow(ista:iend,jsta:jend)
1339 endif
1340 ENDIF
1341
1342 IF ( iget(996)>0 )THEN
1343 if(grib=='grib2') then
1344 cfld=cfld+1
1345 fld_info(cfld)%ifld=iavblfld(iget(996))
1346!$omp parallel do private(i,j,ii,jj)
1347 do j=1,jend-jsta+1
1348 jj = jsta+j-1
1349 do i=1,iend-ista+1
1350 ii = ista+i-1
1351 datapd(i,j,cfld) = landfrac(ii,jj)
1352 enddo
1353 enddo
1354 endif
1355 ENDIF
1356
1357 IF ( iget(997)>0 )THEN
1358 if(grib=='grib2') then
1359 cfld=cfld+1
1360 fld_info(cfld)%ifld=iavblfld(iget(997))
1361!$omp parallel do private(i,j,ii,jj)
1362 do j=1,jend-jsta+1
1363 jj = jsta+j-1
1364 do i=1,iend-ista+1
1365 ii = ista+i-1
1366 datapd(i,j,cfld) = pahi(ii,jj)
1367 enddo
1368 enddo
1369 endif
1370 ENDIF
1371
1372 IF ( iget(998)>0 )THEN
1373 if(grib=='grib2') then
1374 cfld=cfld+1
1375 fld_info(cfld)%ifld=iavblfld(iget(998))
1376!$omp parallel do private(i,j,ii,jj)
1377 do j=1,jend-jsta+1
1378 jj = jsta+j-1
1379 do i=1,iend-ista+1
1380 ii = ista+i-1
1381 datapd(i,j,cfld) = twa(ii,jj)
1382 enddo
1383 enddo
1384 endif
1385 ENDIF
1386
1387 IF ( iget(999)>0 )THEN
1388!$omp parallel do private(i,j)
1389 DO j=jsta,jend
1390 DO i=ista,iend
1391 grid1(i,j) = tecan(i,j)
1392 ENDDO
1393 ENDDO
1394 id(1:25) = 0
1395 itprec = nint(tprec)
1396 if (itprec /= 0) then
1397 ifincr = mod(ifhr,itprec)
1398 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
1399 else
1400 ifincr = 0
1401 endif
1402 id(18) = 0
1403 id(19) = ifhr
1404 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
1405 id(20) = 4
1406 IF (ifincr==0) THEN
1407 id(18) = ifhr-itprec
1408 ELSE
1409 id(18) = ifhr-ifincr
1410 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
1411 ENDIF
1412 IF (id(18)<0) id(18) = 0
1413 if(grib=='grib2') then
1414 cfld=cfld+1
1415 fld_info(cfld)%ifld=iavblfld(iget(999))
1416 fld_info(cfld)%ntrange=1
1417 fld_info(cfld)%tinvstat=ifhr-id(18)
1418!$omp parallel do private(i,j,ii,jj)
1419 do j=1,jend-jsta+1
1420 jj = jsta+j-1
1421 do i=1,iend-ista+1
1422 ii = ista+i-1
1423 datapd(i,j,cfld) = grid1(ii,jj)
1424 enddo
1425 enddo
1426 endif
1427 ENDIF
1428
1429 IF ( iget(1000)>0 )THEN
1430!$omp parallel do private(i,j)
1431 DO j=jsta,jend
1432 DO i=ista,iend
1433 grid1(i,j) = tetran(i,j)
1434 ENDDO
1435 ENDDO
1436 id(1:25) = 0
1437 itprec = nint(tprec)
1438 if (itprec /= 0) then
1439 ifincr = mod(ifhr,itprec)
1440 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
1441 else
1442 ifincr = 0
1443 endif
1444 id(18) = 0
1445 id(19) = ifhr
1446 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
1447 id(20) = 4
1448 IF (ifincr==0) THEN
1449 id(18) = ifhr-itprec
1450 ELSE
1451 id(18) = ifhr-ifincr
1452 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
1453 ENDIF
1454 IF (id(18)<0) id(18) = 0
1455 if(grib=='grib2') then
1456 cfld=cfld+1
1457 fld_info(cfld)%ifld=iavblfld(iget(1000))
1458 fld_info(cfld)%ntrange=1
1459 fld_info(cfld)%tinvstat=ifhr-id(18)
1460!$omp parallel do private(i,j,ii,jj)
1461 do j=1,jend-jsta+1
1462 jj = jsta+j-1
1463 do i=1,iend-ista+1
1464 ii = ista+i-1
1465 datapd(i,j,cfld) = grid1(ii,jj)
1466 enddo
1467 enddo
1468 endif
1469 ENDIF
1470!
1471 IF ( iget(1001)>0 )THEN
1472!$omp parallel do private(i,j)
1473 DO j=jsta,jend
1474 DO i=ista,iend
1475 grid1(i,j) = tedir(i,j)
1476 ENDDO
1477 ENDDO
1478 id(1:25) = 0
1479 itprec = nint(tprec)
1480 if (itprec /= 0) then
1481 ifincr = mod(ifhr,itprec)
1482 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
1483 else
1484 ifincr = 0
1485 endif
1486 id(18) = 0
1487 id(19) = ifhr
1488 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
1489 id(20) = 4
1490 IF (ifincr==0) THEN
1491 id(18) = ifhr-itprec
1492 ELSE
1493 id(18) = ifhr-ifincr
1494 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
1495 ENDIF
1496 IF (id(18)<0) id(18) = 0
1497 if(grib=='grib2') then
1498 cfld=cfld+1
1499 fld_info(cfld)%ifld=iavblfld(iget(1001))
1500 fld_info(cfld)%ntrange=1
1501 fld_info(cfld)%tinvstat=ifhr-id(18)
1502!$omp parallel do private(i,j,ii,jj)
1503 do j=1,jend-jsta+1
1504 jj = jsta+j-1
1505 do i=1,iend-ista+1
1506 ii = ista+i-1
1507 datapd(i,j,cfld) = grid1(ii,jj)
1508 enddo
1509 enddo
1510 endif
1511 ENDIF
1512!
1513
1514 IF (iget(1002)>0) THEN
1515 IF(asrfc>0.)THEN
1516 rrnum=1./asrfc
1517 ELSE
1518 rrnum=0.
1519 ENDIF
1520 DO j=jsta,jend
1521 DO i=ista,iend
1522 IF(paha(i,j)/=spval)THEN
1523 grid1(i,j)=-1.*paha(i,j)*rrnum !change the sign to conform with Grib
1524 ELSE
1525 grid1(i,j)=paha(i,j)
1526 END IF
1527 ENDDO
1528 ENDDO
1529 id(1:25) = 0
1530 itsrfc = nint(tsrfc)
1531 IF(itsrfc /= 0) then
1532 ifincr = mod(ifhr,itsrfc)
1533 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
1534 ELSE
1535 ifincr = 0
1536 endif
1537 id(19) = ifhr
1538 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
1539 id(20) = 3
1540 IF (ifincr==0) THEN
1541 id(18) = ifhr-itsrfc
1542 ELSE
1543 id(18) = ifhr-ifincr
1544 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
1545 ENDIF
1546 IF (id(18)<0) id(18) = 0
1547 if(grib=='grib2') then
1548 cfld=cfld+1
1549 fld_info(cfld)%ifld=iavblfld(iget(1002))
1550 if(itsrfc>0) then
1551 fld_info(cfld)%ntrange=1
1552 else
1553 fld_info(cfld)%ntrange=0
1554 endif
1555 fld_info(cfld)%tinvstat=ifhr-id(18)
1556 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
1557 endif
1558 ENDIF
1559!
1560!
1561!
1562!*** BLOCK 2. SHELTER (2M) LEVEL FIELDS.
1563!
1564! COMPUTE/POST SHELTER LEVEL FIELDS.
1565!
1566 IF ( (iget(106)>0).OR.(iget(112)>0).OR. &
1567 (iget(113)>0).OR.(iget(114)>0).OR. &
1568 (iget(138)>0).OR.(iget(414)>0).OR. &
1569 (iget(546)>0).OR.(iget(547)>0).OR. &
1570 (iget(548)>0).OR.(iget(558)>0).OR. &
1571 (iget(739)>0).OR.(iget(744)>0)) THEN
1572
1573 if (.not. allocated(psfc)) allocate(psfc(ista:iend,jsta:jend))
1574!
1575!HC COMPUTE SHELTER PRESSURE BECAUSE IT WAS NOT OUTPUT FROM WRF
1576 IF(modelname == 'NCAR' .OR. modelname=='RSM'.OR. modelname=='RAPR')THEN
1577 DO j=jsta,jend
1578 DO i=ista,iend
1579 tlow = t(i,j,nint(lmh(i,j)))
1580 psfc(i,j) = pint(i,j,nint(lmh(i,j))+1) !May not have been set above
1581 pshltr(i,j) = psfc(i,j)*exp(-0.068283/tlow)
1582 ENDDO
1583 ENDDO
1584 ENDIF
1585!
1586! print *,'in, surfc,pshltr=',maxval(PSHLTR(1:im,jsta:jend)), &
1587! minval(PSHLTR(1:im,jsta:jend)),PSHLTR(1:3,jsta),'capa=',capa, &
1588! 'tshlter=',tshltr(1:3,jsta:jsta+2),'psfc=',psfc(1:3,jsta:jsta+2), &
1589! 'th10=',th10(1:3,jsta:jsta+2),'thz0=',thz0(1:3,jsta:jsta+2)
1590!
1591! SHELTER LEVEL TEMPERATURE
1592 IF (iget(106)>0) THEN
1593 grid1=spval
1594 DO j=jsta,jend
1595 DO i=ista,iend
1596! GRID1(I,J)=TSHLTR(I,J)
1597!HC CONVERT FROM THETA TO T
1598 if(tshltr(i,j)/=spval)grid1(i,j)=tshltr(i,j)*(pshltr(i,j)*1.e-5)**capa
1599! IF(GRID1(I,J)<200)PRINT*,'ABNORMAL 2MT ',i,j, &
1600! TSHLTR(I,J),PSHLTR(I,J)
1601!! TSHLTR(I,J)=GRID1(I,J)
1602 ENDDO
1603 ENDDO
1604! print *,'2m tmp=',maxval(TSHLTR(ista:iend,jsta:jend)), &
1605! minval(TSHLTR(ista:iend,jsta:jend)),TSHLTR(1:3,jsta),'grd=',grid1(1:3,jsta)
1606 if(grib=='grib2') then
1607 cfld=cfld+1
1608 fld_info(cfld)%ifld=iavblfld(iget(106))
1609 datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = grid1(ista:iend,jsta:jend)
1610 endif
1611 ENDIF
1612!
1613! SHELTER LEVEL POT TEMP
1614 IF (iget(546)>0) THEN
1615! GRID1=spval
1616! DO J=JSTA,JEND
1617! DO I=ISTA,IEND
1618! GRID1(I,J)=TSHLTR(I,J)
1619! ENDDO
1620! ENDDO
1621 if(grib=='grib2') then
1622 cfld=cfld+1
1623 fld_info(cfld)%ifld=iavblfld(iget(546))
1624 datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = tshltr(ista:iend,jsta:jend)
1625 endif
1626 ENDIF
1627!
1628! SHELTER LEVEL SPECIFIC HUMIDITY.
1629 IF (iget(112)>0) THEN
1630 DO j=jsta,jend
1631 DO i=ista,iend
1632 grid1(i,j) = qshltr(i,j)
1633 ENDDO
1634 ENDDO
1635 CALL bound (grid1,h1m12,h99999)
1636 if(grib=='grib2') then
1637 cfld=cfld+1
1638 fld_info(cfld)%ifld=iavblfld(iget(112))
1639 datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = grid1(ista:iend,jsta:jend)
1640 endif
1641 ENDIF
1642! GRID1
1643! SHELTER MIXING RATIO.
1644 IF (iget(414)>0) THEN
1645 DO j=jsta,jend
1646 DO i=ista,iend
1647 grid1(i,j) = mrshltr(i,j)
1648 ENDDO
1649 ENDDO
1650 if(grib=='grib2') then
1651 cfld=cfld+1
1652 fld_info(cfld)%ifld=iavblfld(iget(414))
1653 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
1654 endif
1655 ENDIF
1656!
1657! SHELTER LEVEL DEWPOINT, DEWPOINT DEPRESSION AND SFC EQUIV POT TEMP.
1658 allocate(p1d(ista:iend,jsta:jend), t1d(ista:iend,jsta:jend))
1659 IF ((iget(113)>0) .OR.(iget(547)>0).OR.(iget(548)>0)) THEN
1660
1661 DO j=jsta,jend
1662 DO i=ista,iend
1663
1664!tgs The next 4 lines are GSD algorithm for Dew Point computation
1665!tgs Results are very close to dew point computed in DEWPOINT subroutine
1666 qv = max(1.e-5,(qshltr(i,j)/(1.-qshltr(i,j))))
1667 e = pshltr(i,j)/100.*qv/(0.62197+qv)
1668 dwpt = (243.5*log(e)-440.8)/(19.48-log(e))+273.15
1669
1670! if(i==335.and.j==295)print*,'Debug: RUC-type DEWPT,i,j' &
1671! if(i==ii.and.j==jj)print*,'Debug: RUC-type DEWPT,i,j'
1672! , DWPT,i,j,qv,pshltr(i,j),qshltr(i,j)
1673
1674! EGRID1(I,J) = DWPT
1675
1676 IF(qshltr(i,j)<spval.and.pshltr(i,j)<spval)THEN
1677 evp(i,j) = pshltr(i,j)*qshltr(i,j)/(eps+oneps*qshltr(i,j))
1678 evp(i,j) = evp(i,j)*d001
1679 ELSE
1680 evp(i,j) = spval
1681 ENDIF
1682 ENDDO
1683 ENDDO
1684 CALL dewpoint(evp,egrid1(ista:iend,jsta:jend))
1685! print *,' MAX DEWPOINT',maxval(egrid1)
1686! DEWPOINT
1687 IF (iget(113)>0) THEN
1688 grid1=spval
1689 if(modelname=='RAPR')THEN
1690 DO j=jsta,jend
1691 DO i=ista,iend
1692! DEWPOINT can't be higher than T2
1693 t2=tshltr(i,j)*(pshltr(i,j)*1.e-5)**capa
1694 if(qshltr(i,j)/=spval)grid1(i,j)=min(egrid1(i,j),t2)
1695 ENDDO
1696 ENDDO
1697 else
1698 DO j=jsta,jend
1699 DO i=ista,iend
1700 if(qshltr(i,j)/=spval) grid1(i,j) = egrid1(i,j)
1701 ENDDO
1702 ENDDO
1703 endif
1704 if(grib=='grib2') then
1705 cfld=cfld+1
1706 fld_info(cfld)%ifld=iavblfld(iget(113))
1707 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
1708 endif
1709 ENDIF
1710
1711
1712!-------------------------------------------------------------------------
1713! DEWPOINT at level 1 ------ p1d and t1d are undefined !! -- Moorthi
1714 IF (iget(558)>0) THEN
1715 DO j=jsta,jend
1716 DO i=ista,iend
1717 evp(i,j)=p1d(i,j)*qvl1(i,j)/(eps+oneps*qvl1(i,j))
1718 evp(i,j)=evp(i,j)*d001
1719 ENDDO
1720 ENDDO
1721 CALL dewpoint(evp,egrid1(ista:iend,jsta:jend))
1722! print *,' MAX DEWPOINT at level 1',maxval(egrid1)
1723 grid1=spval
1724 DO j=jsta,jend
1725 DO i=ista,iend
1726!tgs 30 dec 2013 - 1st leel dewpoint can't be higher than 1-st level temperature
1727 if(qvl1(i,j)/=spval)grid1(i,j) = min(egrid1(i,j),t1d(i,j))
1728 ENDDO
1729 ENDDO
1730 if(grib=='grib2') then
1731 cfld=cfld+1
1732 fld_info(cfld)%ifld=iavblfld(iget(558))
1733 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
1734 endif
1735 ENDIF
1736!-------------------------------------------------------------------------
1737
1738!
1739 IF ((iget(547)>0).OR.(iget(548)>0)) THEN
1740 grid1=spval
1741 grid2=spval
1742 DO j=jsta,jend
1743 DO i=ista,iend
1744 if(tshltr(i,j)/=spval.and.pshltr(i,j)/=spval.and.qshltr(i,j)/=spval) then
1745! DEWPOINT DEPRESSION in GRID1
1746 grid1(i,j)=max(0.,tshltr(i,j)*(pshltr(i,j)*1.e-5)**capa-egrid1(i,j))
1747
1748! SURFACE EQIV POT TEMP in GRID2
1749 ape=(h10e5/pshltr(i,j))**capa
1750 grid2(i,j)=tshltr(i,j)*exp(elocp*qshltr(i,j)*ape/tshltr(i,j))
1751 endif
1752 ENDDO
1753 ENDDO
1754! print *,' MAX/MIN --> DEWPOINT DEPRESSION',maxval(grid1(1:im,jsta:jend)),&
1755! minval(grid1(1:im,jsta:jend))
1756! print *,' MAX/MIN --> SFC EQUIV POT TEMP',maxval(grid2(1:im,jsta:jend)),&
1757! minval(grid2(1:im,jsta:jend))
1758
1759 IF (iget(547)>0) THEN
1760 if(grib=='grib2') then
1761 cfld=cfld+1
1762 fld_info(cfld)%ifld=iavblfld(iget(547))
1763 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
1764 endif
1765
1766 ENDIF
1767 IF (iget(548)>0) THEN
1768 if(grib=='grib2') then
1769 cfld=cfld+1
1770 fld_info(cfld)%ifld=iavblfld(iget(548))
1771 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid2(ista:iend,jsta:jend)
1772 endif
1773 ENDIF
1774 ENDIF
1775
1776
1777 ENDIF
1778!
1779! SHELTER LEVEL RELATIVE HUMIDITY AND APPARENT TEMPERATURE
1780 IF (iget(114) > 0 .OR. iget(808) > 0) THEN
1781 allocate(q1d(ista:iend,jsta:jend))
1782!$omp parallel do private(i,j,llmh)
1783 DO j=jsta,jend
1784 DO i=ista,iend
1785 IF(modelname=='RAPR')THEN
1786 llmh = nint(lmh(i,j))
1787! P1D(I,J)=PINT(I,J,LLMH+1)
1788 p1d(i,j) = pmid(i,j,llmh)
1789 t1d(i,j) = t(i,j,llmh)
1790 ELSE
1791 p1d(i,j) = pshltr(i,j)
1792 t1d(i,j) = tshltr(i,j)*(pshltr(i,j)*1.e-5)**capa
1793 ENDIF
1794 q1d(i,j) = qshltr(i,j)
1795 ENDDO
1796 ENDDO
1797
1798 CALL calrh(p1d,t1d,q1d,egrid1(ista:iend,jsta:jend))
1799
1800 if (allocated(q1d)) deallocate(q1d)
1801!$omp parallel do private(i,j)
1802 DO j=jsta,jend
1803 DO i=ista,iend
1804 if(qshltr(i,j) /= spval)then
1805 grid1(i,j) = egrid1(i,j)*100.
1806 else
1807 grid1(i,j) = spval
1808 end if
1809 ENDDO
1810 ENDDO
1811 CALL bound(grid1,h1,h100)
1812 IF (iget(114) > 0) THEN
1813 if(grib == 'grib2') then
1814 cfld = cfld+1
1815 fld_info(cfld)%ifld = iavblfld(iget(114))
1816!$omp parallel do private(i,j,ii,jj)
1817 do j=1,jend-jsta+1
1818 jj = jsta+j-1
1819 do i=1,iend-ista+1
1820 ii = ista+i-1
1821 datapd(i,j,cfld) = grid1(ii,jj)
1822 enddo
1823 enddo
1824 endif
1825 ENDIF
1826
1827 IF(iget(808)>0)THEN
1828 grid2=spval
1829!$omp parallel do private(i,j,dum1,dum2,dum3,dum216,dum1s,dum3s)
1830 DO j=jsta,jend
1831 DO i=ista,iend
1832 if(t1d(i,j)/=spval.and.u10h(i,j)/=spval.and.v10h(i,j)<spval) then
1833 dum1 = (t1d(i,j)-tfrz)*1.8+32.
1834 dum2 = sqrt(u10h(i,j)**2.0+v10h(i,j)**2.0)/0.44704
1835 dum3 = egrid1(i,j) * 100.0
1836! if(abs(gdlon(i,j)-120.)<1. .and. abs(gdlat(i,j))<1.) &
1837! print*,'Debug AT: INPUT', T1D(i,j),dum1,dum2,dum3
1838 IF(dum1 <= 50.) THEN
1839 dum216 = dum2**0.16
1840 grid2(i,j) = 35.74 + 0.6215*dum1 &
1841 - 35.75*dum216 + 0.4275*dum1*dum216
1842 grid2(i,j) =(grid2(i,j)-32.)/1.8+tfrz
1843 ELSE IF(dum1 > 80.) THEN
1844 dum1s = dum1*dum1
1845 dum3s = dum3*dum3
1846 grid2(i,j) = -42.379 + 2.04901523*dum1 &
1847 + 10.14333127*dum3 &
1848 - 0.22475541*dum1*dum3 &
1849 - 0.00683783*dum1s &
1850 - 0.05481717*dum3s &
1851 + 0.00122874*dum1s*dum3 &
1852 + 0.00085282*dum1*dum3s &
1853 - 0.00000199*dum1s*dum3s
1854 grid2(i,j) = (grid2(i,j)-32.)/1.8 + tfrz
1855 ELSE
1856 grid2(i,j) = t1d(i,j)
1857 END IF
1858! if(abs(gdlon(i,j)-120.)<1. .and. abs(gdlat(i,j))<1.) &
1859! print*,'Debug AT: OUTPUT',Grid2(i,j)
1860 endif
1861 ENDDO
1862 ENDDO
1863
1864 if(grib == 'grib2') then
1865 cfld = cfld+1
1866 fld_info(cfld)%ifld = iavblfld(iget(808))
1867!$omp parallel do private(i,j,ii,jj)
1868 do j=1,jend-jsta+1
1869 jj = jsta+j-1
1870 do i=1,iend-ista+1
1871 ii = ista+i-1
1872 datapd(i,j,cfld) = grid2(ii,jj)
1873 enddo
1874 enddo
1875 endif
1876
1877 ENDIF !for 808
1878
1879 ENDIF ! ENDIF for shleter RH or apparent T
1880
1881 if (allocated(p1d)) deallocate (p1d)
1882 if (allocated(t1d)) deallocate (t1d)
1883!
1884! SHELTER LEVEL PRESSURE.
1885 IF (iget(138)>0) THEN
1886! DO J=JSTA,JEND
1887! DO I=ISTA,IEND
1888! GRID1(I,J)=PSHLTR(I,J)
1889! ENDDO
1890! ENDDO
1891 if(grib=='grib2') then
1892 cfld=cfld+1
1893 fld_info(cfld)%ifld=iavblfld(iget(138))
1894!$omp parallel do private(i,j,ii,jj)
1895 do j=1,jend-jsta+1
1896 jj = jsta+j-1
1897 do i=1,iend-ista+1
1898 ii = ista+i-1
1899 datapd(i,j,cfld) = pshltr(ii,jj)
1900 enddo
1901 enddo
1902 endif
1903 ENDIF
1904!
1905 ENDIF
1906!
1907! SHELTER LEVEL MAX TEMPERATURE.
1908 IF (iget(345)>0) THEN
1909! DO J=JSTA,JEND
1910! DO I=ISTA,IEND
1911! GRID1(I,J)=MAXTSHLTR(I,J)
1912! ENDDO
1913! ENDDO
1914!mp
1915 tmaxmin = max(tmaxmin,1.)
1916!mp
1917 itmaxmin = int(tmaxmin)
1918 IF(itmaxmin /= 0) then
1919 ifincr = mod(ifhr,itmaxmin)
1920 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itmaxmin*60)
1921 ELSE
1922 ifincr = 0
1923 endif
1924 id(19) = ifhr
1925 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
1926 id(20) = 2
1927 IF (ifincr==0) THEN
1928 id(18) = ifhr-itmaxmin
1929 ELSE
1930 id(18) = ifhr-ifincr
1931 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
1932 ENDIF
1933 IF (id(18)<0) id(18) = 0
1934 if(grib=='grib2') then
1935 cfld=cfld+1
1936 fld_info(cfld)%ifld=iavblfld(iget(345))
1937 if(itmaxmin==0) then
1938 fld_info(cfld)%ntrange=0
1939 else
1940 fld_info(cfld)%ntrange=1
1941 endif
1942 fld_info(cfld)%tinvstat=ifhr-id(18)
1943 if(ifhr==0) fld_info(cfld)%tinvstat=0
1944!$omp parallel do private(i,j,ii,jj)
1945 do j=1,jend-jsta+1
1946 jj = jsta+j-1
1947 do i=1,iend-ista+1
1948 ii = ista+i-1
1949 datapd(i,j,cfld) = maxtshltr(ii,jj)
1950 enddo
1951 enddo
1952 endif
1953 ENDIF
1954!
1955! SHELTER LEVEL MIN TEMPERATURE.
1956 IF (iget(346)>0) THEN
1957!!$omp parallel do private(i,j)
1958! DO J=JSTA,JEND
1959! DO I=ISTA,IEND
1960! GRID1(I,J) = MINTSHLTR(I,J)
1961! ENDDO
1962! ENDDO
1963 id(1:25) = 0
1964 itmaxmin = int(tmaxmin)
1965 IF(itmaxmin /= 0) then
1966 ifincr = mod(ifhr,itmaxmin)
1967 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itmaxmin*60)
1968 ELSE
1969 ifincr = 0
1970 endif
1971 id(19) = ifhr
1972 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
1973 id(20) = 2
1974 IF (ifincr==0) THEN
1975 id(18) = ifhr-itmaxmin
1976 ELSE
1977 id(18) = ifhr-ifincr
1978 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
1979 ENDIF
1980 IF (id(18)<0) id(18) = 0
1981 if(grib=='grib2') then
1982 cfld=cfld+1
1983 fld_info(cfld)%ifld=iavblfld(iget(346))
1984 if(itmaxmin==0) then
1985 fld_info(cfld)%ntrange=0
1986 else
1987 fld_info(cfld)%ntrange=1
1988 endif
1989 fld_info(cfld)%tinvstat=ifhr-id(18)
1990 if(ifhr==0) fld_info(cfld)%tinvstat=0
1991!$omp parallel do private(i,j,ii,jj)
1992 do j=1,jend-jsta+1
1993 jj = jsta+j-1
1994 do i=1,iend-ista+1
1995 ii = ista+i-1
1996 datapd(i,j,cfld) = mintshltr(ii,jj)
1997 enddo
1998 enddo
1999 endif
2000 ENDIF
2001!
2002! SHELTER LEVEL MAX RH.
2003 IF (iget(347)>0) THEN
2004 grid1=spval
2005 DO j=jsta,jend
2006 DO i=ista,iend
2007 if(maxrhshltr(i,j)/=spval) grid1(i,j)=maxrhshltr(i,j)*100.
2008 ENDDO
2009 ENDDO
2010 id(1:25) = 0
2011 id(02)=129
2012 itmaxmin = int(tmaxmin)
2013 IF(itmaxmin /= 0) then
2014 ifincr = mod(ifhr,itmaxmin)
2015 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itmaxmin*60)
2016 ELSE
2017 ifincr = 0
2018 endif
2019 id(19) = ifhr
2020 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
2021 id(20) = 2
2022 IF (ifincr==0) THEN
2023 id(18) = ifhr-itmaxmin
2024 ELSE
2025 id(18) = ifhr-ifincr
2026 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
2027 ENDIF
2028 IF (id(18)<0) id(18) = 0
2029 if(grib=='grib2') then
2030 cfld=cfld+1
2031 fld_info(cfld)%ifld=iavblfld(iget(347))
2032 if(itmaxmin==0) then
2033 fld_info(cfld)%ntrange=0
2034 else
2035!Meng 03/2019
2036! fld_info(cfld)%ntrange=(IFHR-ID(18))/ITMAXMIN
2037 fld_info(cfld)%ntrange=1
2038 endif
2039! fld_info(cfld)%tinvstat=ITMAXMIN
2040 fld_info(cfld)%tinvstat=ifhr-id(18)
2041 if(ifhr==0) fld_info(cfld)%tinvstat=0
2042! print*,'id(18),tinvstat,IFHR,ITMAXMIN in rhmax= ',ID(18),fld_info(cfld)%tinvstat, &
2043! IFHR, ITMAXMIN
2044!$omp parallel do private(i,j,ii,jj)
2045 do j=1,jend-jsta+1
2046 jj = jsta+j-1
2047 do i=1,iend-ista+1
2048 ii = ista+i-1
2049 datapd(i,j,cfld) = grid1(ii,jj)
2050 enddo
2051 enddo
2052 endif
2053 ENDIF
2054!
2055! SHELTER LEVEL MIN RH.
2056 IF (iget(348)>0) THEN
2057 grid1=spval
2058 DO j=jsta,jend
2059 DO i=ista,iend
2060 if(minrhshltr(i,j)/=spval) grid1(i,j)=minrhshltr(i,j)*100.
2061 ENDDO
2062 ENDDO
2063 id(1:25) = 0
2064 id(02)=129
2065 itmaxmin = int(tmaxmin)
2066 IF(itmaxmin /= 0) then
2067 ifincr = mod(ifhr,itmaxmin)
2068 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itmaxmin*60)
2069 ELSE
2070 ifincr = 0
2071 endif
2072 id(19) = ifhr
2073 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
2074 id(20) = 2
2075 IF (ifincr==0) THEN
2076 id(18) = ifhr-itmaxmin
2077 ELSE
2078 id(18) = ifhr-ifincr
2079 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
2080 ENDIF
2081 IF (id(18)<0) id(18) = 0
2082 if(grib=='grib2') then
2083 cfld=cfld+1
2084 fld_info(cfld)%ifld=iavblfld(iget(348))
2085 if(itmaxmin==0) then
2086 fld_info(cfld)%ntrange=0
2087 else
2088!Meng 03/2019
2089! fld_info(cfld)%ntrange=(IFHR-ID(18))/ITMAXMIN
2090 fld_info(cfld)%ntrange=1
2091 endif
2092! fld_info(cfld)%tinvstat=ITMAXMIN
2093 fld_info(cfld)%tinvstat=ifhr-id(18)
2094 if(ifhr==0) fld_info(cfld)%tinvstat=0
2095!$omp parallel do private(i,j,ii,jj)
2096 do j=1,jend-jsta+1
2097 jj = jsta+j-1
2098 do i=1,iend-ista+1
2099 ii = ista+i-1
2100 datapd(i,j,cfld) = grid1(ii,jj)
2101 enddo
2102 enddo
2103 endif
2104 ENDIF
2105
2106!
2107! SHELTER LEVEL MAX SPFH
2108 IF (iget(510)>0) THEN
2109 id(1:25) = 0
2110 itmaxmin = int(tmaxmin)
2111 IF(itmaxmin /= 0) then
2112 ifincr = mod(ifhr,itmaxmin)
2113 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itmaxmin*60)
2114 ELSE
2115 ifincr = 0
2116 endif
2117 id(19) = ifhr
2118 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
2119 id(20) = 2
2120 IF (ifincr==0) THEN
2121 id(18) = ifhr-itmaxmin
2122 ELSE
2123 id(18) = ifhr-ifincr
2124 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
2125 ENDIF
2126 IF (id(18)<0) id(18) = 0
2127 if(grib=='grib2') then
2128 cfld=cfld+1
2129 fld_info(cfld)%ifld=iavblfld(iget(510))
2130 if(itmaxmin==0) then
2131 fld_info(cfld)%ntrange=0
2132 else
2133 fld_info(cfld)%ntrange=1
2134 endif
2135 fld_info(cfld)%tinvstat=ifhr-id(18)
2136!$omp parallel do private(i,j,ii,jj)
2137 do j=1,jend-jsta+1
2138 jj = jsta+j-1
2139 do i=1,iend-ista+1
2140 ii = ista+i-1
2141 datapd(i,j,cfld) = maxqshltr(ii,jj)
2142 enddo
2143 enddo
2144 endif
2145 ENDIF
2146!
2147! SHELTER LEVEL MIN SPFH
2148 IF (iget(511)>0) THEN
2149 id(1:25) = 0
2150 itmaxmin = int(tmaxmin)
2151 IF(itmaxmin /= 0) then
2152 ifincr = mod(ifhr,itmaxmin)
2153 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itmaxmin*60)
2154 ELSE
2155 ifincr = 0
2156 endif
2157 id(19) = ifhr
2158 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
2159 id(20) = 2
2160 IF (ifincr==0) THEN
2161 id(18) = ifhr-itmaxmin
2162 ELSE
2163 id(18) = ifhr-ifincr
2164 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
2165 ENDIF
2166 IF (id(18)<0) id(18) = 0
2167 if(grib=='grib2') then
2168 cfld=cfld+1
2169 fld_info(cfld)%ifld=iavblfld(iget(511))
2170 if(itmaxmin==0) then
2171 fld_info(cfld)%ntrange=0
2172 else
2173 fld_info(cfld)%ntrange=1
2174 endif
2175 fld_info(cfld)%tinvstat=ifhr-id(18)
2176!$omp parallel do private(i,j,ii,jj)
2177 do j=1,jend-jsta+1
2178 jj = jsta+j-1
2179 do i=1,iend-ista+1
2180 ii = ista+i-1
2181 datapd(i,j,cfld) = minqshltr(ii,jj)
2182 enddo
2183 enddo
2184 endif
2185 ENDIF
2186!
2187! E. James - 12 Sep 2018: SMOKE from WRF-CHEM on lowest model level
2188!
2189 IF (iget(739)>0) THEN
2190 grid1=spval
2191 DO j=jsta,jend
2192 DO i=ista,iend
2193 if(t(i,j,lm)/=spval.and.pmid(i,j,lm)/=spval.and.smoke(i,j,lm,1)/=spval)&
2194 grid1(i,j) = (1./rd)*(pmid(i,j,lm)/t(i,j,lm))*smoke(i,j,lm,1)/(1e9)
2195 ENDDO
2196 ENDDO
2197 if(grib=='grib2') then
2198 cfld=cfld+1
2199 fld_info(cfld)%ifld=iavblfld(iget(739))
2200 datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = grid1(ista:iend,jsta:jend)
2201 endif
2202 ENDIF
2203!
2204! E. James - 14 Sep 2022: DUST from RRFS on lowest model level
2205!
2206 IF (iget(744)>0) THEN
2207 grid1=spval
2208 DO j=jsta,jend
2209 DO i=ista,iend
2210 if(t(i,j,lm)/=spval.and.pmid(i,j,lm)/=spval.and.fv3dust(i,j,lm,1)/=spval)&
2211 grid1(i,j) = (1./rd)*(pmid(i,j,lm)/t(i,j,lm))*fv3dust(i,j,lm,1)/(1e9)
2212 ENDDO
2213 ENDDO
2214 if(grib=='grib2') then
2215 cfld=cfld+1
2216 fld_info(cfld)%ifld=iavblfld(iget(744))
2217 datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = grid1(ista:iend,jsta:jend)
2218 endif
2219 ENDIF
2220!
2221! Hourly averaged surface PM2.5
2222!
2223 IF (iget(759)>0) THEN
2224 grid1=spval
2225 DO j=jsta,jend
2226 DO i=ista,iend
2227 if(t(i,j,lm)/=spval.and.pmid(i,j,lm)/=spval.and.smoke_ave(i,j)/=spval)&
2228 grid1(i,j) = (1./rd)*(pmid(i,j,lm)/t(i,j,lm))*(smoke_ave(i,j)+dust_ave(i,j))/(1e9)
2229 ENDDO
2230 ENDDO
2231 id(1:25) = 0
2232 itsrfc = nint(tsrfc)
2233 IF(itsrfc /= 0) then
2234 ifincr = mod(ifhr,itsrfc)
2235 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
2236 ELSE
2237 ifincr = 0
2238 ENDIF
2239 id(19) = ifhr
2240 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
2241 id(20) = 3
2242 IF (ifincr==0) THEN
2243 id(18) = ifhr-itsrfc
2244 ELSE
2245 id(18) = ifhr-ifincr
2246 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
2247 ENDIF
2248 IF (id(18)<0) id(18) = 0
2249 if(grib=='grib2') then
2250 cfld=cfld+1
2251 fld_info(cfld)%ifld=iavblfld(iget(759))
2252 if(itsrfc>0) then
2253 fld_info(cfld)%ntrange=1
2254 else
2255 fld_info(cfld)%ntrange=0
2256 endif
2257 fld_info(cfld)%tinvstat=ifhr-id(18)
2258 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
2259 endif
2260 ENDIF
2261!
2262! Hourly averaged dust PM10
2263!
2264 IF (iget(771)>0) THEN
2265 grid1=spval
2266 DO j=jsta,jend
2267 DO i=ista,iend
2268 if(t(i,j,lm)/=spval.and.pmid(i,j,lm)/=spval.and.dust_ave(i,j)/=spval)&
2269 grid1(i,j) = (1./rd)*(pmid(i,j,lm)/t(i,j,lm))*(smoke_ave(i,j)+dust_ave(i,j)+coarsepm_ave(i,j))/(1e9)
2270 ENDDO
2271 ENDDO
2272 id(1:25) = 0
2273 itsrfc = nint(tsrfc)
2274 IF(itsrfc /= 0) then
2275 ifincr = mod(ifhr,itsrfc)
2276 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
2277 ELSE
2278 ifincr = 0
2279 ENDIF
2280 id(19) = ifhr
2281 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
2282 id(20) = 3
2283 IF (ifincr==0) THEN
2284 id(18) = ifhr-itsrfc
2285 ELSE
2286 id(18) = ifhr-ifincr
2287 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
2288 ENDIF
2289 IF (id(18)<0) id(18) = 0
2290 if(grib=='grib2') then
2291 cfld=cfld+1
2292 fld_info(cfld)%ifld=iavblfld(iget(771))
2293 if(itsrfc>0) then
2294 fld_info(cfld)%ntrange=1
2295 else
2296 fld_info(cfld)%ntrange=0
2297 endif
2298 fld_info(cfld)%tinvstat=ifhr-id(18)
2299 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
2300 endif
2301 ENDIF
2302!
2303! E. James - 23 Feb 2023: COARSEPM from RRFS on lowest model level
2304!
2305 IF (iget(1014)>0) THEN
2306 grid1=spval
2307 DO j=jsta,jend
2308 DO i=ista,iend
2309 if(t(i,j,lm)/=spval.and.pmid(i,j,lm)/=spval.and.coarsepm(i,j,lm,1)/=spval)&
2310 grid1(i,j) = (1./rd)*(pmid(i,j,lm)/t(i,j,lm))*coarsepm(i,j,lm,1)/(1e9)
2311 ENDDO
2312 ENDDO
2313 if(grib=='grib2') then
2314 cfld=cfld+1
2315 fld_info(cfld)%ifld=iavblfld(iget(1014))
2316 datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = grid1(ista:iend,jsta:jend)
2317 endif
2318 ENDIF
2319!
2320! E. James - 23 Apr 2024: EBB from RRFS on lowest model level
2321!
2322 IF (iget(1017)>0) THEN
2323 grid1=spval
2324 DO j=jsta,jend
2325 DO i=ista,iend
2326 grid1(i,j) = ebb(i,j,lm,1)/(1e9)
2327 ENDDO
2328 ENDDO
2329 if(grib=='grib2') then
2330 cfld=cfld+1
2331 fld_info(cfld)%ifld=iavblfld(iget(1017))
2332 datapd(1:iend-ista+1,1:jend-jsta+1,cfld) = grid1(ista:iend,jsta:jend)
2333 endif
2334 ENDIF
2335!
2336!
2337! BLOCK 3. ANEMOMETER LEVEL (10M) WINDS, THETA, AND Q.
2338!
2339 IF ( (iget(064)>0).OR.(iget(065)>0).OR. &
2340 (iget(506)>0).OR.(iget(507)>0) ) THEN
2341!
2342! ANEMOMETER LEVEL U WIND AND/OR V WIND.
2343 IF ((iget(064)>0).OR.(iget(065)>0)) THEN
2344!$omp parallel do private(i,j)
2345 DO j=jsta,jend
2346 DO i=ista,iend
2347 grid1(i,j) = u10(i,j)
2348 grid2(i,j) = v10(i,j)
2349 ENDDO
2350 ENDDO
2351 if(grib=='grib2') then
2352 cfld=cfld+1
2353 fld_info(cfld)%ifld=iavblfld(iget(064))
2354!$omp parallel do private(i,j,ii,jj)
2355 do j=1,jend-jsta+1
2356 jj = jsta+j-1
2357 do i=1,iend-ista+1
2358 ii = ista+i-1
2359 datapd(i,j,cfld) = grid1(ii,jj)
2360 enddo
2361 enddo
2362 cfld=cfld+1
2363 fld_info(cfld)%ifld=iavblfld(iget(065))
2364!$omp parallel do private(i,j,ii,jj)
2365 do j=1,jend-jsta+1
2366 jj = jsta+j-1
2367 do i=1,iend-ista+1
2368 ii = ista+i-1
2369 datapd(i,j,cfld) = grid2(ii,jj)
2370 enddo
2371 enddo
2372 endif
2373 ENDIF
2374! GSD - Time-averaged wind speed (forecast time labels will all be in minutes)
2375 IF (iget(730)>0) THEN
2376 ifincr = 5
2377 DO j=jsta,jend
2378 DO i=ista,iend
2379 grid1(i,j)=spduv10mean(i,j)
2380 ENDDO
2381 ENDDO
2382 if(grib=='grib2') then
2383! print*,'Outputting time-averaged winds'
2384 cfld=cfld+1
2385 fld_info(cfld)%ifld=iavblfld(iget(730))
2386 if(fld_info(cfld)%ntrange==0) then
2387 if (ifhr==0 .and. ifmin==0) then
2388 fld_info(cfld)%tinvstat=0
2389 else
2390 fld_info(cfld)%tinvstat=ifincr
2391 endif
2392 fld_info(cfld)%ntrange=1
2393 end if
2394 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
2395 endif
2396 ENDIF
2397!---
2398! GSD - Time-averaged U wind speed (forecast time labels will all be in minutes)
2399 IF (iget(731)>0) THEN
2400 ifincr = 5
2401 DO j=jsta,jend
2402 DO i=ista,iend
2403 grid1(i,j)=u10mean(i,j)
2404 ENDDO
2405 ENDDO
2406 if(grib=='grib2') then
2407 cfld=cfld+1
2408 fld_info(cfld)%ifld=iavblfld(iget(731))
2409 if(fld_info(cfld)%ntrange==0) then
2410 if (ifhr==0 .and. ifmin==0) then
2411 fld_info(cfld)%tinvstat=0
2412 else
2413 fld_info(cfld)%tinvstat=ifincr
2414 endif
2415 fld_info(cfld)%ntrange=1
2416 end if
2417 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
2418 endif
2419 ENDIF
2420! GSD - Time-averaged V wind speed (forecast time labels will all be in minutes)
2421 IF (iget(732)>0) THEN
2422 ifincr = 5
2423 DO j=jsta,jend
2424 DO i=ista,iend
2425 grid1(i,j)=v10mean(i,j)
2426 ENDDO
2427 ENDDO
2428 if(grib=='grib2') then
2429 cfld=cfld+1
2430 fld_info(cfld)%ifld=iavblfld(iget(732))
2431 if(fld_info(cfld)%ntrange==0) then
2432 if (ifhr==0 .and. ifmin==0) then
2433 fld_info(cfld)%tinvstat=0
2434 else
2435 fld_info(cfld)%tinvstat=ifincr
2436 endif
2437 fld_info(cfld)%ntrange=1
2438 end if
2439 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
2440 endif
2441 ENDIF
2442! Time-averaged SWDOWN (forecast time labels will all be in minutes)
2443 IF (iget(733)>0 )THEN
2444 ifincr = 15
2445 DO j=jsta,jend
2446 DO i=ista,iend
2447 grid1(i,j) = swradmean(i,j)
2448 ENDDO
2449 ENDDO
2450 if(grib=='grib2') then
2451 cfld=cfld+1
2452 fld_info(cfld)%ifld=iavblfld(iget(733))
2453 if(fld_info(cfld)%ntrange==0) then
2454 if (ifhr==0 .and. ifmin==0) then
2455 fld_info(cfld)%tinvstat=0
2456 else
2457 fld_info(cfld)%tinvstat=ifincr
2458 endif
2459 fld_info(cfld)%ntrange=1
2460 end if
2461 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
2462 endif
2463 ENDIF
2464! Time-averaged SWNORM (forecast time labels will all be in minutes)
2465 IF (iget(734)>0 )THEN
2466 ifincr = 15
2467 DO j=jsta,jend
2468 DO i=ista,iend
2469 grid1(i,j) = swnormmean(i,j)
2470 ENDDO
2471 ENDDO
2472 if(grib=='grib2') then
2473 cfld=cfld+1
2474 fld_info(cfld)%ifld=iavblfld(iget(734))
2475 if(fld_info(cfld)%ntrange==0) then
2476 if (ifhr==0 .and. ifmin==0) then
2477 fld_info(cfld)%tinvstat=0
2478 else
2479 fld_info(cfld)%tinvstat=ifincr
2480 endif
2481 fld_info(cfld)%ntrange=1
2482 endif
2483 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
2484 endif
2485 ENDIF
2486!
2487 IF ((iget(506)>0).OR.(iget(507)>0)) THEN
2488 id(02)=129
2489 id(20) = 2
2490 id(19) = ifhr
2491 IF (ifhr==0) THEN
2492 id(18) = 0
2493 ELSE
2494 id(18) = ifhr - 1
2495 ENDIF
2496!$omp parallel do private(i,j)
2497 DO j=jsta,jend
2498 DO i=ista,iend
2499 grid1(i,j) = u10max(i,j)
2500 grid2(i,j) = v10max(i,j)
2501 ENDDO
2502 ENDDO
2503 itsrfc = nint(tsrfc)
2504 if(grib=='grib2') then
2505 cfld=cfld+1
2506 fld_info(cfld)%ifld=iavblfld(iget(506))
2507 if(itsrfc>0) then
2508 fld_info(cfld)%ntrange=1
2509 else
2510 fld_info(cfld)%ntrange=0
2511 endif
2512 fld_info(cfld)%tinvstat=ifhr-id(18)
2513!$omp parallel do private(i,j,ii,jj)
2514 do j=1,jend-jsta+1
2515 jj = jsta+j-1
2516 do i=1,iend-ista+1
2517 ii = ista+i-1
2518 datapd(i,j,cfld) = grid1(ii,jj)
2519 enddo
2520 enddo
2521 cfld=cfld+1
2522 fld_info(cfld)%ifld=iavblfld(iget(507))
2523 if(itsrfc>0) then
2524 fld_info(cfld)%ntrange=1
2525 else
2526 fld_info(cfld)%ntrange=0
2527 endif
2528 fld_info(cfld)%tinvstat=ifhr-id(18)
2529!$omp parallel do private(i,j,ii,jj)
2530 do j=1,jend-jsta+1
2531 jj = jsta+j-1
2532 do i=1,iend-ista+1
2533 ii = ista+i-1
2534 datapd(i,j,cfld) = grid2(ii,jj)
2535 enddo
2536 enddo
2537 endif
2538 ENDIF
2539
2540 ENDIF
2541!
2542! ANEMOMETER LEVEL (10 M) POTENTIAL TEMPERATURE.
2543! NOT A OUTPUT FROM WRF
2544 IF (iget(158)>0) THEN
2545!$omp parallel do private(i,j)
2546 DO j=jsta,jend
2547 DO i=ista,iend
2548 grid1(i,j)=th10(i,j)
2549 ENDDO
2550 ENDDO
2551 if(grib=='grib2') then
2552 cfld=cfld+1
2553 fld_info(cfld)%ifld=iavblfld(iget(158))
2554!$omp parallel do private(i,j,ii,jj)
2555 do j=1,jend-jsta+1
2556 jj = jsta+j-1
2557 do i=1,iend-ista+1
2558 ii = ista+i-1
2559 datapd(i,j,cfld) = grid1(ii,jj)
2560 enddo
2561 enddo
2562 endif
2563 ENDIF
2564
2565! ANEMOMETER LEVEL (10 M) SENSIBLE TEMPERATURE.
2566! NOT A OUTPUT FROM WRF
2567 IF (iget(505)>0) THEN
2568!$omp parallel do private(i,j)
2569 DO j=jsta,jend
2570 DO i=ista,iend
2571 grid1(i,j)=t10m(i,j)
2572 ENDDO
2573 ENDDO
2574 if(grib=='grib2') then
2575 cfld=cfld+1
2576 fld_info(cfld)%ifld=iavblfld(iget(505))
2577!$omp parallel do private(i,j,ii,jj)
2578 do j=1,jend-jsta+1
2579 jj = jsta+j-1
2580 do i=1,iend-ista+1
2581 ii = ista+i-1
2582 datapd(i,j,cfld) = grid1(ii,jj)
2583 enddo
2584 enddo
2585 endif
2586 ENDIF
2587!
2588! ANEMOMETER LEVEL (10 M) SPECIFIC HUMIDITY.
2589!
2590 IF (iget(159)>0) THEN
2591!$omp parallel do private(i,j)
2592 DO j=jsta,jend
2593 DO i=ista,iend
2594 grid1(i,j) = q10(i,j)
2595 ENDDO
2596 ENDDO
2597 if(grib=='grib2') then
2598 cfld=cfld+1
2599 fld_info(cfld)%ifld=iavblfld(iget(159))
2600!$omp parallel do private(i,j,ii,jj)
2601 do j=1,jend-jsta+1
2602 jj = jsta+j-1
2603 do i=1,iend-ista+1
2604 ii = ista+i-1
2605 datapd(i,j,cfld) = grid1(ii,jj)
2606 enddo
2607 enddo
2608 endif
2609 ENDIF
2610!
2611! SRD
2612!
2613! ANEMOMETER LEVEL (10 M) MAX WIND SPEED.
2614!
2615 IF (iget(422)>0) THEN
2616 IF (modelname == 'GFS') THEN
2617 id(1:25) = 0
2618 itsrfc = nint(tsrfc)
2619 if (itsrfc /= 0) then
2620 ifincr = mod(ifhr,itsrfc)
2621 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
2622 else
2623 ifincr = 0
2624 endif
2625 id(18) = 0
2626 id(19) = ifhr
2627 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
2628 id(20) = 4
2629 IF (ifincr==0) THEN
2630 id(18) = ifhr-itsrfc
2631 ELSE
2632 id(18) = ifhr-ifincr
2633 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
2634 ENDIF
2635 IF (id(18)<0) id(18) = 0
2636 ENDIF
2637!$omp parallel do private(i,j)
2638 DO j=jsta,jend
2639 DO i=ista,iend
2640 grid1(i,j) = wspd10max(i,j)
2641 ENDDO
2642 ENDDO
2643 if(grib=='grib2') then
2644 cfld=cfld+1
2645 fld_info(cfld)%ifld=iavblfld(iget(422))
2646 fld_info(cfld)%ntrange=1
2647 IF (modelname == 'FV3R' .OR. modelname == 'RAPR') THEN
2648 if (ifhr==0) then
2649 fld_info(cfld)%tinvstat=0
2650 else
2651 fld_info(cfld)%tinvstat=1
2652 endif
2653 ELSE IF (modelname == 'GFS') THEN
2654 fld_info(cfld)%tinvstat=ifhr-id(18)
2655 ENDIF
2656!$omp parallel do private(i,j,ii,jj)
2657 do j=1,jend-jsta+1
2658 jj = jsta+j-1
2659 do i=1,iend-ista+1
2660 ii = ista+i-1
2661 datapd(i,j,cfld) = grid1(ii,jj)
2662 enddo
2663 enddo
2664 endif
2665 ENDIF
2666!
2667! ANEMOMETER LEVEL (10 M) MAX WIND SPEED U COMPONENT.
2668!
2669 IF (iget(783)>0) THEN
2670 IF (modelname == 'GFS') THEN
2671 id(1:25) = 0
2672 itsrfc = nint(tsrfc)
2673 if (itsrfc /= 0) then
2674 ifincr = mod(ifhr,itsrfc)
2675 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
2676 else
2677 ifincr = 0
2678 endif
2679 id(18) = 0
2680 id(19) = ifhr
2681 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
2682 id(20) = 4
2683 IF (ifincr==0) THEN
2684 id(18) = ifhr-itsrfc
2685 ELSE
2686 id(18) = ifhr-ifincr
2687 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
2688 ENDIF
2689 IF (id(18)<0) id(18) = 0
2690 ENDIF
2691!$omp parallel do private(i,j)
2692 DO j=jsta,jend
2693 DO i=ista,iend
2694 grid1(i,j) = wspd10umax(i,j)
2695 ENDDO
2696 ENDDO
2697 if(grib=='grib2') then
2698 cfld=cfld+1
2699 fld_info(cfld)%ifld=iavblfld(iget(783))
2700 fld_info(cfld)%ntrange=1
2701 IF (modelname == 'RAPR') THEN
2702 if (ifhr==0) then
2703 fld_info(cfld)%tinvstat=0
2704 else
2705 fld_info(cfld)%tinvstat=1
2706 endif
2707 ELSE IF (modelname == 'GFS') THEN
2708 fld_info(cfld)%tinvstat=ifhr-id(18)
2709 ENDIF
2710!$omp parallel do private(i,j,ii,jj)
2711 do j=1,jend-jsta+1
2712 jj = jsta+j-1
2713 do i=1,iend-ista+1
2714 ii = ista+i-1
2715 datapd(i,j,cfld) = grid1(ii,jj)
2716 enddo
2717 enddo
2718 endif
2719 ENDIF
2720!
2721! ANEMOMETER LEVEL (10 M) MAX WIND SPEED V COMPONENT.
2722!
2723 IF (iget(784)>0) THEN
2724 IF (modelname == 'GFS') THEN
2725 id(1:25) = 0
2726 itsrfc = nint(tsrfc)
2727 if (itsrfc /= 0) then
2728 ifincr = mod(ifhr,itsrfc)
2729 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
2730 else
2731 ifincr = 0
2732 endif
2733 id(18) = 0
2734 id(19) = ifhr
2735 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
2736 id(20) = 4
2737 IF (ifincr==0) THEN
2738 id(18) = ifhr-itsrfc
2739 ELSE
2740 id(18) = ifhr-ifincr
2741 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
2742 ENDIF
2743 IF (id(18)<0) id(18) = 0
2744 ENDIF
2745!$omp parallel do private(i,j)
2746 DO j=jsta,jend
2747 DO i=ista,iend
2748 grid1(i,j) = wspd10vmax(i,j)
2749 ENDDO
2750 ENDDO
2751 if(grib=='grib2') then
2752 cfld=cfld+1
2753 fld_info(cfld)%ifld=iavblfld(iget(784))
2754 fld_info(cfld)%ntrange=1
2755 IF (modelname == 'RAPR') THEN
2756 if (ifhr==0) then
2757 fld_info(cfld)%tinvstat=0
2758 else
2759 fld_info(cfld)%tinvstat=1
2760 endif
2761 ELSE IF (modelname == 'GFS') THEN
2762 fld_info(cfld)%tinvstat=ifhr-id(18)
2763 ENDIF
2764!$omp parallel do private(i,j,ii,jj)
2765 do j=1,jend-jsta+1
2766 jj = jsta+j-1
2767 do i=1,iend-ista+1
2768 ii = ista+i-1
2769 datapd(i,j,cfld) = grid1(i,jj)
2770 enddo
2771 enddo
2772 endif
2773 ENDIF
2774!
2775! SRD
2776!
2777
2778! Ice Growth Rate
2779!
2780 IF (iget(588)>0) THEN
2781
2782 CALL calvessel(iceg(ista:iend,jsta:jend))
2783
2784 DO j=jsta,jend
2785 DO i=ista,iend
2786 grid1(i,j) = iceg(i,j)
2787 ENDDO
2788 ENDDO
2789
2790 if(grib=='grib2') then
2791 cfld=cfld+1
2792 fld_info(cfld)%ifld=iavblfld(iget(588))
2793 if (ifhr==0) then
2794 fld_info(cfld)%tinvstat=0
2795 else
2796 fld_info(cfld)%tinvstat=1
2797 endif
2798 fld_info(cfld)%ntrange=1
2799
2800!$omp parallel do private(i,j,ii,jj)
2801 do j=1,jend-jsta+1
2802 jj = jsta+j-1
2803 do i=1,iend-ista+1
2804 ii = ista+i-1
2805 datapd(i,j,cfld) = grid1(ii,jj)
2806 enddo
2807 enddo
2808 endif
2809
2810 ENDIF
2811
2812!
2813!*** BLOCK 4. PRECIPITATION RELATED FIELDS.
2814!MEB 6/17/02 ASSUMING THAT ALL ACCUMULATED FIELDS NEVER EMPTY
2815! THEIR BUCKETS. THIS IS THE EASIEST WAY TO DEAL WITH
2816! ACCUMULATED FIELDS. SHORTER TIME ACCUMULATIONS CAN
2817! BE COMPUTED AFTER THE FACT IN A SEPARATE CODE ONCE
2818! THE POST HAS FINISHED. I HAVE LEFT IN THE OLD
2819! ETAPOST CODE FOR COMPUTING THE BEGINNING TIME OF
2820! THE ACCUMULATION PERIOD IF THIS IS CHANGED BACK
2821! TO A 12H OR 3H BUCKET. I AM NOT SURE WHAT
2822! TO DO WITH THE TIME AVERAGED FIELDS, SO
2823! LEAVING THAT UNCHANGED.
2824!
2825! SNOW FRACTION FROM EXPLICIT CLOUD SCHEME. LABELLED AS
2826! 'PROB OF FROZEN PRECIP' IN GRIB,
2827! DIDN'T KNOW WHAT ELSE TO CALL IT
2828 IF (iget(172)>0) THEN
2829!$omp parallel do private(i,j)
2830 DO j=jsta,jend
2831 DO i=ista,iend
2832 IF (prec(i,j) <= pthresh .OR. sr(i,j)==spval) THEN
2833 grid1(i,j) = -50.
2834 ELSE
2835 grid1(i,j) = sr(i,j)*100.
2836 ENDIF
2837 ENDDO
2838 ENDDO
2839 if(grib=='grib2') then
2840 cfld=cfld+1
2841 fld_info(cfld)%ifld=iavblfld(iget(172))
2842!$omp parallel do private(i,j,ii,jj)
2843 do j=1,jend-jsta+1
2844 jj = jsta+j-1
2845 do i=1,iend-ista+1
2846 ii = ista+i-1
2847 datapd(i,j,cfld) = grid1(ii,jj)
2848 enddo
2849 enddo
2850 endif
2851 ENDIF
2852!
2853! INSTANTANEOUS CONVECTIVE PRECIPITATION RATE.
2854! SUBSTITUTE WITH CUPPT IN WRF FOR NOW
2855 IF (iget(249)>0) THEN
2856 rdtphs=1000./dtq2 !--- 1000 kg/m**3, density of liquid water
2857! RDTPHS=1000./(TRDLW*3600.)
2858 grid1=spval
2859!$omp parallel do private(i,j)
2860 DO j=jsta,jend
2861 DO i=ista,iend
2862 if(cprate(i,j)/=spval) grid1(i,j) = cprate(i,j)*rdtphs
2863! GRID1(I,J) = CUPPT(I,J)*RDTPHS
2864 ENDDO
2865 ENDDO
2866 if(grib=='grib2') then
2867 cfld=cfld+1
2868 fld_info(cfld)%ifld=iavblfld(iget(249))
2869!$omp parallel do private(i,j,ii,jj)
2870 do j=1,jend-jsta+1
2871 jj = jsta+j-1
2872 do i=1,iend-ista+1
2873 ii = ista+i-1
2874 datapd(i,j,cfld) = grid1(ii,jj)
2875 enddo
2876 enddo
2877 endif
2878 ENDIF
2879!
2880! INSTANTANEOUS PRECIPITATION RATE.
2881 IF (iget(167)>0) THEN
2882!MEB need to get physics DT
2883 rdtphs=1./(dtq2)
2884!MEB need to get physics DT
2885 grid1=spval
2886!$omp parallel do private(i,j)
2887 DO j=jsta,jend
2888 DO i=ista,iend
2889 if(prec(i,j)/=spval) then
2890 IF(modelname /= 'RSM') THEN
2891 grid1(i,j) = prec(i,j)*rdtphs*1000.
2892 ELSE !Add by Binbin
2893 grid1(i,j) = prec(i,j)
2894 END IF
2895 endif
2896 ENDDO
2897 ENDDO
2898 if(grib=='grib2') then
2899 cfld=cfld+1
2900 fld_info(cfld)%ifld=iavblfld(iget(167))
2901!$omp parallel do private(i,j,ii,jj)
2902 do j=1,jend-jsta+1
2903 jj = jsta+j-1
2904 do i=1,iend-ista+1
2905 ii = ista+i-1
2906 datapd(i,j,cfld) = grid1(ii,jj)
2907 enddo
2908 enddo
2909 endif
2910 ENDIF
2911!
2912! MAXIMUM INSTANTANEOUS PRECIPITATION RATE.
2913 IF (iget(508)>0) THEN
2914 IF (ifhr==0) THEN
2915 id(18) = 0
2916 ELSE
2917 id(18) = ifhr - 1
2918 ENDIF
2919!-- PRATE_MAX in units of mm/h from NMMB history files
2920 grid1=spval
2921 DO j=jsta,jend
2922 DO i=ista,iend
2923 if(prate_max(i,j)/=spval) grid1(i,j)=prate_max(i,j)*sec2hr
2924 ENDDO
2925 ENDDO
2926 itsrfc = nint(tsrfc)
2927 if(grib=='grib2') then
2928 cfld=cfld+1
2929 fld_info(cfld)%ifld=iavblfld(iget(508))
2930 fld_info(cfld)%lvl=lvlsxml(1,iget(508))
2931 if(itsrfc>0) then
2932 fld_info(cfld)%ntrange=1
2933 else
2934 fld_info(cfld)%ntrange=0
2935 endif
2936 fld_info(cfld)%tinvstat=ifhr-id(18)
2937!$omp parallel do private(i,j,ii,jj)
2938 do j=1,jend-jsta+1
2939 jj = jsta+j-1
2940 do i=1,iend-ista+1
2941 ii = ista+i-1
2942 datapd(i,j,cfld) = grid1(ii,jj)
2943 enddo
2944 enddo
2945 endif
2946 ENDIF
2947!
2948! MAXIMUM INSTANTANEOUS *FROZEN* PRECIPITATION RATE.
2949 IF (iget(509)>0) THEN
2950!-- FPRATE_MAX in units of mm/h from NMMB history files
2951 grid1=spval
2952 DO j=jsta,jend
2953 DO i=ista,iend
2954 if(fprate_max(i,j)/=spval) grid1(i,j)=fprate_max(i,j)*sec2hr
2955 ENDDO
2956 ENDDO
2957 if(grib=='grib2') then
2958 cfld=cfld+1
2959 fld_info(cfld)%ifld=iavblfld(iget(509))
2960 fld_info(cfld)%lvl=lvlsxml(1,iget(509))
2961 fld_info(cfld)%tinvstat=1
2962 if (ifhr > 0) then
2963 fld_info(cfld)%ntrange=1
2964 else
2965 fld_info(cfld)%ntrange=0
2966 endif
2967!$omp parallel do private(i,j,ii,jj)
2968 do j=1,jend-jsta+1
2969 jj = jsta+j-1
2970 do i=1,iend-ista+1
2971 ii = ista+i-1
2972 datapd(i,j,cfld) = grid1(ii,jj)
2973 enddo
2974 enddo
2975 endif
2976 ENDIF
2977!
2978! TIME-AVERAGED CONVECTIVE PRECIPITATION RATE.
2979 IF (iget(272)>0) THEN
2980 rdtphs=1000./dtq2 !--- 1000 kg/m**3, density of liquid water
2981 id(1:25) = 0
2982 itprec = nint(tprec)
2983!mp
2984 if (itprec /= 0) then
2985 ifincr = mod(ifhr,itprec)
2986 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
2987 else
2988 ifincr = 0
2989 endif
2990!mp
2991 id(18) = 0
2992 id(19) = ifhr
2993 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
2994 id(20) = 3
2995 IF (ifincr==0) THEN
2996 id(18) = ifhr-itprec
2997 ELSE
2998 id(18) = ifhr-ifincr
2999 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3000 ENDIF
3001 IF (id(18)<0) id(18) = 0
3002 grid1=spval
3003!$omp parallel do private(i,j)
3004 DO j=jsta,jend
3005 DO i=ista,iend
3006 if(avgcprate(i,j)/=spval) grid1(i,j) = avgcprate(i,j)*rdtphs
3007 ENDDO
3008 ENDDO
3009
3010! print *,'in surf,iget(272)=',iget(272),'RDTPHS=',RDTPHS, &
3011! 'AVGCPRATE=',maxval(AVGCPRATE(1:im,jsta:jend)),minval(AVGCPRATE(1:im,jsta:jend)), &
3012! 'grid1=',maxval(grid1(1:im,jsta:jend)),minval(grid1(1:im,jsta:jend))
3013 if(grib=='grib2') then
3014 cfld=cfld+1
3015 fld_info(cfld)%ifld=iavblfld(iget(272))
3016
3017 if(itprec==0) then
3018 fld_info(cfld)%ntrange=0
3019 else
3020 fld_info(cfld)%ntrange=1
3021 endif
3022 fld_info(cfld)%tinvstat=ifhr-id(18)
3023
3024!$omp parallel do private(i,j,ii,jj)
3025 do j=1,jend-jsta+1
3026 jj = jsta+j-1
3027 do i=1,iend-ista+1
3028 ii = ista+i-1
3029 datapd(i,j,cfld) = grid1(ii,jj)
3030 enddo
3031 enddo
3032 endif
3033 ENDIF
3034!
3035! TIME-AVERAGED PRECIPITATION RATE.
3036 IF (iget(271)>0) THEN
3037 rdtphs=1000./dtq2 !--- 1000 kg/m**3, density of liquid water
3038! RDTPHS=1000./(TRDLW*3600.)
3039 id(1:25) = 0
3040 itprec = nint(tprec)
3041!mp
3042 if (itprec /= 0) then
3043 ifincr = mod(ifhr,itprec)
3044 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3045 else
3046 ifincr = 0
3047 endif
3048!mp
3049 id(18) = 0
3050 id(19) = ifhr
3051 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3052 id(20) = 3
3053 IF (ifincr==0) THEN
3054 id(18) = ifhr-itprec
3055 ELSE
3056 id(18) = ifhr-ifincr
3057 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3058 ENDIF
3059 IF (id(18)<0) id(18) = 0
3060 grid1=spval
3061!$omp parallel do private(i,j)
3062 DO j=jsta,jend
3063 DO i=ista,iend
3064 if(avgprec(i,j)/=spval) grid1(i,j) = avgprec(i,j)*rdtphs
3065 ENDDO
3066 ENDDO
3067
3068 if(grib=='grib2') then
3069 cfld=cfld+1
3070 fld_info(cfld)%ifld=iavblfld(iget(271))
3071
3072 if(itprec==0) then
3073 fld_info(cfld)%ntrange=0
3074 else
3075 fld_info(cfld)%ntrange=1
3076 endif
3077 fld_info(cfld)%tinvstat=ifhr-id(18)
3078
3079!$omp parallel do private(i,j,ii,jj)
3080 do j=1,jend-jsta+1
3081 jj = jsta+j-1
3082 do i=1,iend-ista+1
3083 ii = ista+i-1
3084 datapd(i,j,cfld) = grid1(ii,jj)
3085 enddo
3086 enddo
3087 endif
3088 ENDIF
3089!
3090! ACCUMULATED TOTAL PRECIPITATION.
3091 IF (iget(087)>0) THEN
3092 id(1:25) = 0
3093 itprec = nint(tprec)
3094!mp
3095 if (itprec /= 0) then
3096 ifincr = mod(ifhr,itprec)
3097 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3098 else
3099 ifincr = 0
3100 endif
3101!mp
3102 id(18) = 0
3103 id(19) = ifhr
3104 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3105 id(20) = 4
3106 IF (ifincr==0) THEN
3107 id(18) = ifhr-itprec
3108 ELSE
3109 id(18) = ifhr-ifincr
3110 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3111 ENDIF
3112 IF(modelname == 'GFS' .OR. modelname == 'FV3R') THEN
3113!$omp parallel do private(i,j)
3114 DO j=jsta,jend
3115 DO i=ista,iend
3116 IF(avgprec(i,j) < spval)THEN
3117 grid1(i,j) = avgprec(i,j)*float(id(19)-id(18))*3600.*1000./dtq2
3118 ELSE
3119 grid1(i,j) = spval
3120 END IF
3121 ENDDO
3122 ENDDO
3123!! Chuang 3/29/2018: add continuous bucket
3124! DO J=JSTA,JEND
3125! DO I=ISTA,IEND
3126! IF(AVGPREC_CONT(I,J) < SPVAL)THEN
3127! GRID2(I,J) = AVGPREC_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2
3128! ELSE
3129! GRID2(I,J) = SPVAL
3130! END IF
3131! ENDDO
3132! ENDDO
3133 ELSE
3134!$omp parallel do private(i,j)
3135 DO j=jsta,jend
3136 DO i=ista,iend
3137 IF(acprec(i,j) < spval)THEN
3138 grid1(i,j) = acprec(i,j)*1000.
3139 ELSE
3140 grid1(i,j) = spval
3141 ENDIF
3142 ENDDO
3143 ENDDO
3144 END IF
3145! IF(IFMIN >= 1 .AND. ID(19) > 256)THEN
3146! IF(ITPREC==3)ID(17)=10
3147! IF(ITPREC==6)ID(17)=11
3148! IF(ITPREC==12)ID(17)=12
3149! END IF
3150 IF (id(18)<0) id(18) = 0
3151! write(6,*) 'call gribit...total precip'
3152 if(grib=='grib2') then
3153 cfld=cfld+1
3154 fld_info(cfld)%ifld=iavblfld(iget(087))
3155 fld_info(cfld)%ntrange=1
3156 fld_info(cfld)%tinvstat=ifhr-id(18)
3157! print*,'id(18),tinvstat in apcp= ',ID(18),fld_info(cfld)%tinvstat
3158!$omp parallel do private(i,j,ii,jj)
3159 do j=1,jend-jsta+1
3160 jj = jsta+j-1
3161 do i=1,iend-ista+1
3162 ii = ista+i-1
3163 datapd(i,j,cfld) = grid1(ii,jj)
3164 enddo
3165 enddo
3166!! add continuous bucket
3167! if(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') then
3168! cfld=cfld+1
3169! fld_info(cfld)%ifld=IAVBLFLD(IGET(087))
3170! fld_info(cfld)%ntrange=1
3171! fld_info(cfld)%tinvstat=IFHR
3172! print*,'tinvstat in cont bucket= ',fld_info(cfld)%tinvstat
3173! do j=1,jend-jsta+1
3174! jj = jsta+j-1
3175! do i=1,im
3176! datapd(i,j,cfld) = GRID2(i,jj)
3177! enddo
3178! enddo
3179! endif
3180 endif
3181 ENDIF
3182
3183!
3184! CONTINOUS ACCUMULATED TOTAL PRECIPITATION.
3185 IF (iget(417)>0) THEN
3186 id(1:25) = 0
3187 itprec = nint(tprec)
3188!mp
3189 if (itprec /= 0) then
3190 ifincr = mod(ifhr,itprec)
3191 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3192 else
3193 ifincr = 0
3194 endif
3195!mp
3196 id(18) = 0
3197 id(19) = ifhr
3198 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3199 id(20) = 4
3200 IF (ifincr==0) THEN
3201 id(18) = ifhr-itprec
3202 ELSE
3203 id(18) = ifhr-ifincr
3204 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3205 ENDIF
3206 IF(modelname == 'GFS' .OR. modelname == 'FV3R') THEN
3207! Chuang 3/29/2018: add continuous bucket
3208!$omp parallel do private(i,j)
3209 DO j=jsta,jend
3210 DO i=ista,iend
3211 IF(avgprec_cont(i,j) < spval)THEN
3212 grid2(i,j) = avgprec_cont(i,j)*((3600.*float(ifhr))+(60.*float(ifmin)))*1000./dtq2
3213 ELSE
3214 grid2(i,j) = spval
3215 END IF
3216 ENDDO
3217 ENDDO
3218 ENDIF
3219 IF (id(18)<0) id(18) = 0
3220 if(grib=='grib2') then
3221! add continuous bucket
3222 if(modelname == 'GFS' .OR. modelname == 'FV3R') then
3223 cfld=cfld+1
3224 fld_info(cfld)%ifld=iavblfld(iget(417))
3225 fld_info(cfld)%ntrange=1
3226 if(ifmin>1)then
3227 fld_info(cfld)%tinvstat=ifhr*60+ifmin
3228 else
3229 fld_info(cfld)%tinvstat=ifhr
3230 endif
3231! print*,'tinvstat in cont bucket= ',fld_info(cfld)%tinvstat
3232!$omp parallel do private(i,j,ii,jj)
3233 do j=1,jend-jsta+1
3234 jj = jsta+j-1
3235 do i=1,iend-ista+1
3236 ii = ista+i-1
3237 datapd(i,j,cfld) = grid2(ii,jj)
3238 enddo
3239 enddo
3240 endif
3241 endif
3242 ENDIF
3243!
3244! ACCUMULATED CONVECTIVE PRECIPITATION.
3245 IF (iget(033)>0) THEN
3246 id(1:25) = 0
3247 itprec = nint(tprec)
3248!mp
3249 if (itprec /= 0) then
3250 ifincr = mod(ifhr,itprec)
3251 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3252 else
3253 ifincr = 0
3254 endif
3255!mp
3256 id(18) = 0
3257 id(19) = ifhr
3258 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3259 id(20) = 4
3260 IF (ifincr==0) THEN
3261 id(18) = ifhr-itprec
3262 ELSE
3263 id(18) = ifhr-ifincr
3264 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3265 ENDIF
3266 IF (id(18)<0) id(18) = 0
3267 IF(modelname == 'GFS' .OR. modelname == 'FV3R') THEN
3268!$omp parallel do private(i,j)
3269 DO j=jsta,jend
3270 DO i=ista,iend
3271 IF(avgcprate(i,j) < spval)THEN
3272 grid1(i,j) = avgcprate(i,j)* &
3273 float(id(19)-id(18))*3600.*1000./dtq2
3274 ELSE
3275 grid1(i,j) = spval
3276 END IF
3277 ENDDO
3278 ENDDO
3279!! Chuang 3/29/2018: add continuous bucket
3280! DO J=JSTA,JEND
3281! DO I=ISTA,IEND
3282! IF(AVGCPRATE_CONT(I,J) < SPVAL)THEN
3283! GRID2(I,J) = AVGCPRATE_CONT(I,J)*FLOAT(IFHR)*3600.*1000./DTQ2
3284! ELSE
3285! GRID2(I,J) = SPVAL
3286! END IF
3287! ENDDO
3288! ENDDO
3289 ELSE
3290!$omp parallel do private(i,j)
3291 DO j=jsta,jend
3292 DO i=ista,iend
3293 IF(cuprec(i,j) < spval)THEN
3294 grid1(i,j) = cuprec(i,j)*1000.
3295 ELSE
3296 grid1(i,j) = spval
3297 ENDIF
3298 ENDDO
3299 ENDDO
3300 END IF
3301! write(6,*) 'call gribit...convective precip'
3302 if(grib=='grib2') then
3303 cfld=cfld+1
3304 fld_info(cfld)%ifld=iavblfld(iget(033))
3305 fld_info(cfld)%ntrange=1
3306 fld_info(cfld)%tinvstat=ifhr-id(18)
3307!$omp parallel do private(i,j,ii,jj)
3308 do j=1,jend-jsta+1
3309 jj = jsta+j-1
3310 do i=1,iend-ista+1
3311 ii = ista+i-1
3312 datapd(i,j,cfld) = grid1(ii,jj)
3313 enddo
3314 enddo
3315!! add continuous bucket
3316! if(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') then
3317! cfld=cfld+1
3318! fld_info(cfld)%ifld=IAVBLFLD(IGET(033))
3319! fld_info(cfld)%ntrange=1
3320! fld_info(cfld)%tinvstat=IFHR
3321! do j=1,jend-jsta+1
3322! jj = jsta+j-1
3323! do i=1,im
3324! datapd(i,j,cfld) = GRID2(i,jj)
3325! enddo
3326! enddo
3327! endif
3328 endif
3329 ENDIF
3330
3331! CONTINOUS ACCUMULATED CONVECTIVE PRECIPITATION.
3332 IF (iget(418)>0) THEN
3333 id(1:25) = 0
3334 itprec = nint(tprec)
3335!mp
3336 if (itprec /= 0) then
3337 ifincr = mod(ifhr,itprec)
3338 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3339 else
3340 ifincr = 0
3341 endif
3342!mp
3343 id(18) = 0
3344 id(19) = ifhr
3345 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3346 id(20) = 4
3347 IF (ifincr==0) THEN
3348 id(18) = ifhr-itprec
3349 ELSE
3350 id(18) = ifhr-ifincr
3351 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3352 ENDIF
3353 IF (id(18)<0) id(18) = 0
3354 IF(modelname == 'GFS' .OR. modelname == 'FV3R') THEN
3355! Chuang 3/29/2018: add continuous bucket
3356!$omp parallel do private(i,j)
3357 DO j=jsta,jend
3358 DO i=ista,iend
3359 IF(avgcprate_cont(i,j) < spval)THEN
3360 grid2(i,j) = avgcprate_cont(i,j)*float(ifhr)*3600.*1000./dtq2
3361 ELSE
3362 grid2(i,j) = spval
3363 END IF
3364 ENDDO
3365 ENDDO
3366 ENDIF
3367! write(6,*) 'call gribit...convective precip'
3368 if(grib=='grib2') then
3369! add continuous bucket
3370 if(modelname == 'GFS' .OR. modelname == 'FV3R') then
3371 cfld=cfld+1
3372 fld_info(cfld)%ifld=iavblfld(iget(418))
3373 fld_info(cfld)%ntrange=1
3374 fld_info(cfld)%tinvstat=ifhr
3375!$omp parallel do private(i,j,ii,jj)
3376 do j=1,jend-jsta+1
3377 jj = jsta+j-1
3378 do i=1,iend-ista+1
3379 ii = ista+i-1
3380 datapd(i,j,cfld) = grid2(ii,jj)
3381 enddo
3382 enddo
3383 endif
3384 endif
3385 ENDIF
3386!
3387! ACCUMULATED GRID-SCALE PRECIPITATION.
3388 IF (iget(034)>0) THEN
3389
3390 id(1:25) = 0
3391 itprec = nint(tprec)
3392!mp
3393 if (itprec /= 0) then
3394 ifincr = mod(ifhr,itprec)
3395 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3396 else
3397 ifincr = 0
3398 endif
3399!mp
3400 id(18) = 0
3401 id(19) = ifhr
3402 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3403 id(20) = 4
3404 IF (ifincr==0) THEN
3405 id(18) = ifhr-itprec
3406 ELSE
3407 id(18) = ifhr-ifincr
3408 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3409 ENDIF
3410 IF (id(18)<0) id(18) = 0
3411 IF(modelname == 'GFS' .OR. modelname == 'FV3R') THEN
3412!$omp parallel do private(i,j)
3413 DO j=jsta,jend
3414 DO i=ista,iend
3415 IF(avgcprate(i,j) < spval .AND. avgprec(i,j) < spval) then
3416 grid1(i,j) = ( avgprec(i,j) - avgcprate(i,j) ) * &
3417 float(id(19)-id(18))*3600.*1000./dtq2
3418 ELSE
3419 grid1(i,j) = spval
3420 END IF
3421 ENDDO
3422 ENDDO
3423!! Chuang 3/29/2018: add continuous bucket
3424! DO J=JSTA,JEND
3425! DO I=ISTA,IEND
3426! IF(AVGCPRATE_CONT(I,J) < SPVAL .AND. AVGPREC_CONT(I,J) < SPVAL)THEN
3427! GRID2(I,J) = (AVGPREC_CONT(I,J) - AVGCPRATE_CONT(I,J)) &
3428! *FLOAT(IFHR)*3600.*1000./DTQ2
3429! ELSE
3430! GRID2(I,J) = SPVAL
3431! END IF
3432! ENDDO
3433! ENDDO
3434 ELSE
3435!$omp parallel do private(i,j)
3436 DO j=jsta,jend
3437 DO i=ista,iend
3438 grid1(i,j) = ancprc(i,j)*1000.
3439 ENDDO
3440 ENDDO
3441 END IF
3442! write(6,*) 'call gribit...grid-scale precip'
3443 if(grib=='grib2') then
3444 cfld=cfld+1
3445 fld_info(cfld)%ifld=iavblfld(iget(034))
3446 fld_info(cfld)%ntrange=1
3447 fld_info(cfld)%tinvstat=ifhr-id(18)
3448!$omp parallel do private(i,j,ii,jj)
3449 do j=1,jend-jsta+1
3450 jj = jsta+j-1
3451 do i=1,iend-ista+1
3452 ii = ista+i-1
3453 datapd(i,j,cfld) = grid1(ii,jj)
3454 enddo
3455 enddo
3456!! add continuous bucket
3457! if(MODELNAME == 'GFS' .OR. MODELNAME == 'FV3R') then
3458! cfld=cfld+1
3459! fld_info(cfld)%ifld=IAVBLFLD(IGET(034))
3460! fld_info(cfld)%ntrange=1
3461! fld_info(cfld)%tinvstat=IFHR
3462! do j=1,jend-jsta+1
3463! jj = jsta+j-1
3464! do i=1,iend-ista+1
3465! ii = ista+1-1
3466! datapd(i,j,cfld) = GRID2(ii,jj)
3467! enddo
3468! enddo
3469! endif
3470 endif
3471 ENDIF
3472
3473! CONTINOUS ACCUMULATED GRID-SCALE PRECIPITATION.
3474 IF (iget(419)>0) THEN
3475 id(1:25) = 0
3476 itprec = nint(tprec)
3477!mp
3478 if (itprec /= 0) then
3479 ifincr = mod(ifhr,itprec)
3480 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3481 else
3482 ifincr = 0
3483 endif
3484!mp
3485 id(18) = 0
3486 id(19) = ifhr
3487 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3488 id(20) = 4
3489 IF (ifincr==0) THEN
3490 id(18) = ifhr-itprec
3491 ELSE
3492 id(18) = ifhr-ifincr
3493 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3494 ENDIF
3495 IF (id(18)<0) id(18) = 0
3496 IF(modelname == 'GFS' .OR. modelname == 'FV3R') THEN
3497! Chuang 3/29/2018: add continuous bucket
3498!$omp parallel do private(i,j)
3499 DO j=jsta,jend
3500 DO i=ista,iend
3501 IF(avgcprate_cont(i,j) < spval .AND. avgprec_cont(i,j) < spval)THEN
3502 grid2(i,j) = (avgprec_cont(i,j) - avgcprate_cont(i,j)) &
3503 *float(ifhr)*3600.*1000./dtq2
3504 ELSE
3505 grid2(i,j) = spval
3506 END IF
3507 ENDDO
3508 ENDDO
3509 ENDIF
3510! write(6,*) 'call gribit...grid-scale precip'
3511 if(grib=='grib2') then
3512! add continuous bucket
3513 if(modelname == 'GFS' .OR. modelname == 'FV3R') then
3514 cfld=cfld+1
3515 fld_info(cfld)%ifld=iavblfld(iget(419))
3516 fld_info(cfld)%ntrange=1
3517 fld_info(cfld)%tinvstat=ifhr
3518!$omp parallel do private(i,j,ii,jj)
3519 do j=1,jend-jsta+1
3520 jj = jsta+j-1
3521 do i=1,iend-ista+1
3522 ii = ista+i-1
3523 datapd(i,j,cfld) = grid2(ii,jj)
3524 enddo
3525 enddo
3526 endif
3527 endif
3528 ENDIF
3529!
3530! ACCUMULATED LAND SURFACE PRECIPITATION.
3531 IF (iget(256)>0) THEN
3532 grid1=spval
3533!$omp parallel do private(i,j)
3534 DO j=jsta,jend
3535 DO i=ista,iend
3536 IF(lspa(i,j)<=-1.0e-6)THEN
3537 if(acprec(i,j)/=spval) grid1(i,j) = acprec(i,j)*1000
3538 ELSE
3539 if(lspa(i,j)/=spval) grid1(i,j) = lspa(i,j)*1000.
3540 END IF
3541 ENDDO
3542 ENDDO
3543 id(1:25) = 0
3544 itprec = nint(tprec)
3545!mp
3546 if (itprec /= 0) then
3547 ifincr = mod(ifhr,itprec)
3548 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3549 else
3550 ifincr = 0
3551 endif
3552!mp
3553 id(18) = 0
3554 id(19) = ifhr
3555 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3556 id(20) = 4
3557 IF (ifincr==0) THEN
3558 id(18) = ifhr-itprec
3559 ELSE
3560 id(18) = ifhr-ifincr
3561 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3562 ENDIF
3563 IF (id(18)<0) id(18) = 0
3564 id(02)= 130
3565 if(grib=='grib2') then
3566 cfld=cfld+1
3567 fld_info(cfld)%ifld=iavblfld(iget(256))
3568 fld_info(cfld)%ntrange=1
3569 fld_info(cfld)%tinvstat=ifhr-id(18)
3570!$omp parallel do private(i,j,ii,jj)
3571 do j=1,jend-jsta+1
3572 jj = jsta+j-1
3573 do i=1,iend-ista+1
3574 ii = ista+i-1
3575 datapd(i,j,cfld) = grid1(ii,jj)
3576 enddo
3577 enddo
3578 endif
3579 ENDIF
3580!
3581! ACCUMULATED SNOWFALL.
3582 IF (iget(035)>0) THEN
3583!$omp parallel do private(i,j)
3584 DO j=jsta,jend
3585 DO i=ista,iend
3586! GRID1(I,J) = ACSNOW(I,J)*1000.
3587 grid1(i,j) = acsnow(i,j)
3588 ENDDO
3589 ENDDO
3590 id(1:25) = 0
3591 itprec = nint(tprec)
3592!mp
3593 if (itprec /= 0) then
3594 ifincr = mod(ifhr,itprec)
3595 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3596 else
3597 ifincr = 0
3598 endif
3599!mp
3600 id(18) = 0
3601 id(19) = ifhr
3602 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3603 id(20) = 4
3604 IF (ifincr==0) THEN
3605 id(18) = ifhr-itprec
3606 ELSE
3607 id(18) = ifhr-ifincr
3608 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3609 ENDIF
3610 IF (id(18)<0) id(18) = 0
3611 if(grib=='grib2') then
3612 cfld=cfld+1
3613 fld_info(cfld)%ifld=iavblfld(iget(035))
3614 fld_info(cfld)%ntrange=1
3615 fld_info(cfld)%tinvstat=ifhr
3616!$omp parallel do private(i,j,ii,jj)
3617 do j=1,jend-jsta+1
3618 jj = jsta+j-1
3619 do i=1,iend-ista+1
3620 ii = ista+i-1
3621 datapd(i,j,cfld) = grid1(ii,jj)
3622 enddo
3623 enddo
3624 endif
3625 ENDIF
3626!
3627! ACCUMULATED GRAUPEL.
3628 IF (iget(746)>0) THEN
3629!$omp parallel do private(i,j)
3630 DO j=jsta,jend
3631 DO i=ista,iend
3632 grid1(i,j) = acgraup(i,j)
3633 ENDDO
3634 ENDDO
3635 id(1:25) = 0
3636 itprec = nint(tprec)
3637!mp
3638 if (itprec /= 0) then
3639 ifincr = mod(ifhr,itprec)
3640 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3641 else
3642 ifincr = 0
3643 endif
3644!mp
3645 id(18) = 0
3646 id(19) = ifhr
3647 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3648 id(20) = 4
3649 IF (ifincr==0) THEN
3650 id(18) = ifhr-itprec
3651 ELSE
3652 id(18) = ifhr-ifincr
3653 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3654 ENDIF
3655 IF (id(18)<0) id(18) = 0
3656 if(grib=='grib2') then
3657 cfld=cfld+1
3658 fld_info(cfld)%ifld=iavblfld(iget(746))
3659 fld_info(cfld)%ntrange=1
3660 if(modelname=='FV3R' .OR. modelname=='GFS')then
3661 if(ifmin>1)then
3662 fld_info(cfld)%tinvstat=ifhr*60+ifmin
3663 else
3664 fld_info(cfld)%tinvstat=ifhr
3665 endif
3666 else
3667 fld_info(cfld)%tinvstat=ifhr-id(18)
3668 endif
3669!$omp parallel do private(i,j,ii,jj)
3670 do j=1,jend-jsta+1
3671 jj = jsta+j-1
3672 do i=1,iend-ista+1
3673 ii = ista+i-1
3674 datapd(i,j,cfld) = grid1(ii,jj)
3675 enddo
3676 enddo
3677 endif
3678 ENDIF
3679!
3680! ACCUMULATED FREEZING RAIN.
3681 IF (iget(782)>0) THEN
3682!$omp parallel do private(i,j)
3683 DO j=jsta,jend
3684 DO i=ista,iend
3685 grid1(i,j) = acfrain(i,j)
3686 ENDDO
3687 ENDDO
3688 id(1:25) = 0
3689 itprec = nint(tprec)
3690!mp
3691 if (itprec /= 0) then
3692 ifincr = mod(ifhr,itprec)
3693 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3694 else
3695 ifincr = 0
3696 endif
3697!mp
3698 id(18) = 0
3699 id(19) = ifhr
3700 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3701 id(20) = 4
3702 IF (ifincr==0) THEN
3703 id(18) = ifhr-itprec
3704 ELSE
3705 id(18) = ifhr-ifincr
3706 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3707 ENDIF
3708 IF (id(18)<0) id(18) = 0
3709 if(grib=='grib2') then
3710 cfld=cfld+1
3711 fld_info(cfld)%ifld=iavblfld(iget(782))
3712 fld_info(cfld)%ntrange=1
3713 if(modelname=='FV3R' .OR. modelname=='GFS')then
3714 if(ifmin>1)then
3715 fld_info(cfld)%tinvstat=ifhr*60+ifmin
3716 else
3717 fld_info(cfld)%tinvstat=ifhr
3718 endif
3719 else
3720 fld_info(cfld)%tinvstat=ifhr-id(18)
3721 endif
3722!$omp parallel do private(i,j,ii,jj)
3723 do j=1,jend-jsta+1
3724 jj = jsta+j-1
3725 do i=1,iend-ista+1
3726 ii = ista+i-1
3727 datapd(i,j,cfld) = grid1(ii,jj)
3728 enddo
3729 enddo
3730 endif
3731 ENDIF
3732
3733! ACCUMULATED SNOWFALL.
3734 IF (iget(1004)>0) THEN
3735!$omp parallel do private(i,j)
3736 DO j=jsta,jend
3737 DO i=ista,iend
3738 grid1(i,j) = snow_acm(i,j)
3739 ENDDO
3740 ENDDO
3741 id(1:25) = 0
3742 itprec = nint(tprec)
3743!mp
3744 if (itprec /= 0) then
3745 ifincr = mod(ifhr,itprec)
3746 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3747 else
3748 ifincr = 0
3749 endif
3750!mp
3751 id(18) = 0
3752 id(19) = ifhr
3753 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3754 id(20) = 4
3755 IF (ifincr==0) THEN
3756 id(18) = ifhr-itprec
3757 ELSE
3758 id(18) = ifhr-ifincr
3759 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3760 ENDIF
3761 IF (id(18)<0) id(18) = 0
3762 if(grib=='grib2') then
3763 cfld=cfld+1
3764 fld_info(cfld)%ifld=iavblfld(iget(1004))
3765 fld_info(cfld)%ntrange=1
3766 if(modelname=='FV3R' .OR. modelname=='GFS')then
3767 if(ifmin>1)then
3768 fld_info(cfld)%tinvstat=ifhr*60+ifmin
3769 else
3770 fld_info(cfld)%tinvstat=ifhr
3771 endif
3772 else
3773 fld_info(cfld)%tinvstat=ifhr-id(18)
3774 endif
3775! print*,'id(18),tinvstat in acgraup= ',ID(18),fld_info(cfld)%tinvstat
3776!$omp parallel do private(i,j,ii,jj)
3777 do j=1,jend-jsta+1
3778 jj = jsta+j-1
3779 do i=1,iend-ista+1
3780 ii = ista+i-1
3781 datapd(i,j,cfld) = grid1(ii,jj)
3782 enddo
3783 enddo
3784 endif
3785 ENDIF
3786
3787!
3788! ACCUMULATED SNOW MELT.
3789 IF (iget(121)>0) THEN
3790!$omp parallel do private(i,j)
3791 DO j=jsta,jend
3792 DO i=ista,iend
3793! GRID1(I,J) = ACSNOM(I,J)*1000.
3794 grid1(i,j) = acsnom(i,j)
3795 ENDDO
3796 ENDDO
3797 id(1:25) = 0
3798 itprec = nint(tprec)
3799!mp
3800 if (itprec /= 0) then
3801 ifincr = mod(ifhr,itprec)
3802 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3803 else
3804 ifincr = 0
3805 endif
3806!mp
3807 id(18) = 0
3808 id(19) = ifhr
3809 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3810 id(20) = 4
3811 IF (ifincr==0) THEN
3812 id(18) = ifhr-itprec
3813 ELSE
3814 id(18) = ifhr-ifincr
3815 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3816 ENDIF
3817 IF (id(18)<0) id(18) = 0
3818 if(grib=='grib2') then
3819 cfld=cfld+1
3820 fld_info(cfld)%ifld=iavblfld(iget(121))
3821 fld_info(cfld)%ntrange=1
3822 fld_info(cfld)%tinvstat=ifhr-id(18)
3823!$omp parallel do private(i,j,ii,jj)
3824 do j=1,jend-jsta+1
3825 jj = jsta+j-1
3826 do i=1,iend-ista+1
3827 ii = ista+i-1
3828 datapd(i,j,cfld) = grid1(ii,jj)
3829 enddo
3830 enddo
3831 endif
3832 ENDIF
3833!
3834! ACCUMULATED SNOWFALL RATE
3835 IF (iget(405)>0) THEN
3836!$omp parallel do private(i,j)
3837 DO j=jsta,jend
3838 DO i=ista,iend
3839 grid1(i,j) = snowfall(i,j)
3840 ENDDO
3841 ENDDO
3842 id(1:25) = 0
3843 itprec = nint(tprec)
3844!mp
3845 if (itprec /= 0) then
3846 ifincr = mod(ifhr,itprec)
3847 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3848 else
3849 ifincr = 0
3850 endif
3851!mp
3852 id(18) = 0
3853 id(19) = ifhr
3854 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3855 id(20) = 4
3856 IF (ifincr==0) THEN
3857 id(18) = ifhr-itprec
3858 ELSE
3859 id(18) = ifhr-ifincr
3860 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3861 ENDIF
3862 IF (id(18)<0) id(18) = 0
3863 IF(itprec < 0)id(1:25)=0
3864 if(grib=='grib2') then
3865 cfld=cfld+1
3866 fld_info(cfld)%ifld=iavblfld(iget(405))
3867 fld_info(cfld)%ntrange=1
3868 fld_info(cfld)%tinvstat=ifhr-id(18)
3869!$omp parallel do private(i,j,ii,jj)
3870 do j=1,jend-jsta+1
3871 jj = jsta+j-1
3872 do i=1,iend-ista+1
3873 ii = ista+i-1
3874 datapd(i,j,cfld) = grid1(ii,jj)
3875 enddo
3876 enddo
3877 endif
3878 ENDIF
3879!
3880! ACCUMULATED STORM SURFACE RUNOFF.
3881 IF (iget(122)>0) THEN
3882!$omp parallel do private(i,j)
3883 DO j=jsta,jend
3884 DO i=ista,iend
3885! GRID1(I,J) = SSROFF(I,J)*1000.
3886 grid1(i,j) = ssroff(i,j)
3887 ENDDO
3888 ENDDO
3889 id(1:25) = 0
3890 itprec = nint(tprec)
3891!mp
3892 if (itprec /= 0) then
3893 ifincr = mod(ifhr,itprec)
3894 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3895 else
3896 ifincr = 0
3897 endif
3898!mp
3899 id(18) = 0
3900 id(19) = ifhr
3901 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3902 id(20) = 4
3903 IF (ifincr==0) THEN
3904 id(18) = ifhr-itprec
3905 ELSE
3906 id(18) = ifhr-ifincr
3907 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3908 ENDIF
3909 IF (id(18)<0) id(18) = 0
3910! 1-HR RUNOFF ACCUMULATIONS IN RR
3911 IF (modelname=='RAPR') THEN
3912 IF (ifhr > 0) THEN
3913 id(18)=ifhr-1
3914 ELSE
3915 id(18)=0
3916 ENDIF
3917 ENDIF
3918 if(grib=='grib2') then
3919 cfld=cfld+1
3920 fld_info(cfld)%ifld=iavblfld(iget(122))
3921 fld_info(cfld)%ntrange=1
3922 fld_info(cfld)%tinvstat=ifhr-id(18)
3923!$omp parallel do private(i,j,ii,jj)
3924 do j=1,jend-jsta+1
3925 jj = jsta+j-1
3926 do i=1,iend-ista+1
3927 ii = ista+i-1
3928 datapd(i,j,cfld) = grid1(ii,jj)
3929 enddo
3930 enddo
3931 endif
3932 ENDIF
3933!
3934! ACCUMULATED BASEFLOW-GROUNDWATER RUNOFF.
3935 IF (iget(123)>0) THEN
3936!$omp parallel do private(i,j)
3937 DO j=jsta,jend
3938 DO i=ista,iend
3939! GRID1(I,J) = BGROFF(I,J)*1000.
3940 grid1(i,j) = bgroff(i,j)
3941 ENDDO
3942 ENDDO
3943 id(1:25) = 0
3944 itprec = nint(tprec)
3945!mp
3946 if (itprec /= 0) then
3947 ifincr = mod(ifhr,itprec)
3948 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
3949 else
3950 ifincr = 0
3951 endif
3952!mp
3953 id(18) = ifhr - 1
3954 id(19) = ifhr
3955 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
3956 id(20) = 4
3957 IF (ifincr==0) THEN
3958 id(18) = ifhr-itprec
3959 ELSE
3960 id(18) = ifhr-ifincr
3961 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
3962 ENDIF
3963 IF (id(18)<0) id(18) = 0
3964! 1-HR RUNOFF ACCUMULATIONS IN RR
3965 IF (modelname=='RAPR') THEN
3966 IF (ifhr > 0) THEN
3967 id(18)=ifhr-1
3968 ELSE
3969 id(18)=0
3970 ENDIF
3971 ENDIF
3972 if(grib=='grib2') then
3973 cfld=cfld+1
3974 fld_info(cfld)%ifld=iavblfld(iget(123))
3975 fld_info(cfld)%ntrange=1
3976 fld_info(cfld)%tinvstat=ifhr-id(18)
3977!$omp parallel do private(i,j,ii,jj)
3978 do j=1,jend-jsta+1
3979 jj = jsta+j-1
3980 do i=1,iend-ista+1
3981 ii = ista+i-1
3982 datapd(i,j,cfld) = grid1(ii,jj)
3983 enddo
3984 enddo
3985 endif
3986 ENDIF
3987!
3988! ACCUMULATED WATER RUNOFF.
3989 IF (iget(343)>0) THEN
3990!$omp parallel do private(i,j)
3991 DO j=jsta,jend
3992 DO i=ista,iend
3993 grid1(i,j) = runoff(i,j)
3994 ENDDO
3995 ENDDO
3996 id(1:25) = 0
3997 itprec = nint(tprec)
3998! GFS starts to use continuous bucket for precipitation only
3999! so have to change water runoff to use different bucket
4000 if(modelname == 'GFS')itprec=nint(tmaxmin)
4001!mp
4002 if (itprec /= 0) then
4003 ifincr = mod(ifhr,itprec)
4004 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
4005 else
4006 ifincr = 0
4007 endif
4008!mp
4009 id(18) = 0
4010 id(19) = ifhr
4011 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
4012 id(20) = 4
4013 IF (ifincr==0) THEN
4014 id(18) = ifhr-itprec
4015 ELSE
4016 id(18) = ifhr-ifincr
4017 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
4018 ENDIF
4019 IF (id(18)<0) id(18) = 0
4020 if(grib=='grib2') then
4021 cfld=cfld+1
4022 fld_info(cfld)%ifld=iavblfld(iget(343))
4023 fld_info(cfld)%ntrange=1
4024 fld_info(cfld)%tinvstat=ifhr-id(18)
4025!$omp parallel do private(i,j,ii,jj)
4026 do j=1,jend-jsta+1
4027 jj = jsta+j-1
4028 do i=1,iend-ista+1
4029 ii = ista+i-1
4030 datapd(i,j,cfld) = grid1(ii,jj)
4031 enddo
4032 enddo
4033 endif
4034 ENDIF
4035
4036! PRECIPITATION BUCKETS - accumulated between output times
4037! 'BUCKET TOTAL PRECIP '
4038 need_ifi = iget(1007)>0 .or. iget(1008)>0 .or. iget(1009)>0 .or. iget(1010)>0
4039 IF (iget(434)>0. .or. need_ifi) THEN
4040!$omp parallel do private(i,j)
4041 DO j=jsta,jend
4042 DO i=ista,iend
4043 IF (ifhr == 0) THEN
4044 ifi_apcp(i,j) = 0.0
4045 ELSE
4046 ifi_apcp(i,j) = pcp_bucket(i,j)
4047 ENDIF
4048 ENDDO
4049 ENDDO
4050 ! Note: IFI.F may replace IFI_APCP with other values where it is spval or 0
4051 ENDIF
4052
4053 IF (iget(434)>0.) THEN
4054 id(1:25) = 0
4055 itprec = nint(tprec)
4056!mp
4057 if (itprec /= 0) then
4058 ifincr = mod(ifhr,itprec)
4059 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
4060 else
4061 ifincr = 0
4062 endif
4063!mp
4064 if(modelname=='NCAR' .OR. modelname=='RAPR') ifincr = nint(prec_acc_dt)/60
4065 id(18) = 0
4066 id(19) = ifhr
4067 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
4068 id(20) = 4
4069 IF (ifincr==0) THEN
4070 id(18) = ifhr-itprec
4071 ELSE
4072 id(18) = ifhr-ifincr
4073 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
4074 ENDIF
4075 IF (id(18)<0) id(18) = 0
4076 if(grib=='grib2' .and. iget(434)>0) then
4077 cfld=cfld+1
4078 fld_info(cfld)%ifld=iavblfld(iget(434))
4079 if(itprec>0) then
4080 fld_info(cfld)%ntrange=(ifhr-id(18))/itprec
4081 else
4082 fld_info(cfld)%ntrange=0
4083 endif
4084 fld_info(cfld)%tinvstat=itprec
4085 if(fld_info(cfld)%ntrange==0) then
4086 if (ifhr==0) then
4087 fld_info(cfld)%tinvstat=0
4088 else
4089 fld_info(cfld)%tinvstat=1
4090 endif
4091 fld_info(cfld)%ntrange=1
4092 end if
4093!$omp parallel do private(i,j,ii,jj)
4094 do j=1,jend-jsta+1
4095 jj = jsta+j-1
4096 do i=1,iend-ista+1
4097 ii = ista+i-1
4098 datapd(i,j,cfld) = ifi_apcp(ii,jj)
4099 enddo
4100 enddo
4101 endif
4102 ENDIF
4103
4104! PRECIPITATION BUCKETS - accumulated between output times
4105! 'BUCKET CONV PRECIP '
4106 IF (iget(435)>0.) THEN
4107!$omp parallel do private(i,j)
4108 DO j=jsta,jend
4109 DO i=ista,iend
4110 IF (ifhr == 0) THEN
4111 grid1(i,j) = 0.0
4112 ELSE
4113 grid1(i,j) = rainc_bucket(i,j)
4114 ENDIF
4115 ENDDO
4116 ENDDO
4117 id(1:25) = 0
4118 itprec = nint(tprec)
4119!mp
4120 if (itprec /= 0) then
4121 ifincr = mod(ifhr,itprec)
4122 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
4123 else
4124 ifincr = 0
4125 endif
4126
4127 if(modelname=='NCAR' .OR. modelname=='RAPR') ifincr = nint(prec_acc_dt)/60
4128!mp
4129 id(18) = 0
4130 id(19) = ifhr
4131 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
4132 id(20) = 4
4133 IF (ifincr==0) THEN
4134 id(18) = ifhr-itprec
4135 ELSE
4136 id(18) = ifhr-ifincr
4137 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
4138 ENDIF
4139 IF (id(18)<0) id(18) = 0
4140
4141! print *,'IFMIN,IFHR,ITPREC',IFMIN,IFHR,ITPREC
4142 if(debugprint .and. me==0)then
4143 print *,'PREC_ACC_DT,ID(18),ID(19)',prec_acc_dt,id(18),id(19)
4144 endif
4145
4146 if(grib=='grib2') then
4147 cfld=cfld+1
4148 fld_info(cfld)%ifld=iavblfld(iget(435))
4149 if(itprec>0) then
4150 fld_info(cfld)%ntrange=(ifhr-id(18))/itprec
4151 else
4152 fld_info(cfld)%ntrange=0
4153 endif
4154 fld_info(cfld)%tinvstat=itprec
4155 if(fld_info(cfld)%ntrange==0) then
4156 if (ifhr==0) then
4157 fld_info(cfld)%tinvstat=0
4158 else
4159 fld_info(cfld)%tinvstat=1
4160 endif
4161 fld_info(cfld)%ntrange=1
4162 end if
4163!$omp parallel do private(i,j,ii,jj)
4164 do j=1,jend-jsta+1
4165 jj = jsta+j-1
4166 do i=1,iend-ista+1
4167 ii = ista+i-1
4168 datapd(i,j,cfld) = grid1(ii,jj)
4169 enddo
4170 enddo
4171 endif
4172 ENDIF
4173! PRECIPITATION BUCKETS - accumulated between output times
4174! 'BUCKET GRDSCALE PRCP'
4175 IF (iget(436)>0.) THEN
4176!$omp parallel do private(i,j)
4177 DO j=jsta,jend
4178 DO i=ista,iend
4179 IF (ifhr == 0) THEN
4180 grid1(i,j) = 0.0
4181 ELSE
4182 grid1(i,j) = rainnc_bucket(i,j)
4183 ENDIF
4184 ENDDO
4185 ENDDO
4186 id(1:25) = 0
4187 itprec = nint(tprec)
4188!mp
4189 if (itprec /= 0) then
4190 ifincr = mod(ifhr,itprec)
4191 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
4192 else
4193 ifincr = 0
4194 endif
4195!mp
4196 if(modelname=='NCAR' .OR. modelname=='RAPR') ifincr = nint(prec_acc_dt)/60
4197 id(18) = 0
4198 id(19) = ifhr
4199 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
4200 id(20) = 4
4201 IF (ifincr==0) THEN
4202 id(18) = ifhr-itprec
4203 ELSE
4204 id(18) = ifhr-ifincr
4205 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
4206 ENDIF
4207 IF (id(18)<0) id(18) = 0
4208 if(grib=='grib2') then
4209 cfld=cfld+1
4210 fld_info(cfld)%ifld=iavblfld(iget(436))
4211 if(itprec>0) then
4212 fld_info(cfld)%ntrange=(ifhr-id(18))/itprec
4213 else
4214 fld_info(cfld)%ntrange=0
4215 endif
4216 fld_info(cfld)%tinvstat=itprec
4217 if(fld_info(cfld)%ntrange==0) then
4218 if (ifhr==0) then
4219 fld_info(cfld)%tinvstat=0
4220 else
4221 fld_info(cfld)%tinvstat=1
4222 endif
4223 fld_info(cfld)%ntrange=1
4224 end if
4225!$omp parallel do private(i,j,ii,jj)
4226 do j=1,jend-jsta+1
4227 jj = jsta+j-1
4228 do i=1,iend-ista+1
4229 ii = ista+i-1
4230 datapd(i,j,cfld) = grid1(ii,jj)
4231 enddo
4232 enddo
4233 endif
4234 ENDIF
4235! PRECIPITATION BUCKETS - accumulated between output times
4236! 'BUCKET SNOW PRECIP '
4237 IF (iget(437)>0.) THEN
4238!$omp parallel do private(i,j)
4239 DO j=jsta,jend
4240 DO i=ista,iend
4241 grid1(i,j) = snow_bucket(i,j)
4242 ENDDO
4243 ENDDO
4244 id(1:25) = 0
4245 itprec = nint(tprec)
4246!mp
4247 if (itprec /= 0) then
4248 ifincr = mod(ifhr,itprec)
4249 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
4250 else
4251 ifincr = 0
4252 endif
4253!mp
4254 if(modelname=='NCAR' .OR. modelname=='RAPR') ifincr = nint(prec_acc_dt)/60
4255 id(18) = 0
4256 id(19) = ifhr
4257 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
4258 id(20) = 4
4259 IF (ifincr==0) THEN
4260 id(18) = ifhr-itprec
4261 ELSE
4262 id(18) = ifhr-ifincr
4263 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
4264 ENDIF
4265 IF (id(18)<0) id(18) = 0
4266! if(me==0)print*,'maxval BUCKET SNOWFALL: ', maxval(GRID1)
4267 if(grib=='grib2') then
4268 cfld=cfld+1
4269 fld_info(cfld)%ifld=iavblfld(iget(437))
4270 if(itprec>0) then
4271 fld_info(cfld)%ntrange=(ifhr-id(18))/itprec
4272 else
4273 fld_info(cfld)%ntrange=0
4274 endif
4275 fld_info(cfld)%tinvstat=itprec
4276 if(fld_info(cfld)%ntrange==0) then
4277 if (ifhr==0) then
4278 fld_info(cfld)%tinvstat=0
4279 else
4280 fld_info(cfld)%tinvstat=1
4281 endif
4282 fld_info(cfld)%ntrange=1
4283 end if
4284!$omp parallel do private(i,j,ii,jj)
4285 do j=1,jend-jsta+1
4286 jj = jsta+j-1
4287 do i=1,iend-ista+1
4288 ii = ista+i-1
4289 datapd(i,j,cfld) = grid1(ii,jj)
4290 enddo
4291 enddo
4292 endif
4293 ENDIF
4294! PRECIPITATION BUCKETS - accumulated between output times
4295! 'BUCKET GRAUPEL PRECIP '
4296 IF (iget(775)>0.) THEN
4297!$omp parallel do private(i,j)
4298 DO j=jsta,jend
4299 DO i=ista,iend
4300 grid1(i,j) = graup_bucket(i,j)
4301 ENDDO
4302 ENDDO
4303 id(1:25) = 0
4304 itprec = nint(tprec)
4305!mp
4306 if (itprec /= 0) then
4307 ifincr = mod(ifhr,itprec)
4308 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
4309 else
4310 ifincr = 0
4311 endif
4312!mp
4313 if(modelname=='NCAR' .OR. modelname=='RAPR') ifincr = nint(prec_acc_dt)/60
4314 id(18) = 0
4315 id(19) = ifhr
4316 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
4317 id(20) = 4
4318 IF (ifincr==0) THEN
4319 id(18) = ifhr-itprec
4320 ELSE
4321 id(18) = ifhr-ifincr
4322 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
4323 ENDIF
4324 IF (id(18)<0) id(18) = 0
4325! print*,'maxval BUCKET GRAUPEL: ', maxval(GRID1)
4326 if(grib=='grib2') then
4327 cfld=cfld+1
4328 fld_info(cfld)%ifld=iavblfld(iget(775))
4329 if(itprec>0) then
4330 fld_info(cfld)%ntrange=(ifhr-id(18))/itprec
4331 else
4332 fld_info(cfld)%ntrange=0
4333 endif
4334 fld_info(cfld)%tinvstat=itprec
4335 if(fld_info(cfld)%ntrange==0) then
4336 if (ifhr==0) then
4337 fld_info(cfld)%tinvstat=0
4338 else
4339 fld_info(cfld)%tinvstat=1
4340 endif
4341 fld_info(cfld)%ntrange=1
4342 end if
4343 if(modelname == 'GFS' .OR. modelname == 'FV3R') then
4344 fld_info(cfld)%ntrange=1
4345 fld_info(cfld)%tinvstat=ifhr-id(18)
4346 endif
4347!$omp parallel do private(i,j,ii,jj)
4348 do j=1,jend-jsta+1
4349 jj = jsta+j-1
4350 do i=1,iend-ista+1
4351 ii = ista+i-1
4352 datapd(i,j,cfld) = grid1(ii,jj)
4353 enddo
4354 enddo
4355 endif
4356 ENDIF
4357
4358! 'BUCKET FREEZING RAIN '
4359 IF (iget(1003)>0.) THEN
4360!$omp parallel do private(i,j)
4361 DO j=jsta,jend
4362 DO i=ista,iend
4363 grid1(i,j) = frzrn_bucket(i,j)
4364 ENDDO
4365 ENDDO
4366 id(1:25) = 0
4367 itprec = nint(tprec)
4368!mp
4369 if (itprec /= 0) then
4370 ifincr = mod(ifhr,itprec)
4371 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
4372 else
4373 ifincr = 0
4374 endif
4375!mp
4376 id(18) = 0
4377 id(19) = ifhr
4378 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
4379 id(20) = 4
4380 IF (ifincr==0) THEN
4381 id(18) = ifhr-itprec
4382 ELSE
4383 id(18) = ifhr-ifincr
4384 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
4385 ENDIF
4386 IF (id(18)<0) id(18) = 0
4387! print*,'maxval BUCKET FREEZING RAIN: ', maxval(GRID1)
4388 if(grib=='grib2') then
4389 cfld=cfld+1
4390 fld_info(cfld)%ifld=iavblfld(iget(1003))
4391 fld_info(cfld)%ntrange=1
4392 fld_info(cfld)%tinvstat=ifhr-id(18)
4393! if(ITPREC>0) then
4394! fld_info(cfld)%ntrange=(IFHR-ID(18))/ITPREC
4395! else
4396! fld_info(cfld)%ntrange=0
4397! endif
4398! fld_info(cfld)%tinvstat=ITPREC
4399! if(fld_info(cfld)%ntrange==0) then
4400! if (ifhr==0) then
4401! fld_info(cfld)%tinvstat=0
4402! else
4403! fld_info(cfld)%tinvstat=1
4404! endif
4405! fld_info(cfld)%ntrange=1
4406! end if
4407!$omp parallel do private(i,j,ii,jj)
4408 do j=1,jend-jsta+1
4409 jj = jsta+j-1
4410 do i=1,iend-ista+1
4411 ii = ista+i-1
4412 datapd(i,j,cfld) = grid1(ii,jj)
4413 enddo
4414 enddo
4415 endif
4416 ENDIF
4417
4418! 'BUCKET SNOWFALL '
4419 IF (iget(1005)>0.) THEN
4420!$omp parallel do private(i,j)
4421 DO j=jsta,jend
4422 DO i=ista,iend
4423 grid1(i,j) = snow_bkt(i,j)
4424 ENDDO
4425 ENDDO
4426 id(1:25) = 0
4427 itprec = nint(tprec)
4428!mp
4429 if (itprec /= 0) then
4430 ifincr = mod(ifhr,itprec)
4431 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
4432 else
4433 ifincr = 0
4434 endif
4435!mp
4436 id(18) = 0
4437 id(19) = ifhr
4438 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
4439 id(20) = 4
4440 IF (ifincr==0) THEN
4441 id(18) = ifhr-itprec
4442 ELSE
4443 id(18) = ifhr-ifincr
4444 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
4445 ENDIF
4446 IF (id(18)<0) id(18) = 0
4447! print*,'maxval BUCKET FREEZING RAIN: ', maxval(GRID1)
4448 if(grib=='grib2') then
4449 cfld=cfld+1
4450 fld_info(cfld)%ifld=iavblfld(iget(1005))
4451 fld_info(cfld)%ntrange=1
4452 fld_info(cfld)%tinvstat=ifhr-id(18)
4453!$omp parallel do private(i,j,ii,jj)
4454 do j=1,jend-jsta+1
4455 jj = jsta+j-1
4456 do i=1,iend-ista+1
4457 ii = ista+i-1
4458 datapd(i,j,cfld) = grid1(ii,jj)
4459 enddo
4460 enddo
4461 endif
4462 ENDIF
4463
4464
4465! ERIC JAMES: 10 JUN 2021 -- adding precip comparison to FFG
4466! thresholds. 913 is for 1h QPF, 914 for run total QPF.
4467 IF (iget(913).GT.0) THEN
4468 ffgfile='ffg_01h.grib2'
4469 call qpf_comp(913,ffgfile,1)
4470 ENDIF
4471 IF (iget(914).GT.0) THEN
4472 IF (ifhr .EQ. 1) THEN
4473 ffgfile='ffg_01h.grib2'
4474 call qpf_comp(914,ffgfile,1)
4475 ELSEIF (ifhr .EQ. 3) THEN
4476 ffgfile='ffg_03h.grib2'
4477 call qpf_comp(914,ffgfile,3)
4478 ELSEIF (ifhr .EQ. 6) THEN
4479 ffgfile='ffg_06h.grib2'
4480 call qpf_comp(914,ffgfile,6)
4481 ELSEIF (ifhr .EQ. 12) THEN
4482 ffgfile='ffg_12h.grib2'
4483 call qpf_comp(914,ffgfile,12)
4484 ELSE
4485 ffgfile='ffg_01h.grib2'
4486 call qpf_comp(914,ffgfile,0)
4487 ENDIF
4488 ENDIF
4489
4490! ERIC JAMES: 8 OCT 2021 -- adding precip comparison to ARI
4491! thresholds. 915 is for 1h QPF, 916 for run total QPF.
4492
4493 IF (iget(915).GT.0) THEN
4494 arifile='ari2y_01h.grib2'
4495 call qpf_comp(915,arifile,1)
4496 ENDIF
4497 IF (iget(916).GT.0) THEN
4498 IF (ifhr .EQ. 1) THEN
4499 arifile='ari2y_01h.grib2'
4500 call qpf_comp(916,arifile,1)
4501 ELSEIF (ifhr .EQ. 3) THEN
4502 arifile='ari2y_03h.grib2'
4503 call qpf_comp(916,arifile,3)
4504 ELSEIF (ifhr .EQ. 6) THEN
4505 arifile='ari2y_06h.grib2'
4506 call qpf_comp(916,arifile,6)
4507 ELSEIF (ifhr .EQ. 12) THEN
4508 arifile='ari2y_12h.grib2'
4509 call qpf_comp(916,arifile,12)
4510 ELSEIF (ifhr .EQ. 24) THEN
4511 arifile='ari2y_24h.grib2'
4512 call qpf_comp(916,arifile,24)
4513 ELSE
4514 arifile='ari2y_01h.grib2'
4515 call qpf_comp(916,arifile,0)
4516 ENDIF
4517 ENDIF
4518
4519 IF (iget(917).GT.0) THEN
4520 arifile='ari5y_01h.grib2'
4521 call qpf_comp(917,arifile,1)
4522 ENDIF
4523 IF (iget(918).GT.0) THEN
4524 IF (ifhr .EQ. 1) THEN
4525 arifile='ari5y_01h.grib2'
4526 call qpf_comp(918,arifile,1)
4527 ELSEIF (ifhr .EQ. 3) THEN
4528 arifile='ari5y_03h.grib2'
4529 call qpf_comp(918,arifile,3)
4530 ELSEIF (ifhr .EQ. 6) THEN
4531 arifile='ari5y_06h.grib2'
4532 call qpf_comp(918,arifile,6)
4533 ELSEIF (ifhr .EQ. 12) THEN
4534 arifile='ari5y_12h.grib2'
4535 call qpf_comp(918,arifile,12)
4536 ELSEIF (ifhr .EQ. 24) THEN
4537 arifile='ari5y_24h.grib2'
4538 call qpf_comp(918,arifile,24)
4539 ELSE
4540 arifile='ari5y_01h.grib2'
4541 call qpf_comp(918,arifile,0)
4542 ENDIF
4543 ENDIF
4544
4545 IF (iget(919).GT.0) THEN
4546 arifile='ari10y_01h.grib2'
4547 call qpf_comp(919,arifile,1)
4548 ENDIF
4549 IF (iget(920).GT.0) THEN
4550 IF (ifhr .EQ. 1) THEN
4551 arifile='ari10y_01h.grib2'
4552 call qpf_comp(920,arifile,1)
4553 ELSEIF (ifhr .EQ. 3) THEN
4554 arifile='ari10y_03h.grib2'
4555 call qpf_comp(920,arifile,3)
4556 ELSEIF (ifhr .EQ. 6) THEN
4557 arifile='ari10y_06h.grib2'
4558 call qpf_comp(920,arifile,6)
4559 ELSEIF (ifhr .EQ. 12) THEN
4560 arifile='ari10y_12h.grib2'
4561 call qpf_comp(920,arifile,12)
4562 ELSEIF (ifhr .EQ. 24) THEN
4563 arifile='ari10y_24h.grib2'
4564 call qpf_comp(920,arifile,24)
4565 ELSE
4566 arifile='ari10y_01h.grib2'
4567 call qpf_comp(920,arifile,0)
4568 ENDIF
4569 ENDIF
4570
4571 IF (iget(921).GT.0) THEN
4572 arifile='ari100y_01h.grib2'
4573 call qpf_comp(921,arifile,1)
4574 ENDIF
4575 IF (iget(922).GT.0) THEN
4576 IF (ifhr .EQ. 1) THEN
4577 arifile='ari100y_01h.grib2'
4578 call qpf_comp(922,arifile,1)
4579 ELSEIF (ifhr .EQ. 3) THEN
4580 arifile='ari100y_03h.grib2'
4581 call qpf_comp(922,arifile,3)
4582 ELSEIF (ifhr .EQ. 6) THEN
4583 arifile='ari100y_06h.grib2'
4584 call qpf_comp(922,arifile,6)
4585 ELSEIF (ifhr .EQ. 12) THEN
4586 arifile='ari100y_12h.grib2'
4587 call qpf_comp(922,arifile,12)
4588 ELSEIF (ifhr .EQ. 24) THEN
4589 arifile='ari100y_24h.grib2'
4590 call qpf_comp(922,arifile,24)
4591 ELSE
4592 arifile='ari100y_01h.grib2'
4593 call qpf_comp(922,arifile,0)
4594 ENDIF
4595 ENDIF
4596
4597! ERIC JAMES: 10 APR 2019 -- adding 15min precip output for RAP/HRRR
4598! PRECIPITATION BUCKETS - accumulated between output times
4599! 'BUCKET1 VAR DENS SNOW '
4600 IF (iget(525)>0.) THEN
4601!$omp parallel do private(i,j)
4602 DO j=jsta,jend
4603 DO i=ista,iend
4604 IF(sndepac(i,j) < spval)THEN
4605 grid1(i,j) = sndepac(i,j)/(1e3)
4606 ENDIF
4607 ENDDO
4608 ENDDO
4609 ifincr = nint(prec_acc_dt1)
4610 if(grib=='grib2') then
4611 cfld=cfld+1
4612 fld_info(cfld)%ifld=iavblfld(iget(525))
4613 if(fld_info(cfld)%ntrange==0) then
4614 if (ifhr==0 .and. ifmin==0) then
4615 fld_info(cfld)%tinvstat=0
4616 else
4617 fld_info(cfld)%tinvstat=ifincr
4618 endif
4619 fld_info(cfld)%ntrange=1
4620 end if
4621!$omp parallel do private(i,j,ii,jj)
4622 do j=1,jend-jsta+1
4623 jj = jsta+j-1
4624 do i=1,iend-ista+1
4625 ii = ista+i-1
4626 datapd(i,j,cfld) = grid1(ii,jj)
4627 enddo
4628 enddo
4629 endif
4630 ENDIF
4631! 'BUCKET1 TOTAL PRECIP '
4632 IF (iget(526)>0.) THEN
4633 IF (modelname .EQ. 'FV3R') THEN
4634!$omp parallel do private(i,j)
4635 DO j=jsta,jend
4636 DO i=ista,iend
4637 IF(avgprec_cont(i,j) < spval)THEN
4638 grid1(i,j) = avgprec_cont(i,j)*900.*1000./dtq2
4639 ENDIF
4640 ENDDO
4641 ENDDO
4642 ELSE
4643!$omp parallel do private(i,j)
4644 DO j=jsta,jend
4645 DO i=ista,iend
4646 IF (ifhr == 0 .AND. ifmin == 0) THEN
4647 grid1(i,j) = 0.0
4648 ELSE
4649 grid1(i,j) = pcp_bucket1(i,j)
4650 ENDIF
4651 ENDDO
4652 ENDDO
4653 ENDIF
4654 ifincr = nint(prec_acc_dt1)
4655 if(grib=='grib2') then
4656 cfld=cfld+1
4657 fld_info(cfld)%ifld=iavblfld(iget(526))
4658 if(fld_info(cfld)%ntrange==0) then
4659 if (ifhr==0 .and. ifmin==0) then
4660 fld_info(cfld)%tinvstat=0
4661 else
4662 fld_info(cfld)%tinvstat=ifincr
4663 endif
4664 fld_info(cfld)%ntrange=1
4665 end if
4666!$omp parallel do private(i,j,ii,jj)
4667 do j=1,jend-jsta+1
4668 jj = jsta+j-1
4669 do i=1,iend-ista+1
4670 ii = ista+i-1
4671 datapd(i,j,cfld) = grid1(ii,jj)
4672 enddo
4673 enddo
4674 endif
4675 ENDIF
4676! 'BUCKET1 FRZR PRECIP '
4677 IF (iget(527)>0.) THEN
4678!$omp parallel do private(i,j)
4679 DO j=jsta,jend
4680 DO i=ista,iend
4681 IF(acfrain(i,j) < spval)THEN
4682 grid1(i,j) = acfrain(i,j)
4683 ENDIF
4684 ENDDO
4685 ENDDO
4686 ifincr = nint(prec_acc_dt1)
4687 if(grib=='grib2') then
4688 cfld=cfld+1
4689 fld_info(cfld)%ifld=iavblfld(iget(527))
4690 if(fld_info(cfld)%ntrange==0) then
4691 if (ifhr==0 .and. ifmin==0) then
4692 fld_info(cfld)%tinvstat=0
4693 else
4694 fld_info(cfld)%tinvstat=ifincr
4695 endif
4696 fld_info(cfld)%ntrange=1
4697 end if
4698!$omp parallel do private(i,j,ii,jj)
4699 do j=1,jend-jsta+1
4700 jj = jsta+j-1
4701 do i=1,iend-ista+1
4702 ii = ista+i-1
4703 datapd(i,j,cfld) = grid1(ii,jj)
4704 enddo
4705 enddo
4706 endif
4707 ENDIF
4708! 'BUCKET1 SNOW PRECIP (WEASD for RAPR) '
4709 IF (iget(528)>0.) THEN
4710!$omp parallel do private(i,j)
4711 DO j=jsta,jend
4712 DO i=ista,iend
4713 IF(snow_acm(i,j) < spval)THEN
4714 grid1(i,j) = snow_acm(i,j)
4715 ENDIF
4716 ENDDO
4717 ENDDO
4718 ifincr = nint(prec_acc_dt1)
4719 if(grib=='grib2') then
4720 cfld=cfld+1
4721 fld_info(cfld)%ifld=iavblfld(iget(528))
4722 if(fld_info(cfld)%ntrange==0) then
4723 if (ifhr==0 .and. ifmin==0) then
4724 fld_info(cfld)%tinvstat=0
4725 else
4726 fld_info(cfld)%tinvstat=ifincr
4727 endif
4728 fld_info(cfld)%ntrange=1
4729 end if
4730!$omp parallel do private(i,j,ii,jj)
4731 do j=1,jend-jsta+1
4732 jj = jsta+j-1
4733 do i=1,iend-ista+1
4734 ii = ista+i-1
4735 datapd(i,j,cfld) = grid1(ii,jj)
4736 enddo
4737 enddo
4738 endif
4739 ENDIF
4740! 'BUCKET1 SNOW PRECIP (TSNOWP for FV3R) '
4741 IF (iget(529)>0.) THEN
4742!$omp parallel do private(i,j)
4743 DO j=jsta,jend
4744 DO i=ista,iend
4745 IF (ifhr == 0 .AND. ifmin == 0) THEN
4746 grid1(i,j) = 0.0
4747 ELSE
4748 grid1(i,j) = snow_bucket1(i,j)
4749 ENDIF
4750 ENDDO
4751 ENDDO
4752 ifincr = nint(prec_acc_dt1)
4753! if(me==0)print*,'maxval BUCKET1 SNOWFALL: ', maxval(GRID1)
4754 if(grib=='grib2') then
4755 cfld=cfld+1
4756 fld_info(cfld)%ifld=iavblfld(iget(529))
4757 if(fld_info(cfld)%ntrange==0) then
4758 if (ifhr==0 .and. ifmin==0) then
4759 fld_info(cfld)%tinvstat=0
4760 else
4761 fld_info(cfld)%tinvstat=ifincr
4762 endif
4763 fld_info(cfld)%ntrange=1
4764 end if
4765!$omp parallel do private(i,j,ii,jj)
4766 do j=1,jend-jsta+1
4767 jj = jsta+j-1
4768 do i=1,iend-ista+1
4769 ii = ista+i-1
4770 datapd(i,j,cfld) = grid1(ii,jj)
4771 enddo
4772 enddo
4773 endif
4774 ENDIF
4775! 'BUCKET1 GRAUPEL PRECIP '
4776 IF (iget(530)>0.) THEN
4777 IF (modelname .EQ. 'FV3R') THEN
4778!$omp parallel do private(i,j)
4779 DO j=jsta,jend
4780 DO i=ista,iend
4781 IF(acgraup(i,j) < spval)THEN
4782 grid1(i,j) = acgraup(i,j)
4783 ENDIF
4784 ENDDO
4785 ENDDO
4786 ELSE
4787!$omp parallel do private(i,j)
4788 DO j=jsta,jend
4789 DO i=ista,iend
4790 IF (ifhr == 0 .AND. ifmin == 0) THEN
4791 grid1(i,j) = 0.0
4792 ELSE
4793 grid1(i,j) = graup_bucket1(i,j)
4794 ENDIF
4795 ENDDO
4796 ENDDO
4797 ENDIF
4798 ifincr = nint(prec_acc_dt1)
4799! print*,'maxval BUCKET1 GRAUPEL: ', maxval(GRID1)
4800 if(grib=='grib2') then
4801 cfld=cfld+1
4802 fld_info(cfld)%ifld=iavblfld(iget(530))
4803 if(fld_info(cfld)%ntrange==0) then
4804 if (ifhr==0 .and. ifmin==0) then
4805 fld_info(cfld)%tinvstat=0
4806 else
4807 fld_info(cfld)%tinvstat=ifincr
4808 endif
4809 fld_info(cfld)%ntrange=1
4810 end if
4811!$omp parallel do private(i,j,ii,jj)
4812 do j=1,jend-jsta+1
4813 jj = jsta+j-1
4814 do i=1,iend-ista+1
4815 ii = ista+i-1
4816 datapd(i,j,cfld) = grid1(ii,jj)
4817 enddo
4818 enddo
4819 endif
4820 ENDIF
4821!
4822! INSTANTANEOUS PRECIPITATION TYPE.
4823! print *,'in surfce,iget(160)=',iget(160),'iget(247)=',iget(247)
4824 IF (iget(160)>0 .OR.(iget(247)>0)) THEN
4825
4826 allocate(sleet(ista:iend,jsta:jend,nalg), rain(ista:iend,jsta:jend,nalg), &
4827 freezr(ista:iend,jsta:jend,nalg), snow(ista:iend,jsta:jend,nalg))
4828 allocate(zwet(ista:iend,jsta:jend))
4829 CALL calwxt_post(t,q,pmid,pint,htm,lmh,prec,zint,iwx1,zwet)
4830! write(*,*)' after first CALWXT_POST'
4831
4832
4833 IF (iget(160)>0) THEN
4834!$omp parallel do private(i,j,iwx)
4835 DO j=jsta,jend
4836 DO i=ista,iend
4837 IF(zwet(i,j)<spval)THEN
4838 iwx = iwx1(i,j)
4839 snow(i,j,1) = mod(iwx,2)
4840 sleet(i,j,1) = mod(iwx,4)/2
4841 freezr(i,j,1) = mod(iwx,8)/4
4842 rain(i,j,1) = iwx/8
4843 ELSE
4844 snow(i,j,1) = spval
4845 sleet(i,j,1) = spval
4846 freezr(i,j,1) = spval
4847 rain(i,j,1) = spval
4848 ENDIF
4849 ENDDO
4850 ENDDO
4851 ENDIF
4852!
4853! LOWEST WET BULB ZERO HEIGHT
4854 IF (iget(247)>0) THEN
4855 DO j=jsta,jend
4856 DO i=ista,iend
4857 grid1(i,j) = zwet(i,j)
4858 ENDDO
4859 ENDDO
4860 if(grib=='grib2') then
4861 cfld=cfld+1
4862 fld_info(cfld)%ifld=iavblfld(iget(247))
4863!$omp parallel do private(i,j,ii,jj)
4864 do j=1,jend-jsta+1
4865 jj = jsta+j-1
4866 do i=1,iend-ista+1
4867 ii = ista+i-1
4868 datapd(i,j,cfld) = grid1(ii,jj)
4869 enddo
4870 enddo
4871 endif
4872 ENDIF
4873
4874! DOMINANT PRECIPITATION TYPE
4875!GSM IF DOMINANT PRECIP TYPE IS REQUESTED, 4 MORE ALGORITHMS
4876!GSM WILL BE CALLED. THE TALLIES ARE THEN SUMMED IN
4877!GSM CALWXT_DOMINANT
4878
4879 IF (iget(160)>0) THEN
4880! RAMER ALGORITHM
4881 CALL calwxt_ramer_post(t,q,pmid,pint,lmh,prec,iwx1)
4882! print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA)
4883
4884! DECOMPOSE IWX1 ARRAY
4885!
4886!$omp parallel do private(i,j,iwx)
4887 DO j=jsta,jend
4888 DO i=ista,iend
4889 iwx = iwx1(i,j)
4890 snow(i,j,2) = mod(iwx,2)
4891 sleet(i,j,2) = mod(iwx,4)/2
4892 freezr(i,j,2) = mod(iwx,8)/4
4893 rain(i,j,2) = iwx/8
4894 ENDDO
4895 ENDDO
4896
4897! BOURGOUIN ALGORITHM
4898 iseed=44641*(int(sdat(1)-1)*24*31+int(sdat(2))*24+ihrst)+ &
4899 & mod(ifhr*60+ifmin,44641)+4357
4900! write(*,*)'in SURFCE,me=',me,'bef 1st CALWXT_BOURG_POST iseed=',iseed
4901 CALL calwxt_bourg_post(im,ista_2l,iend_2u,ista,iend,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1,&
4902 & iseed,g,pthresh, &
4903 & t,q,pmid,pint,lmh,prec,zint,iwx1,me)
4904! write(*,*)'in SURFCE,me=',me,'aft 1st CALWXT_BOURG_POST'
4905! write(*,*)'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA),'PTHRESH=',PTHRESH
4906
4907! DECOMPOSE IWX1 ARRAY
4908!
4909!$omp parallel do private(i,j,iwx)
4910 DO j=jsta,jend
4911 DO i=ista,iend
4912 iwx = iwx1(i,j)
4913 snow(i,j,3) = mod(iwx,2)
4914 sleet(i,j,3) = mod(iwx,4)/2
4915 freezr(i,j,3) = mod(iwx,8)/4
4916 rain(i,j,3) = iwx/8
4917 ENDDO
4918 ENDDO
4919
4920! REVISED NCEP ALGORITHM
4921 CALL calwxt_revised_post(t,q,pmid,pint,htm,lmh,prec,zint,iwx1)
4922! print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA)
4923! DECOMPOSE IWX1 ARRAY
4924!
4925!$omp parallel do private(i,j,iwx)
4926 DO j=jsta,jend
4927 DO i=ista,iend
4928 iwx = iwx1(i,j)
4929 snow(i,j,4) = mod(iwx,2)
4930 sleet(i,j,4) = mod(iwx,4)/2
4931 freezr(i,j,4) = mod(iwx,8)/4
4932 rain(i,j,4) = iwx/8
4933 ENDDO
4934 ENDDO
4935
4936! EXPLICIT ALGORITHM (UNDER 18 NOT ADMITTED WITHOUT PARENT OR GUARDIAN)
4937
4938 IF(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95)then
4939 CALL calwxt_explicit_post(lmh,ths,pmid,prec,sr,f_rimef,iwx1)
4940 else
4941!$omp parallel do private(i,j)
4942 DO j=jsta,jend
4943 DO i=ista,iend
4944 iwx1(i,j) = 0
4945 ENDDO
4946 ENDDO
4947 end if
4948! print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA)
4949! DECOMPOSE IWX1 ARRAY
4950!
4951!$omp parallel do private(i,j,iwx)
4952 DO j=jsta,jend
4953 DO i=ista,iend
4954 iwx = iwx1(i,j)
4955 snow(i,j,5) = mod(iwx,2)
4956 sleet(i,j,5) = mod(iwx,4)/2
4957 freezr(i,j,5) = mod(iwx,8)/4
4958 rain(i,j,5) = iwx/8
4959 ENDDO
4960 ENDDO
4961
4962 allocate(domr(ista:iend,jsta:jend), doms(ista:iend,jsta:jend), &
4963 domzr(ista:iend,jsta:jend), domip(ista:iend,jsta:jend))
4964 CALL calwxt_dominant_post(prec(ista_2l,jsta_2l),rain,freezr,sleet,snow, &
4965 domr,domzr,domip,doms)
4966! if ( me==0) print *,'after CALWXT_DOMINANT, no avrg'
4967! SNOW.
4968 grid1 = spval
4969!$omp parallel do private(i,j)
4970 DO j=jsta,jend
4971 DO i=ista,iend
4972 if(prec(i,j) /= spval) grid1(i,j) = doms(i,j)
4973 ENDDO
4974 ENDDO
4975 if(grib=='grib2') then
4976 cfld=cfld+1
4977 fld_info(cfld)%ifld=iavblfld(iget(551))
4978!$omp parallel do private(i,j,ii,jj)
4979 do j=1,jend-jsta+1
4980 jj = jsta+j-1
4981 do i=1,iend-ista+1
4982 ii = ista+i-1
4983 datapd(i,j,cfld) = grid1(ii,jj)
4984 enddo
4985 enddo
4986 endif
4987! ICE PELLETS.
4988 grid1=spval
4989!$omp parallel do private(i,j)
4990 DO j=jsta,jend
4991 DO i=ista,iend
4992 if(prec(i,j)/=spval) grid1(i,j) = domip(i,j)
4993 ENDDO
4994 ENDDO
4995 if(grib=='grib2') then
4996 cfld=cfld+1
4997 fld_info(cfld)%ifld=iavblfld(iget(552))
4998!$omp parallel do private(i,j,ii,jj)
4999 do j=1,jend-jsta+1
5000 jj = jsta+j-1
5001 do i=1,iend-ista+1
5002 ii = ista+i-1
5003 datapd(i,j,cfld) = grid1(ii,jj)
5004 enddo
5005 enddo
5006 endif
5007! FREEZING RAIN.
5008 grid1=spval
5009!$omp parallel do private(i,j)
5010 DO j=jsta,jend
5011 DO i=ista,iend
5012! if (DOMZR(I,J) == 1) THEN
5013! PSFC(I,J)=PINT(I,J,NINT(LMH(I,J))+1)
5014! print *, 'aha ', I, J, PSFC(I,J)
5015! print *, FREEZR(I,J,1), FREEZR(I,J,2),
5016! * FREEZR(I,J,3), FREEZR(I,J,4), FREEZR(I,J,5)
5017! endif
5018 if(prec(i,j)/=spval)grid1(i,j) = domzr(i,j)
5019 ENDDO
5020 ENDDO
5021 if(grib=='grib2') then
5022 cfld=cfld+1
5023 fld_info(cfld)%ifld=iavblfld(iget(553))
5024!$omp parallel do private(i,j,ii,jj)
5025 do j=1,jend-jsta+1
5026 jj = jsta+j-1
5027 do i=1,iend-ista+1
5028 ii = ista+i-1
5029 datapd(i,j,cfld) = grid1(ii,jj)
5030 enddo
5031 enddo
5032 endif
5033! RAIN.
5034 grid1=spval
5035!$omp parallel do private(i,j)
5036 DO j=jsta,jend
5037 DO i=ista,iend
5038 if(prec(i,j)/=spval)grid1(i,j) = domr(i,j)
5039 ENDDO
5040 ENDDO
5041 if(grib=='grib2') then
5042 cfld=cfld+1
5043 fld_info(cfld)%ifld=iavblfld(iget(160))
5044!$omp parallel do private(i,j,ii,jj)
5045 do j=1,jend-jsta+1
5046 jj = jsta+j-1
5047 do i=1,iend-ista+1
5048 ii = ista+i-1
5049 datapd(i,j,cfld) = grid1(ii,jj)
5050 enddo
5051 enddo
5052 endif
5053 ENDIF
5054 ENDIF
5055!
5056! TIME AVERAGED PRECIPITATION TYPE.
5057 IF (iget(317)>0) THEN
5058
5059 if (.not. allocated(sleet)) allocate(sleet(ista:iend,jsta:jend,nalg))
5060 if (.not. allocated(rain)) allocate(rain(ista:iend,jsta:jend,nalg))
5061 if (.not. allocated(freezr)) allocate(freezr(ista:iend,jsta:jend,nalg))
5062 if (.not. allocated(snow)) allocate(snow(ista:iend,jsta:jend,nalg))
5063 if (.not. allocated(zwet)) allocate(zwet(ista:iend,jsta:jend))
5064 CALL calwxt_post(t,q,pmid,pint,htm,lmh,avgprec,zint,iwx1,zwet)
5065
5066!$omp parallel do private(i,j,iwx)
5067 DO j=jsta,jend
5068 DO i=ista,iend
5069 IF(zwet(i,j)<spval)THEN
5070 iwx = iwx1(i,j)
5071 snow(i,j,1) = mod(iwx,2)
5072 sleet(i,j,1) = mod(iwx,4)/2
5073 freezr(i,j,1) = mod(iwx,8)/4
5074 rain(i,j,1) = iwx/8
5075 ELSE
5076 snow(i,j,1) = spval
5077 sleet(i,j,1) = spval
5078 freezr(i,j,1) = spval
5079 rain(i,j,1) = spval
5080 ENDIF
5081 ENDDO
5082 ENDDO
5083 if (allocated(zwet)) deallocate(zwet)
5084! write(*,*)' after second CALWXT_POST me=',me
5085! print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA)
5086
5087! DOMINANT PRECIPITATION TYPE
5088!GSM IF DOMINANT PRECIP TYPE IS REQUESTED, 4 MORE ALGORITHMS
5089!GSM WILL BE CALLED. THE TALLIES ARE THEN SUMMED IN
5090!GSM CALWXT_DOMINANT
5091
5092! RAMER ALGORITHM
5093 CALL calwxt_ramer_post(t,q,pmid,pint,lmh,avgprec,iwx1)
5094! print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA)
5095
5096! DECOMPOSE IWX1 ARRAY
5097!
5098!$omp parallel do private(i,j,iwx)
5099 DO j=jsta,jend
5100 DO i=ista,iend
5101 iwx = iwx1(i,j)
5102 snow(i,j,2) = mod(iwx,2)
5103 sleet(i,j,2) = mod(iwx,4)/2
5104 freezr(i,j,2) = mod(iwx,8)/4
5105 rain(i,j,2) = iwx/8
5106 ENDDO
5107 ENDDO
5108
5109! BOURGOUIN ALGORITHM
5110 iseed=44641*(int(sdat(1)-1)*24*31+int(sdat(2))*24+ihrst)+ &
5111 & mod(ifhr*60+ifmin,44641)+4357
5112! write(*,*)'in SURFCE,me=',me,'bef sec CALWXT_BOURG_POST'
5113 CALL calwxt_bourg_post(im,ista_2l,iend_2u,ista,iend,jm,jsta_2l,jend_2u,jsta,jend,lm,lp1,&
5114 & iseed,g,pthresh, &
5115 & t,q,pmid,pint,lmh,avgprec,zint,iwx1,me)
5116! write(*,*)'in SURFCE,me=',me,'aft sec CALWXT_BOURG_POST'
5117! print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA)
5118
5119! DECOMPOSE IWX1 ARRAY
5120!
5121!$omp parallel do private(i,j,iwx)
5122 DO j=jsta,jend
5123 DO i=ista,iend
5124 iwx = iwx1(i,j)
5125 snow(i,j,3) = mod(iwx,2)
5126 sleet(i,j,3) = mod(iwx,4)/2
5127 freezr(i,j,3) = mod(iwx,8)/4
5128 rain(i,j,3) = iwx/8
5129 ENDDO
5130 ENDDO
5131
5132! REVISED NCEP ALGORITHM
5133 CALL calwxt_revised_post(t,q,pmid,pint,htm,lmh,avgprec,zint,iwx1)
5134! write(*,*)'in SURFCE,me=',me,'aft sec CALWXT_REVISED_BOURG_POST'
5135! print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA)
5136! DECOMPOSE IWX1 ARRAY
5137!
5138!$omp parallel do private(i,j,iwx)
5139 DO j=jsta,jend
5140 DO i=ista,iend
5141 iwx = iwx1(i,j)
5142 snow(i,j,4) = mod(iwx,2)
5143 sleet(i,j,4) = mod(iwx,4)/2
5144 freezr(i,j,4) = mod(iwx,8)/4
5145 rain(i,j,4) = iwx/8
5146 ENDDO
5147 ENDDO
5148
5149! EXPLICIT ALGORITHM (UNDER 18 NOT ADMITTED WITHOUT PARENT OR GUARDIAN)
5150
5151! write(*,*)'in SURFCE,me=',me,'imp_physics=',imp_physics
5152 IF(imp_physics == 5)then
5153 CALL calwxt_explicit_post(lmh,ths,pmid,avgprec,sr,f_rimef,iwx1)
5154 else
5155!$omp parallel do private(i,j)
5156 DO j=jsta,jend
5157 DO i=ista,iend
5158 iwx1(i,j) = 0
5159 ENDDO
5160 ENDDO
5161 end if
5162! print *,'in SURFCE,me=',me,'IWX1=',IWX1(1:30,JSTA)
5163! DECOMPOSE IWX1 ARRAY
5164!
5165!$omp parallel do private(i,j,iwx)
5166 DO j=jsta,jend
5167 DO i=ista,iend
5168 iwx = iwx1(i,j)
5169 snow(i,j,5) = mod(iwx,2)
5170 sleet(i,j,5) = mod(iwx,4)/2
5171 freezr(i,j,5) = mod(iwx,8)/4
5172 rain(i,j,5) = iwx/8
5173 ENDDO
5174 ENDDO
5175
5176! print *,'me=',me,'before SNOW=',snow(1:10,JSTA,1:5)
5177! print *,'me=',me,'before RAIN=',RAIN(1:10,JSTA,1:5)
5178! print *,'me=',me,'before FREEZR=',FREEZR(1:10,JSTA,1:5)
5179! print *,'me=',me,'before SLEET=',SLEET(1:10,JSTA,1:5)
5180
5181 if (.not. allocated(domr)) allocate(domr(ista:iend,jsta:jend))
5182 if (.not. allocated(doms)) allocate(doms(ista:iend,jsta:jend))
5183 if (.not. allocated(domzr)) allocate(domzr(ista:iend,jsta:jend))
5184 if (.not. allocated(domip)) allocate(domip(ista:iend,jsta:jend))
5185
5186 CALL calwxt_dominant_post(avgprec,rain,freezr,sleet,snow, &
5187 domr,domzr,domip,doms)
5188
5189 id(1:25) = 0
5190 itprec = nint(tprec)
5191!mp
5192 if (itprec /= 0) then
5193 ifincr = mod(ifhr,itprec)
5194 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
5195 else
5196 ifincr = 0
5197 endif
5198!mp
5199 id(18) = 0
5200 id(19) = ifhr
5201 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
5202 id(20) = 3
5203 IF (ifincr==0) THEN
5204 id(18) = ifhr-itprec
5205 ELSE
5206 id(18) = ifhr-ifincr
5207 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
5208 ENDIF
5209
5210! TPREC,'IFHR=',IFHR,'IFMIN=',IFMIN,'IFINCR=',IFINCR,'ID=',ID
5211! SNOW.
5212
5213 id(8) = 143
5214 grid1=spval
5215!$omp parallel do private(i,j)
5216 DO j=jsta,jend
5217 DO i=ista,iend
5218 if(avgprec(i,j) /= spval) grid1(i,j) = doms(i,j)
5219 ENDDO
5220 ENDDO
5221! print *,'me=',me,'SNOW=',GRID1(1:10,JSTA)
5222 if(grib=='grib2') then
5223 cfld=cfld+1
5224 fld_info(cfld)%ifld=iavblfld(iget(555))
5225 if(itprec==0) then
5226 fld_info(cfld)%ntrange=0
5227 else
5228 fld_info(cfld)%ntrange=1
5229 endif
5230 fld_info(cfld)%tinvstat=ifhr-id(18)
5231
5232!$omp parallel do private(i,j,ii,jj)
5233 do j=1,jend-jsta+1
5234 jj = jsta+j-1
5235 do i=1,iend-ista+1
5236 ii = ista+i-1
5237 datapd(i,j,cfld) = grid1(ii,jj)
5238 enddo
5239 enddo
5240 endif
5241! ICE PELLETS.
5242 id(8) = 142
5243 itprec = nint(tprec)
5244!mp
5245 if (itprec /= 0) then
5246 ifincr = mod(ifhr,itprec)
5247 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
5248 else
5249 ifincr = 0
5250 endif
5251!mp
5252 id(18) = 0
5253 id(19) = ifhr
5254 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
5255 id(20) = 3
5256 IF (ifincr==0) THEN
5257 id(18) = ifhr-itprec
5258 ELSE
5259 id(18) = ifhr-ifincr
5260 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
5261 ENDIF
5262 grid1=spval
5263!$omp parallel do private(i,j)
5264 DO j=jsta,jend
5265 DO i=ista,iend
5266 if(avgprec(i,j)/=spval) grid1(i,j) = domip(i,j)
5267 ENDDO
5268 ENDDO
5269 if(grib=='grib2') then
5270 cfld=cfld+1
5271 fld_info(cfld)%ifld=iavblfld(iget(556))
5272 if(itprec==0) then
5273 fld_info(cfld)%ntrange=0
5274 else
5275 fld_info(cfld)%ntrange=1
5276 endif
5277 fld_info(cfld)%tinvstat=ifhr-id(18)
5278
5279!$omp parallel do private(i,j,ii,jj)
5280 do j=1,jend-jsta+1
5281 jj = jsta+j-1
5282 do i=1,iend-ista+1
5283 ii = ista+i-1
5284 datapd(i,j,cfld) = grid1(ii,jj)
5285 enddo
5286 enddo
5287 endif
5288! FREEZING RAIN.
5289 id(8) = 141
5290
5291 itprec = nint(tprec)
5292!mp
5293 if (itprec /= 0) then
5294 ifincr = mod(ifhr,itprec)
5295 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
5296 else
5297 ifincr = 0
5298 endif
5299!mp
5300 id(18) = 0
5301 id(19) = ifhr
5302 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
5303 id(20) = 3
5304 IF (ifincr==0) THEN
5305 id(18) = ifhr-itprec
5306 ELSE
5307 id(18) = ifhr-ifincr
5308 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
5309 ENDIF
5310 grid1=spval
5311!$omp parallel do private(i,j)
5312 DO j=jsta,jend
5313 DO i=ista,iend
5314! if (DOMZR(I,J) == 1) THEN
5315! PSFC(I,J)=PINT(I,J,NINT(LMH(I,J))+1)
5316! print *, 'aha ', I, J, PSFC(I,J)
5317! print *, FREEZR(I,J,1), FREEZR(I,J,2),
5318! * FREEZR(I,J,3), FREEZR(I,J,4), FREEZR(I,J,5)
5319! endif
5320 if(avgprec(i,j)/=spval) grid1(i,j) = domzr(i,j)
5321 ENDDO
5322 ENDDO
5323 if(grib=='grib2') then
5324 cfld=cfld+1
5325 fld_info(cfld)%ifld=iavblfld(iget(557))
5326 if(itprec==0) then
5327 fld_info(cfld)%ntrange=0
5328 else
5329 fld_info(cfld)%ntrange=1
5330 endif
5331 fld_info(cfld)%tinvstat=ifhr-id(18)
5332
5333!$omp parallel do private(i,j,ii,jj)
5334 do j=1,jend-jsta+1
5335 jj = jsta+j-1
5336 do i=1,iend-ista+1
5337 ii = ista+i-1
5338 datapd(i,j,cfld) = grid1(ii,jj)
5339 enddo
5340 enddo
5341 endif
5342! RAIN.
5343 id(8) = 140
5344
5345 itprec = nint(tprec)
5346!mp
5347 if (itprec /= 0) then
5348 ifincr = mod(ifhr,itprec)
5349 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
5350 else
5351 ifincr = 0
5352 endif
5353!mp:w
5354
5355 id(18) = 0
5356 id(19) = ifhr
5357 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
5358 id(20) = 3
5359 IF (ifincr==0) THEN
5360 id(18) = ifhr-itprec
5361 ELSE
5362 id(18) = ifhr-ifincr
5363 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
5364 ENDIF
5365 grid1=spval
5366!$omp parallel do private(i,j)
5367 DO j=jsta,jend
5368 DO i=ista,iend
5369 if(avgprec(i,j)/=spval) grid1(i,j) = domr(i,j)
5370 ENDDO
5371 ENDDO
5372 if(grib=='grib2') then
5373 cfld=cfld+1
5374 fld_info(cfld)%ifld=iavblfld(iget(317))
5375 if(itprec==0) then
5376 fld_info(cfld)%ntrange=0
5377 else
5378 fld_info(cfld)%ntrange=1
5379 endif
5380 fld_info(cfld)%tinvstat=ifhr-id(18)
5381
5382!$omp parallel do private(i,j,ii,jj)
5383 do j=1,jend-jsta+1
5384 jj = jsta+j-1
5385 do i=1,iend-ista+1
5386 ii = ista+i-1
5387 datapd(i,j,cfld) = grid1(ii,jj)
5388 enddo
5389 enddo
5390 endif
5391
5392 ENDIF
5393
5394 if (allocated(rain)) deallocate(rain)
5395 if (allocated(snow)) deallocate(snow)
5396 if (allocated(sleet)) deallocate(sleet)
5397 if (allocated(freezr)) deallocate(freezr)
5398
5399! GSD PRECIPITATION TYPE
5400 IF (iget(407)>0 .or. iget(559)>0 .or. &
5401 iget(560)>0 .or. iget(561)>0) THEN
5402
5403 if (.not. allocated(domr)) allocate(domr(ista:iend,jsta:jend))
5404 if (.not. allocated(doms)) allocate(doms(ista:iend,jsta:jend))
5405 if (.not. allocated(domzr)) allocate(domzr(ista:iend,jsta:jend))
5406 if (.not. allocated(domip)) allocate(domip(ista:iend,jsta:jend))
5407
5408!$omp parallel do private(i,j)
5409 DO j=jsta,jend
5410 DO i=ista,iend
5411 doms(i,j) = 0. !-- snow
5412 domr(i,j) = 0. !-- rain
5413 domzr(i,j) = 0. !-- freezing rain
5414 domip(i,j) = 0. !-- ice pellets
5415 ENDDO
5416 ENDDO
5417
5418 IF (modelname .eq. 'FV3R') THEN
5419 DO j=jsta,jend
5420 DO i=ista,iend
5421 snow_bucket(i,j) = snow_bkt(i,j)
5422 rainnc_bucket(i,j) = 0.0
5423 ENDDO
5424 ENDDO
5425 ENDIF
5426
5427 DO j=jsta,jend
5428 DO i=ista,iend
5429!-- TOTPRCP is total 1-hour accumulated precipitation in [m]
5430!-- RAP/HRRR and RRFS use 1-h bucket. GFS uses 3-h bucket
5431!-- so this section will need to be revised for GFS
5432 IF (modelname .eq. 'FV3R') THEN
5433 if(avgprec(i,j)/=spval)then
5434 totprcp = (avgprec(i,j)*3600./dtq2)
5435 else
5436 totprcp = 0.0
5437 endif
5438 ELSE
5439 totprcp = (rainc_bucket(i,j) + rainnc_bucket(i,j))*1.e-3
5440 ENDIF
5441 snowratio = 0.0
5442!-- This following warning message prints too often and is being commented out by
5443!-- Anders Jensen on 30 Jan 2024. I think that this warning message prints only when
5444!-- graupel alone is reaching the surface. Total precipitation is interpolated
5445!-- and precipitation from individual hydrometeor categories is not. Thus, when
5446!-- total precipitation equals graupel precipitation and total precipitation is
5447!-- interpolated and graupel precipitation is not, the two values may not be equal.
5448! if(graup_bucket(i,j)*1.e-3 > totprcp.and.graup_bucket(i,j)/=spval)then
5449! print *,'WARNING - Graupel is higher than total precip at point',i,j
5450! print *,'totprcp,graup_bucket(i,j)*1.e-3,snow_bucket(i,j),rainnc_bucket',&
5451! totprcp,graup_bucket(i,j)*1.e-3,snow_bucket(i,j),rainnc_bucket(i,j)
5452! endif
5453
5454! ---------------------------------------------------------------
5455! Minimum 1h precipitation to even consider p-type specification
5456! (0.0001 mm in 1h, very light precipitation)
5457! ---------------------------------------------------------------
5458 if (totprcp-graup_bucket(i,j)*1.e-3 > 0.0000001) then
5459! snowratio = snow_bucket(i,j)*1.e-3/totprcp ! orig
5460!14aug15 - change from Stan and Trevor
5461! ---------------------------------------------------------------
5462! Snow-to-total ratio to be used below
5463! ---------------------------------------------------------------
5464 IF(modelname == 'FV3R') THEN
5465 snowratio = sr(i,j)
5466 ELSE
5467 snowratio = snow_bucket(i,j)*1.e-3 / (totprcp-graup_bucket(i,j)*1.e-3)
5468 ENDIF
5469 endif
5470!-- 2-m temperature
5471 t2 = tshltr(i,j)*(pshltr(i,j)*1.e-5)**capa
5472! ---------------------------------------------------------------
5473!--snow (or rain if T2m > 3 C)
5474! ---------------------------------------------------------------
5475!-- SNOW is time step non-convective snow [m]
5476! -- based on either instantaneous snowfall or 1h snowfall and
5477! snowratio
5478 if( (snownc(i,j)/dt > 0.2e-9 .and. snowratio>=0.25 .and. snownc(i,j)/=spval) &
5479 .or. &
5480 (totprcp>0.00001.and.snowratio>=0.25)) then
5481 doms(i,j) = 1.
5482 if (t2>=276.15) then
5483! switch snow to rain if 2m temp > 3 deg
5484 domr(i,j) = 1.
5485 doms(i,j) = 0.
5486 end if
5487 end if
5488
5489! ---------------------------------------------------------------
5490!-- rain/freezing rain
5491! ---------------------------------------------------------------
5492!-- compute RAIN [m/s] from total convective and non-convective precipitation
5493 rainl = (1. - sr(i,j))*prec(i,j)/dt
5494!-- in RUC RAIN is in cm/h and the limit is 1.e-3,
5495!-- converted to m/s will be 2.8e-9
5496 if((rainl > 2.8e-9 .and. snowratio<0.60) .or. &
5497 (totprcp>0.00001 .and. snowratio<0.60)) then
5498
5499 if (t2>=273.15) then
5500!--rain
5501 domr(i,j) = 1.
5502! else if (tmax(i,j)>273.15) then
5503!14aug15 - stan
5504 else
5505!-- freezing rain
5506 domzr(i,j) = 1.
5507 endif
5508 endif
5509
5510! ---------------------------------------------------------------
5511!-- graupel/ice pellets vs. snow or rain
5512! ---------------------------------------------------------------
5513!-- GRAUPEL is time step non-convective graupel in [m]
5514 if(graupelnc(i,j)/dt > 1.e-9 .and. graupelnc(i,j)/=spval) then
5515 if (t2<=276.15) then
5516! This T2m test excludes convectively based hail
5517! from cold-season ice pellets.
5518
5519! check for max rain mixing ratio
5520! if it's > 0.05 g/kg, => ice pellets
5521 if (qrmax(i,j)>0.000005) then
5522 if(graupelnc(i,j) > 0.5*snownc(i,j)) then
5523! if (instantaneous graupel fall rate > 0.5*
5524! instantaneous snow fall rate, ....
5525!-- diagnose ice pellets
5526 domip(i,j) = 1.
5527
5528! -- If graupel is greater than rain,
5529! report graupel only
5530! in RUC --> if (3.6E5*gex2(i,j,8)> gex2(i,j,6)) then
5531 if ((graupelnc(i,j)/dt) > rainl) then
5532 domip(i,j) = 1.
5533 domzr(i,j) = 0.
5534 domr(i,j) = 0.
5535! -- If rain is greater than 4x graupel,
5536! report rain only
5537! in RUC --> else if (gex2(i,j,6)>4.*3.6E5*gex2(i,j,8)) then
5538 else if (rainl > (4.*graupelnc(i,j)/dt)) then
5539 domip(i,j) = 0.
5540 end if
5541
5542 else ! instantaneous graupel fall rate <
5543 ! 0.5 * instantaneous snow fall rate
5544! snow -- ensure snow is diagnosed (no ice pellets)
5545 doms(i,j)=1.
5546 end if
5547 else ! if qrmax is not > 0.00005
5548! snow
5549 doms(i,j)=1.
5550 end if
5551
5552 else ! if t2 >= 3 deg C
5553! rain
5554 domr(i,j) = 1.
5555 end if ! End of t2 if/then loop
5556
5557 end if ! End of GRAUPELNC if/then loop
5558
5559 ENDDO
5560 ENDDO
5561
5562
5563 !write (6,*)' Snow/rain ratio'
5564 !write (6,*)' max/min 1h-SNOWFALL in [cm]', &
5565 ! maxval(snow_bucket)*0.1,minval(snow_bucket)*0.1
5566
5567 DO j=jsta,jend
5568 DO i=ista,iend
5569 do icat=1,10
5570 if (snow_bucket(i,j)*0.1<0.1*float(icat).and. &
5571 snow_bucket(i,j)*0.1>0.1*float(icat-1)) then
5572 cnt_snowratio(icat)=cnt_snowratio(icat)+1
5573 end if
5574 end do
5575 end do
5576 end do
5577
5578 !write (6,*) 'Snow ratio point counts'
5579 ! do icat=1,10
5580 !write (6,*) icat, cnt_snowratio(icat)
5581 ! end do
5582
5583 icnt_snow_rain_mixed = 0
5584 DO j=jsta,jend
5585 DO i=ista,iend
5586 if (domr(i,j)==1 .and. doms(i,j)==1) then
5587 icnt_snow_rain_mixed = icnt_snow_rain_mixed + 1
5588 endif
5589 end do
5590 end do
5591
5592 !write (6,*) 'No. of mixed snow/rain p-type diagnosed=', &
5593 ! icnt_snow_rain_mixed
5594
5595
5596! SNOW.
5597!$omp parallel do private(i,j)
5598 DO j=jsta,jend
5599 DO i=ista,iend
5600 grid1(i,j)=doms(i,j)
5601 ENDDO
5602 ENDDO
5603 if(grib=='grib2') then
5604 cfld=cfld+1
5605 fld_info(cfld)%ifld=iavblfld(iget(559))
5606!$omp parallel do private(i,j,ii,jj)
5607 do j=1,jend-jsta+1
5608 jj = jsta+j-1
5609 do i=1,iend-ista+1
5610 ii = ista+i-1
5611 datapd(i,j,cfld) = grid1(ii,jj)
5612 enddo
5613 enddo
5614 endif
5615! ICE PELLETS.
5616!$omp parallel do private(i,j)
5617 DO j=jsta,jend
5618 DO i=ista,iend
5619 grid1(i,j) = domip(i,j)
5620! if (DOMIP(I,J) == 1) THEN
5621! print *, 'ICE PELLETS at I,J ', I, J
5622! endif
5623 ENDDO
5624 ENDDO
5625 if(grib=='grib2') then
5626 cfld=cfld+1
5627 fld_info(cfld)%ifld=iavblfld(iget(560))
5628!$omp parallel do private(i,j,ii,jj)
5629 do j=1,jend-jsta+1
5630 jj = jsta+j-1
5631 do i=1,iend-ista+1
5632 ii = ista+i-1
5633 datapd(i,j,cfld) = grid1(ii,jj)
5634 enddo
5635 enddo
5636 endif
5637! FREEZING RAIN.
5638!$omp parallel do private(i,j)
5639 DO j=jsta,jend
5640 DO i=ista,iend
5641! if (DOMZR(I,J) == 1) THEN
5642! PSFC(I,J)=PINT(I,J,NINT(LMH(I,J))+1)
5643! print *, 'FREEZING RAIN AT I,J ', I, J, PSFC(I,J)
5644! endif
5645 grid1(i,j) = domzr(i,j)
5646 ENDDO
5647 ENDDO
5648 if(grib=='grib2') then
5649 cfld=cfld+1
5650 fld_info(cfld)%ifld=iavblfld(iget(561))
5651!$omp parallel do private(i,j,ii,jj)
5652 do j=1,jend-jsta+1
5653 jj = jsta+j-1
5654 do i=1,iend-ista+1
5655 ii = ista+i-1
5656 datapd(i,j,cfld) = grid1(ii,jj)
5657 enddo
5658 enddo
5659 endif
5660! RAIN.
5661!$omp parallel do private(i,j)
5662 DO j=jsta,jend
5663 DO i=ista,iend
5664 grid1(i,j) = domr(i,j)
5665 ENDDO
5666 ENDDO
5667 if(grib=='grib2') then
5668 cfld=cfld+1
5669 fld_info(cfld)%ifld=iavblfld(iget(407))
5670!$omp parallel do private(i,j,ii,jj)
5671 do j=1,jend-jsta+1
5672 jj = jsta+j-1
5673 do i=1,iend-ista+1
5674 ii = ista+i-1
5675 datapd(i,j,cfld) = grid1(ii,jj)
5676 enddo
5677 enddo
5678 endif
5679
5680 ENDIF ! End of GSD PRECIPITATION TYPE
5681!
5682 if (allocated(psfc)) deallocate(psfc)
5683 if (allocated(domr)) deallocate(domr)
5684 if (allocated(doms)) deallocate(doms)
5685 if (allocated(domzr)) deallocate(domzr)
5686 if (allocated(domip)) deallocate(domip)
5687!
5688!
5689!*** BLOCK 5. SURFACE EXCHANGE FIELDS.
5690!
5691! TIME AVERAGED SURFACE LATENT HEAT FLUX.
5692 IF (iget(042)>0) THEN
5693 IF(modelname == 'NCAR'.OR.modelname=='RSM' .OR. &
5694 modelname=='RAPR')THEN
5695 grid1=spval
5696 id(1:25)=0
5697 ELSE
5698 IF(asrfc>0.)THEN
5699 rrnum=1./asrfc
5700 ELSE
5701 rrnum=0.
5702 ENDIF
5703 DO j=jsta,jend
5704 DO i=ista,iend
5705 IF(sfclhx(i,j)/=spval)THEN
5706 grid1(i,j)=-1.*sfclhx(i,j)*rrnum !change the sign to conform with Grib
5707 ELSE
5708 grid1(i,j)=sfclhx(i,j)
5709 END IF
5710 ENDDO
5711 ENDDO
5712 id(1:25) = 0
5713 itsrfc = nint(tsrfc)
5714 IF(itsrfc /= 0) then
5715 ifincr = mod(ifhr,itsrfc)
5716 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
5717 ELSE
5718 ifincr = 0
5719 endif
5720 id(19) = ifhr
5721 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
5722 id(20) = 3
5723 IF (ifincr==0) THEN
5724 id(18) = ifhr-itsrfc
5725 ELSE
5726 id(18) = ifhr-ifincr
5727 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
5728 ENDIF
5729 IF (id(18)<0) id(18) = 0
5730 if(grib=='grib2') then
5731 cfld=cfld+1
5732 fld_info(cfld)%ifld=iavblfld(iget(042))
5733 if(itsrfc>0) then
5734 fld_info(cfld)%ntrange=1
5735 else
5736 fld_info(cfld)%ntrange=0
5737 endif
5738 fld_info(cfld)%tinvstat=ifhr-id(18)
5739 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
5740 endif
5741 END IF
5742 ENDIF
5743!
5744! TIME AVERAGED SURFACE SENSIBLE HEAT FLUX.
5745 IF (iget(043)>0) THEN
5746 IF(modelname == 'NCAR'.OR.modelname=='RSM' .OR. &
5747 modelname=='RAPR')THEN
5748 grid1=spval
5749 id(1:25)=0
5750 ELSE
5751 IF(asrfc>0.)THEN
5752 rrnum=1./asrfc
5753 ELSE
5754 rrnum=0.
5755 ENDIF
5756 DO j=jsta,jend
5757 DO i=ista,iend
5758 IF(sfcshx(i,j)/=spval)THEN
5759 grid1(i,j) = -1.* sfcshx(i,j)*rrnum !change the sign to conform with Grib
5760 ELSE
5761 grid1(i,j)=sfcshx(i,j)
5762 END IF
5763 ENDDO
5764 ENDDO
5765 id(1:25) = 0
5766 itsrfc = nint(tsrfc)
5767 IF(itsrfc /= 0) then
5768 ifincr = mod(ifhr,itsrfc)
5769 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
5770 ELSE
5771 ifincr = 0
5772 endif
5773 id(19) = ifhr
5774 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
5775 id(20) = 3
5776 IF (ifincr==0) THEN
5777 id(18) = ifhr-itsrfc
5778 ELSE
5779 id(18) = ifhr-ifincr
5780 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
5781 ENDIF
5782 IF (id(18)<0) id(18) = 0
5783 END IF
5784 if(grib=='grib2') then
5785 cfld=cfld+1
5786 fld_info(cfld)%ifld=iavblfld(iget(043))
5787 if(itsrfc>0) then
5788 fld_info(cfld)%ntrange=1
5789 else
5790 fld_info(cfld)%ntrange=0
5791 endif
5792 fld_info(cfld)%tinvstat=ifhr-id(18)
5793 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
5794 endif
5795 ENDIF
5796!
5797! TIME AVERAGED SUB-SURFACE SENSIBLE HEAT FLUX.
5798 IF (iget(135)>0) THEN
5799 IF(modelname == 'NCAR'.OR.modelname=='RSM' .OR. &
5800 modelname=='RAPR')THEN
5801 grid1=spval
5802 id(1:25)=0
5803 ELSE
5804 IF(asrfc>0.)THEN
5805 rrnum=1./asrfc
5806 ELSE
5807 rrnum=0.
5808 ENDIF
5809 grid1=spval
5810 DO j=jsta,jend
5811 DO i=ista,iend
5812 if(subshx(i,j)/=spval) grid1(i,j) = subshx(i,j)*rrnum
5813 ENDDO
5814 ENDDO
5815 id(1:25) = 0
5816 itsrfc = nint(tsrfc)
5817 IF(itsrfc /= 0) then
5818 ifincr = mod(ifhr,itsrfc)
5819 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
5820 ELSE
5821 ifincr = 0
5822 endif
5823 id(19) = ifhr
5824 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
5825 id(20) = 3
5826 IF (ifincr==0) THEN
5827 id(18) = ifhr-itsrfc
5828 ELSE
5829 id(18) = ifhr-ifincr
5830 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
5831 ENDIF
5832 IF (id(18)<0) id(18) = 0
5833 END IF
5834 if(grib=='grib2') then
5835 cfld=cfld+1
5836 fld_info(cfld)%ifld=iavblfld(iget(135))
5837 if(itsrfc>0) then
5838 fld_info(cfld)%ntrange=1
5839 else
5840 fld_info(cfld)%ntrange=0
5841 endif
5842 fld_info(cfld)%tinvstat=ifhr-id(18)
5843 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
5844 endif
5845 ENDIF
5846!
5847! TIME AVERAGED SNOW PHASE CHANGE HEAT FLUX.
5848 IF (iget(136)>0) THEN
5849 IF(modelname == 'NCAR'.OR.modelname=='RSM' .OR. &
5850 modelname=='RAPR')THEN
5851 grid1=spval
5852 id(1:25)=0
5853 ELSE
5854 IF(asrfc>0.)THEN
5855 rrnum=1./asrfc
5856 ELSE
5857 rrnum=0.
5858 ENDIF
5859 grid1=spval
5860 DO j=jsta,jend
5861 DO i=ista,iend
5862 if(snopcx(i,j)/=spval) grid1(i,j) = snopcx(i,j)*rrnum
5863 ENDDO
5864 ENDDO
5865 id(1:25) = 0
5866 itsrfc = nint(tsrfc)
5867 IF(itsrfc /= 0) then
5868 ifincr = mod(ifhr,itsrfc)
5869 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
5870 ELSE
5871 ifincr = 0
5872 endif
5873 id(19) = ifhr
5874 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
5875 id(20) = 3
5876 IF (ifincr==0) THEN
5877 id(18) = ifhr-itsrfc
5878 ELSE
5879 id(18) = ifhr-ifincr
5880 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
5881 ENDIF
5882 IF (id(18)<0) id(18) = 0
5883 END IF
5884 if(grib=='grib2') then
5885 cfld=cfld+1
5886 fld_info(cfld)%ifld=iavblfld(iget(136))
5887 if(itsrfc>0) then
5888 fld_info(cfld)%ntrange=1
5889 else
5890 fld_info(cfld)%ntrange=0
5891 endif
5892 fld_info(cfld)%tinvstat=ifhr-id(18)
5893 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
5894 endif
5895 ENDIF
5896!
5897! TIME AVERAGED SURFACE MOMENTUM FLUX.
5898 IF (iget(046)>0) THEN
5899 IF(modelname == 'NCAR'.OR.modelname=='RSM' .OR. &
5900 modelname=='RAPR')THEN
5901 grid1=spval
5902 id(1:25)=0
5903 ELSE
5904 IF(asrfc>0.)THEN
5905 rrnum=1./asrfc
5906 ELSE
5907 rrnum=0.
5908 ENDIF
5909 DO j=jsta,jend
5910 DO i=ista,iend
5911 IF(sfcuvx(i,j)/=spval)THEN
5912 grid1(i,j) = sfcuvx(i,j)*rrnum
5913 ELSE
5914 grid1(i,j) = sfcuvx(i,j)
5915 END IF
5916 ENDDO
5917 ENDDO
5918 id(1:25) = 0
5919 itsrfc = nint(tsrfc)
5920 IF(itsrfc /= 0) then
5921 ifincr = mod(ifhr,itsrfc)
5922 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
5923 ELSE
5924 ifincr = 0
5925 endif
5926 id(19) = ifhr
5927 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
5928 id(20) = 3
5929 IF (ifincr==0) THEN
5930 id(18) = ifhr-itsrfc
5931 ELSE
5932 id(18) = ifhr-ifincr
5933 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
5934 ENDIF
5935 IF (id(18)<0) id(18) = 0
5936 END IF
5937 if(grib=='grib2') then
5938 cfld=cfld+1
5939 fld_info(cfld)%ifld=iavblfld(iget(046))
5940 if(itsrfc>0) then
5941 fld_info(cfld)%ntrange=1
5942 else
5943 fld_info(cfld)%ntrange=0
5944 endif
5945 fld_info(cfld)%tinvstat=ifhr-id(18)
5946 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
5947 endif
5948 ENDIF
5949!
5950! TIME AVERAGED SURFACE ZONAL MOMENTUM FLUX.
5951 IF (iget(269)>0) THEN
5952 IF(modelname == 'NCAR'.OR.modelname=='RSM' .OR. &
5953 modelname=='RAPR')THEN
5954 grid1=spval
5955 id(1:25)=0
5956 ELSE
5957 IF(asrfc>0.)THEN
5958 rrnum=1./asrfc
5959 ELSE
5960 rrnum=0.
5961 ENDIF
5962 grid1=spval
5963 DO j=jsta,jend
5964 DO i=ista,iend
5965 if(sfcux(i,j)/=spval) grid1(i,j) = sfcux(i,j)*rrnum
5966 ENDDO
5967 ENDDO
5968 id(1:25) = 0
5969 itsrfc = nint(tsrfc)
5970 IF(itsrfc /= 0) then
5971 ifincr = mod(ifhr,itsrfc)
5972 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
5973 ELSE
5974 ifincr = 0
5975 endif
5976 id(19) = ifhr
5977 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
5978 id(20) = 3
5979 IF (ifincr==0) THEN
5980 id(18) = ifhr-itsrfc
5981 ELSE
5982 id(18) = ifhr-ifincr
5983 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
5984 ENDIF
5985 IF (id(18)<0) id(18) = 0
5986 END IF
5987 if(grib=='grib2') then
5988 cfld=cfld+1
5989 fld_info(cfld)%ifld=iavblfld(iget(269))
5990 if(itsrfc>0) then
5991 fld_info(cfld)%ntrange=1
5992 else
5993 fld_info(cfld)%ntrange=0
5994 endif
5995 fld_info(cfld)%tinvstat=ifhr-id(18)
5996 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
5997 endif
5998 ENDIF
5999!
6000! TIME AVERAGED SURFACE MOMENTUM FLUX.
6001 IF (iget(270)>0) THEN
6002 IF(modelname == 'NCAR'.OR.modelname=='RSM' .OR. &
6003 modelname=='RAPR')THEN
6004 grid1=spval
6005 id(1:25)=0
6006 ELSE
6007 IF(asrfc>0.)THEN
6008 rrnum=1./asrfc
6009 ELSE
6010 rrnum=0.
6011 ENDIF
6012 grid1=spval
6013 DO j=jsta,jend
6014 DO i=ista,iend
6015 if(sfcvx(i,j)/=spval) grid1(i,j) = sfcvx(i,j)*rrnum
6016 ENDDO
6017 ENDDO
6018 id(1:25) = 0
6019 itsrfc = nint(tsrfc)
6020 IF(itsrfc /= 0) then
6021 ifincr = mod(ifhr,itsrfc)
6022 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
6023 ELSE
6024 ifincr = 0
6025 endif
6026 id(19) = ifhr
6027 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
6028 id(20) = 3
6029 IF (ifincr==0) THEN
6030 id(18) = ifhr-itsrfc
6031 ELSE
6032 id(18) = ifhr-ifincr
6033 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
6034 ENDIF
6035 IF (id(18)<0) id(18) = 0
6036 END IF
6037 if(grib=='grib2') then
6038 cfld=cfld+1
6039 fld_info(cfld)%ifld=iavblfld(iget(270))
6040 if(itsrfc>0) then
6041 fld_info(cfld)%ntrange=1
6042 else
6043 fld_info(cfld)%ntrange=0
6044 endif
6045 fld_info(cfld)%tinvstat=ifhr-id(18)
6046 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6047 endif
6048 ENDIF
6049!
6050! ACCUMULATED SURFACE EVAPORATION
6051 IF (iget(047)>0) THEN
6052 grid1=spval
6053 DO j=jsta,jend
6054 DO i=ista,iend
6055 if(sfcevp(i,j)/=spval) grid1(i,j) = sfcevp(i,j)*1000.
6056 ENDDO
6057 ENDDO
6058 id(1:25) = 0
6059 itprec = nint(tprec)
6060!mp
6061 if (itprec /= 0) then
6062 ifincr = mod(ifhr,itprec)
6063 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
6064 else
6065 ifincr = 0
6066 endif
6067!mp
6068 id(18) = 0
6069 id(19) = ifhr
6070 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
6071 id(20) = 4
6072 IF (ifincr==0) THEN
6073 id(18) = ifhr-itprec
6074 ELSE
6075 id(18) = ifhr-ifincr
6076 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
6077 ENDIF
6078 IF (id(18)<0) id(18) = 0
6079 if(grib=='grib2') then
6080 cfld=cfld+1
6081 fld_info(cfld)%ifld=iavblfld(iget(047))
6082 if(itprec>0) then
6083 fld_info(cfld)%ntrange=1
6084 else
6085 fld_info(cfld)%ntrange=0
6086 endif
6087 fld_info(cfld)%tinvstat=ifhr-id(18)
6088 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6089
6090 endif
6091 ENDIF
6092!
6093! ACCUMULATED POTENTIAL EVAPORATION
6094 IF (iget(137)>0) THEN
6095 grid1=spval
6096 DO j=jsta,jend
6097 DO i=ista,iend
6098 if(potevp(i,j)/=spval) grid1(i,j) = potevp(i,j)*1000.
6099 ENDDO
6100 ENDDO
6101 id(1:25) = 0
6102 itprec = nint(tprec)
6103!mp
6104 if (itprec /= 0) then
6105 ifincr = mod(ifhr,itprec)
6106 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
6107 else
6108 ifincr = 0
6109 endif
6110!mp
6111 id(18) = 0
6112 id(19) = ifhr
6113 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
6114 id(20) = 4
6115 IF (ifincr==0) THEN
6116 id(18) = ifhr-itprec
6117 ELSE
6118 id(18) = ifhr-ifincr
6119 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
6120 ENDIF
6121 IF (id(18)<0) id(18) = 0
6122 if(grib=='grib2') then
6123 cfld=cfld+1
6124 fld_info(cfld)%ifld=iavblfld(iget(137))
6125 if(itprec>0) then
6126 fld_info(cfld)%ntrange=1
6127 else
6128 fld_info(cfld)%ntrange=0
6129 endif
6130 fld_info(cfld)%tinvstat=ifhr-id(18)
6131 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6132 endif
6133 ENDIF
6134!
6135! ROUGHNESS LENGTH.
6136 IF (iget(044)>0) THEN
6137 DO j=jsta,jend
6138 DO i=ista,iend
6139 grid1(i,j) = z0(i,j)
6140 ENDDO
6141 ENDDO
6142 if(grib=='grib2') then
6143 cfld=cfld+1
6144 fld_info(cfld)%ifld=iavblfld(iget(044))
6145 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6146 endif
6147 ENDIF
6148!
6149! FRICTION VELOCITY.
6150 IF (iget(045)>0) THEN
6151 DO j=jsta,jend
6152 DO i=ista,iend
6153 grid1(i,j) = ustar(i,j)
6154 ENDDO
6155 ENDDO
6156 if(grib=='grib2') then
6157 cfld=cfld+1
6158 fld_info(cfld)%ifld=iavblfld(iget(045))
6159 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6160 endif
6161 ENDIF
6162!
6163! SURFACE DRAG COEFFICIENT.
6164! dong add missing value for cd
6165 IF (iget(132)>0) THEN
6166 grid1=spval
6167 CALL caldrg(egrid1(ista_2l:iend_2u,jsta_2l:jend_2u))
6168 DO j=jsta,jend
6169 DO i=ista,iend
6170 IF(ustar(i,j) < spval) grid1(i,j)=egrid1(i,j)
6171 ENDDO
6172 ENDDO
6173 if(grib=='grib2') then
6174 cfld=cfld+1
6175 fld_info(cfld)%ifld=iavblfld(iget(132))
6176 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6177 endif
6178 ENDIF
6179
6180 write_cd: IF(iget(924)>0) THEN
6181 DO j=jsta,jend
6182 DO i=ista,iend
6183 grid1(i,j)=cd10(i,j)
6184 ENDDO
6185 ENDDO
6186 if(grib=='grib2') then
6187 cfld=cfld+1
6188 fld_info(cfld)%ifld=iavblfld(iget(924))
6189 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6190 endif
6191 ENDIF write_cd
6192 write_ch: IF(iget(923)>0) THEN
6193 DO j=jsta,jend
6194 DO i=ista,iend
6195 grid1(i,j)=ch10(i,j)
6196 ENDDO
6197 ENDDO
6198 if(grib=='grib2') then
6199 cfld=cfld+1
6200 fld_info(cfld)%ifld=iavblfld(iget(923))
6201 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6202 endif
6203 ENDIF write_ch
6204!
6205! MODEL OUTPUT SURFACE U AND/OR V COMPONENT WIND STRESS
6206 IF ( (iget(900)>0) .OR. (iget(901)>0) ) THEN
6207!
6208! MODEL OUTPUT SURFACE U COMPONENT WIND STRESS.
6209 IF (iget(900)>0) THEN
6210 DO j=jsta,jend
6211 DO i=ista,iend
6212 grid1(i,j)=mdltaux(i,j)
6213 ENDDO
6214 ENDDO
6215 if(grib=='grib2') then
6216 cfld=cfld+1
6217 fld_info(cfld)%ifld=iavblfld(iget(900))
6218 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6219 endif
6220
6221 ENDIF
6222!
6223! MODEL OUTPUT SURFACE V COMPONENT WIND STRESS
6224 IF (iget(901)>0) THEN
6225 DO j=jsta,jend
6226 DO i=ista,iend
6227 grid1(i,j)=mdltauy(i,j)
6228 ENDDO
6229 ENDDO
6230 if(grib=='grib2') then
6231 cfld=cfld+1
6232 fld_info(cfld)%ifld=iavblfld(iget(901))
6233 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6234 endif
6235 ENDIF
6236 ENDIF
6237!
6238! SURFACE U AND/OR V COMPONENT WIND STRESS
6239 IF ( (iget(133)>0) .OR. (iget(134)>0) ) THEN
6240! dong add missing value
6241 grid1 = spval
6242 IF(modelname /= 'FV3R') &
6243 CALL caltau(egrid1(ista:iend,jsta:jend),egrid2(ista:iend,jsta:jend))
6244!
6245! SURFACE U COMPONENT WIND STRESS.
6246! dong for FV3, directly use model output
6247 IF (iget(133)>0) THEN
6248 DO j=jsta,jend
6249 DO i=ista,iend
6250 IF(modelname == 'FV3R') THEN
6251 grid1(i,j)=sfcuxi(i,j)
6252 ELSE
6253 grid1(i,j)=egrid1(i,j)
6254 ENDIF
6255 ENDDO
6256 ENDDO
6257!
6258 if(grib=='grib2') then
6259 cfld=cfld+1
6260 fld_info(cfld)%ifld=iavblfld(iget(133))
6261 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6262 endif
6263 ENDIF
6264!
6265! SURFACE V COMPONENT WIND STRESS
6266 IF (iget(134)>0) THEN
6267 DO j=jsta,jend
6268 DO i=ista,iend
6269 IF(modelname == 'FV3R') THEN
6270 grid1(i,j)=sfcvxi(i,j)
6271 ELSE
6272 grid1(i,j)=egrid2(i,j)
6273 END IF
6274 ENDDO
6275 ENDDO
6276 if(grib=='grib2') then
6277 cfld=cfld+1
6278 fld_info(cfld)%ifld=iavblfld(iget(134))
6279 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6280 endif
6281 ENDIF
6282 ENDIF
6283!
6284! GRAVITY U AND/OR V COMPONENT STRESS
6285 IF ( (iget(315)>0) .OR. (iget(316)>0) ) THEN
6286!
6287! GRAVITY U COMPONENT WIND STRESS.
6288 IF (iget(315)>0) THEN
6289 DO j=jsta,jend
6290 DO i=ista,iend
6291 grid1(i,j) = gtaux(i,j)
6292 ENDDO
6293 ENDDO
6294 id(1:25) = 0
6295 itsrfc = nint(tsrfc)
6296 IF(itsrfc /= 0) then
6297 ifincr = mod(ifhr,itsrfc)
6298 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
6299 ELSE
6300 ifincr = 0
6301 endif
6302 id(19) = ifhr
6303 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
6304 id(20) = 3
6305 IF (ifincr==0) THEN
6306 id(18) = ifhr-itsrfc
6307 ELSE
6308 id(18) = ifhr-ifincr
6309 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
6310 ENDIF
6311 IF (id(18)<0) id(18) = 0
6312 if(grib=='grib2') then
6313 cfld=cfld+1
6314 fld_info(cfld)%ifld=iavblfld(iget(315))
6315 if(itsrfc==0) then
6316 fld_info(cfld)%ntrange=0
6317 else
6318 fld_info(cfld)%ntrange=1
6319 endif
6320 fld_info(cfld)%tinvstat=ifhr-id(18)
6321 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6322 endif
6323 ENDIF
6324!
6325! SURFACE V COMPONENT WIND STRESS
6326 IF (iget(316)>0) THEN
6327 DO j=jsta,jend
6328 DO i=ista,iend
6329 grid1(i,j)=gtauy(i,j)
6330 ENDDO
6331 ENDDO
6332 id(1:25) = 0
6333 itsrfc = nint(tsrfc)
6334 IF(itsrfc /= 0) then
6335 ifincr = mod(ifhr,itsrfc)
6336 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
6337 ELSE
6338 ifincr = 0
6339 endif
6340 id(19) = ifhr
6341 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
6342 id(20) = 3
6343 IF (ifincr==0) THEN
6344 id(18) = ifhr-itsrfc
6345 ELSE
6346 id(18) = ifhr-ifincr
6347 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
6348 ENDIF
6349 IF (id(18)<0) id(18) = 0
6350 if(grib=='grib2') then
6351 cfld=cfld+1
6352 fld_info(cfld)%ifld=iavblfld(iget(316))
6353 if(itsrfc==0) then
6354 fld_info(cfld)%ntrange=0
6355 else
6356 fld_info(cfld)%ntrange=1
6357 endif
6358 fld_info(cfld)%tinvstat=ifhr-id(18)
6359 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6360 endif
6361 ENDIF
6362 ENDIF
6363!
6364! INSTANTANEOUS SENSIBLE HEAT FLUX
6365 IF (iget(154)>0) THEN
6366! dong add missing value to shtfl
6367 grid1 = spval
6368 IF(modelname=='NCAR'.OR.modelname=='RSM' .OR. &
6369 modelname=='RAPR')THEN
6370!4omp parallel do private(i,j)
6371 DO j=jsta,jend
6372 DO i=ista,iend
6373 grid1(i,j) = twbs(i,j)
6374 ENDDO
6375 ENDDO
6376 ELSE
6377!4omp parallel do private(i,j)
6378 DO j=jsta,jend
6379 DO i=ista,iend
6380 IF(twbs(i,j) < spval) grid1(i,j) = -twbs(i,j)
6381 ENDDO
6382 ENDDO
6383 END IF
6384 if(grib=='grib2') then
6385 cfld=cfld+1
6386 fld_info(cfld)%ifld=iavblfld(iget(154))
6387 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6388 endif
6389 ENDIF
6390!
6391! INSTANTANEOUS LATENT HEAT FLUX
6392 IF (iget(155)>0) THEN
6393! dong add missing value to lhtfl
6394 grid1 = spval
6395 IF(modelname=='NCAR'.OR.modelname=='RSM' .OR. &
6396 modelname=='RAPR')THEN
6397!4omp parallel do private(i,j)
6398 DO j=jsta,jend
6399 DO i=ista,iend
6400 grid1(i,j) = qwbs(i,j)
6401 ENDDO
6402 ENDDO
6403 ELSE
6404!4omp parallel do private(i,j)
6405 DO j=jsta,jend
6406 DO i=ista,iend
6407 IF(qwbs(i,j) < spval) grid1(i,j) = -qwbs(i,j)
6408 ENDDO
6409 ENDDO
6410 END IF
6411 if(grib=='grib2') then
6412 cfld=cfld+1
6413 fld_info(cfld)%ifld=iavblfld(iget(155))
6414 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6415 endif
6416 ENDIF
6417!
6418! SURFACE EXCHANGE COEFF
6419 IF (iget(169)>0) THEN
6420 DO j=jsta,jend
6421 DO i=ista,iend
6422 grid1(i,j)=sfcexc(i,j)
6423 ENDDO
6424 ENDDO
6425 if(grib=='grib2') then
6426 cfld=cfld+1
6427 fld_info(cfld)%ifld=iavblfld(iget(169))
6428 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6429 endif
6430 ENDIF
6431!
6432! GREEN VEG FRACTION
6433 IF (iget(170)>0) THEN
6434 grid1=spval
6435 DO j=jsta,jend
6436 DO i=ista,iend
6437 if(vegfrc(i,j)/=spval) grid1(i,j)=vegfrc(i,j)*100.
6438 ENDDO
6439 ENDDO
6440 if(grib=='grib2') then
6441 cfld=cfld+1
6442 fld_info(cfld)%ifld=iavblfld(iget(170))
6443 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6444 endif
6445 ENDIF
6446
6447!
6448! MIN GREEN VEG FRACTION
6449 IF (iget(726)>0) THEN
6450 grid1=spval
6451 DO j=jsta,jend
6452 DO i=ista,iend
6453 if(shdmin(i,j)/=spval) grid1(i,j)=shdmin(i,j)*100.
6454 ENDDO
6455 ENDDO
6456 if(grib=='grib2') then
6457 cfld=cfld+1
6458 fld_info(cfld)%ifld=iavblfld(iget(726))
6459 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6460 endif
6461 ENDIF
6462!
6463! MAX GREEN VEG FRACTION
6464 IF (iget(729)>0) THEN
6465 grid1=spval
6466 DO j=jsta,jend
6467 DO i=ista,iend
6468 if(shdmax(i,j)/=spval) grid1(i,j)=shdmax(i,j)*100.
6469 ENDDO
6470 ENDDO
6471 if(grib=='grib2') then
6472 cfld=cfld+1
6473 fld_info(cfld)%ifld=iavblfld(iget(729))
6474 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6475 endif
6476 ENDIF
6477!
6478! LEAF AREA INDEX
6479 IF (modelname == 'NCAR'.OR.modelname=='NMM' .OR. &
6480 modelname == 'FV3R' .OR. modelname=='RAPR')THEN
6481 IF (isf_surface_physics == 2 .OR. modelname=='FV3R' .OR. modelname=='RAPR') THEN
6482 IF (iget(254)>0) THEN
6483 if (me==0)print*,'starting LAI'
6484 DO j=jsta,jend
6485 DO i=ista,iend
6486 IF (modelname=='RAPR')THEN
6487 grid1(i,j)=lai(i,j)
6488 ELSE IF (modelname=='FV3R')THEN
6489 grid1(i,j)=xlaixy(i,j)
6490 ELSE
6491 grid1(i,j) = xlai
6492 ENDIF
6493 ENDDO
6494 ENDDO
6495 if(grib=='grib2') then
6496 cfld=cfld+1
6497 fld_info(cfld)%ifld=iavblfld(iget(254))
6498 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6499 endif
6500 ENDIF
6501 ENDIF
6502 ENDIF
6503!
6504! INSTANTANEOUS GROUND HEAT FLUX
6505 IF (iget(152)>0) THEN
6506 DO j=jsta,jend
6507 DO i=ista,iend
6508 grid1(i,j)=grnflx(i,j)
6509 ENDDO
6510 ENDDO
6511 if(grib=='grib2') then
6512 cfld=cfld+1
6513 fld_info(cfld)%ifld=iavblfld(iget(152))
6514 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6515 endif
6516 ENDIF
6517! VEGETATION TYPE
6518 IF (iget(218)>0) THEN
6519 DO j=jsta,jend
6520 DO i=ista,iend
6521 grid1(i,j) = float(ivgtyp(i,j))
6522 ENDDO
6523 ENDDO
6524 if(grib=='grib2') then
6525 cfld=cfld+1
6526 fld_info(cfld)%ifld=iavblfld(iget(218))
6527 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6528 endif
6529 ENDIF
6530!
6531! SOIL TYPE
6532 IF (iget(219)>0) THEN
6533 DO j=jsta,jend
6534 DO i=ista,iend
6535 grid1(i,j) = float(isltyp(i,j))
6536 ENDDO
6537 ENDDO
6538 if(grib=='grib2') then
6539 cfld=cfld+1
6540 fld_info(cfld)%ifld=iavblfld(iget(219))
6541 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6542 endif
6543 ENDIF
6544! SLOPE TYPE
6545 IF (iget(223)>0) THEN
6546 DO j=jsta,jend
6547 DO i=ista,iend
6548 grid1(i,j) = float(islope(i,j))
6549 ENDDO
6550 ENDDO
6551 if(grib=='grib2') then
6552 cfld=cfld+1
6553 fld_info(cfld)%ifld=iavblfld(iget(223))
6554 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6555 endif
6556 ENDIF
6557! if (me==0)print*,'starting computing canopy conductance'
6558!
6559! CANOPY CONDUCTANCE
6560! ONLY OUTPUT NEW LSM FIELDS FOR NMM AND ARW BECAUSE RSM USES OLD SOIL TYPES
6561 IF (modelname == 'NCAR'.OR.modelname=='NMM' .OR. &
6562 modelname == 'FV3R' .OR. modelname=='RAPR')THEN
6563 IF (iget(220)>0 .OR. iget(234)>0 &
6564 & .OR. iget(235)>0 .OR. iget(236)>0 &
6565 & .OR. iget(237)>0 .OR. iget(238)>0 &
6566 & .OR. iget(239)>0 .OR. iget(240)>0 &
6567 & .OR. iget(241)>0 ) THEN
6568 IF (isf_surface_physics == 2 .OR. isf_surface_physics == 3) THEN !NSOIL == 4
6569! if(me==0)print*,'starting computing canopy conductance'
6570 allocate(rsmin(ista:iend,jsta:jend), smcref(ista:iend,jsta:jend), gc(ista:iend,jsta:jend), &
6571 rcq(ista:iend,jsta:jend), rct(ista:iend,jsta:jend), rcsoil(ista:iend,jsta:jend), rcs(ista:iend,jsta:jend))
6572 DO j=jsta,jend
6573 DO i=ista,iend
6574 IF( (abs(sm(i,j)-0.) < 1.0e-5) .AND. &
6575 & (abs(sice(i,j)-0.) < 1.0e-5) ) THEN
6576 IF(czmean(i,j)>1.e-6) THEN
6577 factrs = czen(i,j)/czmean(i,j)
6578 ELSE
6579 factrs = 0.0
6580 ENDIF
6581! SOLAR=HBM2(I,J)*RSWIN(I,J)*FACTRS
6582 llmh = nint(lmh(i,j))
6583 solar = rswin(i,j)*factrs
6584 sfctmp = t(i,j,llmh)
6585 sfcq = q(i,j,llmh)
6586 sfcprs = pint(i,j,llmh+1)
6587! IF(IVGTYP(I,J)==0)PRINT*,'IVGTYP ZERO AT ',I,J
6588! & ,SM(I,J)
6589 ivg = ivgtyp(i,j)
6590! IF(IVGTYP(I,J)==0)IVG=7
6591! CALL CANRES(SOLAR,SFCTMP,SFCQ,SFCPRS
6592! & ,SMC(I,J,1:NSOIL),GC(I,J),RC,IVG,ISLTYP(I,J))
6593!
6594 CALL canres(solar,sfctmp,sfcq,sfcprs &
6595 & ,sh2o(i,j,1:nsoil),gc(i,j),rc,ivg,isltyp(i,j) &
6596 & ,rsmin(i,j),nroots(i,j),smcwlt(i,j),smcref(i,j) &
6597 & ,rcs(i,j),rcq(i,j),rct(i,j),rcsoil(i,j),sldpth)
6598 IF(abs(smcwlt(i,j)-0.5)<1.e-5)print*, &
6599 & 'LARGE SMCWLT',i,j,sm(i,j),isltyp(i,j),smcwlt(i,j)
6600 ELSE
6601 gc(i,j) = 0.
6602 rsmin(i,j) = 0.
6603 nroots(i,j) = 0
6604 smcwlt(i,j) = 0.
6605 smcref(i,j) = 0.
6606 rcs(i,j) = 0.
6607 rcq(i,j) = 0.
6608 rct(i,j) = 0.
6609 rcsoil(i,j) = 0.
6610 END IF
6611 ENDDO
6612 ENDDO
6613
6614 IF (iget(220)>0 )THEN
6615 DO j=jsta,jend
6616 DO i=ista,iend
6617 grid1(i,j) = gc(i,j)
6618 ENDDO
6619 ENDDO
6620 if(grib=='grib2') then
6621 cfld=cfld+1
6622 fld_info(cfld)%ifld=iavblfld(iget(220))
6623 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6624 endif
6625 ENDIF
6626
6627 IF (iget(234)>0 )THEN
6628 DO j=jsta,jend
6629 DO i=ista,iend
6630 grid1(i,j) = rsmin(i,j)
6631 ENDDO
6632 ENDDO
6633 if(grib=='grib2') then
6634 cfld=cfld+1
6635 fld_info(cfld)%ifld=iavblfld(iget(234))
6636 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6637 endif
6638 ENDIF
6639
6640 IF (iget(235)>0 )THEN
6641 DO j=jsta,jend
6642 DO i=ista,iend
6643 grid1(i,j) = float(nroots(i,j))
6644 ENDDO
6645 ENDDO
6646 if(grib=='grib2') then
6647 cfld=cfld+1
6648 fld_info(cfld)%ifld=iavblfld(iget(235))
6649 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6650 endif
6651 ENDIF
6652
6653 IF (iget(236)>0 )THEN
6654 DO j=jsta,jend
6655 DO i=ista,iend
6656 grid1(i,j) = smcwlt(i,j)
6657 ENDDO
6658 ENDDO
6659 if(grib=='grib2') then
6660 cfld=cfld+1
6661 fld_info(cfld)%ifld=iavblfld(iget(236))
6662 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6663 endif
6664 ENDIF
6665
6666 IF (iget(237)>0 )THEN
6667 DO j=jsta,jend
6668 DO i=ista,iend
6669 grid1(i,j) = smcref(i,j)
6670 ENDDO
6671 ENDDO
6672 if(grib=='grib2') then
6673 cfld=cfld+1
6674 fld_info(cfld)%ifld=iavblfld(iget(237))
6675 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6676 endif
6677 ENDIF
6678
6679 IF (iget(238)>0 )THEN
6680 DO j=jsta,jend
6681 DO i=ista,iend
6682 grid1(i,j) = rcs(i,j)
6683 ENDDO
6684 ENDDO
6685 if(grib=='grib2') then
6686 cfld=cfld+1
6687 fld_info(cfld)%ifld=iavblfld(iget(238))
6688 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6689 endif
6690 ENDIF
6691
6692 IF (iget(239)>0 )THEN
6693 DO j=jsta,jend
6694 DO i=ista,iend
6695 grid1(i,j) = rct(i,j)
6696 ENDDO
6697 ENDDO
6698 if(grib=='grib2') then
6699 cfld=cfld+1
6700 fld_info(cfld)%ifld=iavblfld(iget(239))
6701 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6702 endif
6703 ENDIF
6704
6705 IF (iget(240)>0 )THEN
6706 DO j=jsta,jend
6707 DO i=ista,iend
6708 grid1(i,j) = rcq(i,j)
6709 ENDDO
6710 ENDDO
6711 if(grib=='grib2') then
6712 cfld=cfld+1
6713 fld_info(cfld)%ifld=iavblfld(iget(240))
6714 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6715 endif
6716 ENDIF
6717
6718 IF (iget(241)>0 )THEN
6719 DO j=jsta,jend
6720 DO i=ista,iend
6721 grid1(i,j) = rcsoil(i,j)
6722 ENDDO
6723 ENDDO
6724 if(grib=='grib2') then
6725 cfld=cfld+1
6726 fld_info(cfld)%ifld=iavblfld(iget(241))
6727 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6728 endif
6729 ENDIF
6730
6731 if (allocated(rsmin)) deallocate(rsmin)
6732 if (allocated(smcref)) deallocate(smcref)
6733 if (allocated(rcq)) deallocate(rcq)
6734 if (allocated(rct)) deallocate(rct)
6735 if (allocated(rcsoil)) deallocate(rcsoil)
6736 if (allocated(rcs)) deallocate(rcs)
6737 if (allocated(gc)) deallocate(gc)
6738
6739
6740 ENDIF
6741 END IF
6742!GPL added endif here
6743 ENDIF
6744 IF(modelname == 'GFS')THEN
6745! Outputting wilting point and field capacity for TIGGE
6746 IF(iget(236)>0)THEN
6747!$omp parallel do private(i,j)
6748 DO j=jsta,jend
6749 DO i=ista,iend
6750 grid1(i,j) = smcwlt(i,j)
6751! IF(isltyp(i,j)/=0)THEN
6752! GRID1(I,J) = WLTSMC(isltyp(i,j))
6753! ELSE
6754! GRID1(I,J) = spval
6755! END IF
6756 ENDDO
6757 ENDDO
6758 if(grib=='grib2') then
6759 cfld=cfld+1
6760 fld_info(cfld)%ifld=iavblfld(iget(236))
6761!$omp parallel do private(i,j,ii,jj)
6762 do j=1,jend-jsta+1
6763 jj = jsta+j-1
6764 do i=1,iend-ista+1
6765 ii = ista+i-1
6766 datapd(i,j,cfld) = grid1(ii,jj)
6767 enddo
6768 enddo
6769 endif
6770 ENDIF
6771
6772 IF(iget(397)>0)THEN
6773!$omp parallel do private(i,j)
6774 DO j=jsta,jend
6775 DO i=ista,iend
6776 grid1(i,j) = fieldcapa(i,j)
6777! IF(isltyp(i,j)/=0)THEN
6778! GRID1(I,J) = REFSMC(isltyp(i,j))
6779! ELSE
6780! GRID1(I,J) = spval
6781! END IF
6782 ENDDO
6783 ENDDO
6784 if(grib=='grib2') then
6785 cfld=cfld+1
6786 fld_info(cfld)%ifld=iavblfld(iget(397))
6787!$omp parallel do private(i,j,ii,jj)
6788 do j=1,jend-jsta+1
6789 jj = jsta+j-1
6790 do i=1,iend-ista+1
6791 ii = ista+i-1
6792 datapd(i,j,cfld) = grid1(ii,jj)
6793 enddo
6794 enddo
6795 endif
6796 ENDIF
6797 END IF
6798 IF(iget(396)>0)THEN
6799!$omp parallel do private(i,j)
6800 DO j=jsta,jend
6801 DO i=ista,iend
6802 grid1(i,j) = suntime(i,j)
6803 ENDDO
6804 ENDDO
6805 id(1:25) = 0
6806 itsrfc = nint(tsrfc)
6807 IF(itsrfc /= 0) then
6808 ifincr = mod(ifhr,itsrfc)
6809 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
6810 ELSE
6811 ifincr = 0
6812 endif
6813 id(19) = ifhr
6814 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
6815 id(20) = 3
6816 IF (ifincr==0) THEN
6817 id(18) = ifhr-itsrfc
6818 ELSE
6819 id(18) = ifhr-ifincr
6820 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
6821 ENDIF
6822 IF (id(18)<0) id(18) = 0
6823 if(grib=='grib2') then
6824 cfld=cfld+1
6825 fld_info(cfld)%ifld=iavblfld(iget(396))
6826 if(itsrfc>0) then
6827 fld_info(cfld)%ntrange=1
6828 else
6829 fld_info(cfld)%ntrange=0
6830 endif
6831 fld_info(cfld)%tinvstat=ifhr-id(18)
6832!$omp parallel do private(i,j,ii,jj)
6833 do j=1,jend-jsta+1
6834 jj = jsta+j-1
6835 do i=1,iend-ista+1
6836 ii = ista+i-1
6837 datapd(i,j,cfld) = grid1(ii,jj)
6838 enddo
6839 enddo
6840 endif
6841 ENDIF
6842
6843 IF(iget(517)>0)THEN
6844!$omp parallel do private(i,j)
6845 DO j=jsta,jend
6846 DO i=ista,iend
6847 grid1(i,j) = avgpotevp(i,j)
6848 ENDDO
6849 ENDDO
6850 id(1:25) = 0
6851 itsrfc = nint(tsrfc)
6852 IF(itsrfc /= 0) then
6853 ifincr = mod(ifhr,itsrfc)
6854 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
6855 ELSE
6856 ifincr = 0
6857 endif
6858 id(19) = ifhr
6859 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
6860 id(20) = 3
6861 IF (ifincr==0) THEN
6862 id(18) = ifhr-itsrfc
6863 ELSE
6864 id(18) = ifhr-ifincr
6865 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
6866 ENDIF
6867 IF (id(18)<0) id(18) = 0
6868 if(grib=='grib2') then
6869 cfld=cfld+1
6870 fld_info(cfld)%ifld=iavblfld(iget(517))
6871 if(itsrfc>0) then
6872 fld_info(cfld)%ntrange=1
6873 else
6874 fld_info(cfld)%ntrange=0
6875 endif
6876 fld_info(cfld)%tinvstat=ifhr-id(18)
6877!$omp parallel do private(i,j,ii,jj)
6878 do j=1,jend-jsta+1
6879 jj = jsta+j-1
6880 do i=1,iend-ista+1
6881 ii = ista+i-1
6882 datapd(i,j,cfld) = grid1(ii,jj)
6883 enddo
6884 enddo
6885 endif
6886 ENDIF
6887
6888!
6889!
6890! MODEL TOP REQUESTED BY CMAQ
6891 IF (iget(282)>0) THEN
6892!$omp parallel do private(i,j)
6893 DO j=jsta,jend
6894 DO i=ista,iend
6895 grid1(i,j) = pt
6896 ENDDO
6897 ENDDO
6898 if(grib=='grib2') then
6899 cfld=cfld+1
6900 fld_info(cfld)%ifld=iavblfld(iget(282))
6901 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6902 endif
6903 ENDIF
6904!
6905! PRESSURE THICKNESS REQUESTED BY CMAQ
6906 IF (iget(283)>0) THEN
6907 DO j=jsta,jend
6908 DO i=ista,iend
6909 grid1(i,j)=pdtop
6910 ENDDO
6911 ENDDO
6912 id(1:25) = 0
6913 IF(me == 0)THEN
6914 DO l=1,lm
6915 IF(pmid(1,1,l)>=(pdtop+pt))EXIT
6916 END DO
6917! PRINT*,'hybrid boundary ',L
6918 END IF
6919 CALL mpi_bcast(l,1,mpi_integer,0,mpi_comm_comp,irtn)
6920 if(grib=='grib2') then
6921 cfld=cfld+1
6922 fld_info(cfld)%ifld=iavblfld(iget(283))
6923 fld_info(cfld)%lvl1=1
6924 fld_info(cfld)%lvl2=l
6925 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6926 endif
6927 ENDIF
6928!
6929! SIGMA PRESSURE THICKNESS REQUESTED BY CMAQ
6930 IF (iget(273)>0) THEN
6931 DO j=jsta,jend
6932 DO i=ista,iend
6933 grid1(i,j)=pd(i,j)
6934 ENDDO
6935 ENDDO
6936 IF(me == 0)THEN
6937 DO l=1,lm
6938! print*,'Debug CMAQ: ',L,PINT(1,1,LM+1),PD(1,1),PINT(1,1,L)
6939 IF((pint(1,1,lm+1)-pd(1,1))<=(pint(1,1,l)+1.00))EXIT
6940 END DO
6941! PRINT*,'hybrid boundary ',L
6942 END IF
6943 CALL mpi_bcast(l,1,mpi_integer,0,mpi_comm_comp,irtn)
6944 if(grib=='grib2') then
6945 cfld=cfld+1
6946 fld_info(cfld)%ifld=iavblfld(iget(273))
6947 fld_info(cfld)%lvl1=l
6948 fld_info(cfld)%lvl2=lm+1
6949 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6950 endif
6951 ENDIF
6952
6953
6954! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR MASS REQUESTED FOR CMAQ
6955 IF (iget(503)>0) THEN
6956 DO j=jsta,jend
6957 DO i=ista,iend
6958 grid1(i,j)=akhsavg(i,j)
6959 ENDDO
6960 ENDDO
6961 id(1:25) = 0
6962 id(02)= 133
6963 id(19) = ifhr
6964 IF (ifhr==0) THEN
6965 id(18) = 0
6966 ELSE
6967 id(18) = ifhr - 1
6968 ENDIF
6969 id(20) = 3
6970 itsrfc = nint(tsrfc)
6971 if(grib=='grib2') then
6972 cfld=cfld+1
6973 fld_info(cfld)%ifld=iavblfld(iget(503))
6974 if(itsrfc>0) then
6975 fld_info(cfld)%ntrange=1
6976 else
6977 fld_info(cfld)%ntrange=0
6978 endif
6979 fld_info(cfld)%tinvstat=ifhr-id(18)
6980 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
6981 endif
6982 ENDIF
6983
6984! TIME-AVERAGED EXCHANGE COEFFICIENTS FOR WIND REQUESTED FOR CMAQ
6985 IF (iget(504)>0) THEN
6986 DO j=jsta,jend
6987 DO i=ista,iend
6988 grid1(i,j)=akmsavg(i,j)
6989 ENDDO
6990 ENDDO
6991 id(1:25) = 0
6992 id(02)= 133
6993 id(19) = ifhr
6994 IF (ifhr==0) THEN
6995 id(18) = 0
6996 ELSE
6997 id(18) = ifhr - 1
6998 ENDIF
6999 id(20) = 3
7000 itsrfc = nint(tsrfc)
7001 if(grib=='grib2') then
7002 cfld=cfld+1
7003 fld_info(cfld)%ifld=iavblfld(iget(504))
7004 if(itsrfc>0) then
7005 fld_info(cfld)%ntrange=1
7006 else
7007 fld_info(cfld)%ntrange=0
7008 endif
7009 fld_info(cfld)%tinvstat=ifhr-id(18)
7010 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
7011 endif
7012
7013 ENDIF
7014
7015 RETURN
7016 END
7017!-------------------------------------------------------------------------------------
7023
7024 subroutine qpf_comp(igetfld,compfile,fcst)
7025
7026 use ctlblk_mod, only: spval,jsta,jend,im,dtq2,ifhr,ifmin,tprec,grib, &
7027 modelname,jm,cfld,datapd,fld_info,jsta_2l,jend_2u,&
7028 ista,iend,ista_2l,iend_2u,me
7029 use rqstfld_mod, only: iget, id, lvls, iavblfld
7030 use grib2_module, only: read_grib2_head, read_grib2_sngle
7031 use vrbls2d, only: avgprec, avgprec_cont
7032 implicit none
7033 character(len=256), intent(in) :: compfile
7034 integer, intent(in) :: igetfld,fcst
7035 integer :: trange,invstat
7036 real, dimension(ista:iend,jsta:jend) :: outgrid
7037
7038 real, allocatable, dimension(:,:) :: mscValue
7039
7040 integer :: nx, ny, nz, ntot, mscNlon, mscNlat, height
7041 integer :: ITPREC, IFINCR
7042 real :: rlonmin, rlatmax
7043 real*8 rdx, rdy
7044
7045 logical :: file_exists
7046
7047 integer :: i, j, k, ii, jj
7048
7049 outgrid = 0
7050
7051! Read in reference grid.
7052 INQUIRE(file=compfile, exist=file_exists)
7053 if (file_exists) then
7054 call read_grib2_head(compfile,nx,ny,nz,rlonmin,rlatmax,&
7055 rdx,rdy)
7056 mscnlon=nx
7057 mscnlat=ny
7058 if (.not. allocated(mscvalue)) then
7059 allocate(mscvalue(mscnlon,mscnlat))
7060 endif
7061 ntot = nx*ny
7062 call read_grib2_sngle(compfile,ntot,height,mscvalue)
7063 else
7064 if(me==0)write(*,*) 'WARNING: FFG file not available for hour: ', fcst
7065 endif
7066
7067! Set GRIB variables.
7068 id(1:25) = 0
7069 itprec = nint(tprec)
7070 if (itprec /= 0) then
7071 ifincr = mod(ifhr,itprec)
7072 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itprec*60)
7073 else
7074 ifincr = 0
7075 endif
7076 id(18) = 0
7077 id(19) = ifhr
7078 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
7079 id(20) = 4
7080 IF (ifincr==0) THEN
7081 id(18) = ifhr-itprec
7082 ELSE
7083 id(18) = ifhr-ifincr
7084 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
7085 ENDIF
7086
7087! Calculate exceedance grid.
7088 IF(modelname == 'GFS' .OR. modelname == 'FV3R') THEN
7089! !$omp parallel do private(i,j)
7090 IF (file_exists) THEN
7091 DO j=jsta,jend
7092 DO i=ista,iend
7093 IF (ifhr .EQ. 0 .OR. fcst .EQ. 0) THEN
7094 outgrid(i,j) = 0.0
7095 ELSE IF (mscvalue(i,j) .LE. 0.0) THEN
7096 outgrid(i,j) = 0.0
7097 ELSE IF (fcst .EQ. 1 .AND. avgprec(i,j)*float(id(19)-id(18))*3600.*1000./dtq2 .GT. mscvalue(i,j)) THEN
7098 outgrid(i,j) = 1.0
7099 ELSE IF (fcst .GT. 1 .AND. avgprec_cont(i,j)*float(ifhr)*3600.*1000./dtq2 .GT. mscvalue(i,j)) THEN
7100 outgrid(i,j) = 1.0
7101 ENDIF
7102 ENDDO
7103 ENDDO
7104 ENDIF
7105 ENDIF
7106! write(*,*) 'FFG MAX, MIN:', &
7107! maxval(mscValue),minval(mscValue)
7108 IF (id(18).LT.0) id(18) = 0
7109
7110! Set GRIB2 variables.
7111 IF(fcst .EQ. 1) THEN
7112 IF(itprec>0) THEN
7113 trange = (ifhr-id(18))/itprec
7114 ELSE
7115 trange = 0
7116 ENDIF
7117 invstat = itprec
7118 IF(trange .EQ. 0) THEN
7119 IF (ifhr .EQ. 0) THEN
7120 invstat = 0
7121 ELSE
7122 invstat = 1
7123 ENDIF
7124 trange = 1
7125 ENDIF
7126 ELSE
7127 trange = 1
7128 IF (ifhr .EQ. fcst) THEN
7129 invstat = fcst
7130 ELSE
7131 invstat = 0
7132 ENDIF
7133 ENDIF
7134
7135 IF(grib=='grib2') then
7136 cfld=cfld+1
7137 fld_info(cfld)%ifld=iavblfld(iget(igetfld))
7138 fld_info(cfld)%ntrange=trange
7139 fld_info(cfld)%tinvstat=invstat
7140!$omp parallel do private(i,j,ii,jj)
7141 do j=1,jend-jsta+1
7142 jj = jsta+j-1
7143 do i=1,iend-ista+1
7144 ii = ista+i-1
7145 datapd(i,j,cfld) = outgrid(ii,jj)
7146 enddo
7147 enddo
7148 endif
7149
7150 RETURN
7151
7152 end subroutine qpf_comp
bound
subroutine bound(fld, fmin, fmax)
Clips data in passed array.
Definition BOUND.f:37
caldrg
subroutine caldrg(dragco)
This rountine computes a surface layer drag coefficient using equation (7.4.1A) in ["An introduction ...
Definition CALDRG.f:22
caltau
subroutine caltau(taux, tauy)
Subroutine that computes U and V wind stresses.
Definition CALTAU.f:34
calwxt_bourg_post
subroutine calwxt_bourg_post(im, ista_2l, iend_2u, ista, iend, jm, jsta_2l, jend_2u, jsta, jend, lm, lp1, iseed, g, pthresh, t, q, pmid, pint, lmh, prec, zint, ptype, me)
calwxt_bourg_post Subroutine that calculates precipitation type (Bourgouin).
Definition CALWXT_BOURG.f:86
dewpoint
subroutine dewpoint(vp, td)
DEWPOINT() Subroutine that computes dewpoints from vapor pressure.
Definition DEWPOINT.f:52
surfce
subroutine surfce
SURFCE posts surface-based fields.
Definition SURFCE.f:79
qpf_comp
subroutine qpf_comp(igetfld, compfile, fcst)
qpf_comp() Read in QPF threshold for exceedance grid.
Definition SURFCE.f:7025