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