UPP  V11.0.0
 All Data Structures Files Functions Pages
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 
masks
Definition: MASKS_mod.f:1
params_mod
Definition: params.F:1
lookup_mod
Definition: LOOKUP.f:1