UPP (develop)
Loading...
Searching...
No Matches
FIXED.f
Go to the documentation of this file.
1
2!
44 SUBROUTINE fixed
45!
46
47!
48 use vrbls3d, only: pint
49 use vrbls2d, only: albedo, avgalbedo, albase, mxsnal, sst, ths, epsr, ti&
50 , fdnsst
51 use masks, only: gdlat, gdlon, sm, sice, lmh, lmv
52 use params_mod, only: small, p1000, capa
53 use lookup_mod, only: itb,jtb,itbq,jtbq
54 use ctlblk_mod, only: jsta, jend, modelname, grib, cfld, fld_info, datapd, spval, tsrfc,&
55 ifhr, ifmin, lm, im, jm, ista, iend
56 use rqstfld_mod, only: iget, lvls, iavblfld, id
57!- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
58 implicit none
59!
60 integer,PARAMETER :: SNOALB=0.55
61! INCLUDE COMMON BLOCKS.
62!
63! DECLARE VARIABLES
64 REAL,dimension(im,jm) :: GRID1
65! REAL,dimension(im,jm) :: GRID1, GRID2
66 integer I,J,ITSRFC,IFINCR
67!
68!********************************************************************
69!
70! START FIXED HERE.
71!
72! LATITUDE (OUTPUT GRID).
73 IF (iget(048)>0) THEN
74!$omp parallel do private(i,j)
75 DO j = jsta,jend
76 DO i = ista,iend
77 grid1(i,j) = gdlat(i,j)
78 END DO
79 END DO
80 if(grib=='grib2') then
81 cfld=cfld+1
82 fld_info(cfld)%ifld=iavblfld(iget(048))
83 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
84 endif
85 ENDIF
86!
87! LONGITUDE (OUTPUT GRID). CONVERT TO EAST
88 IF (iget(049)>0) THEN
89 DO j = jsta,jend
90 DO i = ista,iend
91 IF (gdlon(i,j) < 0.)THEN
92 grid1(i,j) = 360. + gdlon(i,j)
93 ELSE
94 grid1(i,j) = gdlon(i,j)
95 END IF
96 IF (grid1(i,j)>360.)print*,'LARGE GDLON ', &
97 i,j,gdlon(i,j)
98 END DO
99 END DO
100 if(grib=='grib2') then
101 cfld=cfld+1
102 fld_info(cfld)%ifld=iavblfld(iget(049))
103 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
104 endif
105 ENDIF
106!
107! LAND/SEA MASK.
108 IF (iget(050)>0) THEN
109!$omp parallel do private(i,j)
110 DO j = jsta,jend
111 DO i = ista,iend
112 grid1(i,j) = spval
113 IF(sm(i,j) /= spval) grid1(i,j) = 1. - sm(i,j)
114 If(modelname == 'GFS' .or. modelname == 'FV3R')then
115 IF(sice(i,j) /= spval .AND. sice(i,j) > 0.0)grid1(i,j)=0.
116 else
117 IF(sice(i,j) /= spval .AND. sice(i,j) > 0.1)grid1(i,j)=0.
118 end if
119! if(j==jm/2)print*,'i,mask= ',i,grid1(i,j)
120 ENDDO
121 ENDDO
122 if(grib=='grib2') then
123 cfld=cfld+1
124 fld_info(cfld)%ifld=iavblfld(iget(050))
125 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
126 endif
127 ENDIF
128!
129! SEA ICE MASK.
130 IF (iget(051)>0) THEN
131!$omp parallel do private(i,j)
132 DO j = jsta,jend
133 DO i = ista,iend
134 grid1(i,j) = sice(i,j)
135 ENDDO
136 ENDDO
137 if(grib=='grib2') then
138 cfld=cfld+1
139 fld_info(cfld)%ifld=iavblfld(iget(051))
140 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
141 endif
142 ENDIF
143!
144! MASS POINT ETA SURFACE MASK.
145 IF (iget(052)>0) THEN
146!$omp parallel do private(i,j)
147 DO j=jsta,jend
148 DO i=ista,iend
149 grid1(i,j) = lmh(i,j)
150 ENDDO
151 ENDDO
152 if(grib=='grib2') then
153 cfld=cfld+1
154 fld_info(cfld)%ifld=iavblfld(iget(052))
155 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
156 endif
157 ENDIF
158!
159! VELOCITY POINT ETA SURFACE MASK.
160 IF (iget(053)>0) THEN
161!$omp parallel do private(i,j)
162 DO j=jsta,jend
163 DO i=ista,iend
164 grid1(i,j) = lmv(i,j)
165 ENDDO
166 ENDDO
167 if(grib=='grib2') then
168 cfld=cfld+1
169 fld_info(cfld)%ifld=iavblfld(iget(053))
170 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
171 endif
172 ENDIF
173!
174! SURFACE ALBEDO.
175! NO LONGER A FIXED FIELD, THIS VARIES WITH SNOW COVER
176!MEB since this is not a fixed field, move this to SURFCE
177!
178 IF (iget(150)>0) THEN
179!$omp parallel do private(i,j)
180 DO j=jsta,jend
181 DO i=ista,iend
182! SNOK = AMAX1(SNO(I,J),0.0)
183! SNOFAC = AMIN1(SNOK*50.0,1.0)
184! EGRID1(I,J)=ALB(I,J)+(1.-VEGFRC(I,J))*SNOFAC
185! 1 *(SNOALB-ALB(I,J))
186 IF(abs(albedo(i,j)-spval)>small) THEN
187 grid1(i,j)=albedo(i,j)
188 ELSE
189 grid1(i,j) = spval
190 ENDIF
191 ENDDO
192 ENDDO
193! CALL E2OUT(150,000,GRID1,GRID2,GRID1,GRID2,IM,JM)
194 CALL sclfld(grid1(ista:iend,jsta:jend),100.,im,jm)
195 if(grib=='grib2') then
196 cfld=cfld+1
197 fld_info(cfld)%ifld=iavblfld(iget(150))
198 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
199 endif
200 ENDIF
201!
202! TIME AVERAGED SURFACE ALBEDO.
203 IF (iget(266)>0) THEN
204 id(1:25) = 0
205 itsrfc = nint(tsrfc)
206 IF(itsrfc /= 0) then
207 ifincr = mod(ifhr,itsrfc)
208 IF(ifmin >= 1)ifincr= mod(ifhr*60+ifmin,itsrfc*60)
209 ELSE
210 ifincr = 0
211 endif
212 id(19) = ifhr
213 IF(ifmin >= 1)id(19)=ifhr*60+ifmin
214 id(20) = 3
215 IF (ifincr==0) THEN
216 id(18) = ifhr-itsrfc
217 ELSE
218 id(18) = ifhr-ifincr
219 IF(ifmin >= 1)id(18)=ifhr*60+ifmin-ifincr
220 ENDIF
221 IF (id(18)<0) id(18) = 0
222!$omp parallel do private(i,j)
223 DO j=jsta,jend
224 DO i=ista,iend
225 IF(abs(avgalbedo(i,j)-spval)>small) THEN
226 grid1(i,j) = avgalbedo(i,j)*100.
227 ELSE
228 grid1(i,j) = spval
229 ENDIF
230 ENDDO
231 ENDDO
232
233 if(grib=='grib2') then
234 cfld=cfld+1
235 fld_info(cfld)%ifld=iavblfld(iget(266))
236 if(itsrfc>0) then
237 fld_info(cfld)%ntrange=1
238 else
239 fld_info(cfld)%ntrange=0
240 endif
241 fld_info(cfld)%tinvstat=ifhr-id(18)
242 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
243 endif
244 ENDIF
245!
246 IF (iget(226)>0) THEN
247!$omp parallel do private(i,j)
248 DO j=jsta,jend
249 DO i=ista,iend
250 IF(abs(albase(i,j)-spval)>small) THEN
251 grid1(i,j) = albase(i,j)*100.
252 ELSE
253 grid1(i,j) = spval
254 ENDIF
255 ENDDO
256 ENDDO
257 if(grib=='grib2') then
258 cfld=cfld+1
259 fld_info(cfld)%ifld=iavblfld(iget(226))
260 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
261 endif
262 ENDIF
263! Max snow albedo
264 IF (iget(227)>0) THEN
265!$omp parallel do private(i,j)
266 DO j=jsta,jend
267 DO i=ista,iend
268 IF (abs(mxsnal(i,j)-spval)>small) THEN
269! sea point, albedo=0.06 same as snow free albedo
270 IF( (abs(sm(i,j)-1.) < 1.0e-5) ) THEN
271 mxsnal(i,j)=0.06
272! sea-ice point, albedo=0.60, same as snow free albedo
273 ELSEIF( (abs(sm(i,j)-0.) < 1.0e-5) .AND. &
274 & (abs(sice(i,j)-1.) < 1.0e-5) ) THEN
275 mxsnal(i,j)=0.60
276 ENDIF
277 ELSE
278 mxsnal(i,j)=spval
279 ENDIF
280 ENDDO
281 ENDDO
282
283!$omp parallel do private(i,j)
284 DO j=jsta,jend
285 DO i=ista,iend
286 IF(abs(mxsnal(i,j)-spval)>small) THEN
287 grid1(i,j) = mxsnal(i,j)*100.
288 ELSE
289 grid1(i,j) = spval
290 ENDIF
291 ENDDO
292 ENDDO
293 if(grib=='grib2') then
294 cfld=cfld+1
295 fld_info(cfld)%ifld=iavblfld(iget(227))
296 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
297 endif
298 ENDIF
299!
300! SEA SURFACE TEMPERAURE.
301 IF (iget(151)>0) THEN
302!$omp parallel do private(i,j)
303 DO j=jsta,jend
304 DO i=ista,iend
305 grid1(i,j) = spval
306 IF (modelname == 'NMM') THEN
307 IF( (abs(sm(i,j)-1.) < 1.0e-5) ) THEN
308 grid1(i,j) = sst(i,j)
309 ELSE
310 IF(ths(i,j)<spval.and.pint(i,j,lm+1)<spval)&
311 grid1(i,j) = ths(i,j)*(pint(i,j,lm+1)/p1000)**capa
312 END IF
313 ELSE
314 grid1(i,j) = sst(i,j)
315 ENDIF
316 ENDDO
317 ENDDO
318 if(grib=='grib2') then
319 cfld=cfld+1
320 fld_info(cfld)%ifld=iavblfld(iget(151))
321 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
322 endif
323 ENDIF
324
325!
326! SEA ICE SKIN TEMPERAURE.
327 IF (iget(968)>0) THEN
328!$omp parallel do private(i,j)
329 DO j=jsta,jend
330 DO i=ista,iend
331 grid1(i,j) = ti(i,j)
332 ENDDO
333 ENDDO
334 if(grib=='grib2') then
335 cfld=cfld+1
336 fld_info(cfld)%ifld=iavblfld(iget(968))
337 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
338 endif
339 ENDIF
340!
341! FOUNDATION TEMPERAURE.
342 IF (iget(549)>0) THEN
343!$omp parallel do private(i,j)
344 DO j=jsta,jend
345 DO i=ista,iend
346 grid1(i,j) = fdnsst(i,j)
347 ENDDO
348 ENDDO
349 if(grib=='grib2') then
350 cfld=cfld+1
351 fld_info(cfld)%ifld=iavblfld(iget(549))
352 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
353 endif
354 ENDIF
355
356! EMISSIVIT.
357 IF (iget(248)>0) THEN
358!$omp parallel do private(i,j)
359 DO j=jsta,jend
360 DO i=ista,iend
361 grid1(i,j) = epsr(i,j)
362 ENDDO
363 ENDDO
364 if(grib=='grib2') then
365 cfld=cfld+1
366 fld_info(cfld)%ifld=iavblfld(iget(248))
367 datapd(1:iend-ista+1,1:jend-jsta+1,cfld)=grid1(ista:iend,jsta:jend)
368 endif
369 ENDIF
370
371!
372! END OF ROUTINE.
373!
374 RETURN
375 END
376
fixed
subroutine fixed
SUBPROGRAM: FIXED POSTS FIXED FIELDS PRGRMMR: TREADON ORG: W/NP2 DATE: 93-08-30.
Definition FIXED.f:45
sclfld
subroutine sclfld(fld, scale, imo, jmo)
sclfld() scale array element by constant.
Definition SCLFLD.f:34