UPP  11.0.0
 All Data Structures Files Functions Variables Pages
INITPOST_GFS_NEMS_MPIIO.f
Go to the documentation of this file.
1 
5 
29 ! and 2D diag. output (d2d_chem) for GEFS-Aerosols and CCPP-Chem model.
32  SUBROUTINE initpost_gfs_nems_mpiio(iostatusAER)
33 
34 
35  use vrbls4d, only: dust, salt, suso, soot, waso, pp25, pp10
36  use vrbls3d, only: t, q, uh, vh,wh,pmid,pint,alpint, dpres,zint,zmid,o3, &
37  qqr, qqs, cwm, qqi, qqw, omga, rhomid, q2, cfr, rlwtt, rswtt, tcucn, &
38  tcucns, train, el_pbl, exch_h, vdifftt, vdiffmois, dconvmois, nradtt, &
39  o3vdiff, o3prod, o3tndy, mwpv, qqg, vdiffzacce, zgdrag,cnvctummixing, &
40  vdiffmacce, mgdrag, cnvctvmmixing, ncnvctcfrac, cnvctumflx, cnvctdmflx, &
41  cnvctzgdrag, sconvmois, cnvctmgdrag, cnvctdetmflx, duwt, duem, dusd, dudp, &
42  dusv,ssem,sssd,ssdp,sswt,sssv,bcem,bcsd,bcdp,bcwt,bcsv,ocem,ocsd,ocdp, &
43  ocwt,ocsv, ref_10cm
44  use vrbls2d, only: f, pd, fis, pblh, ustar, z0, ths, qs, twbs, qwbs, avgcprate, &
45  cprate, avgprec, prec, lspa, sno, si, cldefi, th10, q10, tshltr, pshltr, &
46  tshltr, albase, avgalbedo, avgtcdc, czen, czmean, mxsnal, radot, sigt4, &
47  cfrach, cfracl, cfracm, avgcfrach, qshltr, avgcfracl, avgcfracm, cnvcfr, &
48  islope, cmc, grnflx, vegfrc, acfrcv, ncfrcv, acfrst, ncfrst, ssroff, &
49  bgroff, rlwin, rlwtoa, cldwork, alwin, alwout, alwtoa, rswin, rswinc, &
50  rswout, aswin, auvbin, auvbinc, aswout, aswtoa, sfcshx, sfclhx, subshx, &
51  snopcx, sfcux, sfcvx, sfcuvx, gtaux, gtauy, potevp, u10, v10, smstav, &
52  smstot, ivgtyp, isltyp, sfcevp, sfcexc, acsnow, acsnom, sst, thz0, qz0, &
53  uz0, vz0, ptop, htop, pbot, hbot, ptopl, pbotl, ttopl, ptopm, pbotm, ttopm, &
54  ptoph, pboth, pblcfr, ttoph, runoff, maxtshltr, mintshltr, maxrhshltr, &
55  minrhshltr, dzice, smcwlt, suntime, fieldcapa, htopd, hbotd, htops, hbots, &
56  cuppt, dusmass, ducmass, dusmass25, ducmass25, aswintoa, &
57  maxqshltr, minqshltr, acond, sr, u10h, v10h, &
58  avgedir,avgecan,avgetrans,avgesnow,avgprec_cont,avgcprate_cont, &
59  avisbeamswin,avisdiffswin,airbeamswin,airdiffswin, &
60  alwoutc,alwtoac,aswoutc,aswtoac,alwinc,aswinc,avgpotevp,snoavg, &
61  dustcb,bccb,occb,sulfcb,sscb,dustallcb,ssallcb,dustpm,dustpm10,sspm,pp25cb, &
62  pp10cb,maod,ti
63  use soil, only: sldpth, sh2o, smc, stc
64  use masks, only: lmv, lmh, htm, vtm, gdlat, gdlon, dx, dy, hbm2, sm, sice
65 ! use kinds, only: i_llong
66 ! use nemsio_module, only: nemsio_gfile, nemsio_getfilehead, nemsio_getheadvar, nemsio_close
67  use physcons_post, only: grav => con_g, fv => con_fvirt, rgas => con_rd, &
68  eps => con_eps, epsm1 => con_epsm1
69  use params_mod, only: erad, dtr, tfrz, h1, d608, rd, p1000, capa
70  use lookup_mod, only: thl, plq, ptbl, ttbl, rdq, rdth, rdp, rdthe, pl, qs0, sqs, sthe, &
71  ttblq, rdpq, rdtheq, stheq, the0q, the0
72  use ctlblk_mod, only: me, mpi_comm_comp, icnt, idsp, jsta, jend, ihrst, idat, sdat, ifhr, &
73  ifmin, filename, tprec, tclod, trdlw, trdsw, tsrfc, tmaxmin, td3d, restrt, sdat, &
74  jend_m, imin, imp_physics, dt, spval, pdtop, pt, qmin, nbin_du, nphs, dtq2, ardlw,&
75  ardsw, asrfc, avrain, avcnvc, theat, gdsdegr, spl, lsm, alsl, im, jm, im_jm, lm, &
76  jsta_2l, jend_2u, nsoil, lp1, icu_physics, ivegsrc, novegtype, nbin_ss, nbin_bc, &
77  nbin_oc, nbin_su, gocart_on, gccpp_on, pt_tbl, hyb_sigp, filenameflux, filenameaer, &
78  isf_surface_physics, d2d_chem
79  use gridspec_mod, only: maptype, gridtype, latstart, latlast, lonstart, lonlast, cenlon, &
80  dxval, dyval, truelat2, truelat1, psmapf, cenlat
81  use nemsio_module_mpi
82  use upp_physics, only: fpvsnew, caldiv, calgradps
83 !- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
84  implicit none
85 !
86  type(nemsio_gfile) :: nfile,ffile,rfile
87 !
88 ! INCLUDE/SET PARAMETERS.
89 !
90  include "mpif.h"
91 
92 ! integer,parameter:: MAXPTS=1000000 ! max im*jm points
93 !
94 ! real,parameter:: con_g =9.80665e+0! gravity
95 ! real,parameter:: con_rv =4.6150e+2 ! gas constant H2O
96 ! real,parameter:: con_rd =2.8705e+2 ! gas constant air
97 ! real,parameter:: con_fvirt =con_rv/con_rd-1.
98 ! real,parameter:: con_eps =con_rd/con_rv
99 ! real,parameter:: con_epsm1 =con_rd/con_rv-1
100 !
101 ! This version of INITPOST shows how to initialize, open, read from, and
102 ! close a NetCDF dataset. In order to change it to read an internal (binary)
103 ! dataset, do a global replacement of _ncd_ with _int_.
104 
105  real, parameter :: gravi = 1.0/grav
106  integer,intent(in) :: iostatusaer
107  character(len=20) :: varname, vcoordname
108  integer :: status, fldsize, fldst, recn
109  integer :: recn_vvel,recn_delz,recn_dpres
110  character startdate*19,sysdepinfo*80,cgar*1
111  character startdate2(19)*4,lprecip_accu*3
112 !
113 ! NOTE: SOME INTEGER VARIABLES ARE READ INTO DUMMY ( A REAL ). THIS IS OK
114 ! AS LONG AS REALS AND INTEGERS ARE THE SAME SIZE.
115 !
116 ! ALSO, EXTRACT IS CALLED WITH DUMMY ( A REAL ) EVEN WHEN THE NUMBERS ARE
117 ! INTEGERS - THIS IS OK AS LONG AS INTEGERS AND REALS ARE THE SAME SIZE.
118  LOGICAL runb,singlrst,subpost,nest,hydro,ioomg,ioall
119  logical, parameter :: debugprint = .false., zerout = .false.
120 ! logical, parameter :: debugprint = .true., zerout = .false.
121  logical :: reduce_grid = .true. ! set default to true for ops GSM
122  CHARACTER*32 label
123  CHARACTER*40 contrl,filall,filmst,filtmp,filtke,filunv,filcld,filrad,filsfc
124  CHARACTER*4 resthr
125  CHARACTER fname*255,envar*50
126  INTEGER idate(8),jdate(8),jpds(200),jgds(200),kpds(200),kgds(200)
127 ! LOGICAL*1 LB(IM,JM)
128 !
129 ! INCLUDE COMMON BLOCKS.
130 !
131 ! DECLARE VARIABLES.
132 !
133 ! REAL fhour
134  integer nfhour ! forecast hour from nems io file
135  integer fhzero ! bucket
136  real dtp !physics time step
137  REAL rinc(5)
138 
139  REAL dummy(im,jm)
140  real, allocatable :: fi(:,:,:)
141 !jw
142  integer ii,jj,js,je,iyear,imn,iday,itmp,ioutcount,istatus, &
143  i,j,l,ll,k,kf,irtn,igdout,n,index,nframe, &
144  impf,jmpf,nframed2,iunitd3d,ierr,idum,iret,nrec,idrt
145  real tstart,tlmh,tsph,es,fact,soilayert,soilayerb,zhour,dum, &
146  tvll,pmll,tv, tx1, tx2
147 
148  character*16,allocatable :: recname(:)
149  character*16,allocatable :: reclevtyp(:)
150  character*6 :: modelname_nemsio
151  integer, allocatable :: reclev(:), kmsk(:,:)
152  real, allocatable :: glat1d(:), glon1d(:), qstl(:)
153  real, allocatable :: wrk1(:,:), wrk2(:,:)
154  real, allocatable :: p2d(:,:), t2d(:,:), q2d(:,:), &
155  qs2d(:,:), cw2d(:,:), cfr2d(:,:)
156  real(kind=4),allocatable :: vcoord4(:,:,:)
157  real, dimension(lm+1) :: ak5, bk5
158  real*8, allocatable :: pm2d(:,:), pi2d(:,:)
159  real, allocatable :: tmp(:)
160  real :: buf(im,jsta_2l:jend_2u)
161  integer :: lonsperlat(jm/2), numi(jm)
162 
163 ! real buf(im,jsta_2l:jend_2u),bufsoil(im,nsoil,jsta_2l:jend_2u) &
164 ! ,buf3d(im,jsta_2l:jend_2u,lm),buf3d2(im,lp1,jsta_2l:jend_2u)
165 
166  real lat
167  integer isa, jsa, latghf, jtem, idvc, idsl, nvcoord, ip1, nn, npass
168 ! REAL, PARAMETER :: QMIN = 1.E-15
169 
170 ! DATA BLANK/' '/
171 !
172 ! integer, parameter :: npass2=2, npass3=3
173 ! integer, parameter :: npass2=20, npass3=30
174  integer, parameter :: npass2=5, npass3=30
175  real, parameter :: third=1.0/3.0
176  INTEGER, DIMENSION(2) :: ij4min, ij4max
177  REAL :: omgmin, omgmax
178  real, allocatable :: d2d(:,:), u2d(:,:), v2d(:,:), omga2d(:,:)
179  REAL, ALLOCATABLE :: ps2d(:,:),psx2d(:,:),psy2d(:,:)
180  real, allocatable :: div3d(:,:,:)
181  real(kind=4),allocatable :: vcrd(:,:)
182  real :: omg1(im), omg2(im+2)
183 
184 !***********************************************************************
185 ! START INIT HERE.
186 !
187  WRITE(6,*)'INITPOST: ENTER INITPOST_GFS_NEMS_MPIIO'
188  WRITE(6,*)'me=',me,'LMV=',size(lmv,1),size(lmv,2),'LMH=', &
189  size(lmh,1),size(lmh,2),'jsta_2l=',jsta_2l,'jend_2u=', &
190  jend_2u,'im=',im
191 !
192  isa = im / 2
193  jsa = (jsta+jend) / 2
194 
195 !$omp parallel do private(i,j)
196  do j = jsta_2l, jend_2u
197  do i=1,im
198  buf(i,j) = spval
199  enddo
200  enddo
201 
202 ! initialize nemsio using mpi io module
203  call nemsio_init()
204  call nemsio_open(nfile,trim(filename),'read',mpi_comm_comp,iret=status)
205  if ( status /= 0 ) then
206  print*,'error opening ',filename, ' Status = ', status ; stop
207  endif
208  call nemsio_getfilehead(nfile,iret=status,nrec=nrec,idrt=idrt)
209 
210 ! open flux file early yo read imp_physics
211  call nemsio_open(ffile,trim(filenameflux),'read',mpi_comm_comp &
212  ,iret=status)
213  if ( status /= 0 ) then
214  print*,'error opening ',filenameflux, ' Status = ', status
215  endif
216 
217 !
218 ! STEP 1. READ MODEL OUTPUT FILE
219 !
220 ! LMH and LMV always = LM for sigma-type vert coord
221 
222 !$omp parallel do private(i,j)
223  do j = jsta_2l, jend_2u
224  do i = 1, im
225  lmv(i,j) = lm
226  lmh(i,j) = lm
227  end do
228  end do
229 
230 ! HTM VTM all 1 for sigma-type vert coord
231 
232 !$omp parallel do private(i,j,l)
233  do l = 1, lm
234  do j = jsta_2l, jend_2u
235  do i = 1, im
236  htm(i,j,l) = 1.0
237  vtm(i,j,l) = 1.0
238  end do
239  end do
240  end do
241 
242 ! write(*,*)'nrec=',nrec
243  allocate(recname(nrec),reclevtyp(nrec),reclev(nrec))
244  allocate(glat1d(im*jm),glon1d(im*jm))
245  allocate(vcoord4(lm+1,3,2))
246 ! get start date
247  call nemsio_getfilehead(nfile,iret=iret &
248  ,idate=idate(1:7),nfhour=nfhour,recname=recname &
249  ,reclevtyp=reclevtyp,reclev=reclev,lat=glat1d &
250  ,lon=glon1d,nframe=nframe,vcoord=vcoord4,idrt=maptype &
251  ,modelname=modelname_nemsio)
252  if(iret/=0)print*,'error getting idate,nfhour'
253  print *,'latstar1=',glat1d(1),glat1d(im*jm)
254 !
255 ! modelname_nemsio='FV3GFS'
256  print*,'modelname = ',modelname_nemsio
257  if(trim(modelname_nemsio)=='FV3GFS')reduce_grid=.false.
258  if(reduce_grid)then
259 !------------------------------
260  if (idrt == 4) then
261 !------------------------------
262 ! read lonsperlat
263  open (201,file='lonsperlat.dat',status='old',form='formatted', &
264  action='read',iostat=iret)
265  rewind(201)
266  read (201,*,iostat=iret) latghf,(lonsperlat(i),i=1,latghf)
267  close (201)
268  print*,'finished reading lonsperlat'
269 
270  if (jm /= latghf+latghf) then
271  write(0,*)' wrong reduced grid - execution skipped'
272  stop 777
273  endif
274  do j=1,jm/2
275  numi(j) = lonsperlat(j)
276  enddo
277  do j=jm/2+1,jm
278  numi(j) = lonsperlat(jm+1-j)
279  enddo
280 !------------------------------
281  else
282 !------------------------------
283  do j=1,jm
284  numi(j) = im
285  enddo
286 !------------------------------
287  endif
288 !------------------------------
289  end if
290 
291 ! Specigy grid staggering type
292  gridtype = 'A'
293  if (me == 0) print *, 'maptype and gridtype is ', &
294  maptype,gridtype
295 
296  if(debugprint)then
297  if (me == 0)then
298  do i=1,nrec
299  print *,'recname,reclevtyp,reclev=',trim(recname(i)),' ', &
300  trim(reclevtyp(i)),reclev(i)
301  end do
302  end if
303  end if
304 
305 !$omp parallel do private(i,j,js)
306  do j=jsta,jend
307  js = (j-1)*im
308  do i=1,im
309  gdlat(i,j) = glat1d(js+i)
310  gdlon(i,j) = glon1d(js+i)
311  end do
312  end do
313 !
314 ! if (hyb_sigp) then
315  do l=1,lm+1
316  ak5(l) = vcoord4(l,1,1)
317  bk5(l) = vcoord4(l,2,1)
318  enddo
319 ! endif
320 
321 !--Fanglin Yang: nemsio file created from FV3 does not have vcoord.
322  if ( minval(ak5) <0 .or. minval(bk5) <0 ) then
323  open (202,file='global_hyblev.txt',status='old',form='formatted', &
324  action='read',iostat=iret)
325  rewind(202)
326  read(202,*)
327  do l=1,lm+1
328  read (202,*,iostat=iret) ak5(l),bk5(l)
329  enddo
330  close (202)
331 
332  if (iret == 0 ) then
333  do l=1,lm+1
334  vcoord4(l,1,1)=ak5(l)
335  vcoord4(l,2,1)=bk5(l)
336  enddo
337  else
338  print *, 'ak5 and bk5 not found, stop !'
339  stop
340  endif
341  endif
342 
343  if (me == 0)then
344  print *,"ak5",ak5
345  print *,"bk5",bk5
346  endif
347 
348 ! deallocate(glat1d,glon1d,vcoord4)
349  deallocate(glat1d,glon1d)
350 
351  print*,'idate = ',(idate(i),i=1,7)
352  print*,'idate after broadcast = ',(idate(i),i=1,4)
353  print*,'nfhour = ',nfhour
354 
355 ! sample print point
356  ii = im/2
357  jj = jm/2
358 
359  print *,me,'max(gdlat)=', maxval(gdlat), &
360  'max(gdlon)=', maxval(gdlon)
361  CALL exch(gdlat)
362  CALL exch(gdlon)
363  print *,'after call EXCH,me=',me
364 
365 !$omp parallel do private(i,j,ip1)
366  do j = jsta, jend_m
367  do i = 1, im
368  ip1 = i + 1
369  if (ip1 > im) ip1 = ip1 - im
370  dx(i,j) = erad*cos(gdlat(i,j)*dtr) *(gdlon(ip1,j)-gdlon(i,j))*dtr
371  dy(i,j) = erad*(gdlat(i,j)-gdlat(i,j+1))*dtr ! like A*DPH
372 ! F(I,J)=1.454441e-4*sin(gdlat(i,j)*DTR) ! 2*omeg*sin(phi)
373 ! if (i == ii .and. j == jj) print*,'sample LATLON, DY, DY=' &
374 ! ,i,j,GDLAT(I,J),GDLON(I,J),DX(I,J),DY(I,J)
375  end do
376  end do
377 
378 !$omp parallel do private(i,j)
379  do j=jsta,jend
380  do i=1,im
381  f(i,j) = 1.454441e-4*sin(gdlat(i,j)*dtr) ! 2*omeg*sin(phi)
382  end do
383  end do
384 
385  impf = im
386  jmpf = jm
387  print*,'impf,jmpf,nframe= ',impf,jmpf,nframe
388 
389  iyear = idate(1)
390  imn = idate(2) ! ask Jun
391  iday = idate(3) ! ask Jun
392  ihrst = idate(4)
393  imin = idate(5)
394  jdate = 0
395  idate = 0
396 !
397  print*,'start yr mo day hr min =',iyear,imn,iday,ihrst,imin
398  print*,'processing yr mo day hr min=' &
399  ,idat(3),idat(1),idat(2),idat(4),idat(5)
400 !
401  idate(1) = iyear
402  idate(2) = imn
403  idate(3) = iday
404  idate(5) = ihrst
405  idate(6) = imin
406  sdat(1) = imn
407  sdat(2) = iday
408  sdat(3) = iyear
409  jdate(1) = idat(3)
410  jdate(2) = idat(1)
411  jdate(3) = idat(2)
412  jdate(5) = idat(4)
413  jdate(6) = idat(5)
414 !
415  print *,' idate=',idate
416  print *,' jdate=',jdate
417 !
418  CALL w3difdat(jdate,idate,0,rinc)
419 !
420  print *,' rinc=',rinc
421  ifhr = nint(rinc(2)+rinc(1)*24.)
422  print *,' ifhr=',ifhr
423  ifmin = nint(rinc(3))
424 ! if(ifhr /= nint(fhour))print*,'find wrong Grib file';stop
425  print*,' in INITPOST ifhr ifmin fileName=',ifhr,ifmin,filename
426 
427 ! Getting tstart
428  tstart = 0.
429  print*,'tstart= ',tstart
430 
431 ! Getiing restart
432 
433  restrt = .true. ! set RESTRT as default
434 
435  IF(tstart > 1.0e-2)THEN
436  ifhr = ifhr+nint(tstart)
437  rinc = 0
438  idate = 0
439  rinc(2) = -1.0*ifhr
440  call w3movdat(rinc,jdate,idate)
441  sdat(1) = idate(2)
442  sdat(2) = idate(3)
443  sdat(3) = idate(1)
444  ihrst = idate(5)
445  print*,'new forecast hours for restrt run= ',ifhr
446  print*,'new start yr mo day hr min =',sdat(3),sdat(1) &
447  ,sdat(2),ihrst,imin
448  END IF
449 
450  varname='imp_physics'
451  call nemsio_getheadvar(ffile,trim(varname),imp_physics,iret)
452  if (iret /= 0) then
453  if(me==0)print*,varname, &
454  " not found in file-Assigned 99 for Zhao"
455  imp_physics=99 !set GFS mp physics to 99 for Zhao scheme
456  end if
457 
458  if(me==0)print*,'MP_PHYSICS= ',imp_physics
459 
460  varname='sf_surface_physi'
461  call nemsio_getheadvar(ffile,trim(varname),imp_physics,iret)
462  if (iret /= 0) then
463  if(me==0)print*,varname, &
464  " not found in file-Assigned 2 for NOAH"
465  isf_surface_physics=2 !set GFS LSM physics to 2 for NOAH
466  end if
467 
468  if(me==0)print*,'SF_SURFACE_PHYSICS= ',isf_surface_physics
469 
470 ! read bucket
471  varname='fhzero'
472  call nemsio_getheadvar(ffile,trim(varname),fhzero,iret)
473  if (iret /= 0) then
474  if(me==0)print*,varname, &
475  " not found in file-Assign 6 or 12 hours precip bucket"
476  tprec = 6.
477  if(ifhr>240)tprec=12.
478  tclod = tprec
479  trdlw = tprec
480  trdsw = tprec
481  tsrfc = tprec
482  tmaxmin = tprec
483  td3d = tprec
484  else
485  tprec=float(fhzero)
486  tclod = tprec
487  trdlw = tprec
488  trdsw = tprec
489  tsrfc = tprec
490  tmaxmin = tprec
491  td3d = tprec
492  end if
493 
494 
495 ! read meta data to see if precip has zero bucket
496 ! VarName='lprecip_accu'
497 ! call nemsio_getheadvar(ffile,trim(VarName),lprecip_accu,iret)
498 ! if (iret /= 0) then
499 ! if(me==0)print*,VarName, &
500 ! " not found in file-Assign non-zero precip bucket"
501 ! lprecip_accu='no'
502 ! end if
503 ! if(lprecip_accu=='yes')tprec=float(ifhr)
504  print*,'tprec, tclod, trdlw = ',tprec,tclod,trdlw
505 
506 
507 ! Initializes constants for Ferrier microphysics
508  if(imp_physics==5 .or. imp_physics==85 .or. imp_physics==95) then
509  CALL microinit(imp_physics)
510  end if
511 
512 ! GFS does not need DT to compute accumulated fields, set it to one
513 ! VarName='DT'
514  dt = 1
515 
516  hbm2 = 1.0
517 
518 
519 ! start reading nemsio sigma files using parallel read
520  fldsize = (jend-jsta+1)*im
521  allocate(tmp(fldsize*nrec))
522  print*,'allocate tmp successfully'
523  tmp = 0.
524  call nemsio_denseread(nfile,1,im,jsta,jend,tmp,iret=iret)
525  if(iret /=0 ) then
526  print*,"fail to read sigma file using mpi io read, stopping"
527  stop
528  end if
529 !
530 ! covert from reduced grid to full grid
531 !
532  if(reduce_grid)then
533  print*,'performing reduced grid'
534  jtem = jend-jsta+1
535  allocate (kmsk(im,jtem))
536  kmsk = 0
537  do recn=1,nrec
538  fldst = (recn-1)*fldsize
539  do j=jsta,jend
540  js = fldst + (j-jsta)*im
541  do i=1,im
542  buf(i,j) = tmp(i+js)
543  enddo
544  enddo
545  call gg2rg(im,jtem,numi(jsta),buf(1,jsta))
546  call uninterpred(2,kmsk,numi(jsta),im,jtem,buf(1,jsta),tmp(fldst+1))
547  enddo
548  deallocate(kmsk)
549  end if
550 
551 ! Terrain height * G using nemsio
552  varname='hgt'
553  vcoordname = 'sfc'
554  l = 1
555  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
556  if(recn /=0 ) then
557  fldst = (recn-1)*fldsize
558 !$omp parallel do private(i,j,js)
559  do j=jsta,jend
560  js = fldst + (j-jsta)*im
561  do i=1,im
562  fis(i,j) = tmp(i+js)
563  enddo
564  enddo
565  else
566  if(me == 0) print*,'fail to read ', varname,vcoordname,l
567  endif
568 
569 ! call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
570 ! ,l,nrec,fldsize,spval,tmp &
571 ! ,recname,reclevtyp,reclev,VarName,VcoordName &
572 ! ,fis)
573 
574 !$omp parallel do private(i,j)
575  do j=jsta,jend
576  do i=1,im
577  if (fis(i,j) /= spval) then
578  zint(i,j,lp1) = fis(i,j)
579  fis(i,j) = fis(i,j) * grav
580  endif
581  enddo
582  enddo
583  if(debugprint) print*,'sample ',varname,' = ',fis(isa,jsa)
584 
585  vcoordname = 'sfc' ! surface fileds
586  l = 1
587 
588 ! Surface pressure using nemsio
589  varname='pres'
590  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
591  ,l,nrec,fldsize,spval,tmp &
592  ,recname,reclevtyp,reclev,varname,vcoordname &
593  ,pint(1,jsta_2l,lp1))
594 
595  if(debugprint)print*,'sample surface pressure = ',pint(isa,jsa,lp1)
596 
597 !
598 ! vertical loop for Layer 3d fields
599 ! --------------------------------
600  vcoordname = 'mid layer'
601 
602  do l=1,lm
603  ll = lm-l+1
604 ! model level T
605  !if (me == 0) print*,'start retrieving GFS T using nemsio'
606  varname='tmp'
607  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
608  if(recn /= 0) then
609  fldst = (recn-1)*fldsize
610 !$omp parallel do private(i,j,js)
611  do j=jsta,jend
612  js = fldst + (j-jsta)*im
613  do i=1,im
614  t(i,j,ll) = tmp(i+js)
615  enddo
616  enddo
617  else
618  print*,'fail to read ', varname,' at lev ',ll, 'stopping'
619  stop
620  endif
621 
622  if(debugprint)print*,'sample ',ll,varname,' = ',ll,t(isa,jsa,ll)
623 
624 ! model level q
625  varname='spfh'
626  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
627  if(recn /= 0) then
628  fldst = (recn-1)*fldsize
629 !$omp parallel do private(i,j,js)
630  do j=jsta,jend
631  js = fldst + (j-jsta)*im
632  do i=1,im
633  q(i,j,ll) = tmp(i+js)
634  enddo
635  enddo
636  else
637  print*,'fail to read ', varname,' at lev ',ll, 'stopping'
638  stop
639  endif
640 
641  if(debugprint)print*,'sample ',ll,varname,' = ',ll,q(isa,jsa,ll)
642 
643 ! model level u
644  varname='ugrd'
645  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
646  if(recn /= 0) then
647  fldst = (recn-1)*fldsize
648 !$omp parallel do private(i,j,js)
649  do j=jsta,jend
650  js = fldst + (j-jsta)*im
651  do i=1,im
652  uh(i,j,ll) = tmp(i+js)
653  enddo
654  enddo
655  else
656  print*,'fail to read ', varname,' at lev ',ll, 'stopping'
657  stop
658  endif
659 
660  if(debugprint)print*,'sample ',ll,varname,' = ',ll,uh(isa,jsa,ll)
661 
662 ! model level v
663  varname='vgrd'
664  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
665  if(recn /= 0) then
666  fldst = (recn-1)*fldsize
667 !$omp parallel do private(i,j,js)
668  do j=jsta,jend
669  js = fldst + (j-jsta)*im
670  do i=1,im
671  vh(i,j,ll) = tmp(i+js)
672  enddo
673  enddo
674  else
675  print*,'fail to read ', varname,' at lev ',ll, 'stopping'
676  stop
677  endif
678 
679  if(debugprint)print*,'sample ',ll,varname,' = ',ll,vh(isa,jsa,ll)
680 
681 ! model level pressure
682 ! if (.not. hyb_sigp) then
683 ! VarName='pres'
684 ! call getrecn(recname,reclevtyp,reclev,nrec,varname,VcoordName,l,recn)
685 ! if(recn /= 0) then
686 ! fldst = (recn-1)*fldsize
687 !!$omp parallel do private(i,j,js)
688 ! do j=jsta,jend
689 ! js = fldst + (j-jsta)*im
690 ! do i=1,im
691 ! pmid(i,j,ll) = tmp(i+js)
692 ! enddo
693 ! enddo
694 ! else
695 ! recn_pres=-9999
696 ! if(me==0)print*,'fail to read ', varname,' at lev ',ll, &
697 ! 'will derive pressure using ak bk later'
698 ! stop
699 ! endif
700 
701 ! if(debugprint)print*,'sample ',ll,VarName,' = ',ll,pmid(isa,jsa,ll)
702 ! end if
703 ! GFS is on A grid and does not need PMIDV
704 
705 ! dp
706  varname='dpres'
707  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
708  if(recn /= 0) then
709  fldst = (recn-1)*fldsize
710 !$omp parallel do private(i,j,js)
711  do j=jsta,jend
712  js = fldst + (j-jsta)*im
713  do i=1,im
714  dpres(i,j,ll) = tmp(i+js)
715  enddo
716  enddo
717  else
718  recn_dpres = -9999
719  if(me==0)print*,'fail to read ', varname,' at lev ',ll, &
720  'will derive pressure using ak bk later'
721  endif
722 ! ozone mixing ratio
723  varname='o3mr'
724  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
725  if(recn /= 0) then
726  fldst = (recn-1)*fldsize
727 !$omp parallel do private(i,j,js)
728  do j=jsta,jend
729  js = fldst + (j-jsta)*im
730  do i=1,im
731  o3(i,j,ll) = tmp(i+js)
732  enddo
733  enddo
734  else
735  print*,'fail to read ', varname,' at lev ',ll, 'stopping'
736  stop
737  endif
738 
739 
740  if(debugprint)print*,'sample ',ll,varname,' = ',ll,o3(isa,jsa,ll)
741 
742 ! cloud water and ice mixing ratio for zhao scheme
743 ! need to look up old eta post to derive cloud water/ice from cwm
744 ! Zhao scheme does not produce suspended rain and snow
745 
746 !!$omp parallel do private(i,j)
747  do j = jsta, jend
748  do i=1,im
749  qqw(i,j,ll) = 0.
750  qqr(i,j,ll) = 0.
751  qqs(i,j,ll) = 0.
752  qqi(i,j,ll) = 0.
753  enddo
754  enddo
755 
756  if(imp_physics==99 .or. imp_physics==98)then
757  varname='clwmr'
758  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
759  if(recn /= 0) then
760  fldst = (recn-1)*fldsize
761 !$omp parallel do private(i,j,js)
762  do j=jsta,jend
763  js = fldst + (j-jsta)*im
764  do i=1,im
765  cwm(i,j,ll) = tmp(i+js)
766  enddo
767  enddo
768  else
769  print*,'fail to read ', varname,' at lev ',ll, 'stopping'
770  stop
771  endif
772 
773  if(debugprint)print*,'sample ',ll,varname,' = ',ll,cwm(isa,jsa,ll)
774 
775 !$omp parallel do private(i,j)
776  do j=jsta,jend
777  do i=1,im
778  if(t(i,j,ll) < (tfrz-15.) )then ! dividing cloud water from ice
779  qqi(i,j,ll) = cwm(i,j,ll)
780  else
781  qqw(i,j,ll) = cwm(i,j,ll)
782  end if
783  end do
784  end do
785  else if(imp_physics==11 .or. imp_physics==8)then ! GFDL or Thompson MP scheme
786  varname='clwmr'
787  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
788  if(recn /= 0) then
789  fldst = (recn-1)*fldsize
790 !$omp parallel do private(i,j,js)
791  do j=jsta,jend
792  js = fldst + (j-jsta)*im
793  do i=1,im
794  qqw(i,j,ll) = tmp(i+js)
795  enddo
796  enddo
797  else
798  print*,'fail to read ', varname,' at lev ',ll, 'stopping'
799  stop
800  endif
801  if(debugprint)print*,'sample ',ll,varname,' = ',ll,qqw(isa,jsa,ll)
802 
803  varname='icmr'
804  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
805  if(recn /= 0) then
806  fldst = (recn-1)*fldsize
807 !$omp parallel do private(i,j,js)
808  do j=jsta,jend
809  js = fldst + (j-jsta)*im
810  do i=1,im
811  qqi(i,j,ll) = tmp(i+js)
812  enddo
813  enddo
814  else
815  print*,'fail to read ', varname,' at lev ',ll, 'stopping'
816  stop
817  endif
818  if(debugprint)print*,'sample ',ll,varname,' = ',ll,qqi(isa,jsa,ll)
819 
820  varname='rwmr'
821  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
822  if(recn /= 0) then
823  fldst = (recn-1)*fldsize
824 !$omp parallel do private(i,j,js)
825  do j=jsta,jend
826  js = fldst + (j-jsta)*im
827  do i=1,im
828  qqr(i,j,ll) = tmp(i+js)
829  enddo
830  enddo
831  else
832  print*,'fail to read ', varname,' at lev ',ll, 'stopping'
833  stop
834  endif
835  if(debugprint)print*,'sample ',ll,varname,' = ',ll,qqr(isa,jsa,ll)
836 
837  varname ='snmr'
838  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
839  if(recn /= 0) then
840  fldst = (recn-1)*fldsize
841 !$omp parallel do private(i,j,js)
842  do j=jsta,jend
843  js = fldst + (j-jsta)*im
844  do i=1,im
845  qqs(i,j,ll) = tmp(i+js)
846  enddo
847  enddo
848  else
849  print*,'fail to read ', varname,' at lev ',ll, 'stopping'
850  stop
851  endif
852  if(debugprint)print*,'sample ',ll,varname,' = ',ll,qqs(isa,jsa,ll)
853 
854  varname ='grle'
855  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
856  if(recn /= 0) then
857  fldst = (recn-1)*fldsize
858 !$omp parallel do private(i,j,js)
859  do j=jsta,jend
860  js = fldst + (j-jsta)*im
861  do i=1,im
862  qqg(i,j,ll) = tmp(i+js)
863  enddo
864  enddo
865  else
866  print*,'fail to read ', varname,' at lev ',ll, 'stopping'
867  stop
868  endif
869  if(debugprint)print*,'sample ',ll,varname,' = ',ll,qqg(isa,jsa,ll)
870 !define cwm
871  do j=jsta,jend
872  do i=1,im
873  cwm(i,j,ll)=qqg(i,j,ll)+qqs(i,j,ll)+qqr(i,j,ll)+qqi(i,j,ll)+qqw(i,j,ll)
874  enddo
875  enddo
876 
877  end if ! end of reading MP species for diff MP options
878 
879 ! if (iret /= 0)print*,'Error scattering array';stop
880 
881 ! pressure vertical velocity
882  if(trim(modelname_nemsio)=='FV3GFS')then
883  recn_vvel = 0 ! do not derive omega
884  varname='dzdt'
885  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
886  if(recn /= 0) then
887  fldst = (recn-1)*fldsize
888 !$omp parallel do private(i,j,js)
889  do j=jsta,jend
890  js = fldst + (j-jsta)*im
891  do i=1,im
892  wh(i,j,ll) = tmp(i+js)
893  enddo
894  enddo
895  if(debugprint)print*,'sample l ',varname,' = ',ll,wh(isa,jsa,ll)
896  else
897  if(me==0)print*,'fail to read ', varname,' at lev ',ll
898  end if
899  else
900  varname='vvel'
901  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
902  if(recn /= 0) then
903  fldst = (recn-1)*fldsize
904 !$omp parallel do private(i,j,js)
905  do j=jsta,jend
906  js = fldst + (j-jsta)*im
907  do i=1,im
908  omga(i,j,ll) = tmp(i+js)
909  enddo
910  enddo
911  if(debugprint)print*,'sample l ',varname,' = ',ll,omga(isa,jsa,ll)
912  else
913  recn_vvel = -9999
914  if(me==0)print*,'fail to read ', varname,' at lev ',ll, &
915  'will derive omega later'
916  endif
917  end if
918 
919 ! pressure vertical velocity
920  varname='delz'
921  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
922  if(recn /= 0) then
923  fldst = (recn-1)*fldsize
924 ! make sure delz is positive.
925 !$omp parallel do private(i,j,js)
926  do j=jsta,jend
927  js = fldst + (j-jsta)*im
928  do i=1,im
929  zint(i,j,ll)=zint(i,j,ll+1)+abs(tmp(i+js))
930  if(recn_dpres /= -9999)pmid(i,j,ll)=rgas*dpres(i,j,ll)* &
931  t(i,j,ll)*(q(i,j,ll)*fv+1.0)/grav/abs(tmp(i+js))
932  enddo
933  enddo
934  if(debugprint)print*,'sample l ',varname,' = ',ll, &
935  zint(isa,jsa,ll)
936  if(trim(modelname_nemsio)=='FV3GFS' .and. &
937  recn_dpres /= -9999)then
938  do j=jsta,jend
939  js = fldst + (j-jsta)*im
940  do i=1,im
941  omga(i,j,ll)=(-1.)*wh(i,j,ll)*dpres(i,j,ll)/abs(tmp(i+js))
942  end do
943  end do
944  if(debugprint)print*,'sample l omga for FV3',ll, &
945  omga(isa,jsa,ll)
946  end if
947  else
948  recn_delz = -9999
949  if(me==0)print*,'fail to read ', varname,' at lev ',ll, &
950  'will derive height later'
951  endif
952 
953 ! cloud fraction
954  varname='cld_amt'
955  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
956  if(recn /= 0) then
957  fldst = (recn-1)*fldsize
958 !$omp parallel do private(i,j,js)
959  do j=jsta,jend
960  js = fldst + (j-jsta)*im
961  do i=1,im
962  cfr(i,j,ll)=tmp(i+js)
963  enddo
964  enddo
965 ! if(debugprint)print*,'sample l ',VarName,' = ',ll, &
966 ! cfr(isa,jsa,ll)
967  endif
968 
969  if(imp_physics == 99)then
970  allocate(p2d(im,lm),t2d(im,lm),q2d(im,lm),cw2d(im,lm), &
971  qs2d(im,lm),cfr2d(im,lm))
972  do j=jsta,jend
973  do k=1,lm
974  do i=1,im
975  p2d(i,k) = pmid(i,j,ll)*0.01
976  t2d(i,k) = t(i,j,ll)
977  q2d(i,k) = q(i,j,ll)
978  cw2d(i,k) = cwm(i,j,ll)
979  es = min(fpvsnew(t(i,j,ll)),pmid(i,j,ll))
980  qs2d(i,k) = eps*es/(pmid(i,j,ll)+epsm1*es)!saturation q for GFS
981  enddo
982  enddo
983  call progcld1 &
984 !...................................
985 ! --- inputs:
986  ( p2d,t2d,q2d,qs2d,cw2d,im,lm,0, &
987 ! --- outputs:
988  cfr2d &
989  )
990 !$omp parallel do private(i,k)
991  do k=1,lm
992  do i=1,im
993  cfr(i,j,k) = cfr2d(i,k)
994  enddo
995  end do
996  end do
997  deallocate(p2d,t2d,q2d,qs2d,cw2d,cfr2d)
998  end if
999 
1000 ! With SHOC NEMS/GSM does output TKE now
1001  varname='tke'
1002  recn = 0
1003  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
1004  if(recn /=0 ) then
1005  fldst = (recn-1)*fldsize
1006 !$omp parallel do private(i,j,js)
1007  do j=jsta,jend
1008  js = fldst + (j-jsta)*im
1009  do i=1,im
1010  q2(i,j,ll) = tmp(i+js)
1011  enddo
1012  enddo
1013  else
1014  if(me==0)print*,'fail to read ', varname,' at lev ',ll
1015 !$omp parallel do private(i,j)
1016  do j=jsta,jend
1017  do i=1,im
1018  q2(i,j,ll) = spval
1019  end do
1020  end do
1021  endif
1022  if(debugprint)print*,'sample l ',varname,' = ',ll,q2(isa,jsa,ll)
1023 
1024 ! Read model derived radar ref.
1025  varname='ref3D'
1026  recn = 0
1027  call getrecn(recname,reclevtyp,reclev,nrec,varname,vcoordname,l,recn)
1028  if(recn /=0 ) then
1029 !$omp parallel do private(i,j,js)
1030  do j=jsta,jend
1031  js = fldst + (j-jsta)*im
1032  do i=1,im
1033  ref_10cm(i,j,ll) = tmp(i+js)
1034  enddo
1035  enddo
1036  else
1037 !$omp parallel do private(i,j)
1038  do j=jsta,jend
1039  do i=1,im
1040  ref_10cm(i,j,ll) = spval
1041  end do
1042  end do
1043  if(me==0)print*,'fail to read ', varname,' at lev ',ll
1044  endif
1045  if(debugprint)print*,'sample l ',varname,' = ',ll,ref_10cm(isa,jsa,ll)
1046 
1047 
1048  end do ! do loop for l
1049 
1050 ! construct interface pressure from model top (which is zero) and dp from top down PDTOP
1051 ! pdtop = spval
1052 ! pt = 0.
1053 ! pd = spval ! GFS does not output PD
1054  pt=ak5(lp1)
1055 
1056  ii = im/2
1057  jj = (jsta+jend)/2
1058 
1059 !!!!! COMPUTE Z, GFS integrates Z on mid-layer instead
1060 !!! use GFS contants to see if height becomes more aggreable to GFS pressure grib file
1061 
1062  if (recn_dpres == -9999) then
1063  do l=lm,1,-1
1064 !$omp parallel do private(i,j)
1065  do j=jsta,jend
1066  do i=1,im
1067  pint(i,j,l) = ak5(lm+2-l) + bk5(lm+2-l)*pint(i,j,lp1)
1068  if(recn_delz == -9999)pmid(i,j,l) = 0.5*(pint(i,j,l)+ &
1069  pint(i,j,l+1)) ! for now - Moorthi
1070  enddo
1071  enddo
1072  if (me == 0) print*,'sample pint,pmid' ,ii,jj,l,pint(ii,jj,l),pmid(ii,jj,l)
1073  enddo
1074  else
1075 ! compute pint using dpres from bot up
1076 ! do l=lm,1,-1
1077 ! do j=jsta,jend
1078 ! do i=1,im
1079 ! pint(i,j,l) = pint(i,j,l+1) - dpres(i,j,l)
1080 ! enddo
1081 ! enddo
1082 ! if (me == 0) print*,'sample model pint,pmid' ,ii,jj,l &
1083 ! ,pint(ii,jj,l),pmid(ii,jj,l)
1084 ! end do
1085 
1086 !Feb 6 2018: per Jun, change to compute pint from top down
1087  do j=jsta,jend
1088  do i=1,im
1089  pint(i,j,1)=ak5(lp1)
1090  end do
1091  end do
1092 
1093  do l=2,lp1
1094  do j=jsta,jend
1095  do i=1,im
1096  pint(i,j,l) = pint(i,j,l-1) + dpres(i,j,l-1)
1097  enddo
1098  enddo
1099  if (me == 0) print*,'sample model pint,pmid' ,ii,jj,l &
1100  ,pint(ii,jj,l)
1101  end do
1102  endif
1103 
1104 !
1105 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1106 ! Compute omega
1107 !sk05132016
1108 
1109  if (recn_vvel == -9999) then !only compute omega if it's not in model output
1110  allocate(ps2d(im,jsta_2l:jend_2u), psx2d(im,jsta_2l:jend_2u), &
1111  psy2d(im,jsta_2l:jend_2u))
1112  allocate(div3d(im,jsta:jend,lm))
1113 
1114 !$omp parallel do private(i,j)
1115  do j=jsta,jend
1116  do i=1,im
1117  ps2d(i,j) = log(pint(i,j,lm+1))
1118  enddo
1119  enddo
1120  call calgradps(ps2d,psx2d,psy2d)
1121 
1122  call caldiv(uh, vh, div3d)
1123 
1124 !----------------------------------------------------------------------
1125  allocate (vcrd(lm+1,2), d2d(im,lm), u2d(im,lm), v2d(im,lm), &
1126  pi2d(im,lm+1), pm2d(im,lm), omga2d(im,lm))
1127  omga2d=spval
1128  idvc = 2
1129  idsl = 2
1130  nvcoord = 2
1131  do l=1,lm+1
1132  vcrd(l,1) = vcoord4(l,1,1)
1133  vcrd(l,2) = vcoord4(l,2,1)
1134  enddo
1135 
1136 ! jtem = jm / 18 + 1
1137  jtem = jm / 20 + 1
1138  do j=jsta,jend
1139  npass = npass2
1140 ! if (j > jm-jtem+1 .or. j < jtem) npass = npass3
1141  if (j > jm-jtem+1) then
1142  npass = npass + nint(0.5*(j-jm+jtem-1))
1143  elseif (j < jtem) then
1144  npass = npass + nint(0.5*(jtem-j))
1145  endif
1146 ! npass = 0
1147 !$omp parallel do private(i,l,ll)
1148  do l=1,lm
1149  ll = lm-l+1
1150  do i=1,im
1151  u2d(i,l) = uh(i,j,ll) !flip u & v for calling modstuff
1152  v2d(i,l) = vh(i,j,ll)
1153  d2d(i,l) = div3d(i,j,ll)
1154  end do
1155  end do
1156 
1157  call modstuff2(im, im, lm, idvc, idsl, nvcoord, &
1158  vcrd, pint(1,j,lp1), psx2d(1,j), psy2d(1,j), &
1159  d2d, u2d, v2d, pi2d, pm2d, omga2d, me)
1160 ! if (j ==1 .or. j == jm) &
1161 ! write (*,*)' omga2d=',omga2d(1,:),' j=',j
1162 
1163  if (npass <= 0 ) then
1164 !$omp parallel do private(i,l,ll)
1165  do l=1,lm
1166  ll = lm-l+1
1167  do i=1,im
1168  omga(i,j,l) = omga2d(i,ll)
1169 ! pmid(i,j,l) = pm2d(i,ll)
1170 ! pint(i,j,l) = pi2d(i,ll+1)
1171  enddo
1172  enddo
1173  else
1174 !$omp parallel do private(i,l,ll,nn,omg1,omg2)
1175  do l=1,lm
1176  ll = lm-l+1
1177  do i=1,im
1178  omg1(i) = omga2d(i,ll)
1179  enddo
1180  do nn=1,npass
1181  do i=1,im
1182  omg2(i+1) = omg1(i)
1183  enddo
1184  omg2(1) = omg2(im+1)
1185  omg2(im+2) = omg2(2)
1186  do i=2,im+1
1187  omg1(i-1) = third * (omg2(i-1) + omg2(i) + omg2(i+1))
1188  enddo
1189  enddo
1190 
1191  do i=1,im
1192  omga(i,j,l) = omg1(i)
1193  enddo
1194 ! if (j ==1 .or. j == jm) &
1195 ! write (1000+me,*)' omga=',omga(:,j,l),' j=',j,' l=',l
1196 
1197  enddo
1198  endif
1199 
1200 ! Average omega for the last point near the poles - moorthi
1201  if (j ==1 .or. j == jm) then
1202  tx1 = 1.0 / im
1203 ! write(*,*)' j=',j,' omgamax=',maxval(omga(:,j,:)),' omgamin=',minval(omga(:,j,:))
1204 !$omp parallel do private(i,l,tx2)
1205  do l=1,lm
1206  tx2 = 0.0
1207  do i=1,im
1208  tx2 = tx2 + omga(i,j,l)
1209  enddo
1210  tx2 = tx2 * tx1
1211  do i=1,im
1212  omga(i,j,l) = tx2
1213  enddo
1214  enddo
1215  endif
1216 
1217  enddo ! end of j loop
1218 
1219  deallocate (vcrd,d2d,u2d,v2d,pi2d,pm2d,omga2d)
1220  deallocate (ps2d,psx2d,psy2d,div3d)
1221  end if
1222  deallocate (vcoord4)
1223 
1224 !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1225 
1226 !
1227  allocate(wrk1(im,jsta:jend),wrk2(im,jsta:jend))
1228  allocate(fi(im,jsta:jend,2))
1229 
1230  do j=jsta,jend
1231  do i=1,im
1232  pd(i,j) = spval ! GFS does not output PD
1233  pint(i,j,1) = pt
1234  end do
1235  end do
1236 
1237  do l=lp1,1,-1
1238  do j=jsta,jend
1239  do i=1,im
1240  alpint(i,j,l)=log(pint(i,j,l))
1241  end do
1242  end do
1243  end do
1244 
1245  if (recn_delz == -9999) then !only compute H if it's not in model output
1246  do j=jsta,jend
1247  do i=1,im
1248  wrk1(i,j) = log(pmid(i,j,lm))
1249  wrk2(i,j) = t(i,j,lm)*(q(i,j,lm)*fv+1.0)
1250  fi(i,j,1) = fis(i,j) &
1251  + wrk2(i,j)*rgas*(alpint(i,j,lp1)-wrk1(i,j))
1252  zmid(i,j,lm) = fi(i,j,1) * gravi
1253  end do
1254  end do
1255 
1256  DO l=lm,2,-1 ! omit computing model top height because it's infinity
1257  ll = l - 1
1258  do j = jsta, jend
1259  do i = 1, im
1260  tvll = t(i,j,ll)*(q(i,j,ll)*fv+1.0)
1261  pmll = log(pmid(i,j,ll))
1262 
1263  fi(i,j,2) = fi(i,j,1) + (0.5*rgas)*(wrk2(i,j)+tvll) &
1264  * (wrk1(i,j)-pmll)
1265  zmid(i,j,ll) = fi(i,j,2) * gravi
1266 !
1267  fact = (alpint(i,j,l)-wrk1(i,j)) / (pmll-wrk1(i,j))
1268  zint(i,j,l) = zmid(i,j,l) +(zmid(i,j,ll)-zmid(i,j,l))*fact
1269  fi(i,j,1) = fi(i,j,2)
1270  wrk1(i,j) = pmll
1271  wrk2(i,j) = tvll
1272  ENDDO
1273  ENDDO
1274 
1275  if (me == 0) print*,'L ZINT= ',l,zint(ii,jj,l), &
1276  'alpint=',alpint(ii,jj,l),'pmid=',log(pmid(ii,jj,l)), &
1277  'pmid(l-1)=',log(pmid(ii,jj,l-1)),'zmd=',zmid(ii,jj,l), &
1278  'zmid(l-1)=',zmid(ii,jj,l-1)
1279  ENDDO
1280  deallocate(wrk1,wrk2,fi)
1281  else
1282  do l=lm,1,-1
1283  do j=jsta,jend
1284  do i=1,im
1285  zmid(i,j,l)=zint(i,j,l+1)+(zint(i,j,l)-zint(i,j,l+1))* &
1286  (log(pmid(i,j,l))-alpint(i,j,l+1))/ &
1287  (alpint(i,j,l)-alpint(i,j,l+1))
1288  end do
1289  end do
1290  end do
1291  end if
1292 
1293 ! do j=jsta,jend
1294 ! do i=1,im
1295 ! pd(i,j) = spval ! GFS does not output PD
1296 ! pint(i,j,1) = PT
1297 ! alpint(i,j,lp1) = log(pint(i,j,lp1))
1298 ! wrk1(i,j) = log(PMID(I,J,LM))
1299 ! wrk2(i,j) = T(I,J,LM)*(Q(I,J,LM)*fv+1.0)
1300 ! FI(I,J,1) = FIS(I,J) &
1301 ! + wrk2(i,j)*rgas*(ALPINT(I,J,Lp1)-wrk1(i,j))
1302 ! ZMID(I,J,LM) = FI(I,J,1) * gravi
1303 ! end do
1304 ! end do
1305 
1306 ! SECOND, INTEGRATE HEIGHT HYDROSTATICLY, GFS integrate height on mid-layer
1307 
1308 ! DO L=LM,2,-1 ! omit computing model top height because it's infinity
1309 ! ll = l - 1
1310 ! do j = jsta, jend
1311 ! do i = 1, im
1312 ! alpint(i,j,l) = log(pint(i,j,l))
1313 ! tvll = T(I,J,LL)*(Q(I,J,LL)*fv+1.0)
1314 ! pmll = log(PMID(I,J,LL))
1315 
1316 ! FI(I,J,2) = FI(I,J,1) + (0.5*rgas)*(wrk2(i,j)+tvll) &
1317 ! * (wrk1(i,j)-pmll)
1318 ! ZMID(I,J,LL) = FI(I,J,2) * gravi
1319 !
1320 ! FACT = (ALPINT(I,J,L)-wrk1(i,j)) / (pmll-wrk1(i,j))
1321 ! ZINT(I,J,L) = ZMID(I,J,L) +(ZMID(I,J,LL)-ZMID(I,J,L))*FACT
1322 ! FI(I,J,1) = FI(I,J,2)
1323 ! wrk1(i,J) = pmll
1324 ! wrk2(i,j) = tvll
1325 ! ENDDO
1326 ! ENDDO
1327 
1328 ! if (me == 0) print*,'L ZINT= ',l,zint(ii,jj,l), &
1329 ! 'alpint=',ALPINT(ii,jj,l),'pmid=',LOG(PMID(Ii,Jj,L)), &
1330 ! 'pmid(l-1)=',LOG(PMID(Ii,Jj,L-1)),'zmd=',ZMID(Ii,Jj,L), &
1331 ! 'zmid(l-1)=',ZMID(Ii,Jj,L-1)
1332 ! ENDDO
1333 ! deallocate(wrk1,wrk2)
1334 
1335 
1336  print *, 'gocart_on=',gocart_on
1337  print *, 'gccpp_on=',gccpp_on
1338  if (gocart_on .or. gccpp_on) then
1339 
1340 ! GFS output dust in nemsio (GOCART)
1341  dustcb=0.0
1342  dustallcb=0.0
1343 ! DUST = SPVAL
1344  !VarName='du001'
1345  varname='dust1'
1346  vcoordname='mid layer'
1347  do l=1,lm
1348  ll=lm-l+1
1349  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1350  ,l,nrec,fldsize,spval,tmp &
1351  ,recname,reclevtyp,reclev,varname,vcoordname &
1352  ,dust(1:im,jsta_2l:jend_2u,ll,1))
1353 
1354 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,1)
1355  end do ! do loop for l
1356 
1357  !VarName='du002'
1358  varname='dust2'
1359  vcoordname='mid layer'
1360  do l=1,lm
1361  ll=lm-l+1
1362  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1363  ,l,nrec,fldsize,spval,tmp &
1364  ,recname,reclevtyp,reclev,varname,vcoordname &
1365  ,dust(1:im,jsta_2l:jend_2u,ll,2))
1366 
1367  dustcb(1:im,jsta_2l:jend_2u)=dustcb(1:im,jsta_2l:jend_2u)+ &
1368  (dust(1:im,jsta_2l:jend_2u,ll,1)+0.38*dust(1:im,jsta_2l:jend_2u,ll,2))* &
1369  dpres(1:im,jsta_2l:jend_2u,ll)/grav
1370 
1371 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,2)
1372  end do ! do loop for l
1373 
1374  !VarName='du003'
1375  varname='dust3'
1376  vcoordname='mid layer'
1377  do l=1,lm
1378  ll=lm-l+1
1379  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1380  ,l,nrec,fldsize,spval,tmp &
1381  ,recname,reclevtyp,reclev,varname,vcoordname &
1382  ,dust(1:im,jsta_2l:jend_2u,ll,3))
1383 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,3)
1384  end do ! do loop for l
1385 
1386  !VarName='du004'
1387  varname='dust4'
1388  vcoordname='mid layer'
1389  do l=1,lm
1390  ll=lm-l+1
1391  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1392  ,l,nrec,fldsize,spval,tmp &
1393  ,recname,reclevtyp,reclev,varname,vcoordname &
1394  ,dust(1:im,jsta_2l:jend_2u,ll,4))
1395 
1396 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,4)
1397  end do ! do loop for l
1398 
1399  !VarName='du005'
1400  varname='dust5'
1401  vcoordname='mid layer'
1402  do l=1,lm
1403  ll=lm-l+1
1404  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1405  ,l,nrec,fldsize,spval,tmp &
1406  ,recname,reclevtyp,reclev,varname,vcoordname &
1407  ,dust(1:im,jsta_2l:jend_2u,ll,5))
1408 
1409  dustallcb(1:im,jsta_2l:jend_2u)=dustallcb(1:im,jsta_2l:jend_2u)+ &
1410  (dust(1:im,jsta_2l:jend_2u,ll,1)+dust(1:im,jsta_2l:jend_2u,ll,2)+ &
1411  dust(1:im,jsta_2l:jend_2u,ll,3)+0.74*dust(1:im,jsta_2l:jend_2u,ll,4))* &
1412  dpres(1:im,jsta_2l:jend_2u,ll)/grav
1413 
1414 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,dust(isa,jsa,ll,5)
1415  end do ! do loop for l
1416 !
1417 ! GFS output sea salt in nemsio (GOCART)
1418  sscb=0.0
1419  ssallcb=0.0
1420 ! SALT = SPVAL
1421  !VarName='ss001'
1422  varname='seas1'
1423  vcoordname='mid layer'
1424  do l=1,lm
1425  ll=lm-l+1
1426  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1427  ,l,nrec,fldsize,spval,tmp &
1428  ,recname,reclevtyp,reclev,varname,vcoordname &
1429  ,salt(1:im,jsta_2l:jend_2u,ll,1))
1430 
1431 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,1)
1432  end do ! do loop for l
1433 
1434  !VarName='ss002'
1435  varname='seas2'
1436  vcoordname='mid layer'
1437  do l=1,lm
1438  ll=lm-l+1
1439  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1440  ,l,nrec,fldsize,spval,tmp &
1441  ,recname,reclevtyp,reclev,varname,vcoordname &
1442  ,salt(1:im,jsta_2l:jend_2u,ll,2))
1443 
1444 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,2)
1445  end do ! do loop for l
1446 
1447  !VarName='ss003'
1448  varname='seas3'
1449  vcoordname='mid layer'
1450  do l=1,lm
1451  ll=lm-l+1
1452  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1453  ,l,nrec,fldsize,spval,tmp &
1454  ,recname,reclevtyp,reclev,varname,vcoordname &
1455  ,salt(1:im,jsta_2l:jend_2u,ll,3))
1456 
1457  sscb(1:im,jsta_2l:jend_2u)=sscb(1:im,jsta_2l:jend_2u)+ &
1458  (salt(1:im,jsta_2l:jend_2u,ll,1)+ &
1459  salt(1:im,jsta_2l:jend_2u,ll,2)+0.83*salt(1:im,jsta_2l:jend_2u,ll,3))* &
1460  dpres(1:im,jsta_2l:jend_2u,ll)/grav
1461 
1462 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,3)
1463  end do ! do loop for l
1464 
1465  !VarName='ss004'
1466  varname='seas4'
1467  vcoordname='mid layer'
1468  do l=1,lm
1469  ll=lm-l+1
1470  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1471  ,l,nrec,fldsize,spval,tmp &
1472  ,recname,reclevtyp,reclev,varname,vcoordname &
1473  ,salt(1:im,jsta_2l:jend_2u,ll,4))
1474 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,4)
1475  end do ! do loop for l
1476 
1477  !VarName='ss005'
1478  varname='seas5'
1479  vcoordname='mid layer'
1480  do l=1,lm
1481  ll=lm-l+1
1482  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1483  ,l,nrec,fldsize,spval,tmp &
1484  ,recname,reclevtyp,reclev,varname,vcoordname &
1485  ,salt(1:im,jsta_2l:jend_2u,ll,5))
1486 
1487  ssallcb(1:im,jsta_2l:jend_2u)=ssallcb(1:im,jsta_2l:jend_2u)+ &
1488  (salt(1:im,jsta_2l:jend_2u,ll,1)+salt(1:im,jsta_2l:jend_2u,ll,2)+ &
1489  salt(1:im,jsta_2l:jend_2u,ll,3)+ &
1490  salt(1:im,jsta_2l:jend_2u,ll,4))* &
1491  dpres(1:im,jsta_2l:jend_2u,ll)/grav
1492 
1493 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,salt(isa,jsa,ll,5)
1494  end do ! do loop for l
1495 
1496 ! GFS output black carbon in nemsio (GOCART)
1497  bccb=0.0
1498 ! SOOT = SPVAL
1499  !VarName='bcphobic'
1500  varname='bc1'
1501  vcoordname='mid layer'
1502  do l=1,lm
1503  ll=lm-l+1
1504  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1505  ,l,nrec,fldsize,spval,tmp &
1506  ,recname,reclevtyp,reclev,varname,vcoordname &
1507  ,soot(1:im,jsta_2l:jend_2u,ll,1))
1508 
1509 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,1)
1510  end do ! do loop for l
1511 
1512  !VarName='bcphilic'
1513  varname='bc2'
1514  vcoordname='mid layer'
1515  do l=1,lm
1516  ll=lm-l+1
1517  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1518  ,l,nrec,fldsize,spval,tmp &
1519  ,recname,reclevtyp,reclev,varname,vcoordname &
1520  ,soot(1:im,jsta_2l:jend_2u,ll,2))
1521 
1522  bccb(1:im,jsta_2l:jend_2u)=bccb(1:im,jsta_2l:jend_2u)+ &
1523  (soot(1:im,jsta_2l:jend_2u,ll,1)+soot(1:im,jsta_2l:jend_2u,ll,2))* &
1524  dpres(1:im,jsta_2l:jend_2u,ll)/grav
1525 
1526 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,soot(isa,jsa,ll,2)
1527  end do ! do loop for l
1528 
1529  occb=0.0
1530 ! GFS output organic carbon in nemsio (GOCART)
1531 ! WASO = SPVAL
1532  !VarName='ocphobic'
1533  varname='oc1'
1534  vcoordname='mid layer'
1535  do l=1,lm
1536  ll=lm-l+1
1537  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1538  ,l,nrec,fldsize,spval,tmp &
1539  ,recname,reclevtyp,reclev,varname,vcoordname &
1540  ,waso(1:im,jsta_2l:jend_2u,ll,1))
1541 
1542 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,1)
1543  end do ! do loop for l
1544 
1545  !VarName='ocphilic'
1546  varname='oc2'
1547  vcoordname='mid layer'
1548  do l=1,lm
1549  ll=lm-l+1
1550  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1551  ,l,nrec,fldsize,spval,tmp &
1552  ,recname,reclevtyp,reclev,varname,vcoordname &
1553  ,waso(1:im,jsta_2l:jend_2u,ll,2))
1554 
1555  occb(1:im,jsta_2l:jend_2u)=occb(1:im,jsta_2l:jend_2u)+ &
1556  (waso(1:im,jsta_2l:jend_2u,ll,1)+waso(1:im,jsta_2l:jend_2u,ll,2)) * &
1557  dpres(1:im,jsta_2l:jend_2u,ll)/grav
1558 
1559 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,waso(isa,jsa,ll,2)
1560  end do ! do loop for l
1561 
1562 ! GFS output sulfate in nemsio (GOCART)
1563  sulfcb=0.0
1564 ! SUSO = SPVAL
1565  !VarName='so4'
1566  varname='sulf'
1567  vcoordname='mid layer'
1568  do l=1,lm
1569  ll=lm-l+1
1570  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1571  ,l,nrec,fldsize,spval,tmp &
1572  ,recname,reclevtyp,reclev,varname,vcoordname &
1573  ,suso(1:im,jsta_2l:jend_2u,ll,1))
1574 
1575  sulfcb(1:im,jsta_2l:jend_2u)=sulfcb(1:im,jsta_2l:jend_2u)+ &
1576  suso(1:im,jsta_2l:jend_2u,ll,1)* &
1577  dpres(1:im,jsta_2l:jend_2u,ll)/grav
1578 
1579 ! if(debugprint)print*,'sample l ',VarName,' = ',ll,suso(isa,jsa,ll,1)
1580  end do ! do loop for l
1581 
1582 ! GFS output pp25 in nemsio (GOCART)
1583  pp25cb=0.0
1584 ! PP25 = SPVAL
1585  !VarName='so4'
1586  varname='pp25'
1587  vcoordname='mid layer'
1588  do l=1,lm
1589  ll=lm-l+1
1590  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1591  ,l,nrec,fldsize,spval,tmp &
1592  ,recname,reclevtyp,reclev,varname,vcoordname &
1593  ,pp25(1:im,jsta_2l:jend_2u,ll,1))
1594  pp25cb(1:im,jsta_2l:jend_2u)=pp25cb(1:im,jsta_2l:jend_2u)+ &
1595  pp25(1:im,jsta_2l:jend_2u,ll,1)* &
1596  dpres(1:im,jsta_2l:jend_2u,ll)/grav
1597 ! if(debugprint)print*,'sample l ',VarName,' =
1598 ! ',ll,suso(isa,jsa,ll,1)
1599  end do ! do loop for l
1600 ! GFS output pp10 in nemsio (GOCART)
1601  pp10cb=0.0
1602 ! PP10 = SPVAL
1603  !VarName='so4'
1604  varname='pp10'
1605  vcoordname='mid layer'
1606  do l=1,lm
1607  ll=lm-l+1
1608  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1609  ,l,nrec,fldsize,spval,tmp &
1610  ,recname,reclevtyp,reclev,varname,vcoordname &
1611  ,pp10(1:im,jsta_2l:jend_2u,ll,1))
1612  pp10cb(1:im,jsta_2l:jend_2u)=pp10cb(1:im,jsta_2l:jend_2u)+ &
1613  pp10(1:im,jsta_2l:jend_2u,ll,1)* &
1614  dpres(1:im,jsta_2l:jend_2u,ll)/grav
1615 ! if(debugprint)print*,'sample l ',VarName,' =
1616 ! ',ll,suso(isa,jsa,ll,1)
1617  end do ! do loop for l
1618 
1619 ! -- compute air density RHOMID and remove negative tracer values
1620  do l=1,lm
1621 !$omp parallel do private(i,j,n,tv)
1622  do j=jsta,jend
1623  do i=1,im
1624 
1625  tv = t(i,j,l) * (h1+d608*max(q(i,j,l),qmin))
1626  rhomid(i,j,l) = pmid(i,j,l) / (rd*tv)
1627  do n = 1, nbin_du
1628  IF ( dust(i,j,l,n) < spval) THEN
1629  dust(i,j,l,n) = max(dust(i,j,l,n), 0.0)
1630  ENDIF
1631  enddo
1632  do n = 1, nbin_ss
1633  IF ( salt(i,j,l,n) < spval) THEN
1634  salt(i,j,l,n) = max(salt(i,j,l,n), 0.0)
1635  ENDIF
1636  enddo
1637  do n = 1, nbin_oc
1638  IF ( waso(i,j,l,n) < spval) THEN
1639  waso(i,j,l,n) = max(waso(i,j,l,n), 0.0)
1640  ENDIF
1641  enddo
1642  do n = 1, nbin_bc
1643  IF ( soot(i,j,l,n) < spval) THEN
1644  soot(i,j,l,n) = max(soot(i,j,l,n), 0.0)
1645  ENDIF
1646  enddo
1647  do n = 1, nbin_su
1648  IF ( suso(i,j,l,n) < spval) THEN
1649  suso(i,j,l,n) = max(suso(i,j,l,n), 0.0)
1650  ENDIF
1651  enddo
1652 
1653  end do
1654  end do
1655  end do
1656  l=lm
1657 !$omp parallel do private(i,j)
1658  do j=jsta,jend
1659  do i=1,im
1660  dustcb(i,j) = max(dustcb(i,j), 0.0)
1661  dustallcb(i,j) = max(dustallcb(i,j), 0.0)
1662  sscb(i,j) = max(sscb(i,j), 0.0)
1663  ssallcb(i,j) = max(ssallcb(i,j), 0.0)
1664  bccb(i,j) = max(bccb(i,j), 0.0)
1665  occb(i,j) = max(occb(i,j), 0.0)
1666  sulfcb(i,j) = max(sulfcb(i,j), 0.0)
1667  pp25cb(i,j) = max(pp25cb(i,j), 0.0)
1668  pp10cb(i,j) = max(pp10cb(i,j), 0.0)
1669 ! PM10 concentration
1670  dusmass(i,j)=(dust(i,j,l,1)+dust(i,j,l,2)+dust(i,j,l,3)+ &
1671  0.74*dust(i,j,l,4)+salt(i,j,l,1)+salt(i,j,l,2)+salt(i,j,l,3)+ &
1672  salt(i,j,l,4) + soot(i,j,l,1)+soot(i,j,l,2)+waso(i,j,l,1)+ &
1673  waso(i,j,l,2) +suso(i,j,l,1)+pp25(i,j,l,1)+pp10(i,j,l,1)) &
1674  *rhomid(i,j,l) !ug/m3
1675 ! PM25 dust and seasalt
1676  dustpm(i,j)=(dust(i,j,l,1)+0.38*dust(i,j,l,2))*rhomid(i,j,l) !ug/m3
1677  dustpm10(i,j)=(dust(i,j,l,1)+dust(i,j,l,2)+dust(i,j,l,3)+ &
1678  0.74*dust(i,j,l,4))*rhomid(i,j,l) !ug/m3
1679  sspm(i,j)=(salt(i,j,l,1)+salt(i,j,l,2)+ &
1680  0.83*salt(i,j,l,3))*rhomid(i,j,l) !ug/m3
1681 ! PM25 concentration
1682  dusmass25(i,j)=(dust(i,j,l,1)+0.38*dust(i,j,l,2)+ &
1683  salt(i,j,l,1)+salt(i,j,l,2)+0.83*salt(i,j,l,3) + &
1684  soot(i,j,l,1)+soot(i,j,l,2)+waso(i,j,l,1)+ &
1685  waso(i,j,l,2) +suso(i,j,l,1)+pp25(i,j,l,1))*rhomid(i,j,l) !ug/m3
1686 ! PM10 column
1687  ducmass(i,j)=dustallcb(i,j)+ssallcb(i,j)+bccb(i,j)+ &
1688  occb(i,j)+sulfcb(i,j)+pp25cb(i,j)+pp10cb(i,j)
1689 ! PM25 column
1690  ducmass25(i,j)=dustcb(i,j)+sscb(i,j)+bccb(i,j)+occb(i,j) &
1691  +sulfcb(i,j)+pp25cb(i,j)
1692  end do
1693  end do
1694  endif ! endif for gocart_on
1695 !
1696 ! done with sigma file, close it for now
1697  call nemsio_close(nfile,iret=status)
1698  deallocate(tmp,recname,reclevtyp,reclev)
1699 
1700 ! open flux file
1701 ! has to move it to beginning to read imp_physics
1702 ! call nemsio_open(ffile,trim(fileNameFlux),'read',mpi_comm_comp &
1703 ! ,iret=status)
1704 ! if ( Status /= 0 ) then
1705 ! print*,'error opening ',fileNameFlux, ' Status = ', Status
1706 ! print*,'skip reading of flux file'
1707 ! endif
1708  call nemsio_getfilehead(ffile,iret=status,nrec=nrec)
1709  print*,'nrec for flux file=',nrec
1710  allocate(recname(nrec),reclevtyp(nrec),reclev(nrec))
1711  call nemsio_getfilehead(ffile,iret=iret &
1712  ,recname=recname ,reclevtyp=reclevtyp,reclev=reclev)
1713  if(debugprint)then
1714  if (me == 0)then
1715  do i=1,nrec
1716  print *,'recname,reclevtyp,reclev=',trim(recname(i)),' ', &
1717  trim(reclevtyp(i)),reclev(i)
1718  end do
1719  end if
1720  end if
1721 
1722 ! IVEGSRC=1 for IGBP, 0 for USGS, 2 for UMD
1723  varname='IVEGSRC'
1724  call nemsio_getheadvar(ffile,trim(varname),ivegsrc,iret)
1725  if (iret /= 0) then
1726  print*,varname,' not found in file-use 1 for IGBP as default'
1727  ivegsrc=1
1728  end if
1729  if (me == 0) print*,'IVEGSRC= ',ivegsrc
1730 
1731 ! set novegtype based on vegetation classification
1732  if(ivegsrc==2)then
1733  novegtype=13
1734  else if(ivegsrc==1)then
1735  novegtype=20
1736  else if(ivegsrc==0)then
1737  novegtype=24
1738  end if
1739  if (me == 0) print*,'novegtype= ',novegtype
1740 
1741  varname='CU_PHYSICS'
1742  call nemsio_getheadvar(ffile,trim(varname),icu_physics,iret)
1743  if (iret /= 0) then
1744  print*,varname," not found in file-Assigned 4 for SAS as default"
1745  icu_physics=4
1746  end if
1747  if (me == 0) print*,'CU_PHYSICS= ',icu_physics
1748 
1749  varname='dtp'
1750  call nemsio_getheadvar(ffile,trim(varname),dtp,iret)
1751  if (iret /= 0) then
1752  print*,varname," not found in file-Assigned 225. for dtp as default"
1753  dtp=225.
1754  end if
1755  if (me == 0) print*,'dtp= ',dtp
1756 
1757 ! Chuang: zhour is when GFS empties bucket last so using this
1758 ! to compute buket will result in changing bucket with forecast time.
1759 ! set default bucket for now
1760 
1761 ! call nemsio_getheadvar(ffile,'zhour',zhour,iret=iret)
1762 ! if(iret == 0) then
1763 ! tprec = 1.0*ifhr-zhour
1764 ! tclod = tprec
1765 ! trdlw = tprec
1766 ! trdsw = tprec
1767 ! tsrfc = tprec
1768 ! tmaxmin = tprec
1769 ! td3d = tprec
1770 ! print*,'tprec from flux file header= ',tprec
1771 ! else
1772 ! print*,'Error reading accumulation bucket from flux file', &
1773 ! 'header - will try to read from env variable FHZER'
1774 ! CALL GETENV('FHZER',ENVAR)
1775 ! read(ENVAR, '(I2)')idum
1776 ! tprec = idum*1.0
1777 ! tclod = tprec
1778 ! trdlw = tprec
1779 ! trdsw = tprec
1780 ! tsrfc = tprec
1781 ! tmaxmin = tprec
1782 ! td3d = tprec
1783 ! print*,'TPREC from FHZER= ',tprec
1784 ! end if
1785 
1786 
1787 ! start reading nemsio flux files using parallel read
1788  fldsize = (jend-jsta+1)*im
1789  allocate(tmp(fldsize*nrec))
1790  print*,'allocate tmp successfully'
1791  tmp=0.
1792  call nemsio_denseread(ffile,1,im,jsta,jend,tmp,iret=iret)
1793 ! can't stop because anl does not have flux file
1794 ! if(iret/=0)then
1795 ! print*,"fail to read flux file using mpi io read, stopping"
1796 ! stop
1797 ! end if
1798 
1799  vcoordname='sfc' ! surface fileds
1800  varname='land'
1801  l=1
1802  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1803  ,l,nrec,fldsize,spval,tmp &
1804  ,recname,reclevtyp,reclev,varname,vcoordname,sm)
1805  if(debugprint)print*,'sample ',varname,' =',sm(im/2,(jsta+jend)/2)
1806 
1807 !$omp parallel do private(i,j)
1808  do j=jsta,jend
1809  do i=1,im
1810  if (sm(i,j) /= spval) sm(i,j) = 1.0 - sm(i,j)
1811  enddo
1812  enddo
1813 
1814 ! sea ice mask
1815 
1816  varname='icec'
1817  vcoordname = 'sfc'
1818  l=1
1819  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1820  ,l,nrec,fldsize,spval,tmp &
1821  ,recname,reclevtyp,reclev,varname,vcoordname,sice)
1822 
1823  if(debugprint)print*,'sample ',varname,' = ',sice(isa,jsa)
1824 
1825 ! where(sice /=spval .and. sice >=1.0)sm=0.0 !sea ice has sea
1826 ! mask=0
1827 ! GFS flux files have land points with non-zero sea ice, per Iredell,
1828 ! these
1829 ! points have sea ice changed to zero, i.e., trust land mask more than
1830 ! sea ice
1831 ! where(sm/=spval .and. sm==0.0)sice=0.0 !specify sea ice=0 at land
1832 
1833 !$omp parallel do private(i,j)
1834  do j=jsta,jend
1835  do i=1,im
1836  if (sm(i,j) /= spval .and. sm(i,j) == 0.0) sice(i,j) = 0.0
1837  enddo
1838  enddo
1839 
1840 
1841 ! PBL height using nemsio
1842  varname='hpbl'
1843  vcoordname = 'sfc'
1844  l=1
1845  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1846  ,l,nrec,fldsize,spval,tmp &
1847  ,recname,reclevtyp,reclev,varname,vcoordname &
1848  ,pblh)
1849  if(debugprint)print*,'sample ',varname,' = ',pblh(isa,jsa)
1850 
1851 ! frictional velocity using nemsio
1852  varname='fricv'
1853 ! VcoordName='sfc'
1854 ! l=1
1855  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1856  ,l,nrec,fldsize,spval,tmp &
1857  ,recname,reclevtyp,reclev,varname,vcoordname &
1858  ,ustar)
1859 ! if(debugprint)print*,'sample ',VarName,' = ',ustar(isa,jsa)
1860 
1861 ! roughness length using getgb
1862  varname='sfcr'
1863 ! VcoordName='sfc'
1864 ! l=1
1865  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1866  ,l,nrec,fldsize,spval,tmp &
1867  ,recname,reclevtyp,reclev,varname,vcoordname &
1868  ,z0)
1869 ! if(debugprint)print*,'sample ',VarName,' = ',z0(isa,jsa)
1870 
1871 ! sfc exchange coeff
1872  varname='sfexc'
1873 ! VcoordName='sfc'
1874 ! l=1
1875  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1876  ,l,nrec,fldsize,spval,tmp &
1877  ,recname,reclevtyp,reclev,varname,vcoordname &
1878  ,sfcexc)
1879 
1880 ! aerodynamic conductance
1881  varname='acond'
1882 ! VcoordName='sfc'
1883 ! l=1
1884  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1885  ,l,nrec,fldsize,spval,tmp &
1886  ,recname,reclevtyp,reclev,varname,vcoordname &
1887  ,acond)
1888 
1889 ! surface potential T using getgb
1890  varname='tmp'
1891 ! VcoordName='sfc'
1892 ! l=1
1893  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1894  ,l,nrec,fldsize,spval,tmp &
1895  ,recname,reclevtyp,reclev,varname,vcoordname &
1896  ,ths)
1897 
1898 ! where(ths/=spval)ths=ths*(p1000/pint(:,:,lp1))**CAPA ! convert to THS
1899 
1900 !$omp parallel do private(i,j)
1901  do j=jsta,jend
1902  do i=1,im
1903  if (ths(i,j) /= spval) then
1904 ! write(*,*)' i=',i,' j=',j,' ths=',ths(i,j),' pint=',pint(i,j,lp1)
1905  ths(i,j) = ths(i,j) * (p1000/pint(i,j,lp1))**capa
1906  endif
1907  qs(i,j) = spval ! GFS does not have surface specific humidity
1908  twbs(i,j) = spval ! GFS does not have inst sensible heat flux
1909  qwbs(i,j) = spval ! GFS does not have inst latent heat flux
1910 !assign sst
1911  if (sm(i,j) /= 0.0) then
1912  if (sice(i,j) >= 0.15) then
1913  sst(i,j)=271.4
1914  else
1915  sst(i,j) = ths(i,j) * (pint(i,j,lp1)/p1000)**capa
1916  endif
1917  else
1918  sst(i,j) = spval
1919  endif
1920  enddo
1921  enddo
1922 ! if(debugprint)print*,'sample ',VarName,' = ',ths(isa,jsa)
1923 
1924 
1925 ! GFS does not have time step and physics time step, make up ones since they
1926 ! are not really used anyway
1927 ! NPHS=2.
1928 ! DT=80.
1929  dtq2 = dtp !MEB need to get physics DT
1930  nphs=2.
1931  dt=dtq2/nphs
1932  tsph = 3600./dt !MEB need to get DT
1933 
1934 ! convective precip in m per physics time step using getgb
1935 ! read 6 hour bucket
1936  varname='cpratb_ave'
1937 ! VcoordName='sfc'
1938 ! l=1
1939  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1940  ,l,nrec,fldsize,spval,tmp &
1941  ,recname,reclevtyp,reclev,varname,vcoordname &
1942  ,avgcprate)
1943 ! where(avgcprate /= spval)avgcprate=avgcprate*dtq2/1000. ! convert to m
1944 !$omp parallel do private(i,j)
1945  do j=jsta,jend
1946  do i=1,im
1947  if (avgcprate(i,j) /= spval) avgcprate(i,j) = avgcprate(i,j) * (dtq2*0.001)
1948 !wm cprate(i,j) = avgcprate(i,j)
1949  enddo
1950  enddo
1951 ! read continuous bucket
1952  varname='cprat_ave'
1953 ! VcoordName='sfc'
1954 ! l=1
1955  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1956  ,l,nrec,fldsize,spval,tmp &
1957  ,recname,reclevtyp,reclev,varname,vcoordname &
1958  ,avgcprate_cont)
1959 !$omp parallel do private(i,j)
1960  do j=jsta,jend
1961  do i=1,im
1962  if (avgcprate_cont(i,j) /= spval) avgcprate_cont(i,j) = &
1963  avgcprate_cont(i,j) * (dtq2*0.001)
1964  enddo
1965  enddo
1966 
1967 ! if(debugprint)print*,'sample ',VarName,' = ',avgcprate(isa,jsa)
1968 
1969 ! print*,'maxval CPRATE: ', maxval(CPRATE)
1970 
1971 ! time averaged bucketed precip rate
1972  varname='prateb_ave'
1973 ! VcoordName='sfc'
1974 ! l=1
1975  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1976  ,l,nrec,fldsize,spval,tmp &
1977  ,recname,reclevtyp,reclev,varname,vcoordname &
1978  ,avgprec)
1979 ! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m
1980 !$omp parallel do private(i,j)
1981  do j=jsta,jend
1982  do i=1,im
1983  if (avgprec(i,j) /= spval) avgprec(i,j) = avgprec(i,j) * (dtq2*0.001)
1984  enddo
1985  enddo
1986 
1987 ! if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa)
1988 
1989 ! time averaged continuous precip rate in m per physics time step using getgb
1990  varname='prate_ave'
1991 ! VcoordName='sfc'
1992 ! l=1
1993  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
1994  ,l,nrec,fldsize,spval,tmp &
1995  ,recname,reclevtyp,reclev,varname,vcoordname &
1996  ,avgprec_cont)
1997 ! where(avgprec /= spval)avgprec=avgprec*dtq2/1000. ! convert to m
1998 !$omp parallel do private(i,j)
1999  do j=jsta,jend
2000  do i=1,im
2001  if (avgprec_cont(i,j) /= spval) avgprec_cont(i,j) = avgprec_cont(i,j) &
2002  * (dtq2*0.001)
2003  enddo
2004  enddo
2005 
2006 ! if(debugprint)print*,'sample ',VarName,' = ',avgprec(isa,jsa)
2007 
2008 ! precip rate in m per physics time step
2009  varname='tprcp'
2010 ! VcoordName='sfc'
2011 ! l=1
2012  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2013  ,l,nrec,fldsize,spval,tmp &
2014  ,recname,reclevtyp,reclev,varname,vcoordname &
2015  ,prec)
2016 !$omp parallel do private(i,j)
2017 ! unit of prec and cprate in post is supposed to be m per physics time step
2018 ! it will be converted back to kg/m^2/s by multiplying by density in SURFCE
2019  do j=jsta,jend
2020  do i=1,im
2021  if (prec(i,j) /= spval) prec(i,j) = prec(i,j) * (dtq2*0.001) &
2022  * 1000. / dtp
2023  enddo
2024  enddo
2025 
2026 ! convective precip rate in m per physics time step
2027  varname='cnvprcp'
2028 ! VcoordName='sfc'
2029 ! l=1
2030  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2031  ,l,nrec,fldsize,spval,tmp &
2032  ,recname,reclevtyp,reclev,varname,vcoordname &
2033  ,cprate)
2034 !$omp parallel do private(i,j)
2035  do j=jsta,jend
2036  do i=1,im
2037  if (cprate(i,j) /= spval) then
2038  cprate(i,j) = max(0.,cprate(i,j)) * (dtq2*0.001) * 1000. / dtp
2039  else
2040  cprate(i,j) = 0.
2041  endif
2042  enddo
2043  enddo
2044  if(debugprint)print*,'sample ',varname,' = ',cprate(isa,jsa)
2045 
2046 ! GFS does not have accumulated total, gridscale, and convective precip, will use inst precip to derive in SURFCE.f
2047 
2048 
2049 ! inst snow water eqivalent using nemsio
2050  varname='weasd'
2051 ! VcoordName='sfc'
2052 ! l=1
2053  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2054  ,l,nrec,fldsize,spval,tmp &
2055  ,recname,reclevtyp,reclev,varname,vcoordname &
2056  ,sno)
2057 ! mask water areas
2058 !$omp parallel do private(i,j)
2059  do j=jsta,jend
2060  do i=1,im
2061  if (sm(i,j) == 1.0 .and. sice(i,j)==0.) sno(i,j) = spval
2062  enddo
2063  enddo
2064 ! if(debugprint)print*,'sample ',VarName,' = ',sno(isa,jsa)
2065 
2066 ! ave snow cover
2067  varname='snowc_ave'
2068 ! VcoordName='sfc'
2069 ! l=1
2070  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2071  ,l,nrec,fldsize,spval,tmp &
2072  ,recname,reclevtyp,reclev,varname,vcoordname &
2073  ,snoavg)
2074 ! snow cover is multipled by 100 in SURFCE before writing it out
2075  do j=jsta,jend
2076  do i=1,im
2077  if (sm(i,j)==1.0 .and. sice(i,j)==0.) snoavg(i,j)=spval
2078  if(snoavg(i,j)/=spval)snoavg(i,j)=snoavg(i,j)/100.
2079  end do
2080  end do
2081 
2082 ! snow depth in mm using nemsio
2083  varname='snod'
2084 ! VcoordName='sfc'
2085 ! l=1
2086  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2087  ,l,nrec,fldsize,spval,tmp &
2088  ,recname,reclevtyp,reclev,varname,vcoordname &
2089  ,si)
2090 ! where(si /= spval)si=si*1000. ! convert to mm
2091 !$omp parallel do private(i,j)
2092  do j=jsta,jend
2093  do i=1,im
2094  if (sm(i,j)==1.0 .and. sice(i,j)==0.) si(i,j)=spval
2095  if (si(i,j) /= spval) si(i,j) = si(i,j) * 1000.0
2096  cldefi(i,j) = spval ! GFS does not have convective cloud efficiency
2097  lspa(i,j) = spval ! GFS does not have similated precip
2098  th10(i,j) = spval ! GFS does not have 10 m theta
2099  th10(i,j) = spval ! GFS does not have 10 m theta
2100  q10(i,j) = spval ! GFS does not have 10 m humidity
2101  albase(i,j) = spval ! GFS does not have snow free albedo
2102  enddo
2103  enddo
2104 ! if(debugprint)print*,'sample ',VarName,' = ',si(isa,jsa)
2105 
2106 
2107 ! 2m T using nemsio
2108  varname='tmp'
2109  vcoordname='2 m above gnd'
2110 ! l=1
2111  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2112  ,l,nrec,fldsize,spval,tmp &
2113  ,recname,reclevtyp,reclev,varname,vcoordname &
2114  ,tshltr)
2115 ! if(debugprint)print*,'sample ',VarName,' = ',tshltr(isa,jsa)
2116 
2117 ! GFS does not have 2m pres, estimate it, also convert t to theta
2118  Do j=jsta,jend
2119  Do i=1,im
2120  pshltr(i,j)=pint(i,j,lm+1)*exp(-0.068283/tshltr(i,j))
2121  tshltr(i,j)= tshltr(i,j)*(p1000/pshltr(i,j))**capa ! convert to theta
2122 ! if (j == jm/2 .and. mod(i,50) == 0)
2123 ! + print*,'sample 2m T and P after scatter= '
2124 ! + ,i,j,tshltr(i,j),pshltr(i,j)
2125  end do
2126  end do
2127 
2128 ! 2m specific humidity using nemsio
2129  varname='spfh'
2130  vcoordname='2 m above gnd'
2131 ! l=1
2132  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2133  ,l,nrec,fldsize,spval,tmp &
2134  ,recname,reclevtyp,reclev,varname,vcoordname &
2135  ,qshltr)
2136 ! if(debugprint)print*,'sample ',VarName,' = ',qshltr(isa,jsa)
2137 
2138 ! mid day avg albedo in fraction using nemsio
2139  varname='albdo_ave'
2140  vcoordname='sfc'
2141 ! l=1
2142  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2143  ,l,nrec,fldsize,spval,tmp &
2144  ,recname,reclevtyp,reclev,varname,vcoordname &
2145  ,avgalbedo)
2146 ! where(avgalbedo /= spval)avgalbedo=avgalbedo/100. ! convert to fraction
2147 !$omp parallel do private(i,j)
2148  do j=jsta,jend
2149  do i=1,im
2150  if (avgalbedo(i,j) /= spval) avgalbedo(i,j) = avgalbedo(i,j) * 0.01
2151  enddo
2152  enddo
2153 ! if(debugprint)print*,'sample ',VarName,' = ',avgalbedo(isa,jsa)
2154 
2155 ! time averaged column cloud fractionusing nemsio
2156  varname='tcdc_ave'
2157  vcoordname='atmos col'
2158 ! l=1
2159  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2160  ,l,nrec,fldsize,spval,tmp &
2161  ,recname,reclevtyp,reclev,varname,vcoordname &
2162  ,avgtcdc)
2163 ! where(avgtcdc /= spval)avgtcdc=avgtcdc/100. ! convert to fraction
2164 !$omp parallel do private(i,j)
2165  do j=jsta,jend
2166  do i=1,im
2167  if (avgtcdc(i,j) /= spval) avgtcdc(i,j) = avgtcdc(i,j) * 0.01
2168  enddo
2169  enddo
2170 ! if(debugprint)print*,'sample ',VarName,' = ',avgtcdc(isa,jsa)
2171 
2172 ! GFS probably does not use zenith angle
2173 !$omp parallel do private(i,j)
2174  do j=jsta_2l,jend_2u
2175  do i=1,im
2176  czen(i,j) = spval
2177  czmean(i,j) = spval
2178  enddo
2179  enddo
2180 
2181 ! maximum snow albedo in fraction using nemsio
2182  varname='mxsalb'
2183  vcoordname='sfc'
2184 ! l=1
2185  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2186  ,l,nrec,fldsize,spval,tmp &
2187  ,recname,reclevtyp,reclev,varname,vcoordname &
2188  ,mxsnal)
2189 ! where(mxsnal /= spval)mxsnal=mxsnal/100. ! convert to fraction
2190 !$omp parallel do private(i,j)
2191  do j=jsta,jend
2192  do i=1,im
2193  if (mxsnal(i,j) /= spval) mxsnal(i,j) = mxsnal(i,j) * 0.01
2194  enddo
2195  enddo
2196 ! if(debugprint)print*,'sample ',VarName,' = ',mxsnal(isa,jsa)
2197 
2198 !$omp parallel do private(i,j)
2199  do j=jsta_2l,jend_2u
2200  do i=1,im
2201  radot(i,j) = spval ! GFS does not have inst surface outgoing longwave
2202  enddo
2203  enddo
2204 
2205 ! GFS probably does not use sigt4, set it to sig*t^4
2206 !$omp parallel do private(i,j,tlmh)
2207  Do j=jsta,jend
2208  Do i=1,im
2209  tlmh = t(i,j,lm) * t(i,j,lm)
2210  sigt4(i,j) = 5.67e-8 * tlmh * tlmh
2211  End do
2212  End do
2213 
2214 ! TG is not used, skip it for now
2215 
2216 ! GFS does not have inst cloud fraction for high, middle, and low cloud
2217 !$omp parallel do private(i,j)
2218  do j=jsta_2l,jend_2u
2219  do i=1,im
2220  cfrach(i,j) = spval
2221  cfracl(i,j) = spval
2222  cfracm(i,j) = spval
2223  enddo
2224  enddo
2225 
2226 ! ave high cloud fraction using nemsio
2227  varname='tcdc_ave'
2228  vcoordname='high cld lay'
2229  l=1
2230  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2231  ,l,nrec,fldsize,spval,tmp &
2232  ,recname,reclevtyp,reclev,varname,vcoordname &
2233  ,avgcfrach)
2234 ! where(avgcfrach /= spval)avgcfrach=avgcfrach/100. ! convert to fraction
2235 !$omp parallel do private(i,j)
2236  do j=jsta,jend
2237  do i=1,im
2238  if (avgcfrach(i,j) /= spval) avgcfrach(i,j) = avgcfrach(i,j) * 0.01
2239  enddo
2240  enddo
2241 ! if(debugprint)print*,'sample ',VarName,' = ',avgcfrach(isa,jsa)
2242 
2243 ! ave low cloud fraction using nemsio
2244  varname='tcdc_ave'
2245  vcoordname='low cld lay'
2246  l=1
2247  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2248  ,l,nrec,fldsize,spval,tmp &
2249  ,recname,reclevtyp,reclev,varname,vcoordname &
2250  ,avgcfracl)
2251 ! where(avgcfracl /= spval)avgcfracl=avgcfracl/100. ! convert to fraction
2252 !$omp parallel do private(i,j)
2253  do j=jsta,jend
2254  do i=1,im
2255  if (avgcfracl(i,j) /= spval) avgcfracl(i,j) = avgcfracl(i,j) * 0.01
2256  enddo
2257  enddo
2258 ! if(debugprint)print*,'sample ',VarName,' = ',avgcfracl(isa,jsa)
2259 
2260 ! ave middle cloud fraction using nemsio
2261  varname='tcdc_ave'
2262  vcoordname='mid cld lay'
2263  l=1
2264  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2265  ,l,nrec,fldsize,spval,tmp &
2266  ,recname,reclevtyp,reclev,varname,vcoordname &
2267  ,avgcfracm)
2268 ! where(avgcfracm /= spval)avgcfracm=avgcfracm/100. ! convert to fraction
2269 !$omp parallel do private(i,j)
2270  do j=jsta,jend
2271  do i=1,im
2272  if (avgcfracm(i,j) /= spval) avgcfracm(i,j) = avgcfracm(i,j) * 0.01
2273  enddo
2274  enddo
2275 ! if(debugprint)print*,'sample ',VarName,' = ',avgcfracm(isa,jsa)
2276 
2277 ! inst convective cloud fraction using nemsio
2278  varname='tcdc'
2279  vcoordname='convect-cld laye'
2280  l=1
2281  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2282  ,l,nrec,fldsize,spval,tmp &
2283  ,recname,reclevtyp,reclev,varname,vcoordname &
2284  ,cnvcfr)
2285 ! where(cnvcfr /= spval)cnvcfr=cnvcfr/100. ! convert to fraction
2286 !$omp parallel do private(i,j)
2287  do j=jsta,jend
2288  do i=1,im
2289  if (cnvcfr(i,j) /= spval) cnvcfr(i,j)= cnvcfr(i,j) * 0.01
2290  enddo
2291  enddo
2292 ! if(debugprint)print*,'sample ',VarName,' = ',cnvcfr(isa,jsa)
2293 
2294 ! slope type using nemsio
2295  varname='sltyp'
2296  vcoordname='sfc'
2297  l=1
2298  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2299  ,l,nrec,fldsize,spval,tmp &
2300  ,recname,reclevtyp,reclev,varname,vcoordname &
2301  ,buf)
2302 ! where(buf /= spval)islope=nint(buf)
2303 !$omp parallel do private(i,j)
2304  do j = jsta_2l, jend_2u
2305  do i=1,im
2306  if (buf(i,j) < spval) then
2307  islope(i,j) = nint(buf(i,j))
2308  else
2309  islope(i,j) = 0
2310  endif
2311  enddo
2312  enddo
2313 ! if(debugprint)print*,'sample ',VarName,' = ',islope(isa,jsa)
2314 
2315 ! plant canopy sfc wtr in m using nemsio
2316  varname='cnwat'
2317  vcoordname='sfc'
2318  l=1
2319  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2320  ,l,nrec,fldsize,spval,tmp &
2321  ,recname,reclevtyp,reclev,varname,vcoordname &
2322  ,cmc)
2323 ! where(cmc /= spval)cmc=cmc/1000. ! convert from kg*m^2 to m
2324 !$omp parallel do private(i,j)
2325  do j=jsta,jend
2326  do i=1,im
2327  if (cmc(i,j) /= spval) cmc(i,j) = cmc(i,j) * 0.001
2328  if (sm(i,j) /= 0.0) cmc(i,j) = spval
2329  enddo
2330  enddo
2331 ! if(debugprint)print*,'sample ',VarName,' = ',cmc(isa,jsa)
2332 
2333 !$omp parallel do private(i,j)
2334  do j=jsta_2l,jend_2u
2335  do i=1,im
2336  grnflx(i,j) = spval ! GFS does not have inst ground heat flux
2337  enddo
2338  enddo
2339 
2340 ! frozen precip fraction using nemsio
2341  varname='cpofp'
2342  vcoordname='sfc'
2343  l=1
2344  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2345  ,l,nrec,fldsize,spval,tmp &
2346  ,recname,reclevtyp,reclev,varname,vcoordname &
2347  ,sr)
2348 !$omp parallel do private(i,j)
2349  do j=jsta,jend
2350  do i=1,im
2351  if(sr(i,j) /= spval) then
2352 !set range within (0,1)
2353  sr(i,j)=min(1.,max(0.,sr(i,j)))
2354  endif
2355  enddo
2356  enddo
2357 
2358 ! sea ice skin temperature
2359  varname='ti'
2360  vcoordname='sfc'
2361  l=1
2362  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2363  ,l,nrec,fldsize,spval,tmp &
2364  ,recname,reclevtyp,reclev,varname,vcoordname &
2365  ,ti)
2366 !$omp parallel do private(i,j)
2367  do j=jsta,jend
2368  do i=1,im
2369  if (sice(i,j) == spval .or. sice(i,j) == 0.) ti(i,j)=spval
2370  enddo
2371  enddo
2372 
2373 ! vegetation fraction in fraction. using nemsio
2374  varname='veg'
2375  vcoordname='sfc'
2376  l=1
2377  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2378  ,l,nrec,fldsize,spval,tmp &
2379  ,recname,reclevtyp,reclev,varname,vcoordname &
2380  ,vegfrc)
2381 !$omp parallel do private(i,j)
2382  do j=jsta,jend
2383  do i=1,im
2384  if (vegfrc(i,j) /= spval) then
2385  vegfrc(i,j) = vegfrc(i,j) * 0.01
2386  else
2387  vegfrc(i,j) = 0.0
2388  endif
2389  enddo
2390  enddo
2391 ! mask water areas
2392 !$omp parallel do private(i,j)
2393  do j=jsta,jend
2394  do i=1,im
2395  if (sm(i,j) /= 0.0) vegfrc(i,j) = spval
2396  enddo
2397  enddo
2398 ! if(debugprint)print*,'sample ',VarName,' = ',vegfrc(isa,jsa)
2399 
2400 ! GFS doesn not yet output soil layer thickness, assign SLDPTH to be the same as nam
2401 
2402  sldpth(1) = 0.10
2403  sldpth(2) = 0.3
2404  sldpth(3) = 0.6
2405  sldpth(4) = 1.0
2406 
2407 ! liquid volumetric soil mpisture in fraction using nemsio
2408  varname='soill'
2409  vcoordname='0-10 cm down'
2410  l=1
2411  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2412  ,l,nrec,fldsize,spval,tmp &
2413  ,recname,reclevtyp,reclev,varname,vcoordname &
2414  ,sh2o(1,jsta_2l,1))
2415 ! mask water areas
2416 !$omp parallel do private(i,j)
2417  do j=jsta,jend
2418  do i=1,im
2419  if (sm(i,j) /= 0.0) sh2o(i,j,1) = spval
2420  enddo
2421  enddo
2422 ! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,1)
2423 
2424  varname='soill'
2425  vcoordname='10-40 cm down'
2426  l=1
2427  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2428  ,l,nrec,fldsize,spval,tmp &
2429  ,recname,reclevtyp,reclev,varname,vcoordname &
2430  ,sh2o(1,jsta_2l,2))
2431 ! mask water areas
2432 !$omp parallel do private(i,j)
2433  do j=jsta,jend
2434  do i=1,im
2435  if (sm(i,j) /= 0.0) sh2o(i,j,2) = spval
2436  enddo
2437  enddo
2438 ! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,2)
2439 
2440  varname='soill'
2441  vcoordname='40-100 cm down'
2442  l=1
2443  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2444  ,l,nrec,fldsize,spval,tmp &
2445  ,recname,reclevtyp,reclev,varname,vcoordname &
2446  ,sh2o(1,jsta_2l,3))
2447 ! mask water areas
2448 !$omp parallel do private(i,j)
2449  do j=jsta,jend
2450  do i=1,im
2451  if (sm(i,j) /= 0.0) sh2o(i,j,3) = spval
2452  enddo
2453  enddo
2454 ! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,3)
2455 
2456  varname='soill'
2457  vcoordname='100-200 cm down'
2458  l=1
2459  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2460  ,l,nrec,fldsize,spval,tmp &
2461  ,recname,reclevtyp,reclev,varname,vcoordname &
2462  ,sh2o(1,jsta_2l,4))
2463 ! mask water areas
2464 !$omp parallel do private(i,j)
2465  do j=jsta,jend
2466  do i=1,im
2467  if (sm(i,j) /= 0.0) sh2o(i,j,4) = spval
2468  enddo
2469  enddo
2470 ! if(debugprint)print*,'sample l',VarName,' = ',1,sh2o(isa,jsa,4)
2471 
2472 ! volumetric soil moisture using nemsio
2473  varname='soilw'
2474  vcoordname='0-10 cm down'
2475  l=1
2476  l=1
2477  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2478  ,l,nrec,fldsize,spval,tmp &
2479  ,recname,reclevtyp,reclev,varname,vcoordname &
2480  ,smc(1,jsta_2l,1))
2481 ! mask water areas
2482 !$omp parallel do private(i,j)
2483  do j=jsta,jend
2484  do i=1,im
2485  if (sm(i,j) /= 0.0) smc(i,j,1) = spval
2486  enddo
2487  enddo
2488 ! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,1)
2489 
2490  varname='soilw'
2491  vcoordname='10-40 cm down'
2492  l=1
2493  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2494  ,l,nrec,fldsize,spval,tmp &
2495  ,recname,reclevtyp,reclev,varname,vcoordname &
2496  ,smc(1,jsta_2l,2))
2497 ! mask water areas
2498 !$omp parallel do private(i,j)
2499  do j=jsta,jend
2500  do i=1,im
2501  if (sm(i,j) /= 0.0) smc(i,j,2) = spval
2502  enddo
2503  enddo
2504 ! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,2)
2505 
2506  varname='soilw'
2507  vcoordname='40-100 cm down'
2508  l=1
2509  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2510  ,l,nrec,fldsize,spval,tmp &
2511  ,recname,reclevtyp,reclev,varname,vcoordname &
2512  ,smc(1,jsta_2l,3))
2513 ! mask water areas
2514 !$omp parallel do private(i,j)
2515  do j=jsta,jend
2516  do i=1,im
2517  if (sm(i,j) /= 0.0) smc(i,j,3) = spval
2518  enddo
2519  enddo
2520 ! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,3)
2521 
2522  varname='soilw'
2523  vcoordname='100-200 cm down'
2524  l=1
2525  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2526  ,l,nrec,fldsize,spval,tmp &
2527  ,recname,reclevtyp,reclev,varname,vcoordname &
2528  ,smc(1,jsta_2l,4))
2529 ! mask water areas
2530 !$omp parallel do private(i,j)
2531  do j=jsta,jend
2532  do i=1,im
2533  if (sm(i,j) /= 0.0) smc(i,j,4) = spval
2534  enddo
2535  enddo
2536 ! if(debugprint)print*,'sample l',VarName,' = ',1,smc(isa,jsa,4)
2537 
2538 ! soil temperature using nemsio
2539  varname='tmp'
2540  vcoordname='0-10 cm down'
2541  l=1
2542  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2543  ,l,nrec,fldsize,spval,tmp &
2544  ,recname,reclevtyp,reclev,varname,vcoordname &
2545  ,stc(1,jsta_2l,1))
2546 ! mask open water areas, combine with sea ice tmp
2547 !$omp parallel do private(i,j)
2548  do j=jsta,jend
2549  do i=1,im
2550  if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,1) = spval
2551  !if (sm(i,j) /= 0.0) stc(i,j,1) = spval
2552  enddo
2553  enddo
2554 ! if(debugprint)print*,'sample l','stc',' = ',1,stc(isa,jsa,1)
2555 
2556  varname='tmp'
2557  vcoordname='10-40 cm down'
2558  l=1
2559  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2560  ,l,nrec,fldsize,spval,tmp &
2561  ,recname,reclevtyp,reclev,varname,vcoordname &
2562  ,stc(1,jsta_2l,2))
2563 ! mask open water areas, combine with sea ice tmp
2564 !$omp parallel do private(i,j)
2565  do j=jsta,jend
2566  do i=1,im
2567  if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,2) = spval
2568  !if (sm(i,j) /= 0.0) stc(i,j,2) = spval
2569  enddo
2570  enddo
2571 ! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,2)
2572 
2573  varname='tmp'
2574  vcoordname='40-100 cm down'
2575  l=1
2576  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2577  ,l,nrec,fldsize,spval,tmp &
2578  ,recname,reclevtyp,reclev,varname,vcoordname &
2579  ,stc(1,jsta_2l,3))
2580 ! mask open water areas, combine with sea ice tmp
2581 !$omp parallel do private(i,j)
2582  do j=jsta,jend
2583  do i=1,im
2584  if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,3) = spval
2585  !if (sm(i,j) /= 0.0) stc(i,j,3) = spval
2586  enddo
2587  enddo
2588 ! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,3)
2589 
2590  varname='tmp'
2591  vcoordname='100-200 cm down'
2592  l=1
2593  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2594  ,l,nrec,fldsize,spval,tmp &
2595  ,recname,reclevtyp,reclev,varname,vcoordname &
2596  ,stc(1,jsta_2l,4))
2597 ! mask open water areas, combine with sea ice tmp
2598 !$omp parallel do private(i,j)
2599  do j=jsta,jend
2600  do i=1,im
2601  if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) stc(i,j,4) = spval
2602  !if (sm(i,j) /= 0.0) stc(i,j,4) = spval
2603  enddo
2604  enddo
2605 ! if(debugprint)print*,'sample stc = ',1,stc(isa,jsa,4)
2606 
2607 !$omp parallel do private(i,j)
2608  do j=jsta,jend
2609  do i=1,im
2610  acfrcv(i,j) = spval ! GFS does not output time averaged convective and strat cloud fraction, set acfrcv to spval, ncfrcv to 1
2611  ncfrcv(i,j) = 1.0
2612  acfrst(i,j) = spval ! GFS does not output time averaged cloud fraction, set acfrst to spval, ncfrst to 1
2613  ncfrst(i,j) = 1.0
2614  ssroff(i,j) = spval ! GFS does not have storm runoff
2615  bgroff(i,j) = spval ! GFS does not have UNDERGROUND RUNOFF
2616  rlwin(i,j) = spval ! GFS does not have inst incoming sfc longwave
2617  rlwtoa(i,j) = spval ! GFS does not have inst model top outgoing longwave
2618  enddo
2619  enddo
2620 ! trdlw(i,j) = 6.0
2621  ardlw = 1.0 ! GFS incoming sfc longwave has been averaged over 6 hr bucket, set ARDLW to 1
2622 
2623 ! time averaged incoming sfc longwave using nemsio
2624  varname='dlwrf_ave'
2625  vcoordname='sfc'
2626  l=1
2627  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2628  ,l,nrec,fldsize,spval,tmp &
2629  ,recname,reclevtyp,reclev,varname,vcoordname &
2630  ,alwin)
2631 
2632 ! inst incoming sfc longwave using nemsio
2633  varname='dlwrf'
2634  vcoordname='sfc'
2635  l=1
2636  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2637  ,l,nrec,fldsize,spval,tmp &
2638  ,recname,reclevtyp,reclev,varname,vcoordname &
2639  ,rlwin)
2640 
2641 ! time averaged outgoing sfc longwave using gfsio
2642  varname='ulwrf_ave'
2643  vcoordname='sfc'
2644  l=1
2645  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2646  ,l,nrec,fldsize,spval,tmp &
2647  ,recname,reclevtyp,reclev,varname,vcoordname &
2648  ,alwout)
2649 ! inst outgoing sfc longwave using nemsio
2650  varname='ulwrf'
2651  vcoordname='sfc'
2652  l=1
2653  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2654  ,l,nrec,fldsize,spval,tmp &
2655  ,recname,reclevtyp,reclev,varname,vcoordname &
2656  ,radot)
2657 
2658 ! where(alwout /= spval) alwout=-alwout ! CLDRAD puts a minus sign before gribbing
2659 !$omp parallel do private(i,j)
2660  do j=jsta,jend
2661  do i=1,im
2662  if (alwout(i,j) /= spval) alwout(i,j) = -alwout(i,j)
2663  enddo
2664  enddo
2665 ! if(debugprint)print*,'sample l',VarName,' = ',1,alwout(isa,jsa)
2666 
2667 ! time averaged outgoing model top longwave using gfsio
2668  varname='ulwrf_ave'
2669  vcoordname='nom. top'
2670  l=1
2671  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2672  ,l,nrec,fldsize,spval,tmp &
2673  ,recname,reclevtyp,reclev,varname,vcoordname &
2674  ,alwtoa)
2675 ! if(debugprint)print*,'sample l',VarName,' = ',1,alwtoa(isa,jsa)
2676 
2677 !$omp parallel do private(i,j)
2678  do j=jsta_2l,jend_2u
2679  do i=1,im
2680  rswin(i,j) = spval ! GFS does not have inst incoming sfc shortwave
2681  rswinc(i,j) = spval ! GFS does not have inst incoming clear sky sfc shortwave
2682  rswout(i,j) = spval ! GFS does not have inst outgoing sfc shortwave
2683  enddo
2684  enddo
2685 
2686 ! GFS incoming sfc longwave has been averaged, set ARDLW to 1
2687  ardsw=1.0
2688 ! trdsw=6.0
2689 
2690 ! time averaged incoming sfc shortwave using gfsio
2691  varname='dswrf_ave'
2692  vcoordname='sfc'
2693  l=1
2694  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2695  ,l,nrec,fldsize,spval,tmp &
2696  ,recname,reclevtyp,reclev,varname,vcoordname &
2697  ,aswin)
2698 ! if(debugprint)print*,'sample l',VarName,' = ',1,aswin(isa,jsa)
2699 
2700 ! inst incoming sfc shortwave using nemsio
2701  varname='dswrf'
2702  vcoordname='sfc'
2703  l=1
2704  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2705  ,l,nrec,fldsize,spval,tmp &
2706  ,recname,reclevtyp,reclev,varname,vcoordname &
2707  ,rswin)
2708 
2709 ! time averaged incoming sfc uv-b using getgb
2710  varname='duvb_ave'
2711  vcoordname='sfc'
2712  l=1
2713  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2714  ,l,nrec,fldsize,spval,tmp &
2715  ,recname,reclevtyp,reclev,varname,vcoordname &
2716  ,auvbin)
2717 ! if(debugprint)print*,'sample l',VarName,' = ',1,auvbin(isa,jsa)
2718 
2719 ! time averaged incoming sfc clear sky uv-b using getgb
2720  varname='cduvb_ave'
2721  vcoordname='sfc'
2722  l=1
2723  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2724  ,l,nrec,fldsize,spval,tmp &
2725  ,recname,reclevtyp,reclev,varname,vcoordname &
2726  ,auvbinc)
2727 ! if(debugprint)print*,'sample l',VarName,' = ',1,auvbinc(isa,jsa)
2728 
2729 ! time averaged outgoing sfc shortwave using gfsio
2730  varname='uswrf_ave'
2731  vcoordname='sfc'
2732  l=1
2733  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2734  ,l,nrec,fldsize,spval,tmp &
2735  ,recname,reclevtyp,reclev,varname,vcoordname &
2736  ,aswout)
2737 ! where(aswout /= spval) aswout=-aswout ! CLDRAD puts a minus sign before gribbing
2738 !$omp parallel do private(i,j)
2739  do j=jsta,jend
2740  do i=1,im
2741  if (aswout(i,j) /= spval) aswout(i,j) = -aswout(i,j)
2742  enddo
2743  enddo
2744 ! if(debugprint)print*,'sample l',VarName,' = ',1,aswout(isa,jsa)
2745 
2746 ! inst outgoing sfc shortwave using gfsio
2747  varname='uswrf'
2748  vcoordname='sfc'
2749  l=1
2750  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2751  ,l,nrec,fldsize,spval,tmp &
2752  ,recname,reclevtyp,reclev,varname,vcoordname &
2753  ,rswout)
2754 
2755 ! time averaged model top incoming shortwave
2756  varname='dswrf_ave'
2757  vcoordname='nom. top'
2758  l=1
2759  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2760  ,l,nrec,fldsize,spval,tmp &
2761  ,recname,reclevtyp,reclev,varname,vcoordname &
2762  ,aswintoa)
2763 
2764 ! if(debugprint)print*,'sample l',VarName,' = ',1,aswintoa(isa,jsa)
2765 
2766 ! time averaged model top outgoing shortwave
2767  varname='uswrf_ave'
2768  vcoordname='nom. top'
2769  l=1
2770  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2771  ,l,nrec,fldsize,spval,tmp &
2772  ,recname,reclevtyp,reclev,varname,vcoordname &
2773  ,aswtoa)
2774 ! if(debugprint)print*,'sample l',VarName,' = ',1,aswtoa(isa,jsa)
2775 
2776 ! time averaged surface sensible heat flux, multiplied by -1 because wrf model flux
2777 ! has reversed sign convention using gfsio
2778  varname='shtfl_ave'
2779  vcoordname='sfc'
2780  l=1
2781  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2782  ,l,nrec,fldsize,spval,tmp &
2783  ,recname,reclevtyp,reclev,varname,vcoordname &
2784  ,sfcshx)
2785 ! where (sfcshx /= spval)sfcshx=-sfcshx
2786 !$omp parallel do private(i,j)
2787  do j=jsta,jend
2788  do i=1,im
2789  if (sfcshx(i,j) /= spval) sfcshx(i,j) = -sfcshx(i,j)
2790  enddo
2791  enddo
2792 ! if(debugprint)print*,'sample l',VarName,' = ',1,sfcshx(isa,jsa)
2793 
2794 ! inst surface sensible heat flux
2795  varname='shtfl'
2796  vcoordname='sfc'
2797  l=1
2798  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2799  ,l,nrec,fldsize,spval,tmp &
2800  ,recname,reclevtyp,reclev,varname,vcoordname &
2801  ,twbs)
2802 !$omp parallel do private(i,j)
2803  do j=jsta,jend
2804  do i=1,im
2805  if (twbs(i,j) /= spval) twbs(i,j) = -twbs(i,j)
2806  enddo
2807  enddo
2808 
2809 ! GFS surface flux has been averaged, set ASRFC to 1
2810  asrfc=1.0
2811 ! tsrfc=6.0
2812 
2813 ! time averaged surface latent heat flux, multiplied by -1 because wrf model flux
2814 ! has reversed sign vonvention using gfsio
2815  varname='lhtfl_ave'
2816  vcoordname='sfc'
2817  l=1
2818  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2819  ,l,nrec,fldsize,spval,tmp &
2820  ,recname,reclevtyp,reclev,varname,vcoordname &
2821  ,sfclhx)
2822 ! where (sfclhx /= spval)sfclhx=-sfclhx
2823 !$omp parallel do private(i,j)
2824  do j=jsta,jend
2825  do i=1,im
2826  if (sfclhx(i,j) /= spval) sfclhx(i,j) = -sfclhx(i,j)
2827  enddo
2828  enddo
2829 ! if(debugprint)print*,'sample l',VarName,' = ',1,sfclhx(isa,jsa)
2830 
2831 ! inst surface latent heat flux
2832  varname='lhtfl'
2833  vcoordname='sfc'
2834  l=1
2835  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2836  ,l,nrec,fldsize,spval,tmp &
2837  ,recname,reclevtyp,reclev,varname,vcoordname &
2838  ,qwbs)
2839 ! where (sfclhx /= spval)sfclhx=-sfclhx
2840 !$omp parallel do private(i,j)
2841  do j=jsta,jend
2842  do i=1,im
2843  if (qwbs(i,j) /= spval) qwbs(i,j) = -qwbs(i,j)
2844  enddo
2845  enddo
2846 
2847 ! time averaged ground heat flux using nemsio
2848  varname='gflux_ave'
2849  vcoordname='sfc'
2850  l=1
2851  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2852  ,l,nrec,fldsize,spval,tmp &
2853  ,recname,reclevtyp,reclev,varname,vcoordname &
2854  ,subshx)
2855 ! mask water areas
2856 !$omp parallel do private(i,j)
2857  do j=jsta,jend
2858  do i=1,im
2859  if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) subshx(i,j) = spval
2860  enddo
2861  enddo
2862 ! if(debugprint)print*,'sample l',VarName,' = ',1,subshx(isa,jsa)
2863 
2864 ! inst ground heat flux using nemsio
2865  varname='gflux'
2866  vcoordname='sfc'
2867  l=1
2868  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2869  ,l,nrec,fldsize,spval,tmp &
2870  ,recname,reclevtyp,reclev,varname,vcoordname &
2871  ,grnflx)
2872 ! mask water areas
2873 !$omp parallel do private(i,j)
2874  do j=jsta,jend
2875  do i=1,im
2876  if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) grnflx(i,j) = spval
2877  enddo
2878  enddo
2879 ! time averaged zonal momentum flux using gfsio
2880  varname='uflx_ave'
2881  vcoordname='sfc'
2882  l=1
2883  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2884  ,l,nrec,fldsize,spval,tmp &
2885  ,recname,reclevtyp,reclev,varname,vcoordname &
2886  ,sfcux)
2887 ! if(debugprint)print*,'sample l',VarName,' = ',1,sfcux(isa,jsa)
2888 
2889 ! time averaged meridional momentum flux using nemsio
2890  varname='vflx_ave'
2891  vcoordname='sfc'
2892  l=1
2893  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2894  ,l,nrec,fldsize,spval,tmp &
2895  ,recname,reclevtyp,reclev,varname,vcoordname &
2896  ,sfcvx)
2897 ! if(debugprint)print*,'sample l',VarName,' = ',1,sfcvx(isa,jsa)
2898 
2899 !$omp parallel do private(i,j)
2900  do j=jsta_2l,jend_2u
2901  do i=1,im
2902 ! snopcx(i,j) =spval ! GFS does not have snow phase change heat flux
2903  sfcuvx(i,j) = spval ! GFS does not use total momentum flux
2904  enddo
2905  enddo
2906 
2907 ! time averaged zonal gravity wave stress using nemsio
2908  varname='u-gwd_ave'
2909  vcoordname='sfc'
2910  l=1
2911  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2912  ,l,nrec,fldsize,spval,tmp &
2913  ,recname,reclevtyp,reclev,varname,vcoordname &
2914  ,gtaux)
2915 
2916 ! if(debugprint)print*,'sample l',VarName,' = ',1,gtaux(isa,jsa)
2917 
2918 ! time averaged meridional gravity wave stress using getgb
2919  varname='v-gwd_ave'
2920  vcoordname='sfc'
2921  l=1
2922  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2923  ,l,nrec,fldsize,spval,tmp &
2924  ,recname,reclevtyp,reclev,varname,vcoordname &
2925  ,gtauy)
2926 ! if(debugprint)print*,'sample l',VarName,' = ',1,gtauy(isa,jsa)
2927 
2928 ! time averaged accumulated potential evaporation
2929  varname='pevpr_ave'
2930  vcoordname='sfc'
2931  l=1
2932  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2933  ,l,nrec,fldsize,spval,tmp &
2934  ,recname,reclevtyp,reclev,varname,vcoordname &
2935  ,avgpotevp)
2936 ! mask water areas
2937 !$omp parallel do private(i,j)
2938  do j=jsta,jend
2939  do i=1,im
2940  if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) avgpotevp(i,j) = spval
2941  enddo
2942  enddo
2943 ! if(debugprint)print*,'sample l',VarName,' = ',1,potevp(isa,jsa)
2944 
2945 ! inst potential evaporation
2946  varname='pevpr'
2947  vcoordname='sfc'
2948  l=1
2949  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2950  ,l,nrec,fldsize,spval,tmp &
2951  ,recname,reclevtyp,reclev,varname,vcoordname &
2952  ,potevp)
2953 ! mask water areas
2954 !$omp parallel do private(i,j)
2955  do j=jsta,jend
2956  do i=1,im
2957  if (sm(i,j) == 1.0 .and. sice(i,j) ==0.) potevp(i,j) = spval
2958  enddo
2959  enddo
2960 
2961  do l=1,lm
2962 !$omp parallel do private(i,j)
2963  do j=jsta_2l,jend_2u
2964  do i=1,im
2965 ! GFS does not have temperature tendency due to long wave radiation
2966  rlwtt(i,j,l) = spval
2967 ! GFS does not have temperature tendency due to short wave radiation
2968  rswtt(i,j,l) = spval
2969 ! GFS does not have temperature tendency due to latent heating from convection
2970  tcucn(i,j,l) = spval
2971  tcucns(i,j,l) = spval
2972 ! GFS does not have temperature tendency due to latent heating from grid scale
2973  train(i,j,l) = spval
2974  enddo
2975  enddo
2976  enddo
2977 
2978 ! set avrain to 1
2979  avrain=1.0
2980  avcnvc=1.0
2981  theat=6.0 ! just in case GFS decides to output T tendency
2982 
2983 ! 10 m u using nemsio
2984  varname='ugrd'
2985  vcoordname='10 m above gnd'
2986  l=1
2987  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
2988  ,l,nrec,fldsize,spval,tmp &
2989  ,recname,reclevtyp,reclev,varname,vcoordname &
2990  ,u10)
2991 
2992  do j=jsta,jend
2993  do i=1,im
2994  u10h(i,j)=u10(i,j)
2995  end do
2996  end do
2997 ! if(debugprint)print*,'sample l',VarName,' = ',1,u10(isa,jsa)
2998 
2999 ! 10 m v using gfsio
3000  varname='vgrd'
3001  vcoordname='10 m above gnd'
3002  l=1
3003  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3004  ,l,nrec,fldsize,spval,tmp &
3005  ,recname,reclevtyp,reclev,varname,vcoordname &
3006  ,v10)
3007 
3008  do j=jsta,jend
3009  do i=1,im
3010  v10h(i,j)=v10(i,j)
3011  end do
3012  end do
3013 ! if(debugprint)print*,'sample l',VarName,' = ',1,v10(isa,jsa)
3014 
3015 ! vegetation type, it's in GFS surface file, hopefully will merge into gfsio soon
3016 ! VarName='vgtyp'
3017 !Use for fv3 model output
3018  varname='vtype'
3019  vcoordname='sfc'
3020  l=1
3021  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3022  ,l,nrec,fldsize,spval,tmp &
3023  ,recname,reclevtyp,reclev,varname,vcoordname &
3024  ,buf)
3025 ! where (buf /= spval)
3026 ! ivgtyp=nint(buf)
3027 ! elsewhere
3028 ! ivgtyp=0 !need to feed reasonable value to crtm
3029 ! end where
3030 !$omp parallel do private(i,j)
3031  do j = jsta_2l, jend_2u
3032  do i=1,im
3033  if (buf(i,j) < spval) then
3034  ivgtyp(i,j) = nint(buf(i,j))
3035  else
3036  ivgtyp(i,j) = 0
3037  endif
3038  enddo
3039  enddo
3040 ! if(debugprint)print*,'sample l',VarName,' = ',1,ivgtyp(isa,jsa)
3041 
3042 ! soil type, it's in GFS surface file, hopefully will merge into gfsio soon
3043  varname='sotyp'
3044  vcoordname='sfc'
3045  l=1
3046  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3047  ,l,nrec,fldsize,spval,tmp &
3048  ,recname,reclevtyp,reclev,varname,vcoordname &
3049  ,buf)
3050 ! where (buf /= spval)
3051 ! isltyp=nint(buf)
3052 ! elsewhere
3053 ! isltyp=0 !need to feed reasonable value to crtm
3054 ! end where
3055 !$omp parallel do private(i,j)
3056  do j = jsta_2l, jend_2u
3057  do i=1,im
3058  if (buf(i,j) < spval) then
3059  isltyp(i,j) = nint(buf(i,j))
3060  else
3061  isltyp(i,j) = 0 !need to feed reasonable value to crtm
3062  endif
3063  enddo
3064  enddo
3065 ! if(debugprint)print*,'sample l',VarName,' = ',1,isltyp(isa,jsa)
3066 
3067 !$omp parallel do private(i,j)
3068  do j=jsta_2l,jend_2u
3069  do i=1,im
3070  smstav(i,j) = spval ! GFS does not have soil moisture availability
3071 ! smstot(i,j) = spval ! GFS does not have total soil moisture
3072  sfcevp(i,j) = spval ! GFS does not have accumulated surface evaporation
3073  acsnow(i,j) = spval ! GFS does not have averaged accumulated snow
3074  acsnom(i,j) = spval ! GFS does not have snow melt
3075 ! sst(i,j) = spval ! GFS does not have sst????
3076  thz0(i,j) = ths(i,j) ! GFS does not have THZ0, use THS to substitute
3077  qz0(i,j) = spval ! GFS does not output humidity at roughness length
3078  uz0(i,j) = spval ! GFS does not output u at roughness length
3079  vz0(i,j) = spval ! GFS does not output humidity at roughness length
3080  enddo
3081  enddo
3082  do l=1,lm
3083 !$omp parallel do private(i,j)
3084  do j=jsta_2l,jend_2u
3085  do i=1,im
3086  el_pbl(i,j,l) = spval ! GFS does not have mixing length
3087  exch_h(i,j,l) = spval ! GFS does not output exchange coefficient
3088  enddo
3089  enddo
3090  enddo
3091 ! if(debugprint)print*,'sample l',VarName,' = ',1,thz0(isa,jsa)
3092 
3093 ! retrieve inst convective cloud top, GFS has cloud top pressure instead of index,
3094 ! will need to modify CLDRAD.f to use pressure directly instead of index
3095  varname='pres'
3096  vcoordname='convect-cld top'
3097  l=1
3098  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3099  ,l,nrec,fldsize,spval,tmp &
3100  ,recname,reclevtyp,reclev,varname,vcoordname &
3101  ,ptop)
3102 ! if(debugprint)print*,'sample l',VarName,' = ',1,ptop(isa,jsa)
3103 
3104 !$omp parallel do private(i,j)
3105  do j=jsta,jend
3106  do i=1,im
3107  htop(i,j) = spval
3108  if(ptop(i,j) <= 0.0) ptop(i,j) = spval
3109  enddo
3110  enddo
3111  do j=jsta,jend
3112  do i=1,im
3113  if(ptop(i,j) < spval)then
3114  do l=1,lm
3115  if(ptop(i,j) <= pmid(i,j,l))then
3116  htop(i,j) = l
3117 ! if(i==ii .and. j==jj)print*,'sample ptop,pmid pmid-1,pint= ', &
3118 ! ptop(i,j),pmid(i,j,l),pmid(i,j,l-1),pint(i,j,l),htop(i,j)
3119  exit
3120  end if
3121  end do
3122  end if
3123  end do
3124  end do
3125 
3126 ! retrieve inst convective cloud bottom, GFS has cloud top pressure instead of index,
3127 ! will need to modify CLDRAD.f to use pressure directly instead of index
3128  varname='pres'
3129  vcoordname='convect-cld bot'
3130  l=1
3131  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3132  ,l,nrec,fldsize,spval,tmp &
3133  ,recname,reclevtyp,reclev,varname,vcoordname &
3134  ,pbot)
3135 ! if(debugprint)print*,'sample l',VarName,VcoordName,' = ',1,pbot(isa,jsa)
3136 
3137 !$omp parallel do private(i,j)
3138  do j=jsta,jend
3139  do i=1,im
3140  hbot(i,j) = spval
3141  if(pbot(i,j) <= 0.0) pbot(i,j) = spval
3142  enddo
3143  enddo
3144  do j=jsta,jend
3145  do i=1,im
3146 ! if(.not.lb(i,j))print*,'false bitmask for pbot at '
3147 ! + ,i,j,pbot(i,j)
3148  if(pbot(i,j) < spval)then
3149  do l=lm,1,-1
3150  if(pbot(i,j) >= pmid(i,j,l)) then
3151  hbot(i,j) = l
3152 ! if(i==ii .and. j==jj)print*,'sample pbot,pmid= ', &
3153 ! pbot(i,j),pmid(i,j,l),hbot(i,j)
3154  exit
3155  end if
3156  end do
3157  end if
3158  end do
3159  end do
3160 
3161 ! retrieve time averaged low cloud top pressure using nemsio
3162  varname='pres_ave'
3163  vcoordname='low cld top'
3164  l=1
3165  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3166  ,l,nrec,fldsize,spval,tmp &
3167  ,recname,reclevtyp,reclev,varname,vcoordname &
3168  ,ptopl)
3169 ! if(debugprint)print*,'sample l',VarName,' = ',1,ptopl(isa,jsa)
3170 
3171 ! retrieve time averaged low cloud bottom pressure using nemsio
3172  varname='pres_ave'
3173  vcoordname='low cld bot'
3174  l=1
3175  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3176  ,l,nrec,fldsize,spval,tmp &
3177  ,recname,reclevtyp,reclev,varname,vcoordname &
3178  ,pbotl)
3179 ! if(debugprint)print*,'sample l',VarName,' = ',1,pbotl(isa,jsa)
3180 
3181 ! retrieve time averaged low cloud top temperature using nemsio
3182  varname='tmp_ave'
3183  vcoordname='low cld top'
3184  l=1
3185  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3186  ,l,nrec,fldsize,spval,tmp &
3187  ,recname,reclevtyp,reclev,varname,vcoordname &
3188  ,ttopl)
3189 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopl(isa,jsa)
3190 
3191 ! retrieve time averaged middle cloud top pressure using nemsio
3192  varname='pres_ave'
3193  vcoordname='mid cld top'
3194  l=1
3195  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3196  ,l,nrec,fldsize,spval,tmp &
3197  ,recname,reclevtyp,reclev,varname,vcoordname &
3198  ,ptopm)
3199 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptopm(isa,jsa)
3200 
3201 ! retrieve time averaged middle cloud bottom pressure using nemsio
3202  varname='pres_ave'
3203  vcoordname='mid cld bot'
3204  l=1
3205  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3206  ,l,nrec,fldsize,spval,tmp &
3207  ,recname,reclevtyp,reclev,varname,vcoordname &
3208  ,pbotm)
3209 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pbotm(isa,jsa)
3210 
3211 ! retrieve time averaged middle cloud top temperature using nemsio
3212  varname='tmp_ave'
3213  vcoordname='mid cld top'
3214  l=1
3215  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3216  ,l,nrec,fldsize,spval,tmp &
3217  ,recname,reclevtyp,reclev,varname,vcoordname &
3218  ,ttopm)
3219 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttopm(isa,jsa)
3220 
3221 ! retrieve time averaged high cloud top pressure using nemsio *********
3222  varname='pres_ave'
3223  vcoordname='high cld top'
3224  l=1
3225  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3226  ,l,nrec,fldsize,spval,tmp &
3227  ,recname,reclevtyp,reclev,varname,vcoordname &
3228  ,ptoph)
3229 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,ptoph(isa,jsa)
3230 
3231 ! retrieve time averaged high cloud bottom pressure using nemsio
3232  varname='pres_ave'
3233  vcoordname='high cld bot'
3234  l=1
3235  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3236  ,l,nrec,fldsize,spval,tmp &
3237  ,recname,reclevtyp,reclev,varname,vcoordname &
3238  ,pboth)
3239 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,pboth(isa,jsa)
3240 
3241 ! retrieve time averaged high cloud top temperature using nemsio
3242  varname='tmp_ave'
3243  vcoordname='high cld top'
3244  l=1
3245  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3246  ,l,nrec,fldsize,spval,tmp &
3247  ,recname,reclevtyp,reclev,varname,vcoordname &
3248  ,ttoph)
3249 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',1,Ttoph(isa,jsa)
3250 
3251 ! retrieve boundary layer cloud cover using nemsio
3252  varname='tcdc_ave'
3253  vcoordname='bndary-layer cld'
3254  l=1
3255  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3256  ,l,nrec,fldsize,spval,tmp &
3257  ,recname,reclevtyp,reclev,varname,vcoordname &
3258  ,pblcfr)
3259 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,pblcfr(isa,jsa)
3260 ! where (pblcfr /= spval)pblcfr=pblcfr/100. ! convert to fraction
3261 !$omp parallel do private(i,j)
3262  do j = jsta_2l, jend_2u
3263  do i=1,im
3264  if (pblcfr(i,j) < spval) pblcfr(i,j) = pblcfr(i,j) * 0.01
3265  enddo
3266  enddo
3267 
3268 ! retrieve cloud work function using nemsio
3269  varname='cwork_ave'
3270  vcoordname='atmos col'
3271  l=1
3272  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3273  ,l,nrec,fldsize,spval,tmp &
3274  ,recname,reclevtyp,reclev,varname,vcoordname &
3275  ,cldwork)
3276 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,cldwork(isa,jsa)
3277 
3278 ! retrieve water runoff using nemsio
3279  varname='watr_acc'
3280  vcoordname='sfc'
3281  l=1
3282  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3283  ,l,nrec,fldsize,spval,tmp &
3284  ,recname,reclevtyp,reclev,varname,vcoordname &
3285  ,runoff)
3286 ! mask water areas
3287 !$omp parallel do private(i,j)
3288  do j=jsta,jend
3289  do i=1,im
3290  if (sm(i,j) /= 0.0) runoff(i,j) = spval
3291  enddo
3292  enddo
3293 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,runoff(isa,jsa)
3294 
3295 ! retrieve shelter max temperature using nemsio
3296  varname='tmax_max'
3297  vcoordname='2 m above gnd'
3298  l=1
3299  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3300  ,l,nrec,fldsize,spval,tmp &
3301  ,recname,reclevtyp,reclev,varname,vcoordname &
3302  ,maxtshltr)
3303 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,maxtshltr(isa,jsa)
3304 
3305 ! retrieve shelter min temperature using nemsio
3306  varname='tmin_min'
3307  vcoordname='2 m above gnd'
3308  l=1
3309  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3310  ,l,nrec,fldsize,spval,tmp &
3311  ,recname,reclevtyp,reclev,varname,vcoordname &
3312  ,mintshltr)
3313 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', &
3314 ! 1,mintshltr(im/2,(jsta+jend)/2)
3315 
3316 !$omp parallel do private(i,j)
3317  do j=jsta_2l,jend_2u
3318  do i=1,im
3319  maxrhshltr(i,j) = spval
3320  minrhshltr(i,j) = spval
3321  enddo
3322  enddo
3323 
3324 ! retrieve ice thickness using nemsio
3325  varname='icetk'
3326  vcoordname='sfc'
3327  l=1
3328  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3329  ,l,nrec,fldsize,spval,tmp &
3330  ,recname,reclevtyp,reclev,varname,vcoordname &
3331  ,dzice)
3332 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,dzice(isa,jsa)
3333 
3334 ! retrieve wilting point using nemsio
3335  varname='wilt'
3336  vcoordname='sfc'
3337  l=1
3338  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3339  ,l,nrec,fldsize,spval,tmp &
3340  ,recname,reclevtyp,reclev,varname,vcoordname &
3341  ,smcwlt)
3342 ! mask water areas
3343 !$omp parallel do private(i,j)
3344  do j=jsta,jend
3345  do i=1,im
3346  if (sm(i,j) /= 0.0) smcwlt(i,j) = spval
3347  enddo
3348  enddo
3349 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,smcwlt(isa,jsa)
3350 
3351 ! retrieve sunshine duration using nemsio
3352  varname='sunsd_acc'
3353  vcoordname='sfc'
3354  l=1
3355  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3356  ,l,nrec,fldsize,spval,tmp &
3357  ,recname,reclevtyp,reclev,varname,vcoordname &
3358  ,suntime)
3359 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,suntime(isa,jsa)
3360 
3361 ! retrieve field capacity using nemsio
3362  varname='fldcp'
3363  vcoordname='sfc'
3364  l=1
3365  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3366  ,l,nrec,fldsize,spval,tmp &
3367  ,recname,reclevtyp,reclev,varname,vcoordname &
3368  ,fieldcapa)
3369 ! mask water areas
3370 !$omp parallel do private(i,j)
3371  do j=jsta,jend
3372  do i=1,im
3373  if (sm(i,j) /= 0.0) fieldcapa(i,j) = spval
3374  enddo
3375  enddo
3376 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ', 1,fieldcapa(isa,jsa)
3377 
3378 ! retrieve time averaged surface visible beam downward solar flux
3379  varname='vbdsf_ave'
3380  vcoordname='sfc'
3381  l=1
3382  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3383  ,l,nrec,fldsize,spval,tmp &
3384  ,recname,reclevtyp,reclev,varname,vcoordname &
3385  ,avisbeamswin)
3386 
3387 ! retrieve time averaged surface visible diffuse downward solar flux
3388  varname='vddsf_ave'
3389  vcoordname='sfc'
3390  l=1
3391  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3392  ,l,nrec,fldsize,spval,tmp &
3393  ,recname,reclevtyp,reclev,varname,vcoordname &
3394  ,avisdiffswin)
3395 
3396 ! retrieve time averaged surface near IR beam downward solar flux
3397  varname='nbdsf_ave'
3398  vcoordname='sfc'
3399  l=1
3400  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3401  ,l,nrec,fldsize,spval,tmp &
3402  ,recname,reclevtyp,reclev,varname,vcoordname &
3403  ,airbeamswin)
3404 
3405 ! retrieve time averaged surface near IR diffuse downward solar flux
3406  varname='nddsf_ave'
3407  vcoordname='sfc'
3408  l=1
3409  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3410  ,l,nrec,fldsize,spval,tmp &
3411  ,recname,reclevtyp,reclev,varname,vcoordname &
3412  ,airdiffswin)
3413 
3414 ! retrieve time averaged surface clear sky outgoing LW
3415  varname='csulf'
3416  vcoordname='sfc'
3417  l=1
3418  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3419  ,l,nrec,fldsize,spval,tmp &
3420  ,recname,reclevtyp,reclev,varname,vcoordname &
3421  ,alwoutc)
3422 
3423 ! retrieve time averaged TOA clear sky outgoing LW
3424  varname='csulf'
3425  vcoordname='nom. top'
3426  l=1
3427  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3428  ,l,nrec,fldsize,spval,tmp &
3429  ,recname,reclevtyp,reclev,varname,vcoordname &
3430  ,alwtoac)
3431 
3432 ! retrieve time averaged surface clear sky outgoing SW
3433  varname='csusf'
3434  vcoordname='sfc'
3435  l=1
3436  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3437  ,l,nrec,fldsize,spval,tmp &
3438  ,recname,reclevtyp,reclev,varname,vcoordname &
3439  ,aswoutc)
3440 
3441 ! retrieve time averaged TOA clear sky outgoing LW
3442  varname='csusf'
3443  vcoordname='nom. top'
3444  l=1
3445  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3446  ,l,nrec,fldsize,spval,tmp &
3447  ,recname,reclevtyp,reclev,varname,vcoordname &
3448  ,aswtoac)
3449 
3450 ! retrieve time averaged surface clear sky incoming LW
3451  varname='csdlf'
3452  vcoordname='sfc'
3453  l=1
3454  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3455  ,l,nrec,fldsize,spval,tmp &
3456  ,recname,reclevtyp,reclev,varname,vcoordname &
3457  ,alwinc)
3458 
3459 ! retrieve time averaged surface clear sky incoming SW
3460  varname='csdsf'
3461  vcoordname='sfc'
3462  l=1
3463  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3464  ,l,nrec,fldsize,spval,tmp &
3465  ,recname,reclevtyp,reclev,varname,vcoordname &
3466  ,aswinc)
3467 
3468 ! retrieve shelter max specific humidity using nemsio
3469  varname='spfhmax_max'
3470  vcoordname='2 m above gnd'
3471  l=1
3472  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3473  ,l,nrec,fldsize,spval,tmp &
3474  ,recname,reclevtyp,reclev,varname,vcoordname &
3475  ,maxqshltr)
3476 ! if(debugprint)print*,'sample l',VcoordName,VarName,' = ',
3477 ! 1,maxtshltr(isa,jsa)
3478 
3479 ! retrieve shelter min temperature using nemsio
3480  varname='spfhmin_min'
3481  vcoordname='2 m above gnd'
3482  l=1
3483  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3484  ,l,nrec,fldsize,spval,tmp &
3485  ,recname,reclevtyp,reclev,varname,vcoordname &
3486  ,minqshltr)
3487 
3488 ! retrieve storm runoff using nemsio
3489  varname='ssrun_acc'
3490  vcoordname='sfc'
3491  l=1
3492  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3493  ,l,nrec,fldsize,spval,tmp &
3494  ,recname,reclevtyp,reclev,varname,vcoordname &
3495  ,ssroff)
3496 ! mask water areas
3497 !$omp parallel do private(i,j)
3498  do j=jsta,jend
3499  do i=1,im
3500  if (sm(i,j) /= 0.0) ssroff(i,j) = spval
3501  enddo
3502  enddo
3503 
3504 ! retrieve direct soil evaporation
3505  varname='evbs_ave'
3506  vcoordname='sfc'
3507  l=1
3508  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3509  ,l,nrec,fldsize,spval,tmp &
3510  ,recname,reclevtyp,reclev,varname,vcoordname &
3511  ,avgedir)
3512 ! mask water areas
3513 !$omp parallel do private(i,j)
3514  do j=jsta,jend
3515  do i=1,im
3516  if (sm(i,j) /= 0.0) avgedir(i,j) = spval
3517  enddo
3518  enddo
3519 
3520 ! retrieve CANOPY WATER EVAP
3521  varname='evcw_ave'
3522  vcoordname='sfc'
3523  l=1
3524  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3525  ,l,nrec,fldsize,spval,tmp &
3526  ,recname,reclevtyp,reclev,varname,vcoordname &
3527  ,avgecan)
3528 ! mask water areas
3529 !$omp parallel do private(i,j)
3530  do j=jsta,jend
3531  do i=1,im
3532  if (sm(i,j) /= 0.0) avgecan(i,j) = spval
3533  enddo
3534  enddo
3535 
3536 ! retrieve PLANT TRANSPIRATION
3537  varname='trans_ave'
3538  vcoordname='sfc'
3539  l=1
3540  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3541  ,l,nrec,fldsize,spval,tmp &
3542  ,recname,reclevtyp,reclev,varname,vcoordname &
3543  ,avgetrans)
3544 ! mask water areas
3545 !$omp parallel do private(i,j)
3546  do j=jsta,jend
3547  do i=1,im
3548  if (sm(i,j) /= 0.0) avgetrans(i,j) = spval
3549  enddo
3550  enddo
3551 
3552 ! retrieve snow sublimation
3553  varname='sbsno_ave'
3554  vcoordname='sfc'
3555  l=1
3556  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3557  ,l,nrec,fldsize,spval,tmp &
3558  ,recname,reclevtyp,reclev,varname,vcoordname &
3559  ,avgesnow)
3560 ! mask water areas
3561 !$omp parallel do private(i,j)
3562  do j=jsta,jend
3563  do i=1,im
3564  if (sm(i,j)==1.0 .and. sice(i,j)==0.) avgesnow(i,j)=spval
3565  enddo
3566  enddo
3567 
3568 ! retrive total soil moisture
3569  varname='soilm'
3570  vcoordname='0-200 cm down'
3571  l=1
3572  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3573  ,l,nrec,fldsize,spval,tmp &
3574  ,recname,reclevtyp,reclev,varname,vcoordname &
3575  ,smstot)
3576 ! mask water areas
3577 !$omp parallel do private(i,j)
3578  do j=jsta,jend
3579  do i=1,im
3580  if (sm(i,j) /= 0.0) smstot(i,j) = spval
3581  enddo
3582  enddo
3583 
3584 ! retrieve snow phase change heat flux
3585  varname='snohf'
3586  vcoordname='sfc'
3587  l=1
3588  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3589  ,l,nrec,fldsize,spval,tmp &
3590  ,recname,reclevtyp,reclev,varname,vcoordname &
3591  ,snopcx)
3592 ! mask water areas
3593 !$omp parallel do private(i,j)
3594  do j=jsta,jend
3595  do i=1,im
3596  if (sm(i,j) /= 0.0) snopcx(i,j) = spval
3597  enddo
3598  enddo
3599 
3600 ! GFS does not have deep convective cloud top and bottom fields
3601 
3602 !$omp parallel do private(i,j)
3603  do j=jsta,jend
3604  do i=1,im
3605  htopd(i,j) = spval
3606  hbotd(i,j) = spval
3607  htops(i,j) = spval
3608  hbots(i,j) = spval
3609  cuppt(i,j) = spval
3610  enddo
3611  enddo
3612 
3613  if ((gocart_on .or. gccpp_on) .and. d2d_chem ) then
3614 ! retrieve dust emission fluxes
3615  do k = 1, nbin_du
3616  if ( k == 1) varname='duem001'
3617  if ( k == 2) varname='duem002'
3618  if ( k == 3) varname='duem003'
3619  if ( k == 4) varname='duem004'
3620  if ( k == 5) varname='duem005'
3621  vcoordname='sfc'
3622  l=1
3623  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3624  ,l,nrec,fldsize,spval,tmp &
3625  ,recname,reclevtyp,reclev,varname,vcoordname&
3626  ,duem(1,jsta_2l,k))
3627 ! if(debugprint)print*,'sample ',VarName,' = ',duem(isa,jsa,k)
3628  enddo
3629 
3630 ! retrieve dust sedimentation fluxes
3631  do k = 1, nbin_du
3632  if ( k == 1) varname='dust1sd'
3633  if ( k == 2) varname='dust2sd'
3634  if ( k == 3) varname='dust3sd'
3635  if ( k == 4) varname='dust4sd'
3636  if ( k == 5) varname='dsut5sd'
3637  vcoordname='sfc'
3638  l=1
3639  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3640  ,l,nrec,fldsize,spval,tmp &
3641  ,recname,reclevtyp,reclev,varname,vcoordname&
3642  ,dusd(1,jsta_2l,k))
3643 ! if(debugprint)print*,'sample ',VarName,' = ',dusd(isa,jsa,k)
3644  enddo
3645 
3646 ! retrieve dust dry deposition fluxes
3647  do k = 1, nbin_du
3648  if ( k == 1) varname='dust1dp'
3649  if ( k == 2) varname='dust2dp'
3650  if ( k == 3) varname='dust3dp'
3651  if ( k == 4) varname='dust4dp'
3652  if ( k == 5) varname='dust5dp'
3653  vcoordname='sfc'
3654  l=1
3655  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3656  ,l,nrec,fldsize,spval,tmp &
3657  ,recname,reclevtyp,reclev,varname,vcoordname&
3658  ,dudp(1,jsta_2l,k))
3659  print *,'dudp,ck=',maxval(dudp(1:im,jsta:jend,k)), &
3660  minval(dudp(1:im,jsta:jend,k))
3661 ! if(debugprint)print*,'sample ',VarName,' = ',dudp(isa,jsa,k)
3662  enddo
3663 
3664 ! retrieve dust wet deposition fluxes
3665  do k = 1, nbin_du
3666  if ( k == 1) varname='dust1wtl'
3667  if ( k == 2) varname='dust2wtl'
3668  if ( k == 3) varname='dust3wtl'
3669  if ( k == 4) varname='dust4wtl'
3670  if ( k == 5) varname='dust5wtl'
3671  vcoordname='sfc'
3672  l=1
3673  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3674  ,l,nrec,fldsize,spval,tmp &
3675  ,recname,reclevtyp,reclev,varname,vcoordname&
3676  ,duwt(1,jsta_2l,k))
3677  enddo
3678 ! retrieve dust scavenging fluxes
3679  do k = 1, nbin_du
3680  if ( k == 1) varname='dust1wtc'
3681  if ( k == 2) varname='dust2wtc'
3682  if ( k == 3) varname='dust3wtc'
3683  if ( k == 4) varname='dust4wtc'
3684  if ( k == 5) varname='dust5wtc'
3685  vcoordname='sfc'
3686  l=1
3687  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3688  ,l,nrec,fldsize,spval,tmp &
3689  ,recname,reclevtyp,reclev,varname,vcoordname&
3690  ,dusv(1,jsta_2l,k))
3691  enddo
3692 
3693 ! retrieve seasalt emission fluxes
3694  do k = 1, nbin_ss
3695  if ( k == 1) varname='ssem001'
3696  if ( k == 2) varname='ssem002'
3697  if ( k == 3) varname='ssem003'
3698  if ( k == 4) varname='ssem004'
3699  if ( k == 5) varname='ssem005'
3700  vcoordname='sfc'
3701  l=1
3702  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3703  ,l,nrec,fldsize,spval,tmp &
3704  ,recname,reclevtyp,reclev,varname,vcoordname&
3705  ,ssem(1,jsta_2l,k))
3706  enddo
3707 
3708 ! retrieve seasalt emission fluxes
3709  do k = 1, nbin_ss
3710  if ( k == 1) varname='seas1sd'
3711  if ( k == 2) varname='seas2sd'
3712  if ( k == 3) varname='seas3sd'
3713  if ( k == 4) varname='seas4sd'
3714  if ( k == 5) varname='seas5sd'
3715  vcoordname='sfc'
3716  l=1
3717  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3718  ,l,nrec,fldsize,spval,tmp &
3719  ,recname,reclevtyp,reclev,varname,vcoordname&
3720  ,sssd(1,jsta_2l,k))
3721  enddo
3722 
3723 
3724 ! retrieve seasalt dry deposition fluxes
3725  do k = 1, nbin_ss
3726  if ( k == 1) varname='seas1dp'
3727  if ( k == 2) varname='seas2dp'
3728  if ( k == 3) varname='seas3dp'
3729  if ( k == 4) varname='seas4dp'
3730  if ( k == 5) varname='seas5dp'
3731  vcoordname='sfc'
3732  l=1
3733  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3734  ,l,nrec,fldsize,spval,tmp &
3735  ,recname,reclevtyp,reclev,varname,vcoordname&
3736  ,ssdp(1,jsta_2l,k))
3737  enddo
3738 
3739 ! retrieve seasalt wet deposition fluxes
3740  do k = 1, nbin_ss
3741  if ( k == 1) varname='seas1wtl'
3742  if ( k == 2) varname='seas2wtl'
3743  if ( k == 3) varname='seas3wtl'
3744  if ( k == 4) varname='seas4wtl'
3745  if ( k == 5) varname='seas5wtl'
3746  vcoordname='sfc'
3747  l=1
3748  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3749  ,l,nrec,fldsize,spval,tmp &
3750  ,recname,reclevtyp,reclev,varname,vcoordname&
3751  ,sswt(1,jsta_2l,k))
3752  enddo
3753 
3754 ! retrieve seasalt scavenging fluxes
3755  do k = 1, nbin_ss
3756  if ( k == 1) varname='seas1wtc'
3757  if ( k == 2) varname='seas1wtc'
3758  if ( k == 3) varname='seas1wtc'
3759  if ( k == 4) varname='seas1wtc'
3760  if ( k == 5) varname='seas1wtc'
3761  vcoordname='sfc'
3762  l=1
3763  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3764  ,l,nrec,fldsize,spval,tmp &
3765  ,recname,reclevtyp,reclev,varname,vcoordname&
3766  ,sssv(1,jsta_2l,k))
3767  enddo
3768 
3769 ! retrieve bc emission fluxes
3770  do k = 1, nbin_bc
3771  if ( k == 1) varname='bceman'
3772  if ( k == 2) varname='bcembb'
3773  vcoordname='sfc'
3774  l=1
3775  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3776  ,l,nrec,fldsize,spval,tmp &
3777  ,recname,reclevtyp,reclev,varname,vcoordname&
3778  ,bcem(1,jsta_2l,k))
3779  enddo
3780 
3781 ! retrieve bc sedimentation fluxes
3782  do k = 1, nbin_bc
3783  if ( k == 1) varname='bc1sd'
3784  if ( k == 2) varname='bc2sd'
3785  vcoordname='sfc'
3786  l=1
3787  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3788  ,l,nrec,fldsize,spval,tmp &
3789  ,recname,reclevtyp,reclev,varname,vcoordname&
3790  ,bcsd(1,jsta_2l,k))
3791  enddo
3792 
3793 ! retrieve bc dry deposition fluxes
3794  do k = 1, nbin_bc
3795  if ( k == 1) varname='bc1dp'
3796  if ( k == 2) varname='bc2dp'
3797  vcoordname='sfc'
3798  l=1
3799  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3800  ,l,nrec,fldsize,spval,tmp &
3801  ,recname,reclevtyp,reclev,varname,vcoordname&
3802  ,bcdp(1,jsta_2l,k))
3803  enddo
3804 
3805 ! retrieve bc large wet deposition fluxes
3806  do k = 1, nbin_bc
3807  if ( k == 1) varname='bc1wtl'
3808  if ( k == 2) varname='bc2wtl'
3809  vcoordname='sfc'
3810  l=1
3811  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3812  ,l,nrec,fldsize,spval,tmp &
3813  ,recname,reclevtyp,reclev,varname,vcoordname&
3814  ,bcwt(1,jsta_2l,k))
3815  enddo
3816 
3817 ! retrieve bc convective wet deposition fluxes
3818  do k = 1, nbin_bc
3819  if ( k == 1) varname='bc1wtc'
3820  if ( k == 2) varname='bc2wtc'
3821  vcoordname='sfc'
3822  l=1
3823  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3824  ,l,nrec,fldsize,spval,tmp &
3825  ,recname,reclevtyp,reclev,varname,vcoordname&
3826  ,bcsv(1,jsta_2l,k))
3827  enddo
3828 
3829 ! retrieve oc emission fluxes
3830  do k = 1, nbin_oc
3831  if ( k == 1) varname='oceman'
3832  if ( k == 2) varname='ocembb'
3833  vcoordname='sfc'
3834  l=1
3835  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3836  ,l,nrec,fldsize,spval,tmp &
3837  ,recname,reclevtyp,reclev,varname,vcoordname&
3838  ,ocem(1,jsta_2l,k))
3839  enddo
3840 
3841 ! retrieve oc sedimentation fluxes
3842  do k = 1, nbin_oc
3843  if ( k == 1) varname='oc1sd'
3844  if ( k == 2) varname='oc2sd'
3845  vcoordname='sfc'
3846  l=1
3847  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3848  ,l,nrec,fldsize,spval,tmp &
3849  ,recname,reclevtyp,reclev,varname,vcoordname&
3850  ,ocsd(1,jsta_2l,k))
3851  enddo
3852 
3853 ! retrieve oc dry deposition fluxes
3854  do k = 1, nbin_oc
3855  if ( k == 1) varname='oc1dp'
3856  if ( k == 2) varname='oc2dp'
3857  vcoordname='sfc'
3858  l=1
3859  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3860  ,l,nrec,fldsize,spval,tmp &
3861  ,recname,reclevtyp,reclev,varname,vcoordname&
3862  ,ocdp(1,jsta_2l,k))
3863  enddo
3864 
3865 ! retrieve oc large wet deposition fluxes
3866  do k = 1, nbin_oc
3867  if ( k == 1) varname='oc1wtl'
3868  if ( k == 2) varname='oc2wtl'
3869  vcoordname='sfc'
3870  l=1
3871  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3872  ,l,nrec,fldsize,spval,tmp &
3873  ,recname,reclevtyp,reclev,varname,vcoordname&
3874  ,ocwt(1,jsta_2l,k))
3875  enddo
3876 
3877 ! retrieve oc convective wet deposition fluxes
3878  do k = 1, nbin_oc
3879  if ( k == 1) varname='oc1wtc'
3880  if ( k == 2) varname='oc2wtc'
3881  vcoordname='sfc'
3882  l=1
3883  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3884  ,l,nrec,fldsize,spval,tmp &
3885  ,recname,reclevtyp,reclev,varname,vcoordname&
3886  ,ocsv(1,jsta_2l,k))
3887  enddo
3888 
3889 ! retrieve MIE AOD
3890  varname='maod'
3891  vcoordname='sfc'
3892  l=1
3893  call assignnemsiovar(im,jsta,jend,jsta_2l,jend_2u &
3894  ,l,nrec,fldsize,spval,tmp &
3895  ,recname,reclevtyp,reclev,varname,vcoordname&
3896  ,maod(1,jsta_2l))
3897 
3898  endif
3899 ! done with flux file, close it for now
3900  call nemsio_close(ffile,iret=status)
3901  deallocate(tmp,recname,reclevtyp,reclev)
3902 
3903 ! pos east
3904  call collect_loc(gdlat,dummy)
3905  if(me == 0)then
3906  latstart = nint(dummy(1,1)*gdsdegr)
3907  latlast = nint(dummy(im,jm)*gdsdegr)
3908  print*,'laststart,latlast B bcast= ',latstart,latlast,'gdsdegr=',gdsdegr,&
3909  'dummy(1,1)=',dummy(1,1),dummy(im,jm),'gdlat=',gdlat(1,1)
3910  end if
3911  call mpi_bcast(latstart,1,mpi_integer,0,mpi_comm_comp,irtn)
3912  call mpi_bcast(latlast,1,mpi_integer,0,mpi_comm_comp,irtn)
3913  write(6,*) 'laststart,latlast,me A calling bcast=',latstart,latlast,me
3914  call collect_loc(gdlon,dummy)
3915  if(me == 0)then
3916  lonstart = nint(dummy(1,1)*gdsdegr)
3917  lonlast = nint(dummy(im,jm)*gdsdegr)
3918  end if
3919  call mpi_bcast(lonstart,1,mpi_integer,0,mpi_comm_comp,irtn)
3920  call mpi_bcast(lonlast, 1,mpi_integer,0,mpi_comm_comp,irtn)
3921 
3922  write(6,*)'lonstart,lonlast A calling bcast=',lonstart,lonlast
3923 !
3924 
3925 ! generate look up table for lifted parcel calculations
3926 
3927  thl = 210.
3928  plq = 70000.
3929  pt_tbl = 10000. ! this is for 100 hPa added by Moorthi
3930 
3931  CALL table(ptbl,ttbl,pt_tbl, &
3932  rdq,rdth,rdp,rdthe,pl,thl,qs0,sqs,sthe,the0)
3933 
3934  CALL tableq(ttblq,rdpq,rdtheq,plq,thl,stheq,the0q)
3935 
3936 !
3937 !
3938  IF(me == 0)THEN
3939  WRITE(6,*)' SPL (POSTED PRESSURE LEVELS) BELOW: '
3940  WRITE(6,51) (spl(l),l=1,lsm)
3941  50 FORMAT(14(f4.1,1x))
3942  51 FORMAT(8(f8.1,1x))
3943  ENDIF
3944 !
3945 !$omp parallel do private(l)
3946  DO l = 1,lsm
3947  alsl(l) = log(spl(l))
3948  END DO
3949 !
3950 !HC WRITE IGDS OUT FOR WEIGHTMAKER TO READ IN AS KGDSIN
3951  if(me == 0)then
3952  print*,'writing out igds'
3953  igdout = 110
3954 ! open(igdout,file='griddef.out',form='unformatted'
3955 ! + ,status='unknown')
3956  if(maptype == 1)THEN ! Lambert conformal
3957  WRITE(igdout)3
3958  WRITE(6,*)'igd(1)=',3
3959  WRITE(igdout)im
3960  WRITE(igdout)jm
3961  WRITE(igdout)latstart
3962  WRITE(igdout)lonstart
3963  WRITE(igdout)8
3964  WRITE(igdout)cenlon
3965  WRITE(igdout)dxval
3966  WRITE(igdout)dyval
3967  WRITE(igdout)0
3968  WRITE(igdout)64
3969  WRITE(igdout)truelat2
3970  WRITE(igdout)truelat1
3971  WRITE(igdout)255
3972  ELSE IF(maptype == 2)THEN !Polar stereographic
3973  WRITE(igdout)5
3974  WRITE(igdout)im
3975  WRITE(igdout)jm
3976  WRITE(igdout)latstart
3977  WRITE(igdout)lonstart
3978  WRITE(igdout)8
3979  WRITE(igdout)cenlon
3980  WRITE(igdout)dxval
3981  WRITE(igdout)dyval
3982  WRITE(igdout)0
3983  WRITE(igdout)64
3984  WRITE(igdout)truelat2 !Assume projection at +-90
3985  WRITE(igdout)truelat1
3986  WRITE(igdout)255
3987  ! Note: The calculation of the map scale factor at the standard
3988  ! lat/lon and the PSMAPF
3989  ! Get map factor at 60 degrees (N or S) for PS projection, which will
3990  ! be needed to correctly define the DX and DY values in the GRIB GDS
3991  if (truelat1 < 0.) THEN
3992  lat = -60.
3993  else
3994  lat = 60.
3995  end if
3996 
3997  CALL msfps(lat,truelat1*0.001,psmapf)
3998 
3999  ELSE IF(maptype == 3) THEN !Mercator
4000  WRITE(igdout)1
4001  WRITE(igdout)im
4002  WRITE(igdout)jm
4003  WRITE(igdout)latstart
4004  WRITE(igdout)lonstart
4005  WRITE(igdout)8
4006  WRITE(igdout)latlast
4007  WRITE(igdout)lonlast
4008  WRITE(igdout)truelat1
4009  WRITE(igdout)0
4010  WRITE(igdout)64
4011  WRITE(igdout)dxval
4012  WRITE(igdout)dyval
4013  WRITE(igdout)255
4014  ELSE IF(maptype == 0 .OR. maptype == 203)THEN !A STAGGERED E-GRID
4015  WRITE(igdout)203
4016  WRITE(igdout)im
4017  WRITE(igdout)jm
4018  WRITE(igdout)latstart
4019  WRITE(igdout)lonstart
4020  WRITE(igdout)136
4021  WRITE(igdout)cenlat
4022  WRITE(igdout)cenlon
4023  WRITE(igdout)dxval
4024  WRITE(igdout)dyval
4025  WRITE(igdout)64
4026  WRITE(igdout)0
4027  WRITE(igdout)0
4028  WRITE(igdout)0
4029  END IF
4030  end if
4031 !
4032 !
4033 
4034  RETURN
4035  END
4036  subroutine rg2gg(im,jm,numi,a)
4037 !
4038  implicit none
4039 !
4040  integer,intent(in):: im,jm,numi(jm)
4041  real,intent(inout):: a(im,jm)
4042  integer j,ir,ig
4043  real r,t(im)
4044  do j=1,jm
4045  r = real(numi(j))/real(im)
4046  do ig=1,im
4047  ir = mod(nint((ig-1)*r),numi(j)) + 1
4048  t(ig) = a(ir,j)
4049  enddo
4050  do ig=1,im
4051  a(ig,j) = t(ig)
4052  enddo
4053  enddo
4054  end subroutine rg2gg
4055  subroutine gg2rg(im,jm,numi,a)
4056 !
4057  implicit none
4058 !
4059  integer,intent(in):: im,jm,numi(jm)
4060  real,intent(inout):: a(im,jm)
4061  integer j,ir,ig
4062  real r,t(im)
4063  do j=1,jm
4064  r = real(numi(j))/real(im)
4065  do ir=1,numi(j)
4066  ig = nint((ir-1)/r) + 1
4067  t(ir) = a(ig,j)
4068  enddo
4069  do ir=1,numi(j)
4070  a(ir,j) = t(ir)
4071  enddo
4072  enddo
4073  end subroutine gg2rg
4074 
4075  subroutine uninterpred(iord,kmsk,lonsperlat,lonr,latr,fi,f)
4076 !!
4077  implicit none
4078 !!
4079  integer, intent(in) :: iord, lonr, latr
4080  integer, intent(in) :: kmsk(lonr,latr), lonsperlat(latr)
4081  real, intent(in) :: fi(lonr,latr)
4082  real, intent(out) :: f(lonr,latr)
4083  integer j,lons
4084 !!
4085 !!$omp parallel do private(j,lons)
4086  do j=1,latr
4087  lons = lonsperlat(j)
4088  if(lons /= lonr) then
4089  call intlon(iord,1,lons,lonr,kmsk(1,j),fi(1,j),f(1,j))
4090  else
4091  f(:,j) = fi(:,j)
4092  endif
4093  enddo
4094  end subroutine
4095  subroutine intlon(iord,imsk,m1,m2,k1,f1,f2)
4096  implicit none
4097  integer,intent(in) :: iord,imsk,m1,m2
4098  integer,intent(in) :: k1(m1)
4099  real, intent(in) :: f1(m1)
4100  real, intent(out):: f2(m2)
4101  integer i2,in,il,ir
4102  real r,x1
4103  r = real(m1)/real(m2)
4104  do i2=1,m2
4105  x1 = (i2-1)*r
4106  il = int(x1)+1
4107  ir = mod(il,m1)+1
4108  if(iord == 2 .and. (imsk == 0 .or. k1(il) == k1(ir))) then
4109  f2(i2) = f1(il)*(il-x1) + f1(ir)*(x1-il+1)
4110  else
4111  in = mod(nint(x1),m1) + 1
4112  f2(i2) = f1(in)
4113  endif
4114  enddo
4115  end subroutine intlon
subroutine, public calgradps(PS, PSX, PSY)
CALGRADPS computes gardients of a scalar field PS or LNPS.
Definition: UPP_PHYSICS.f:2462
Definition: MASKS_mod.f:1
Definition: physcons.f:1
subroutine modstuff2(im, ix, km, idvc, idsl, nvcoord, vcoord, ps, psx, psy, d, u, v, pi, pm, om, me)
modstuff2() computes model coordinate dependent functions.
Definition: GFSPOSTSIG.F:376
Definition: SOIL_mod.f:1
subroutine, public caldiv(UWND, VWND, DIV)
CALDIV computes divergence.
Definition: UPP_PHYSICS.f:2175
subroutine msfps(LAT, TRUELAT1, MSF)
msfps() computes the map scale factor for a polar stereographic grid at a give latitude.
Definition: MSFPS.f:26
elemental real function, public fpvsnew(t)
Definition: UPP_PHYSICS.f:378
subroutine initpost_gfs_nems_mpiio(iostatusAER)
This routine initializes constants and variables at the start of GFS model or post processor run...