File: C:\NOAA\NEMS_11731\src\atmos\gfs\phys\wrtout_physics.f

1     
2           subroutine wrtout_physics(phour,fhour,zhour,idate,
3          &                  sl,si,
4          &                  sfc_fld, flx_fld, nst_fld, g2d_fld,
5          &                  fluxr,
6          &                  lats_nodes_r,global_lats_r,lonsperlar,nblck,
7          &                  colat1,cfhour1,pl_coeff)
8     !!
9     !
10     ! May 2009 Jun Wang, modified to use write grid component
11     ! Jan 2010 Sarah Lu, AOD added to flx files
12     ! Feb 2010 Jun Wang, write out restart file
13     ! Jul 2010 S. Moorthi - added nst and other modifications
14     ! Jul 2010 S. Moorthi - added  hchuang  Add flx files output to wrtflx_a
15     ! Jul 2010 Sarah Lu, write out aerosol diag files (for g2d_fld)
16     ! Aug 2010 Sarah Lu, scale the 2d_aer_diag by 1.e6
17     !                    output time-avg 2d_aer_diag
18     ! Oct 2010 Sarah Lu, add g2d_fld%met
19     ! Oct 2010 Sarah Lu, g2d_fld%met changed from instant to accumulated
20     ! Dec 2010 Sarah Lu, g2d_fld%met contains both instant and time-avg;
21     !                    wrtaer is called only when gocart is on
22     !
23     
24           use resol_def,               ONLY: latr, levs, levp1, lonr, nfxr,
25          &                                   ngrids_aer
26           use layout1,                 ONLY: me, nodes, lats_node_r, 
27          &                                   nodes_comp
28           use namelist_physics_def,    ONLY: gen_coord_hybrid, ldiag3d, 
29          &                                   hybrid, fhlwr, fhswr, ens_nam,
30          &                                   nst_fcst, lggfs3d
31           use mpi_def,                 ONLY: liope, info, mpi_comm_all, 
32          &                                   mc_comp, mpi_comm_null,quilting
33           use gfs_physics_sfc_flx_mod, ONLY: Sfc_Var_Data, Flx_Var_Data
34           use gfs_physics_nst_var_mod, ONLY: Nst_Var_Data
35           use gfs_physics_g2d_mod,     ONLY: G2D_Var_Data
36           USE machine,                 ONLY: kind_evod, kind_io8
37           implicit none
38     !!
39           TYPE(Sfc_Var_Data)        :: sfc_fld
40           TYPE(Flx_Var_Data)        :: flx_fld
41           TYPE(Nst_Var_Data)        :: nst_fld
42           TYPE(G2D_Var_Data)        :: g2d_fld
43           CHARACTER(16)             :: CFHOUR1    ! for ESMF Export State Creation
44           integer ixgr, pl_coeff
45           real(kind=kind_evod) phour,fhour,zhour
46     !     real(kind=kind_evod) phour,fhour,zhour, xgf
47     !!
48           integer              idate(4),nblck,km,iostat,no3d,ks
49           logical lfnhr
50           real colat1
51           real(kind=8) t1,t2,t3,t4,t5,ta,tb,tc,td,te,tf,rtc,tx,ty
52           real timesum
53     !!
54           real(kind=kind_evod) sl(levs), si(levp1)
55     !!
56           integer              lats_nodes_r(nodes)
57     !!
58           integer              ierr,j,k,l,lenrec,locl,n,node
59           integer nosfc,noflx,nonst,noaer,nfill
60           character*16 cosfc,const
61           data timesum/0./
62     !!
63     !!
64           character CFHOUR*40,CFORM*40
65           integer jdate(4),ndigyr,ndig,kh,IOPROC
66     !!
67           REAL (KIND=KIND_IO8) GESHEM(LONR,LATS_NODE_R)
68           INTEGER              GLOBAL_LATS_R(LATR),   lonsperlar(LATR)
69     !
70           REAL (KIND=kind_io8) fluxr(nfxr,LONR,LATS_NODE_R)
71     !!
72           real(kind=kind_evod) secphy,secswr,seclwr
73           real(kind=8) tba,tbb,tbc,tbd
74           integer iret
75     !
76     !     print *,' in wrtout_phyiscs me=',me
77           t3=rtc()
78           call mpi_barrier(mpi_comm_all,ierr)
79           t4=rtc()
80           tba=t4-t3
81           if(nodes_comp .lt. 1 .or. nodes_comp .gt. nodes) then
82             print *, '  NODES_COMP UNDEFINED, CANNOT DO I.O '
83             call mpi_finalize()
84              stop 333
85           endif
86     !
87           ioproc=nodes_comp-1
88            
89           t1=rtc()
90     !!
91     !!
92     !     CREATE CFHOUR
93           JDATE=IDATE
94           ndigyr=4
95           IF(NDIGYR.EQ.2) THEN
96             JDATE(4)=MOD(IDATE(4)-1,100)+1
97           ENDIF
98     
99     !sela set lfnhr to false for writing one step output etc.
100           lfnhr=.true.    ! no output
101           lfnhr=3600*abs(fhour-nint(fhour)).le.1.or.phour.eq.0
102           IF(LFNHR) THEN
103             KH=NINT(FHOUR)
104             NDIG=MAX(LOG10(KH+0.5)+1.,2.)
105             WRITE(CFORM,'("(I",I1,".",I1,")")') NDIG,NDIG
106             WRITE(CFHOUR,CFORM) KH
107           ELSE
108             KS=NINT(FHOUR*3600)
109             KH=KS/3600
110             KM=(KS-KH*3600)/60
111             KS=KS-KH*3600-KM*60
112             NDIG=MAX(LOG10(KH+0.5)+1.,2.)
113             WRITE(CFORM,
114          &      '("(I",I1,".",I1,",A1,I2.2,A1,I2.2)")') NDIG,NDIG
115             WRITE(CFHOUR,CFORM) KH,':',KM,':',KS
116           ENDIF
117           IF(nfill(ens_nam) == 0) THEN
118           CFHOUR = CFHOUR(1:nfill(CFHOUR))
119           ELSE
120           CFHOUR = CFHOUR(1:nfill(CFHOUR)) // ens_nam(1:nfill(ens_nam))
121           END IF
122     !jfe
123           nosfc = 62
124           noflx = 63
125           nonst = 65
126           noaer = 66
127     !!
128           t3=rtc()
129           call MPI_BARRIER(mpi_comm_all,ierr)
130           t4=rtc()
131           tbd=t4-t3
132           t3=rtc()
133           SECPHY=(FHOUR-ZHOUR)*3600.
134           SECSWR=MAX(SECPHY,FHSWR*3600.)
135           SECLWR=MAX(SECPHY,FHLWR*3600.)
136     !
137     !*** BUILD STATE ON EACH NODE ********
138     ! build state on each node.   COMP tasks only
139     ! assemble spectral state first then sfc state,
140     ! then (only if liope)  flux state.
141     ! finally (only if gocart is turned on) aer_diag state
142     ! 
143     !      print *,'---- start sfc collection section -----'
144           t3=rtc()
145           if(mc_comp .ne. MPI_COMM_NULL) then
146             CALL sfc_collect(sfc_fld,global_lats_r,lonsperlar)
147     
148            if ( nst_fcst > 0 ) then
149              call nst_collect(nst_fld,global_lats_r,lonsperlar)
150            endif
151     !
152     ! collect flux grids as was done with sfc grids above.
153     ! but only if liope is true.  If liope is false,
154     ! the fluxes are handled by the original wrtsfc
155     ! predating the I/O task updates.
156     !
157                 call   wrtflx_a
158          &             (IOPROC,noflx,ZHOUR,FHOUR,IDATE,colat1,SECSWR,SECLWR,
159          &              sfc_fld, flx_fld, fluxr, global_lats_r,lonsperlar)
160     
161     	    if ( ngrids_aer .gt. 0) then
162                    call   wrtaer
163          &             (IOPROC,noaer,ZHOUR,FHOUR,IDATE,
164          &              sfc_fld, g2d_fld, global_lats_r, lonsperlar)
165                 endif
166     
167           endif                 ! comp node
168           t4=rtc()
169           td=t4-t3
170     !
171     !  done with state build
172     !  NOW STATE IS ASSEMBLED ON EACH NODE.  GET EVERYTHING OFF THE COMPUTE
173     !  NODES (currently done with a send to the I/O task_
174     !  send state to I/O task.  All tasks
175     !
176     !jw      if(.not.quilting) then
177     !jw          print *,'---- start sfc.f section -----'
178     !jw          call sfc_only_move(ioproc)
179     !jw          cosfc='SFC.F'//CFHOUR
180     !jw          call sfc_wrt(ioproc,cosfc,fhour,jdate
181     !jw     &,                global_lats_r,lonsperlar)
182     !
183     !jw          print *,' wrtout_physics call wrtsfc to write out flx'
184     !jw          call FLX_ONLY_MOVE(ioproc)
185     !jw          cosfc='FLX.F'//CFHOUR
186     !jw          call  flx_wrt
187     !jw     &          (IOPROC,cosfc,ZHOUR,FHOUR,IDATE,
188     !jw     &           global_lats_r,lonsperlar)
189     !jw      endif          !  quilting
190     !
191           t4=rtc()
192           te=t4-t3
193     !
194     !jw      print *,'---- start diag3d.f section -----'
195     !jw        IF (LDIAG3D) THEN
196     !jw          print *,' wrtout_physics ldiag3d on so wrt3d '
197     !jw          no3d=64
198     !jw          if(icolor.eq.2.and.me.eq.IOPROC)
199     !jw     &    call BAOPENWT(NO3D,'D3D.F'//CFHOUR,iostat)
200     !jw          if (hybrid .or. gen_coord_hybrid) then
201     !     print *,' pl_coeff bef call wrt3d_hyb=',pl_coeff
202     !jw            call WRT3D_hyb(IOPROC,no3d,nblck,ZHOUR,FHOUR,IDATE,colat1,
203     !jw     .                     global_lats_r,lonsperlar,pl_coeff,
204     !jw     &                     SECSWR,SECLWR,sfc_fld%slmsk,flx_fld%psurf)
205     !jw          else
206     !jw            call WRT3D(IOPROC,no3d,nblck,ZHOUR,FHOUR,IDATE,colat1,
207     !jw     .                 global_lats_r,lonsperlar,pl_coeff,
208     !jw     &                 SECSWR,SECLWR,sl,si,sfc_fld%slmsk,flx_fld%psurf)
209     !jw          endif
210     !jw        ENDIF
211     !
212     !      if(me .eq. ioproc)  call wrtlog_physics(phour,fhour,idate)
213     
214           tb = rtc()
215           tf = tb-t1
216     !     tf = tb-ta
217           t2 = rtc()
218     
219            if (me == ioproc) write(0,*)' WRTOUT_PHYSICS TIME=',tf
220     
221     !     print 1011,tf
222     !1011 format(' WRTOUT_PHYSICS TIME ',f10.4)
223           timesum = timesum+(t2-t1)
224     !     print 1012,timesum,t2-t1,td,te,tf,t4-t3,tba,tbb,tbc,tbd
225      1012 format(
226          1 ' WRTOUT_PHYSICS TIME ALL TASKS  ',f10.4,f10.4,
227          1 ' state, send, io  iobarr, (beginbarr),
228          1 spectbarr,open, openbarr )  ' ,
229          1  8f9.4)
230     !
231           return
232           end
233     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
234           SUBROUTINE wrtout_restart_physics(
235          &        sfc_fld, nst_fld, fhour,idate,
236          &        lats_nodes_r,global_lats_r,lonsperlar,
237          &        phy_f3d, phy_f2d, ngptc, nblck, ens_nam)
238     !!
239           use resol_def,               ONLY: latr, levp1, levs, lonr,
240          &                                   num_p2d, num_p3d
241           use  namelist_physics_def,   ONLY: nst_fcst
242           use layout1,                 ONLY: me, nodes, lats_node_r
243           use gfs_physics_sfc_flx_mod, ONLY: Sfc_Var_Data, Flx_Var_Data
244           use gfs_physics_nst_var_mod, ONLY: Nst_Var_Data
245           USE machine,                 ONLY: kind_evod, kind_phys
246           implicit none
247     !!
248           TYPE(Sfc_Var_Data)        :: sfc_fld
249           TYPE(Nst_Var_Data)        :: nst_fld
250     
251           real(kind=kind_evod) fhour
252           character (len=*)  :: ens_nam
253     !!
254           integer              idate(4), ixgr
255     !
256           integer              ngptc, nblck
257           REAL (KIND=KIND_phys)
258          &            phy_f3d(ngptc,levs,nblck,LATS_NODE_R,num_p3d)
259          &,           phy_f2d(LONR,LATS_NODE_R,num_p2d)
260     !!
261           real(kind=kind_evod) sl(levs)
262           real(kind=kind_evod) si(levp1)
263     !!
264           integer igen
265     !!
266           INTEGER              lats_nodes_r(nodes)
267           INTEGER              GLOBAL_LATS_R(LATR)
268           INTEGER              lonsperlar(LATR)
269           integer IOPROC, IPRINT
270           integer needoro, iret, nfill
271     !
272     !!
273           integer n3,n4,nflop
274           character*20 cfile
275           integer nn
276     !!
277           IPRINT = 0
278     !
279           cfile='SFCR'
280     !      print *,' cfile=',cfile,'ens_nam=',ens_nam(1:nfill(ens_nam))
281     !
282     !      print *,' in rest write fhour=',fhour,
283     !     &  'idate=',idate,' before para_fixio_w'
284     !
285           IOPROC=nodes-1
286           CALL para_fixio_w(ioproc,sfc_fld,cfile,fhour,idate,
287          &  lats_nodes_r,global_lats_r,lonsperlar,
288          &  phy_f3d, phy_f2d, ngptc, nblck, ens_nam)
289     !
290           if(nst_fcst>0) then
291             cfile='NSTR'
292             CALL para_nst_w(ioproc,nst_fld,cfile,fhour,idate,
293          &   lats_nodes_r,global_lats_r,lonsperlar,
294          &   ens_nam)
295           endif 
296     !
297           return
298           end
299     !
300     !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
301           SUBROUTINE wrtlog_physics(phour,fhour,idate)
302           use namelist_physics_def, ONLY: ens_nam
303           implicit none
304     
305           integer idate(4),ndigyr,nolog
306           integer ks,kh,km,ndig,nfill
307           character CFHOUR*40,CFORM*40
308           logical lfnhr
309           real phour,fhour
310     !
311     !     CREATE CFHOUR
312     
313     !sela set lfnhr to false for writing one step output etc.
314           lfnhr=.true.    ! no output
315     !!mr  lfnhr=.false.   !    output
316           lfnhr=3600*abs(fhour-nint(fhour)).le.1.or.phour.eq.0
317           IF(LFNHR) THEN
318             KH=NINT(FHOUR)
319             NDIG=MAX(LOG10(KH+0.5)+1.,2.)
320             WRITE(CFORM,'("(I",I1,".",I1,")")') NDIG,NDIG
321             WRITE(CFHOUR,CFORM) KH
322             WRITE(CFORM,'("(I",I1,".",I1,")")') NDIG,NDIG
323             WRITE(CFHOUR,CFORM) KH
324           ELSE
325             KS=NINT(FHOUR*3600)
326             KH=KS/3600
327             KM=(KS-KH*3600)/60
328             KS=KS-KH*3600-KM*60
329             NDIG=MAX(LOG10(KH+0.5)+1.,2.)
330             WRITE(CFORM,
331          &      '("(I",I1,".",I1,",A1,I2.2,A1,I2.2)")') NDIG,NDIG
332             WRITE(CFHOUR,CFORM) KH,':',KM,':',KS
333           ENDIF
334           IF(nfill(ens_nam) == 0) THEN
335           CFHOUR = CFHOUR(1:nfill(CFHOUR))
336           ELSE
337           CFHOUR = CFHOUR(1:nfill(CFHOUR)) // ens_nam(1:nfill(ens_nam))
338           END IF
339     
340           nolog=99
341           OPEN(NOlog,FILE='LOG.F'//CFHOUR,FORM='FORMATTED')
342           write(nolog,100)fhour,idate
343     100   format(' completed mrf fhour=',f10.3,2x,4(i4,2x))
344           CLOSE(NOlog)
345     
346           RETURN
347           END
348     
349     
350     
351           SUBROUTINE sfc_collect (sfc_fld,global_lats_r,lonsperlar)
352     !!
353           use resol_def,               ONLY: latr, lonr, ngrids_sfcc, 
354          &                                   ngrids_sfcc2d,ngrids_sfcc3d,
355          &                                   ngrids_flx, lsoil
356           use mod_state,               ONLY:
357          &                                   buff_mult_piecea2d,ngrid2d,
358          &                                   buff_mult_piecea3d,ngrid3d
359           use layout1,                 ONLY: lats_node_r,lats_node_r_max
360           use gfs_physics_sfc_flx_mod, ONLY: Sfc_Var_Data
361           USE machine,                 ONLY: kind_io8, kind_io4
362           implicit none
363     !!
364           TYPE(Sfc_Var_Data)        :: sfc_fld
365     !
366           INTEGER              GLOBAL_LATS_R(latr)
367           INTEGER              lonsperlar(latr)
368     !!
369     !!!   real(kind=kind_io4) buff4(lonr,latr,4),bufsave(lonr,lats_node_r)
370           real(kind=kind_io8) buffo(lonr,lats_node_r)
371           real(kind=kind_io8) buffi(lonr,lats_node_r_max)
372           integer kmsk(lonr,lats_node_r_max),kmskcv(lonr,lats_node_r_max)
373           integer k,il
374            integer ubound
375            integer icount
376             integer  ierr
377     !!
378           CHARACTER*8 labfix(4)
379           real(kind=kind_io4) yhour
380           integer,save:: version
381           data version/200004/
382           data  icount/0/
383           integer maxlats_comp
384     !
385           ngrid2d=1
386           ngrid3d=1
387     !
388     !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
389     !
390     !!
391           if(allocated(buff_mult_piecea2d)) then
392              continue
393           else
394              allocate
395          1 (buff_mult_piecea2d(lonr,lats_node_r_max,1:ngrids_sfcc2d+1),
396          1  buff_mult_piecea3d(lonr,lats_node_r_max,1:ngrids_sfcc3d+1))
397           endif
398     !
399           kmsk= nint(sfc_fld%slmsk)
400     !
401           ngrid2d=1
402           CALL uninterprez(1,kmsk,buffo,sfc_fld%tsea,
403          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
404     !
405     ! ngrid=2 here
406                                                                                                             
407     !
408           ngrid3d=0
409           DO k=1,LSOIL
410             buffi(:,:) = sfc_fld%SMC(k,:,:)
411             ngrid3d=ngrid3d+1
412             CALL uninterprez(1,kmsk,buffo,buffi,global_lats_r,lonsperlar,
413          &        buff_mult_piecea3d(1,1,ngrid3d))
414           ENDDO
415     !
416           ngrid2d=ngrid2d+1
417           CALL uninterprez(1,kmsk,buffo,sfc_fld%SHELEG,
418          &   global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
419     !
420           DO k=1,LSOIL
421             buffi(:,:) = sfc_fld%STC(k,:,:)
422     !
423             ngrid3d=ngrid3d+1
424             CALL uninterprez(1,kmsk,buffo,buffi,global_lats_r,lonsperlar,
425          &         buff_mult_piecea3d(1,1,ngrid3d))
426           ENDDO
427     !
428           ngrid2d=ngrid2d+1
429           CALL uninterprez(1,kmsk,buffo,sfc_fld%TG3,
430          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
431     !
432           ngrid2d=ngrid2d+1
433           CALL uninterprez(1,kmsk,buffo,sfc_fld%ZORL,
434          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
435     !!
436     !     where(CV.gt.0.)
437     !         kmskcv=1
438     !     elsewhere
439     !         kmskcv=0
440     !     endwhere
441     !
442     !*********************************************************************
443     !   Not in version 200501
444     !     CALL uninterprez(1,kmskcv,buffo,CV,global_lats_r,lonsperlar)
445     !     CALL uninterprez(1,kmskcv,buffo,CVB,global_lats_r,lonsperlar)
446     !     CALL uninterprez(1,kmskcv,buffo,CVT,global_lats_r,lonsperlar)
447     !*********************************************************************
448     !jws
449           ngrid2d=ngrid2d+1
450           CALL uninterprez(1,kmsk,buffo,sfc_fld%ALVSF,
451          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
452     !
453           ngrid2d=ngrid2d+1
454           CALL uninterprez(1,kmsk,buffo,sfc_fld%ALVWF,
455          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
456     !
457           ngrid2d=ngrid2d+1
458           CALL uninterprez(1,kmsk,buffo,sfc_fld%ALNSF,
459          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
460     !
461           ngrid2d=ngrid2d+1
462           CALL uninterprez(1,kmsk,buffo,sfc_fld%ALNWF,
463          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
464     !
465           ngrid2d=ngrid2d+1
466           CALL uninterprez(1,kmsk,buffo,sfc_fld%SLMSK,
467          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
468     !
469           ngrid2d=ngrid2d+1
470           CALL uninterprez(1,kmsk,buffo,sfc_fld%VFRAC,
471          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
472     !
473           ngrid2d=ngrid2d+1
474           CALL uninterprez(1,kmsk,buffo,sfc_fld%CANOPY,
475          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
476     !
477           ngrid2d=ngrid2d+1
478           CALL uninterprez(1,kmsk,buffo,sfc_fld%F10M,
479          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
480     ! T2M
481           ngrid2d=ngrid2d+1
482           CALL uninterprez(1,kmsk,buffo,sfc_fld%T2M,
483          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
484     ! Q2M
485           ngrid2d=ngrid2d+1
486           CALL uninterprez(1,kmsk,buffo,sfc_fld%Q2M,
487          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
488     !
489           ngrid2d=ngrid2d+1
490           CALL uninterprez(1,kmsk,buffo,sfc_fld%VTYPE,
491          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
492     !
493           ngrid2d=ngrid2d+1
494           CALL uninterprez(1,kmsk,buffo,sfc_fld%STYPE,
495          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
496     
497     !
498           ngrid2d=ngrid2d+1
499           CALL uninterprez(1,kmsk,buffo,sfc_fld%FACSF,
500          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
501     !
502           ngrid2d=ngrid2d+1
503           CALL uninterprez(1,kmsk,buffo,sfc_fld%FACWF,
504          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
505     !
506           ngrid2d=ngrid2d+1
507           CALL uninterprez(1,kmsk,buffo,sfc_fld%UUSTAR,
508          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
509     !
510           ngrid2d=ngrid2d+1
511           CALL uninterprez(1,kmsk,buffo,sfc_fld%FFMM,
512          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
513     !
514           ngrid2d=ngrid2d+1
515           CALL uninterprez(1,kmsk,buffo,sfc_fld%FFHH,
516          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
517     !
518     !c-- XW: FOR SEA-ICE Nov04
519           ngrid2d=ngrid2d+1
520           CALL uninterprez(1,kmsk,buffo,sfc_fld%HICE,
521          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
522           ngrid2d=ngrid2d+1
523           CALL uninterprez(1,kmsk,buffo,sfc_fld%FICE,
524          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
525           ngrid2d=ngrid2d+1
526           CALL uninterprez(1,kmsk,buffo,sfc_fld%TISFC,
527          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
528     !      write(0,*)'in wrt phy,tisfc=',
529     !     &    maxval(buff_mult_piecea2d(:,:,ngrid2d)),
530     !     &    minval(buff_mult_piecea2d(:,:,ngrid2d))
531     
532     !c-- XW: END SEA-ICE Nov04
533     !
534     !lu: the addition of 8 Noah-related records starts here ........................
535     !tprcp
536           ngrid2d=ngrid2d+1
537           CALL uninterprez(1,kmsk,buffo,sfc_fld%TPRCP,
538          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
539     !srflag
540           ngrid2d=ngrid2d+1
541           CALL uninterprez(1,kmsk,buffo,sfc_fld%SRFLAG,
542          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
543     !snwdph
544           ngrid2d=ngrid2d+1
545           CALL uninterprez(1,kmsk,buffo,sfc_fld%SNWDPH,
546          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
547     !slc
548     !      write(0,*)'in wrt phy, before stc,ngrid2d=',ngrid2d,'ngrid3d=',
549     !     &   ngrid3d,'lsoil=',lsoil
550           DO k=1,LSOIL
551             buffi(:,:) = sfc_fld%SLC(k,:,:)
552             ngrid3d=ngrid3d+1
553             CALL uninterprez(1,kmsk,buffo,buffi,global_lats_r,lonsperlar,
554          &         buff_mult_piecea3d(1,1,ngrid3d))
555           ENDDO
556     !shdmin
557           ngrid2d=ngrid2d+1
558           CALL uninterprez(1,kmsk,buffo,sfc_fld%SHDMIN,
559          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
560     !shdmax
561           ngrid2d=ngrid2d+1
562           CALL uninterprez(1,kmsk,buffo,sfc_fld%SHDMAX,
563          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
564     !slope
565           ngrid2d=ngrid2d+1
566           CALL uninterprez(1,kmsk,buffo,sfc_fld%SLOPE,
567          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
568     !snoalb
569           ngrid2d=ngrid2d+1
570           CALL uninterprez(1,kmsk,buffo,sfc_fld%SNOALB,
571          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
572     !lu: the addition of 8 Noah records ends here .........................
573     !
574     ! Oro
575           ngrid2d=ngrid2d+1
576           CALL uninterprez(1,kmsk,buffo,sfc_fld%ORO,
577          &       global_lats_r,lonsperlar,buff_mult_piecea2d(1,1,ngrid2d))
578     !
579     !       write(0,*)' finished sfc_collect for  ngrid2d=',ngrid2d,ngrid3d
580       999 continue
581           return
582           end
583            subroutine sfc_only_move(ioproc)
584     !
585     !***********************************************************************
586     !
587           use resol_def, ONLY: ngrids_flx, ngrids_sfcc, lonr,latr
588          &                    ,ngrids_sfcc2d,ngrids_sfcc3d
589           use mod_state, ONLY: buff_mult_pieces,buff_mult_piece,
590          &                     buff_mult_piecea2d,
591          &                     buff_mult_piecea3d, 
592          &                     ivar_global_a, ivar_global
593           use layout1,   ONLY: nodes, ipt_lats_node_r, lats_node_r, 
594          &                     lats_node_r_max, me, nodes_comp
595           use mpi_def,   ONLY: mpi_comm_null, mpi_r_io, mc_comp, 
596          &                     mpi_integer, mpi_comm_all, liope, 
597          &                     info, stat
598           implicit none
599     !
600           integer ipt_lats_node_rl,nodesr
601           integer lats_nodes_rl
602     !     integer lats_nodes_r(nodes),ipt,maxfld,ioproc,nproct
603           integer ioproc
604           integer proc,j,lat,msgtag,nproc,i,msgtag1,buff,startlat,ierr
605           integer illen,ubound,nd1
606           integer icount
607           data icount/0/
608           save icount
609           integer maxlats_comp
610     !  allocate the data structures
611     !
612           if(icount .eq. 0) then
613              allocate(ivar_global(10))
614              allocate(ivar_global_a(10,nodes))
615              ivar_global(1)=ipt_lats_node_r
616              ivar_global(2)= lats_node_r
617              ivar_global(3)=lats_node_r_max
618              call mpi_gather(ivar_global,10,MPI_INTEGER,
619          1       ivar_global_a,10,MPI_INTEGER,ioproc,mc_comp,ierr)
620              if(me==ioproc) write(0,*)'in sfc_only_move, ivar_global_a=',
621          &     ivar_global_a(1:3,1:nodes)
622              icount=icount+1
623           endif
624     !!
625           if(allocated(buff_mult_pieces)) then
626               deallocate(buff_mult_pieces)
627           else
628               maxlats_comp=lats_node_r_max
629               if(me .eq. ioproc) then
630                 maxlats_comp=ivar_global_a(3,1)
631                endif
632           endif
633           if(me .eq. ioproc) then
634     !gwv watch this!!
635               allocate
636          1  (buff_mult_pieces(lonr*latr*ngrids_sfcc))
637              buff_mult_pieces=0.
638           endif
639     
640           if(allocated(buff_mult_piece)) then
641              continue
642           else
643              allocate(buff_mult_piece(lonr*lats_node_r*ngrids_sfcc))
644           endif                                                   
645     !
646     !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
647     !   SENDLOOP of grids from comp processors to I/O task.  The
648     !   I/O task may or may not be a comp task also.  The
649     !   send logic on that task is different for these two cases
650     !
651     !  big send
652     !     if(me .gt. -1) return
653     !
654            buff_mult_piece=0.
655            buff_mult_piece(1:lonr*lats_node_r*ngrids_sfcc2d)=
656          1 reshape(buff_mult_piecea2d(1:lonr,1:lats_node_r,1:ngrids_sfcc2d),
657          1   (/lonr*lats_node_r*ngrids_sfcc2d/)) 
658            buff_mult_piece(lonr*lats_node_r*ngrids_sfcc2d+1:
659          1    lonr*lats_node_r*ngrids_sfcc)=
660          1 reshape(buff_mult_piecea3d(1:lonr,1:lats_node_r,1:ngrids_sfcc3d),
661          1   (/lonr*lats_node_r*ngrids_sfcc3d/) )
662     !
663           IF (ME .ne. ioproc) THEN    !   Sending the data
664              msgtag=me
665              illen=lats_node_r
666              CALL mpi_send            !  send the local grid domain
667          &(buff_mult_piece,illen*lonr*ngrids_sfcc,MPI_R_IO,ioproc,
668          &                  msgtag,MPI_COMM_ALL,info)
669           ELSE
670             if( MC_COMP .ne. MPI_COMM_NULL) then
671     !
672     c iotask is also a compute task.  send is replaced with direct
673     c  array copy
674     !
675              if(nodes_comp==1) then
676                buff_mult_pieces(1:lonr*lats_node_r*ngrids_sfcc)=
677          1     buff_mult_piece(1:lonr*lats_node_r*ngrids_sfcc)
678     !                              END COMPUTE TASKS PORTION OF LOGIC
679              else
680     !
681     !  END COMPUTE TASKS PORTION OF LOGIC
682     !  receiving part of I/O task, ioproc is the last fcst pe
683     !
684     !!
685     !!      for pes ioproc
686     !jw        nd1=lonr*lats_node_r*ngrids_sfcc
687             nd1=0
688             DO proc=1,nodes_comp
689               illen=ivar_global_a(2,proc)
690               if (proc.ne.ioproc+1) then
691                 msgtag=proc-1
692                 CALL mpi_recv(buff_mult_pieces(nd1+1),
693          1        illen*lonr*ngrids_sfcc
694          1        ,MPI_R_IO,proc-1,
695          &                msgtag,MPI_COMM_ALL,stat,info)
696               else
697                buff_mult_pieces(nd1+1:nd1+lonr*illen*ngrids_sfcc)=
698          1       buff_mult_piece(1:lonr*illen*ngrids_sfcc)
699               endif
700               nd1=nd1+illen*lonr*ngrids_sfcc
701             enddo
702             endif
703     
704            Endif
705     !end ioproc
706           ENDIF
707     !!
708           return
709           end
710           SUBROUTINE sfc_wrt(IOPROC,cfile,xhour,idate
711          &,                  global_lats_r,lonsperlar)
712     !!
713           use module_nemsio
714           use resol_def,    ONLY: lonr, latr, levs,ngrids_sfcc,
715          &   ncld,ntrac,ntcw,ntoz,lsoil, ivssfc,thermodyn_id,sfcpress_id
716           use layout1,      ONLY: me,idrt
717           USE machine,      ONLY: kind_io8, kind_io4
718     !jw
719           use gfs_physics_output, only : PHY_INT_STATE_ISCALAR,
720          &    PHY_INT_STATE_RSCALAR,
721          &    PHY_INT_STATE_1D_I,PHY_INT_STATE_1D_R,
722          &    PHY_INT_STATE_2D_R_SFC,PHY_INT_STATE_3D_R
723           implicit none
724     !!
725           integer IOPROC
726           character*16 cfile
727           real(kind=kind_io8) xhour
728           integer idate(4),k,il, ngridss
729     !
730           integer i,j,ndim3,N2DR,idate7(7),nrec,kount
731           integer nfhour,nfminute,nfsecondd,nfsecondn
732           logical  :: outtest
733           integer ::nmetavari,nmetavarr,nmetavarl,nmetaaryi,nmetaaryr
734           character(16),allocatable :: recname(:),reclevtyp(:)
735           integer,allocatable :: reclev(:)
736           character(16),allocatable :: variname(:),varrname(:),
737          &    aryiname(:),aryrname(:)
738           integer,allocatable :: varival(:),aryilen(:),aryival(:,:)
739           real(kind_io4),allocatable    :: varrval(:),aryrval(:,:)
740           real(kind_io4),allocatable :: buff_mult(:,:,:),tmp(:)
741           type(nemsio_gfile) gfileout
742     !
743     !!
744           CHARACTER*8 labfix(4)
745           real(kind=kind_io4) yhour
746           integer,save:: version
747           data version/200501/
748           INTEGER              GLOBAL_LATS_R(latr), lonsperlar(latr)
749     !
750           integer iret
751           logical first
752           save first
753           save  recname, reclevtyp, reclev
754           save nrec,nmetavari,nmetavarr,nmetaaryi,nmetaaryr,
755          &     variname,varrname,aryiname,
756          &     varival,varrval,aryilen,aryival
757           data first /.true./
758     !
759     !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
760     !
761     !    Build surface fields in to buff_mult
762     !
763           if (me.eq.ioproc) then
764     !
765     !
766              allocate(buff_mult(lonr,latr,ngrids_sfcc))
767              do ngridss=1,ngrids_sfcc
768                call unsplit2z(ioproc,ngridss,ngrids_sfcc,
769          &       buff_mult(1,1,ngridss),global_lats_r)
770              enddo
771     !
772     !    Building surface field is done
773     !
774              if (first) then
775     !write out nemsio sfc file:
776               nrec=ngrids_sfcc
777               kount=size(PHY_INT_STATE_ISCALAR,2)
778               do i=1,kount
779                if(trim(PHY_INT_STATE_ISCALAR(2,i)).eq.'OGFS_PHY'
780          &     .or.trim(PHY_INT_STATE_ISCALAR(2,i)).eq.'OGFS_SFC')
781          &        nmetavari=nmetavari+1
782               enddo
783               allocate(variname(nmetavari),varival(nmetavari))
784               j=0
785               do i=1,kount
786                if(trim(PHY_INT_STATE_ISCALAR(2,i)).eq.'OGFS_PHY' .or.
787          &      trim(PHY_INT_STATE_ISCALAR(2,i)).eq.'OGFS_SFC' )then
788                 j=j+1
789                 variname(j)=trim(PHY_INT_STATE_ISCALAR(1,i))
790                 if(trim(variname(j))=='latr') varival(j)=latr
791                 if(trim(variname(j))=='lonr') varival(j)=lonr
792                 if(trim(variname(j))=='levs') varival(j)=levs
793                 if(trim(variname(j))=='ntoz') varival(j)=ntoz
794                 if(trim(variname(j))=='ntcw') varival(j)=ntcw
795                 if(trim(variname(j))=='ncld') varival(j)=ncld
796                 if(trim(variname(j))=='ntrac') varival(j)=ntrac
797                 if(trim(variname(j))=='thermodyn_id')varival(j)=thermodyn_id
798                 if(trim(variname(j))=='sfcpress_id') varival(j)=sfcpress_id
799                 if(trim(variname(j))=='lsoil') varival(j)=lsoil
800                 if(trim(variname(j))=='idrt') varival(j)=idrt
801                 if(trim(variname(j))=='ivssfc') varival(j)=ivssfc
802                endif
803               enddo
804     !!for real var::
805               nmetavarr=0
806               do i=1,kount
807                if(trim(PHY_INT_STATE_RSCALAR(2,i)).eq.'OGFS_PHY'
808          &     .or.trim(PHY_INT_STATE_RSCALAR(2,i)).eq.'OGFS_SFC')
809          &     nmetavarr=nmetavarr+1
810               enddo
811               allocate(varrname(nmetavarr),varrval(nmetavarr))
812               j=0
813               do i=1,kount
814                if(trim(PHY_INT_STATE_RSCALAR(2,i)).eq.'OGFS_PHY'
815          &     .or.trim(PHY_INT_STATE_RSCALAR(2,i)).eq.'OGFS_SFC')then
816                  j=j+1
817                  varrname(j)=trim(PHY_INT_STATE_RSCALAR(1,i))
818                  if(trim(varrname(j))=='fhour') varrval(j)=xhour
819                endif
820               enddo
821     !!for 1D ary::
822               nmetaaryi=0
823               do i=1,kount
824                if(trim(PHY_INT_STATE_1D_I(2,i)).eq.'OGFS_PHY'
825          &     .or.trim(PHY_INT_STATE_1D_I(2,i)).eq.'OGFS_SFC')
826          &     nmetaaryi=nmetaaryi+1
827               enddo
828               allocate(aryiname(nmetaaryi),aryilen(nmetaaryi))
829               j=0
830               do i=1,kount
831                if(trim(PHY_INT_STATE_1D_I(2,i)).eq.'OGFS_PHY'
832          &     .or.trim(PHY_INT_STATE_1D_I(2,i)).eq.'OGFS_SFC')then
833                  j=j+1
834                  aryiname(j)=trim(PHY_INT_STATE_1D_I(1,i))
835                  if(aryiname(j)=='IDATE') aryilen(j)=size(idate)
836                endif
837               enddo
838               allocate(aryival(maxval(aryilen),nmetaaryi) )
839               aryival(1:aryilen(1),1)=idate(1:aryilen(1))
840     !
841     !!for record name, levtyp and lev
842               allocate (recname(nrec),reclevtyp(nrec),reclev(nrec))
843               N2DR=0
844               do i=1,kount
845                if(trim(PHY_INT_STATE_2D_R_SFC(2,i)).eq.'OGFS_SFC')then
846                 N2DR=N2DR+1
847                 recname(N2DR)=trim(PHY_INT_STATE_2D_R_SFC(1,i))
848                 reclevtyp(N2DR)=trim(trim(PHY_INT_STATE_2D_R_SFC(3,i)))
849                 reclev(N2DR)=1
850                endif
851               enddo
852     !
853               do i=1,kount
854                if(trim(PHY_INT_STATE_3D_R(2,i)).eq.'OGFS_SFC')then
855                 ndim3=0
856                 if(trim(PHY_INT_STATE_3D_R(4,i)).eq.'lsoil') then
857                  ndim3=lsoil
858                 endif
859                 if(ndim3>0) then
860                  do j=1,ndim3
861                   N2DR=N2DR+1
862                   recname(N2DR)=trim(PHY_INT_STATE_3D_R(1,i))
863                   reclevtyp(N2DR)=trim(trim(PHY_INT_STATE_3D_R(3,i)) )
864                   if(trim(PHY_INT_STATE_3D_R(4,i)).eq.'lsoil') then
865                     reclev(N2DR)=j
866                   endif
867                  enddo
868                 endif
869     !
870                endif
871               enddo
872     !end first
873               first=.false.
874              endif
875          
876             idate7=0
877             idate7(1)=idate(4)
878             idate7(2)=idate(2)
879             idate7(3)=idate(3)
880             idate7(4)=idate(1)
881             idate7(7)=100           !denominator for second
882     !
883             nfhour=int(xhour)
884             nfminute=int((xhour-nfhour)*60)
885             nfsecondn=int(((xhour-nfhour)*3600-nfminute*60)*100)
886             nfsecondd=100
887     !
888             call nemsio_init()
889     !
890             call nemsio_open(gfileout,trim(cfile),'write',
891          &    iret = iret,
892          &    modelname='GFS',gdatatype='bin4',
893          &    idate=idate7,nrec=nrec,
894          &    dimx=lonr,dimy=latr,dimz=levs,ncldt=ncld,nmeta=5,
895          &    nfhour=nfhour,nfminute=nfminute,nfsecondn=nfsecondn,
896          &    nfsecondd=nfsecondd,
897          &    extrameta=.true.,nmetavari=nmetavari,
898          &    nmetavarr=nmetavarr,
899          &    nmetaaryi=nmetaaryi,nmetaaryr=nmetaaryr,
900          &    variname=variname,varival=varival,varrname=varrname,
901          &    varrval=varrval,
902          &    aryiname=aryiname,aryilen=aryilen,aryival=aryival,
903          &    ntrac=ntrac,nsoil=lsoil,idrt=idrt,
904          &    recname=recname,reclevtyp=reclevtyp,reclev=reclev)
905     !
906             allocate(tmp(lonr*latr))
907             do i=1,nrec
908              tmp(:)=reshape(buff_mult(:,:,i),(/lonr*latr/) )
909              call nemsio_writerec(gfileout,i,tmp,iret=iret)
910             enddo
911             deallocate(tmp)
912             deallocate(buff_mult)
913     !
914             call nemsio_close(gfileout)
915     !end write pe
916           endif
917     !
918           return
919           end
920           SUBROUTINE wrtflx_a(IOPROC,noflx,ZHOUR,FHOUR,IDATE,colat1,
921          &                  SECSWR,SECLWR, sfc_fld, flx_fld, fluxr,
922          &                  global_lats_r,lonsperlar)
923     !!
924           use resol_def,               ONLY: lonr, latr, levp1, lsoil, nfxr,
925          *                                   ngrids_sfcc
926           use namelist_physics_def,    ONLY: lggfs3d
927           use mod_state,               ONLY: buff_mult_piecef
928           use layout1,                 ONLY: me, lats_node_r,lats_node_r_max
929           use gfs_physics_sfc_flx_mod, ONLY: Sfc_Var_Data, Flx_Var_Data
930           USE machine,             ONLY: kind_io8, kind_io4,grib_undef
931           implicit none
932     !!
933           TYPE(Sfc_Var_Data)        :: sfc_fld
934           TYPE(Flx_Var_Data)        :: flx_fld
935           INTEGER              GLOBAL_LATS_R(LATR)
936           INTEGER              lonsperlar(LATR)
937           integer   IOPROC
938     !!
939           integer LEN,NFLD
940           integer j,i,k,itop,ibot,k4,l,noflx,nundef,ngrid2d
941     !*    PARAMETER(NFLD=18)
942     !     PARAMETER(NFLD=18+6)      ! 550nm AOD added
943           PARAMETER(NFLD=25+6)      ! 550nm AOD added
944            integer ilpds,iyr,imo,ida,ihr,ifhr,ithr,lg,ierr
945            real (kind=kind_io8) RTIMER(NFLD),rtime,rtimsw,rtimlw
946            real (kind=kind_io8) colat1
947            real (kind=kind_io8) cl1,secswr,zhour,fhour,seclwr
948     C
949     
950           real(kind=kind_io4) wrkga(lonr*latr),wrkgb(lonr*latr)
951           real(kind=kind_io8) slmskful(lonr,lats_node_r)
952           real(kind=kind_io8) slmskloc(LONR,LATS_NODE_R_max)
953     !
954           INTEGER     IDATE(4), IDS(255),IENS(5)
955     !     INTEGER     IDATE(4)
956           real (kind=kind_io8) SI(LEVP1)
957     !
958     !sela..................................................................
959     !* change rflux 3rd dimension from 27 to nfxr (Sarah Lu)
960     !*    real (kind=kind_io8)   rflux(lonr,LATS_NODE_R,27)     
961           real (kind=kind_io8)   rflux(lonr,LATS_NODE_R_max,nfxr)
962           real (kind=kind_io8)   glolal(lonr,LATS_NODE_R_max)
963           real (kind=kind_io8)   buffo(lonr,LATS_NODE_R_max)
964           real (kind=kind_io4)   buff1(lonr,latr)
965           real (kind=kind_io4)   buff1l(lonr*latr)
966     !sela..................................................................
967           real (kind=kind_io8)  FLUXR(nfxr,LONR,LATS_NODE_R)
968     !sela..................................................................
969           integer kmsk(lonr,lats_node_r_max),kmsk0(lonr,lats_node_r_max)
970           integer kmskcv(lonr,LATS_NODE_R_max)
971     !jws
972           integer kmskgrib(lonr,lats_node_r_max)
973           real(kind=kind_io4) buff_max
974     !jwe
975     !
976     !!
977           kmsk     = nint(sfc_fld%slmsk)
978           kmsk0    = 0
979     !
980           kmskgrib = 0
981           ngrid2d  = 1
982     !
983           CALL uninterprez(1,kmsk,glolal,sfc_fld%slmsk,
984          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
985           slmskloc = glolal
986           slmskful = buff_mult_piecef(1:lonr,1:lats_node_r,ngrid2d)
987     c
988           do k=1,nfxr
989            do j=1,LATS_NODE_R
990             do i=1,lonr
991              rflux(i,j,k) = fluxr(k,i,j)
992             enddo
993            enddo
994           enddo
995     !!
996     !
997           IF(FHOUR > ZHOUR) THEN
998             RTIME   = 1./(3600.*(FHOUR-ZHOUR))
999           ELSE
1000             RTIME   = 0.
1001           ENDIF
1002           IF(SECSWR > 0.) THEN
1003             RTIMSW   = 1./SECSWR
1004           ELSE
1005             RTIMSW   = 1.
1006           ENDIF
1007           IF(SECLWR > 0.) THEN
1008             RTIMLW   = 1./SECLWR
1009           ELSE
1010             RTIMLW   = 1.
1011           ENDIF
1012           RTIMER     = RTIMSW
1013           RTIMER(1)  = RTIMLW
1014     !*RADFLX*
1015           RTIMER(20) = RTIMLW       ! CSULF_TOA
1016           RTIMER(22) = RTIMLW       ! CSDLF_SFC
1017           RTIMER(25) = RTIMLW       ! CSULF_SFC
1018     !*RADFLX*
1019           CL1        = colat1
1020     !!
1021     !..........................................................
1022           glolal  = flx_fld%DUSFC*RTIME
1023     !jw
1024           ngrid2d = 1
1025           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1026          &    buff_mult_piecef(1,1,ngrid2d))
1027     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1028     !    x '01)Zonal compt of momentum flux (N/m**2) land and sea surface '
1029     
1030     !..........................................................
1031           glolal  = flx_fld%DVSFC*RTIME
1032           ngrid2d = ngrid2d+1
1033           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1034          &     buff_mult_piecef(1,1,ngrid2d))
1035     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1036     !    x '02)Merid compt of momentum flux (N/m**2) land and sea surface '
1037     !..........................................................
1038           glolal  = flx_fld%DTSFC*RTIME
1039           ngrid2d = ngrid2d+1
1040           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1041          &     buff_mult_piecef(1,1,ngrid2d))
1042     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1043     !    x '03)Sensible heat flux (W/m**2) land and sea surface           '
1044     !..........................................................
1045           glolal  = flx_fld%DQSFC*RTIME
1046           ngrid2d = ngrid2d+1
1047           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1048          &     buff_mult_piecef(1,1,ngrid2d))
1049     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1050     !    x '04)Latent heat flux (W/m**2) land and sea surface             '
1051     !..........................................................
1052           ngrid2d = ngrid2d+1
1053           CALL uninterprez(2,kmsk0,buffo,sfc_fld%tsea,
1054          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1055     !     if(ierr.ne.0)print*,'wrtsfc gribsn ierr=',ierr,'  ',
1056     !    x '05)Temperature (K) land and sea surface                       '
1057     !..........................................................
1058           glolal(:,:) = sfc_fld%SMC(1,:,:)
1059           ngrid2d = ngrid2d+1
1060           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1061          &     buff_mult_piecef(1,1,ngrid2d))
1062           where(nint(slmskful)/=1)
1063          &     buff_mult_piecef(:,:,ngrid2d)=grib_undef
1064     !     if(ierr.ne.0)print*,'wrtsfc gribsn ierr=',ierr,'  ',
1065     !    x '06)Volumetric soil moist content (frac) layer 10cm and 0cm    '
1066     !..........................................................
1067           glolal(:,:) = sfc_fld%SMC(2,:,:)
1068           ngrid2d = ngrid2d+1
1069           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1070          &     buff_mult_piecef(1,1,ngrid2d))
1071           where(nint(slmskful)/=1)
1072          &     buff_mult_piecef(:,:,ngrid2d)=grib_undef
1073     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1074     !lu  x '07)Volumetric soil moist content (frac) layer 200cm and 10cm  '
1075     !    + '07)Volumetric soil moist content (frac) layer 40cm and 10cm  '
1076     !..........................................................
1077           glolal(:,:) = sfc_fld%STC(1,:,:)
1078           ngrid2d = ngrid2d+1
1079           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1080          &     buff_mult_piecef(1,1,ngrid2d))
1081           where(nint(slmskful) /= 1)
1082          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1083           nundef   = 0
1084           buff_max = 0.
1085           do j=1,lats_node_r
1086             do i=1,lonr
1087               if(buff_mult_piecef(i,j,ngrid2d)/=grib_undef) then
1088                 if(buff_mult_piecef(i,j,ngrid2d) >buff_max)
1089          &                      buff_max = buff_mult_piecef(i,j,ngrid2d)
1090                 nundef = nundef+1
1091               endif
1092             enddo
1093           enddo
1094     !      write(0,*)'in wrtsfc_a, max stc=',buff_max,' grib_undef=',
1095     !     &   grib_undef,'nundef=',nundef
1096     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1097     !    x '08)Temp (K) layer betw two depth below land sfc 10cm and 0cm  '
1098     !..........................................................
1099           glolal(:,:) = sfc_fld%STC(2,:,:)
1100           ngrid2d = ngrid2d+1
1101           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1102          &     buff_mult_piecef(1,1,ngrid2d))
1103           where(slmskful /= 1._kind_io8)
1104          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1105     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1106     !lu  x '09)Temp (K) layer betw two depth below land sfc 200cm and 10cm'
1107     !    + '09)Temp (K) layer betw two depth below land sfc 40cm and 10cm'
1108     !..........................................................
1109           ngrid2d = ngrid2d+1
1110           CALL uninterprez(2,kmsk,buffo,sfc_fld%sheleg,
1111          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1112     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1113     !    x '10)Water equiv of accum snow depth (kg/m**2) land sea surface '
1114     c..........................................................
1115     !      write(0,*)'before DLWSFC'
1116           glolal  = flx_fld%DLWSFC*RTIME
1117           ngrid2d = ngrid2d+1
1118           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1119          &     buff_mult_piecef(1,1,ngrid2d))
1120     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1121     !    x '11)Downward long wave radiation flux (W/m**2) land sea surface'
1122     !..........................................................
1123           glolal  = flx_fld%ULWSFC*RTIME
1124           ngrid2d = ngrid2d+1
1125           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1126          &     buff_mult_piecef(1,1,ngrid2d))
1127     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1128     !    x '12)Upward long wave radiation flux (W/m**2) land sea surface  '
1129     !..........................................................
1130     !.......  FIX FLUXES FOR APPROX DIURNAL CYCLE
1131           DO 113 K=1,4
1132            do j=1,LATS_NODE_R
1133             do i=1,lonr
1134              glolal(i,j) = rflux(i,j,k)*RTIMER(k)
1135             enddo
1136            enddo
1137           ngrid2d = ngrid2d+1
1138           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1139          &     buff_mult_piecef(1,1,ngrid2d))
1140     !     if(ierr.ne.0.and.k.eq.1)print*,'wrtsfc gribit ierr=',ierr,'  ',
1141     !    x '13)Upward long wave radiation flux (W/m**2) top of atmosphere '
1142     !     if(ierr.ne.0.and.k.eq.2)print*,'wrtsfc gribit ierr=',ierr,'  ',
1143     !    x '14)Upward solar radiation flux (W/m**2) top of atmosphere     '
1144     !     if(ierr.ne.0.and.k.eq.3)print*,'wrtsfc gribit ierr=',ierr,'  ',
1145     !    x '15)Upward solar radiation flux (W/m**2) land and sea surface  '
1146     !     if(ierr.ne.0.and.k.eq.4)print*,'wrtsfc gribit ierr=',ierr,'  ',
1147     !    x '16)Downward solar radiation flux (W/m**2) land and sea surface'
1148       113 CONTINUE
1149     !..........................................................
1150     !
1151     !     For UV-B fluxes
1152     !
1153           do j=1,LATS_NODE_R
1154             do i=1,lonr
1155               glolal(i,j) = rflux(i,j,21)*rtimsw
1156             enddo
1157           enddo
1158           ngrid2d = ngrid2d+1
1159           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1160          &     buff_mult_piecef(1,1,ngrid2d))
1161     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1162     !    x '17)UV-B Downward solar flux (W/m**2) land sea surface'
1163           do j=1,LATS_NODE_R
1164             do i=1,lonr
1165               glolal(i,j) = rflux(i,j,22)*rtimsw
1166             enddo
1167           enddo
1168           ngrid2d = ngrid2d+1
1169           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1170          &     buff_mult_piecef(1,1,ngrid2d))
1171     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1172     !    x '18)clear sky UV-B Downward solar flux (W/m**2) land sea surface'
1173     !
1174     !     End UV-B fluxes
1175     !
1176     !..........................................................
1177     !..........................................................
1178           DO 813 K=5,7
1179     !
1180            do j=1,LATS_NODE_R
1181             do i=1,lonr
1182              glolal(i,j) = rflux(i,j,k)*100.*rtimsw
1183             enddo
1184            enddo
1185           where(glolal.ge.0.5)
1186             kmskcv = 1
1187           elsewhere
1188             kmskcv = 0
1189           endwhere
1190     !!
1191           ngrid2d = ngrid2d+1
1192           CALL uninterprez(2,kmskcv,buffo,glolal,global_lats_r,lonsperlar,
1193          &     buff_mult_piecef(1,1,ngrid2d))
1194     !      where(buff_mult_piecef(:,:,ngrid2d)<=0.5_kind_io4)
1195     !     &    buff_mult_piecef(:,:,ngrid2d) = grib_undef
1196           kmskgrib = 0
1197           where(buff_mult_piecef(:,:,ngrid2d)<=0.5_kind_io4)
1198          &    kmskgrib = 1
1199     !     if(ierr.ne.0.and.k.eq.5)print*,'wrtsfc gribit ierr=',ierr,'  ',
1200     !    x '19)Total cloud cover (percent) high cloud layer               '
1201     !     if(ierr.ne.0.and.k.eq.6)print*,'wrtsfc gribit ierr=',ierr,'  ',
1202     !    x '23)Total cloud cover (percent) middle cloud layer             '
1203     !     if(ierr.ne.0.and.k.eq.7)print*,'wrtsfc gribit ierr=',ierr,'  ',
1204     !    x '27)Total cloud cover (percent) low cloud layer                '
1205     !
1206             K4 = 4  + (K-5)*4
1207             L  = K4 + 1
1208     !
1209            do j=1,LATS_NODE_R
1210             do i=1,lonr
1211              if(rflux(i,j,k) > 0.) then
1212               glolal(i,j) = rflux(i,j,k+3)/rflux(i,j,k)
1213              else
1214               glolal(i,j) = 0.
1215              endif
1216             enddo
1217            enddo
1218           ngrid2d = ngrid2d+1
1219           CALL uninterprez(2,kmskcv,buffo,glolal,global_lats_r,lonsperlar,
1220          &     buff_mult_piecef(1,1,ngrid2d))
1221           where(kmskgrib==1) buff_mult_piecef(:,:,ngrid2d)=grib_undef
1222     !     if(ierr.ne.0.and.k.eq.5)print*,'wrtsfc gribit ierr=',ierr,'  ',
1223     !    x '20)Pressure (Pa) high cloud top level                         '
1224     !     if(ierr.ne.0.and.k.eq.6)print*,'wrtsfc gribit ierr=',ierr,'  ',
1225     !    x '24)Pressure (Pa) middle cloud top level                       '
1226     !     if(ierr.ne.0.and.k.eq.7)print*,'wrtsfc gribit ierr=',ierr,'  ',
1227     !    x '28)Pressure (Pa) low cloud top level                          '
1228             L = K4 + 2
1229     !
1230            do j=1,LATS_NODE_R
1231             do i=1,lonr
1232              if(rflux(i,j,k) > 0.)then
1233               glolal(i,j) = rflux(i,j,k+6)/rflux(i,j,k)
1234              else
1235               glolal(i,j) = 0.
1236              endif
1237             enddo
1238            enddo
1239           ngrid2d = ngrid2d+1
1240           CALL uninterprez(2,kmskcv,buffo,glolal,global_lats_r,lonsperlar,
1241          &     buff_mult_piecef(1,1,ngrid2d))
1242           where(kmskgrib==1) buff_mult_piecef(:,:,ngrid2d)=grib_undef
1243     !     if(ierr.ne.0.and.k.eq.5)print*,'wrtsfc gribit ierr=',ierr,'  ',
1244     !    x '21)Pressure (Pa) high cloud bottom level                      '
1245     !     if(ierr.ne.0.and.k.eq.6)print*,'wrtsfc gribit ierr=',ierr,'  ',
1246     !    x '25)Pressure (Pa) middle cloud bottom level                    '
1247     !     if(ierr.ne.0.and.k.eq.7)print*,'wrtsfc gribit ierr=',ierr,'  ',
1248     !    x '29)Pressure (Pa) low cloud bottom level                       '
1249             L = K4 + 3
1250     !
1251            do j=1,LATS_NODE_R
1252             do i=1,lonr
1253              if(rflux(i,j,k) > 0.)then
1254               glolal(i,j) = rflux(i,j,k+9)/rflux(i,j,k)
1255              else
1256               glolal(i,j) = 0.
1257              endif
1258             enddo
1259            enddo
1260           ngrid2d = ngrid2d+1
1261           CALL uninterprez(2,kmskcv,buffo,glolal,global_lats_r,lonsperlar,
1262          &     buff_mult_piecef(1,1,ngrid2d))
1263           where(kmskgrib==1) buff_mult_piecef(:,:,ngrid2d)=grib_undef
1264     !     if(ierr.ne.0.and.k.eq.5)print*,'wrtsfc gribit ierr=',ierr,'  ',
1265     !    x '22)Temperature (K) high cloud top level                       '
1266     !     if(ierr.ne.0.and.k.eq.6)print*,'wrtsfc gribit ierr=',ierr,'  ',
1267     !    x '26)Temperature (K) middle cloud top level                     '
1268     !     if(ierr.ne.0.and.k.eq.7)print*,'wrtsfc gribit ierr=',ierr,'  ',
1269     !    x '30)Temperature (K) low cloud top level                        '
1270             L = K4 + 4
1271     !
1272       813 CONTINUE
1273     !!
1274     !...................................................................
1275           glolal = flx_fld%GESHEM*1.E3*RTIME
1276           ngrid2d = ngrid2d+1
1277           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1278          &     buff_mult_piecef(1,1,ngrid2d))
1279     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1280     !    x '31)Precipitation rate (kg/m**2/s) land and sea surface        '
1281     c...................................................................
1282           glolal = flx_fld%BENGSH*1.E3*RTIME
1283           ngrid2d = ngrid2d+1
1284           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1285          &     buff_mult_piecef(1,1,ngrid2d))
1286     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1287     !    x '32)Convective precipitation rate (kg/m**2/s) land sea surface '
1288     !...................................................................
1289           glolal  = flx_fld%GFLUX*RTIME
1290           ngrid2d = ngrid2d+1
1291           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1292          &     buff_mult_piecef(1,1,ngrid2d))
1293           where(slmskful==0._kind_io8)
1294          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1295     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1296     !    x '33)Ground heat flux (W/m**2) land and sea surface             '
1297     !...................................................................
1298     !     buffo=MOD(slmskloc,2._kind_io8)
1299     !gwv   add something here
1300     !     do j=1,lats_node_r
1301     !       do i=1,lonr
1302     !         buff_mult_piecea(i,ngrid,j)=buffo(i,j)
1303     !       end do
1304     !     end do
1305     !     ngrid=ngrid+1
1306     !...................................................................
1307     !     Add land/sea mask here
1308           ngrid2d=ngrid2d+1
1309           buffo=MOD(slmskloc,2._kind_io8)
1310           do j=1,lats_node_r
1311             do i=1,lonr
1312     !jw          buff_mult_piecea(i,ngrid,j) = buffo(i,j)
1313               buff_mult_piecef(i,j,ngrid2d) = buffo(i,j)
1314             end do
1315           end do
1316     !jw        ngrid=ngrid+1
1317     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1318     !    x '34)Land-sea mask (1=land; 0=sea) (integer) land sea surface   '
1319     !gwv   add something here
1320     !
1321     !c-- XW: FOR SEA-ICE Nov04
1322           ngrid2d = ngrid2d+1
1323           CALL uninterprez(2,kmsk0,buffo,sfc_fld%fice,
1324          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1325     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1326     !    x '35)Ice concentration (ice>0; no ice=0) (1/0) land sea surface '
1327     !c-- XW: END SEA-ICE
1328     !...................................................................
1329           ngrid2d = ngrid2d+1
1330           CALL uninterprez(2,kmsk0,buffo,flx_fld%u10m,
1331          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1332     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1333     !    x '36)u wind (m/s) height above ground                           '
1334     !...................................................................
1335           ngrid2d = ngrid2d+1
1336           CALL uninterprez(2,kmsk0,buffo,flx_fld%v10m,
1337          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1338     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1339     !    x '37)v wind (m/s) height above ground                           '
1340     !...................................................................
1341           ngrid2d = ngrid2d+1
1342           CALL uninterprez(2,kmsk0,buffo,sfc_fld%t2m,
1343          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1344     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1345     !    x '38)Temperature (K) height above ground                        '
1346     !...................................................................
1347           ngrid2d = ngrid2d+1
1348           CALL uninterprez(2,kmsk0,buffo,sfc_fld%q2m,
1349          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1350     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1351     !    x '39)Specific humidity (kg/kg) height above ground              '
1352     !...................................................................
1353           glolal  = flx_fld%PSURF
1354           ngrid2d = ngrid2d+1
1355           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1356          &     buff_mult_piecef(1,1,ngrid2d))
1357     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1358     !    x '40)Pressure (Pa) land and sea surface                         '
1359     !...................................................................
1360           ngrid2d = ngrid2d+1
1361           CALL uninterprez(2,kmsk0,buffo,flx_fld%tmpmax,
1362          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1363     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1364     !    x '41)Maximum temperature (K) height above ground                '
1365     !...................................................................
1366           ngrid2d = ngrid2d+1
1367           CALL uninterprez(2,kmsk0,buffo,flx_fld%tmpmin,
1368          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1369     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1370     !    x '42)Minimum temperature (K) height above ground                '
1371     !...................................................................
1372           ngrid2d = ngrid2d+1
1373           CALL uninterprez(2,kmsk0,buffo,flx_fld%spfhmax,
1374          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1375     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1376     !    x '41a)Maximum specific humidity (kg/kg) height above ground      '
1377     !...................................................................
1378           ngrid2d = ngrid2d+1
1379           CALL uninterprez(2,kmsk0,buffo,flx_fld%spfhmin,
1380          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1381     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1382     !    x '42a)Minimum specific humidity (kg/kg) height above ground      '
1383     !...................................................................
1384           glolal = flx_fld%RUNOFF * 1.E3
1385           ngrid2d = ngrid2d+1
1386           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1387          &     buff_mult_piecef(1,1,ngrid2d))
1388           where(slmskful == 0._kind_io8)
1389          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1390     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1391     !    x '43)Runoff (kg/m**2) land and sea surface                      '
1392     !...................................................................
1393           glolal  = flx_fld%EP * RTIME
1394           ngrid2d = ngrid2d+1
1395           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1396          &     buff_mult_piecef(1,1,ngrid2d))
1397           where(slmskful == 0._kind_io8)
1398          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1399     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1400     !    x '44)Potential evaporation rate (w/m**/) land and sea surface   '
1401     !...................................................................
1402           glolal  = flx_fld%CLDWRK * RTIME
1403           ngrid2d = ngrid2d+1
1404           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1405          &     buff_mult_piecef(1,1,ngrid2d))
1406     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1407     !    x '45)Cloud work function (J/Kg) total atmospheric column        '
1408     !...................................................................
1409           glolal  = flx_fld%DUGWD*RTIME
1410           ngrid2d = ngrid2d+1
1411           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1412          &     buff_mult_piecef(1,1,ngrid2d))
1413     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1414     !    x '46)Zonal gravity wave stress (N/m**2) land and sea surface    '
1415     !...................................................................
1416           glolal  = flx_fld%DVGWD*RTIME
1417           ngrid2d = ngrid2d+1
1418           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1419          &     buff_mult_piecef(1,1,ngrid2d))
1420     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1421     !    x '47)Meridional gravity wave stress (N/m**2) land sea surface   '
1422     !...................................................................
1423           ngrid2d = ngrid2d+1
1424           CALL uninterprez(2,kmsk0,buffo,flx_fld%hpbl,
1425          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1426     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1427     !    x '48)Boundary layer height '
1428     !...................................................................
1429     !hmhj CALL uninterprez(2,kmsk0,buffo,flx_fld%pwat,
1430     !hmhj&                 global_lats_r,lonsperlar)
1431           ngrid2d = ngrid2d+1
1432           CALL uninterprez(2,kmsk0,buffo,flx_fld%pwat,
1433          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1434     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1435     !    x '49)Precipitable water (kg/m**2) total atmospheric column      '
1436     !...................................................................
1437     !
1438            do j=1,LATS_NODE_R
1439             do i=1,lonr
1440              if (rflux(i,j,4) > 0.) then
1441               glolal(i,j) = rflux(i,j,3)/rflux(i,j,4) * 100.
1442               if (glolal(i,j) > 100.) glolal(i,j) = 100.
1443              else
1444               glolal(i,j) = 0.
1445              endif
1446             enddo
1447            enddo
1448           ngrid2d = ngrid2d+1
1449           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1450          &     buff_mult_piecef(1,1,ngrid2d))
1451     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1452     !    x '50)Albedo (percent) land and sea surface                      '
1453     !
1454            do j=1,LATS_NODE_R
1455             do i=1,lonr
1456              glolal(i,j) = rflux(i,j,26)*100.*rtimsw
1457             enddo
1458            enddo
1459           ngrid2d = ngrid2d+1
1460           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1461          &     buff_mult_piecef(1,1,ngrid2d))
1462     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1463     !    x '51)Total cloud cover (percent) total atmospheric column       '
1464     !
1465     ! CONVECTIVE CLOUDS
1466     ! LABELED INSTANTANEOUS BUT ACTUALLY AVERAGED OVER FHSWR HOURS
1467     !
1468           glolal = sfc_fld%CV*1.E2
1469           where(glolal >= 0.5)
1470             kmskcv = 1
1471           elsewhere
1472             kmskcv = 0
1473           endwhere
1474           ngrid2d = ngrid2d+1
1475           CALL uninterprez(2,kmskcv,buffo,glolal,global_lats_r,lonsperlar,
1476          &     buff_mult_piecef(1,1,ngrid2d))
1477           kmskgrib = 0
1478           where(buff_mult_piecef(:,:,ngrid2d)<0.5_kind_io8)
1479          &     kmskgrib = 1
1480     !      where(buff_mult_piecef(:,:,ngrid2d)<0.5_kind_io8)
1481     !     &     buff_mult_piecef(:,:,ngrid2d)=grib_undef
1482     !      write(0,*)'52after cloud cover,buff=',maxval(buff_mult_piecef(
1483     !     &   1:lonr,1:lats_node_r,ngrid2d)), minval(buff_mult_piecef(
1484     !     &   1:lonr,1:lats_node_r,ngrid2d)),'ngrid2d=',ngrid2d
1485     
1486     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1487     !    x '52)Total cloud cover (percent) convective cloud layer         '
1488     !.................................................
1489            do j=1,LATS_NODE_R
1490             do i=1,lonr
1491             glolal(i,j) = 0.
1492             IF(sfc_fld%CV(i,j) > 0.) THEN
1493     !        ITOP=NINT(CVT(i,j))
1494     !        IF(ITOP.GE.1.AND.ITOP.LE.LEVS)
1495     !    &   glolal(i,j)=SI(ITOP+1)*PSURF(i,j)*1.E3
1496     !...      cvt already a pressure (cb)...convert to Pa
1497     !        glolal(i,j) = sfc_fld%CVT(i,j)*1.E3
1498              glolal(i,j) = sfc_fld%CVT(i,j)     ! already Pa
1499             END IF
1500            ENDDO
1501           ENDDO
1502           ngrid2d = ngrid2d+1
1503           CALL uninterprez(2,kmskcv,buffo,glolal,global_lats_r,lonsperlar,
1504          &     buff_mult_piecef(1,1,ngrid2d))
1505           where(kmskgrib == 1)
1506          &     buff_mult_piecef(:,:,ngrid2d)=grib_undef
1507     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1508     !    x '53)Pressure (Pa) convective cloud top level                   '
1509     !.................................................
1510            do j=1,LATS_NODE_R
1511             do i=1,lonr
1512             glolal(i,j) = 0.
1513             IF(sfc_fld%CV(i,j) > 0.) THEN
1514     !        Ibot=NINT(CVB(i,j))
1515     !        IF(Ibot.GE.1.AND.Ibot.LE.LEVS)
1516     !    &   glolal(i,j)=SI(IBOT)*PSURF(i,j)*1.E3
1517     !...      cvb already a pressure (cb)...convert to Pa
1518     !        glolal(i,j) = sfc_fld%CVB(i,j)*1.E3
1519              glolal(i,j) = sfc_fld%CVB(i,j)      ! already Pa
1520             END IF
1521            ENDDO
1522           ENDDO
1523           ngrid2d = ngrid2d+1
1524           CALL uninterprez(2,kmskcv,buffo,glolal,global_lats_r,lonsperlar,
1525          &     buff_mult_piecef(1,1,ngrid2d))
1526           where(kmskgrib == 1)
1527          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1528     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1529     !    x '54)Pressure (Pa) convective cloud bottom level                '
1530     !.................................................
1531     !...   SAVE B.L. CLOUD AMOUNT
1532     !
1533            do j=1,LATS_NODE_R
1534             do i=1,lonr
1535              glolal(i,j) = rflux(i,j,27)*100.*rtimsw
1536             enddo
1537            enddo
1538           ngrid2d = ngrid2d+1
1539           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1540          &     buff_mult_piecef(1,1,ngrid2d))
1541     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1542     !    x '55)Total cloud cover (percent) boundary layer cloud layer     '
1543     !c-- XW: FOR SEA-ICE Nov04
1544           ngrid2d = ngrid2d+1
1545           CALL uninterprez(2,kmsk0,buffo,sfc_fld%hice,
1546          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1547     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1548           where(nint(slmskful) /= 1)
1549          &     buff_mult_piecef(:,:,ngrid2d)=grib_undef
1550     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1551     !    x '56)Sea ice thickness (m) category 1'
1552     !c-- XW: END SEA-ICE
1553     !.................................................
1554     !lu: add smc(3:4), stc(3:4), slc(1:4), snwdph, canopy
1555     !lu: addition of 10 records starts here -------------------------------
1556           if(lsoil > 2)then
1557             glolal(:,:) = sfc_fld%SMC(3,:,:)
1558             ngrid2d = ngrid2d+1
1559             CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1560          &     buff_mult_piecef(1,1,ngrid2d))
1561           where(nint(slmskful) /= 1)
1562          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1563     !       if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1564     !    &   '57)Volumetric soil moist content (frac) layer 100cm and 40cm '
1565     !..........................................................
1566             glolal(:,:) = sfc_fld%SMC(4,:,:)
1567             ngrid2d = ngrid2d+1
1568             CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1569          &     buff_mult_piecef(1,1,ngrid2d))
1570           where(nint(slmskful) /= 1)
1571          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1572     !       if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1573     !    &   '58)Volumetric soil moist content (frac) layer 200cm and 100cm '
1574     !..........................................................
1575             glolal(:,:) = sfc_fld%STC(3,:,:)
1576             ngrid2d = ngrid2d+1
1577             CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1578          &     buff_mult_piecef(1,1,ngrid2d))
1579           where(nint(slmskful) /= 1)
1580          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1581     !       if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1582     !    &   '59)Temp (K) layer betw two depth below land sfc 100cm and 40cm'
1583     !..........................................................
1584             glolal(:,:) = sfc_fld%STC(4,:,:)
1585             ngrid2d = ngrid2d+1
1586             CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1587          &     buff_mult_piecef(1,1,ngrid2d))
1588           where(nint(slmskful) /= 1)
1589          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1590     !       if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1591     !    &   '60)Temp (K) layer betw two depth below land sfc 200cm and 100cm'
1592           endif
1593     !..........................................................
1594           glolal(:,:) = sfc_fld%SLC(1,:,:)
1595           ngrid2d = ngrid2d+1
1596           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1597          &     buff_mult_piecef(1,1,ngrid2d))
1598           where(nint(slmskful) /= 1)
1599          &     buff_mult_piecef(:,:,ngrid2d)=grib_undef
1600     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1601     !    x '61)Liquid soil moist content (frac) layer 10cm and 0cm  '
1602     !..........................................................
1603           glolal(:,:) = sfc_fld%SLC(2,:,:)
1604           ngrid2d = ngrid2d+1
1605           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1606          &     buff_mult_piecef(1,1,ngrid2d))
1607           where(nint(slmskful) /=1 )
1608          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1609     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1610     !    x '62)Liquid soil moist content (frac) layer 40cm and 10cm '
1611     !..........................................................
1612           if(lsoil.gt.2)then
1613             glolal(:,:) = sfc_fld%SLC(3,:,:)
1614           ngrid2d = ngrid2d+1
1615             CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1616          &     buff_mult_piecef(1,1,ngrid2d))
1617           where(nint(slmskful) /= 1)
1618          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1619     !       if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1620     !    &   '63)Liquid soil moist content (frac) layer 100cm and 40cm'
1621     !..........................................................
1622             glolal(:,:) = sfc_fld%SLC(4,:,:)
1623           ngrid2d = ngrid2d+1
1624             CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1625          &     buff_mult_piecef(1,1,ngrid2d))
1626           where(nint(slmskful) /= 1)
1627          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1628     !       if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1629     !    &   '64)Liquid soil moist content (frac) layer 200cm and 100cm'
1630           endif
1631     !..........................................................
1632           glolal = sfc_fld%SNWDPH / 1.E3       !! convert from mm to m
1633           ngrid2d = ngrid2d+1
1634           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1635          &     buff_mult_piecef(1,1,ngrid2d))
1636           where(nint(slmskful) /= 1)
1637          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1638     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1639     !    & '65)Snow depth (m) land surface 
1640     c..........................................................
1641     !     LBM=slmskful.EQ.1._kind_io8
1642           ngrid2d = ngrid2d+1
1643           CALL uninterprez(2,kmsk,buffo,sfc_fld%canopy,
1644          &       global_lats_r,lonsperlar,
1645          &       buff_mult_piecef(1,1,ngrid2d))
1646           where(nint(slmskful) /= 1)
1647          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1648     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1649     !    & '66)Canopy water content (kg/m^2) land surface      '
1650     !lu: addition of 10 records ends here -------------------------------
1651     !
1652     !wei: addition of 30 records starts here -------------------------------
1653           glolal  = sfc_fld%ZORL / 1.E2       !! convert from cm to m
1654           ngrid2d = ngrid2d+1
1655           CALL uninterprez(1,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1656          &     buff_mult_piecef(1,1,ngrid2d))
1657     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1658     !    & '67)Surface roughness (m)       '
1659     !..........................................................
1660           glolal  = sfc_fld%vfrac*100.
1661           ngrid2d = ngrid2d+1
1662           CALL uninterprez(1,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1663          &     buff_mult_piecef(1,1,ngrid2d))
1664           where(nint(slmskful) /= 1)
1665          &     buff_mult_piecef(:,:,ngrid2d)=grib_undef
1666     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1667     !    & '68)Vegetation fraction (fractional) land surface      '
1668     !..........................................................
1669           ngrid2d = ngrid2d+1
1670           CALL uninterprez(1,kmsk,glolal,sfc_fld%vtype,
1671          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1672           buffo = MOD(glolal,2._kind_io8)
1673           where(nint(slmskful) /= 1)
1674          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1675     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1676     !    & '69)Vegetation type land surface      '
1677     !..........................................................
1678           ngrid2d = ngrid2d+1
1679           CALL uninterprez(1,kmsk,glolal,sfc_fld%stype,
1680          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1681           buffo=MOD(glolal,2._kind_io8)
1682           where(nint(slmskful) /= 1)
1683          &     buff_mult_piecef(:,:,ngrid2d)=grib_undef
1684     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1685     !    & '70)Soil type land surface      '
1686     !..........................................................
1687           ngrid2d = ngrid2d+1
1688           CALL uninterprez(1,kmsk,glolal,sfc_fld%slope,
1689          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1690           buffo = MOD(glolal,2._kind_io8)
1691           where(nint(slmskful) /= 1)
1692          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1693     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1694     !    & '71)Slope type land surface      '
1695     !..........................................................
1696           ngrid2d = ngrid2d+1
1697           CALL uninterprez(2,kmsk0,buffo,sfc_fld%uustar,
1698          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1699     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1700     !    & '72)Frictional velocity (m/s)     '
1701     !..........................................................
1702           ngrid2d = ngrid2d+1
1703           CALL uninterprez(1,kmsk,buffo,sfc_fld%oro,
1704          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1705     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1706     !    & '73)Surface height (m)       '
1707     !..........................................................
1708           ngrid2d = ngrid2d+1
1709           CALL uninterprez(1,kmsk,buffo,sfc_fld%srflag,
1710          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1711           where(nint(slmskful) /= 1)
1712          &     buff_mult_piecef(:,:,ngrid2d)=grib_undef
1713     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1714     !    & '74)Freezing precip flag land surface      '
1715     !..........................................................
1716           ngrid2d = ngrid2d+1
1717           CALL uninterprez(2,kmsk0,buffo,flx_fld%chh,
1718          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1719     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1720     !    & '75)Exchange coefficient CH(m/s)       '
1721     !..........................................................
1722           ngrid2d = ngrid2d+1
1723           CALL uninterprez(2,kmsk0,buffo,flx_fld%cmm,
1724          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1725     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1726     !    & '76)Exchange coefficient CM(m/s)       '
1727     !..........................................................
1728           ngrid2d = ngrid2d+1
1729           CALL uninterprez(2,kmsk,buffo,flx_fld%EPI,
1730          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1731           where(nint(slmskful) /= 1)
1732          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1733     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1734     !    & '77)Potential evaporation rate (w/m**2) land and sea surface   '
1735     !..........................................................
1736           ngrid2d = ngrid2d+1
1737           CALL uninterprez(2,kmsk0,buffo,flx_fld%DLWSFCI,
1738          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1739     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1740     !    & '78)Downward long wave radiation flux (W/m**2) '
1741     !..........................................................
1742           ngrid2d = ngrid2d+1
1743           CALL uninterprez(2,kmsk0,buffo,flx_fld%ULWSFCI,
1744          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1745     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1746     !    & '79)Upward long wave radiation flux (W/m**2)  '
1747     !..........................................................
1748           ngrid2d = ngrid2d+1
1749           CALL uninterprez(2,kmsk0,buffo,flx_fld%USWSFCI,
1750          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1751     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1752     !    & '80)Upward short wave radiation flux (W/m**2)  '
1753     !..........................................................
1754           ngrid2d = ngrid2d+1
1755           CALL uninterprez(2,kmsk0,buffo,flx_fld%DSWSFCI,
1756          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1757     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1758     !    & '81)Downward short wave radiation flux (W/m**2)   '
1759     !..........................................................
1760           ngrid2d = ngrid2d+1
1761           CALL uninterprez(2,kmsk0,buffo,flx_fld%DTSFCI,
1762          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1763     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1764     !    & '82)Sensible heat flux (W/m**2) land and sea surface       '
1765     !..........................................................
1766           ngrid2d = ngrid2d+1
1767           CALL uninterprez(2,kmsk0,buffo,flx_fld%DQSFCI,
1768          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1769     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1770     !    & '83)Latent heat flux (W/m**2) land and sea surface         '
1771     !..........................................................
1772           ngrid2d = ngrid2d+1
1773           CALL uninterprez(2,kmsk,buffo,flx_fld%GFLUXI,
1774          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1775           where(nint(slmskful) /= 1)
1776          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1777     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1778     !    & '84)Ground heat flux (W/m**2) land and sea surface         '
1779     !..........................................................
1780           glolal  = flx_fld%SRUNOFF * 1.E3
1781           ngrid2d = ngrid2d+1
1782           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1783          &    buff_mult_piecef(1,1,ngrid2d))
1784           where(nint(slmskful) /= 1)
1785          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1786     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1787     !    & '85)Surface runoff (kg/m^2) land surface      '
1788     !..........................................................
1789           ngrid2d = ngrid2d+1
1790           CALL uninterprez(2,kmsk0,buffo,flx_fld%t1,
1791          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1792     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1793     !    x '86)Lowest model level Temp (K)      '
1794     !..........................................................
1795           ngrid2d = ngrid2d+1
1796           CALL uninterprez(2,kmsk0,buffo,flx_fld%q1,
1797          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1798     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1799     !    & '87)Lowest model specific humidity (kg/kg)    '
1800     !..........................................................
1801           ngrid2d = ngrid2d+1
1802           CALL uninterprez(2,kmsk0,buffo,flx_fld%u1,
1803          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1804     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1805     !    x '88)Lowest model u wind (m/s)      '
1806     !..........................................................
1807           ngrid2d = ngrid2d+1
1808           CALL uninterprez(2,kmsk0,buffo,flx_fld%v1,
1809          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1810     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1811     !    & '89)Lowest model v wind (m/s)       '
1812     !..........................................................
1813           ngrid2d = ngrid2d+1
1814           CALL uninterprez(2,kmsk,buffo,flx_fld%zlvl,
1815          &       global_lats_r,lonsperlar,buff_mult_piecef(1,1,ngrid2d))
1816           where(nint(slmskful) /= 1)
1817          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1818     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1819     !    x '90)Lowest model level height (m) land surface      '
1820     !..........................................................
1821           glolal  = flx_fld%EVBSA*RTIME
1822           ngrid2d = ngrid2d+1
1823           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1824          &     buff_mult_piecef(1,1,ngrid2d))
1825           where(nint(slmskful) /= 1)
1826          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1827     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1828     !    & '91)Direct evaporation from bare soil(W/m^2) land surface      '
1829     !..........................................................
1830           glolal  = flx_fld%EVCWA*RTIME
1831           ngrid2d = ngrid2d+1
1832           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1833          &     buff_mult_piecef(1,1,ngrid2d))
1834           where(nint(slmskful) /=1 )
1835          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1836     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1837     !    & '92)Canopy water evaporation(W/m^2) land surface      '
1838     !..........................................................
1839           glolal  = flx_fld%TRANSA*RTIME
1840           ngrid2d = ngrid2d+1
1841           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1842          &     buff_mult_piecef(1,1,ngrid2d))
1843           where(nint(slmskful) /= 1)
1844          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1845     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1846     !    & '93)Transpiration (W/m^2) land surface      '
1847     !..........................................................
1848           glolal  = flx_fld%SBSNOA*RTIME
1849           ngrid2d = ngrid2d+1
1850           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1851          &     buff_mult_piecef(1,1,ngrid2d))
1852           where(nint(slmskful) /= 1)
1853          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1854     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1855     !    & '94)Snow Sublimation (W/m^2) land surface      '
1856     !..........................................................
1857           glolal  = flx_fld%SNOWCA*RTIME*100.
1858           ngrid2d = ngrid2d+1
1859           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1860          &     buff_mult_piecef(1,1,ngrid2d))
1861           where(nint(slmskful) /= 1)
1862          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1863     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1864     !    & '95)Snow Cover (fraction) land surface      '
1865     !..........................................................
1866           glolal  = flx_fld%soilm*1.E3       !! convert from m to (mm)kg/m^2
1867           ngrid2d = ngrid2d+1
1868           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1869          &     buff_mult_piecef(1,1,ngrid2d))
1870           where(nint(slmskful) /= 1)
1871          &     buff_mult_piecef(:,:,ngrid2d) = grib_undef
1872     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1873     !    & '96)Total column soil moisture (Kg/m^2) land surface      '
1874     
1875     Cwei: addition of 30 records ends here -------------------------------
1876     
1877     !*RADFLX*
1878     !Clu: addition of 7 records starts here -------------------------------
1879     !dswrf_toa, csulf_toa, csusf_toa, csdlf_sfc,csusf_sfc, csdsf_sfc, csulf_sfc
1880     !
1881           DO 115 K=19, 25
1882            if(K .eq. 19)  then
1883               L = 18
1884             else
1885               L = K + 8
1886            endif
1887            do j=1,LATS_NODE_R
1888             do i=1,lonr
1889              glolal(i,j)=rflux(i,j,L)*RTIMER(K)
1890             enddo
1891            enddo
1892           ngrid2d = ngrid2d+1
1893           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1894          &     buff_mult_piecef(1,1,ngrid2d))
1895     !     if(ierr.ne.0.and.k.eq.19)print*,'wrtsfc gribit ierr=',ierr,'  ',
1896     !    x '97)Downward solar radiation flux (W/m**2) TOA '
1897     !     if(ierr.ne.0.and.k.eq.20)print*,'wrtsfc gribit ierr=',ierr,'  ',
1898     
1899     !    x '98)CS upward long wave radiation flux (W/m**2) TOA '
1900     !     if(ierr.ne.0.and.k.eq.21)print*,'wrtsfc gribit ierr=',ierr,'  ',
1901     !    x '99)CS upward solar radiation flux (W/m**2) TOA     '
1902     !     if(ierr.ne.0.and.k.eq.22)print*,'wrtsfc gribit ierr=',ierr,'  ',
1903     !    x '100)CS downward long radiation flux (W/m**2) SFC  '
1904     !     if(ierr.ne.0.and.k.eq.23)print*,'wrtsfc gribit ierr=',ierr,'  ',
1905     !    x '101)CS upward solar radiation flux (W/m**2)  SFC '
1906     !     if(ierr.ne.0.and.k.eq.24)print*,'wrtsfc gribit ierr=',ierr,'  ',
1907     !    x '102)CS downward solar radiation flux (W/m**2) SFC'
1908     !     if(ierr.ne.0.and.k.eq.25)print*,'wrtsfc gribit ierr=',ierr,'  ',
1909     !    x '103)CS upward long wave radiation flux (W/m**2) SFC '
1910     
1911       115 CONTINUE
1912     !..........................................................
1913           glolal  = flx_fld%snohfa*RTIME
1914           ngrid2d = ngrid2d+1
1915           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1916          &     buff_mult_piecef(1,1,ngrid2d))
1917     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1918     !    x '104)Snow phase-change heat flux [W/m^2] land surface      '
1919     !..........................................................
1920           glolal  = flx_fld%smcwlt2
1921           ngrid2d = ngrid2d+1
1922     !      print *,'in wrtout,smcwlt=',maxval(flx_fld%smcwlt2),
1923     !     &  minval(flx_fld%smcwlt2),'loc=',minloc(flx_fld%smcwlt2)
1924           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1925          &     buff_mult_piecef(1,1,ngrid2d))
1926     !      print *,'in wrtout,aft unitpl,smcwlt=',
1927     !     &  maxval(buff_mult_piecef(:,:,ngrid2d)),
1928     !     &  minval(buff_mult_piecef(:,:,ngrid2d)),'ngrid2d=',ngrid2d
1929     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1930     !    x '105)Wilting point [fraction] land surface      '
1931     !..........................................................
1932           glolal  = flx_fld%smcref2
1933           ngrid2d = ngrid2d+1
1934           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1935          &     buff_mult_piecef(1,1,ngrid2d))
1936     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1937     !    x '106)Field capacity [fraction] land surface      '
1938     !..........................................................
1939     
1940     !lu: addition of 7 records ends here ---------------------------------
1941     !..........................................................
1942     !
1943     !    accumulated sunshine time
1944     !
1945           glolal  = flx_fld%suntim
1946           ngrid2d = ngrid2d+1
1947           CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1948          &     buff_mult_piecef(1,1,ngrid2d))
1949     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1950     !    x '107)Accumulated sunshine duration (sec)'
1951     !
1952     !    end sunshine time
1953     !
1954     Clu: addition of 6 aod fields starts here ---------------------------
1955            do k = nfxr-5, nfxr
1956              do j=1,LATS_NODE_R
1957                do i=1,lonr
1958                  glolal(i,j) = rflux(i,j,k)*RTIMER(k-15)
1959                enddo
1960              enddo
1961            ngrid2d = ngrid2d+1
1962            CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,lonsperlar,
1963          &     buff_mult_piecef(1,1,ngrid2d))
1964     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1965     !    x '108)Total Aerosol optical depth at 550nm land sea surface'
1966     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1967     !    x '109)DU Aerosol optical depth at 550nm land sea surface'
1968     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1969     !    x '110)BC Aerosol optical depth at 550nm land sea surface'
1970     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1971     !    x '111)OC Aerosol optical depth at 550nm land sea surface'
1972     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1973     !    x '112)SU Aerosol optical depth at 550nm land sea surface'
1974     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1975     !    x '113)SS Aerosol optical depth at 550nm land sea surface'
1976            enddo
1977     Clu: addition of 6 aod fields ends here -----------------------------
1978     !
1979     !...................................................................
1980     ! Output additional variable (averaged quantity) for GOCART
1981     ! If LGGFS3D = .TRUE.
1982     !
1983           IF ( LGGFS3D ) THEN
1984     !
1985     !hchuang code change [+16L] 11/12/2007 :
1986     !..........................................................
1987           glolal  = flx_fld%gsoil*rtime !! gsoil already in mm (kg/m^2)
1988           ngrid2d = ngrid2d+1
1989           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1990          &     buff_mult_piecef(1,1,ngrid2d))
1991     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1992     !    x '114)Average VOL soil moist content(frac) layer 10cm -> 0cm'
1993     !..........................................................
1994           glolal  = flx_fld%gtmp2m*rtime
1995           ngrid2d = ngrid2d+1
1996           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
1997          &     buff_mult_piecef(1,1,ngrid2d))
1998     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
1999     !    x '115)Average temperature at 2 meter (K)                    '
2000     !..........................................................
2001           glolal  = flx_fld%gustar*rtime
2002           ngrid2d = ngrid2d+1
2003           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
2004          &     buff_mult_piecef(1,1,ngrid2d))
2005     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
2006     !    x '116)Average Frictional Velocity (m/s)                     '
2007     !..........................................................
2008           glolal  = flx_fld%gpblh*rtime
2009           ngrid2d = ngrid2d+1
2010           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
2011          &     buff_mult_piecef(1,1,ngrid2d))
2012     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
2013     !    x '117)Average Boundary layer height                        '
2014     !..........................................................
2015           glolal  = flx_fld%gu10m*rtime
2016           ngrid2d = ngrid2d+1
2017           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
2018          &     buff_mult_piecef(1,1,ngrid2d))
2019     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
2020     !    x '118)Average u wind (m/s) height 10m above ground         '
2021     !..........................................................
2022           glolal  = flx_fld%gv10m*rtime
2023           ngrid2d = ngrid2d+1
2024           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
2025          &     buff_mult_piecef(1,1,ngrid2d))
2026     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
2027     !    x '119)Average v wind (m/s) height 10m above ground         '
2028     !..........................................................
2029     !hchuang confirmed by Helin, correct bug, zorl unit in cm not mm
2030     ! BUG      glolal=gzorl*1.0E-3*rtime  !! convert from mm to m
2031           glolal  = flx_fld%gzorl*1.0E-2*rtime  !! convert from cm to m
2032           ngrid2d = ngrid2d+1
2033           CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
2034          &     buff_mult_piecef(1,1,ngrid2d))
2035     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
2036     !    x '120)Average Surface roughness (m)
2037     !
2038     !..........................................................
2039     !
2040     !hchuang when callng sub  uninterprez, array glolal is assign to
2041     !        buff_mult_piecea at the ngrid location, then ngrid advanced
2042     !        by 1.  Before assign the modified value (buffo) to
2043     !        buff_mult_piecea again dial ngrid back by 1 for the correct
2044     !        ngrid index otherwise, you risk the chance that ngrid might
2045     !        > ngrids_flx+1  which cause the address error or arry over-run
2046     !
2047     !hchuang code change [+2]  when callng sub  uninterprez, array glolal is assign
2048     to
2049             glolal  = flx_fld%goro*rtime
2050             ngrid2d = ngrid2d+1
2051             CALL uninterprez(2,kmsk,buffo,glolal,global_lats_r,lonsperlar,
2052          &     buff_mult_piecef(1,1,ngrid2d))
2053     !     if(ierr.ne.0)print*,'wrtsfc gribit ierr=',ierr,'  ',
2054     !    x '121)Average Land Sea surface (fraction)                  '
2055     !
2056     !..........................................................
2057           ENDIF
2058     
2059     
2060           if(me.eq.ioproc)
2061          &   PRINT *,'(wrtflx_a) GRIB FLUX FILE WRITTEN ',FHOUR,IDATE,noflx
2062     !!
2063           RETURN
2064           END
2065     
2066     !!*********************************************************************
2067     !! This routine is added to output 2d aerosol diag fields (Sarah Lu)
2068     
2069           SUBROUTINE wrtaer(IOPROC,noaer,ZHOUR,FHOUR,IDATE,
2070          &             sfc_fld, g2d_fld,global_lats_r, lonsperlar)
2071     !!
2072           use resol_def,               ONLY: lonr, latr, ngrids_aer
2073           use mod_state,               ONLY: buff_mult_pieceg
2074           use layout1,                 ONLY: me, lats_node_r,lats_node_r_max
2075           use gfs_physics_sfc_flx_mod, ONLY: Sfc_Var_Data
2076           use gfs_physics_g2d_mod,     ONLY: G2D_Var_Data
2077           USE machine,                 ONLY: kind_io8, kind_io4
2078           implicit none
2079     !!
2080           TYPE(Sfc_Var_Data)        :: sfc_fld
2081           TYPE(G2D_Var_Data)        :: g2d_fld
2082           INTEGER                   GLOBAL_LATS_R(LATR)
2083           INTEGER                   lonsperlar(LATR)
2084           integer                   IOPROC
2085     !!
2086           integer                   i,j,k,l,noaer,ngrid2d,ierr
2087           real (kind=kind_io8)      rtime
2088           real (kind=kind_io8)      zhour,fhour
2089     
2090     !     real(kind=kind_io8) slmskful(lonr,lats_node_r)
2091     !     real(kind=kind_io8) slmskloc(LONR,LATS_NODE_R)
2092     !
2093           INTEGER     IDATE(4), IDS(255),IENS(5)
2094     !
2095           real (kind=kind_io8)   glolal(lonr,LATS_NODE_R_max)
2096           real (kind=kind_io8)   buffo(lonr,LATS_NODE_R_max)
2097           integer kmsk  (lonr,lats_node_r_max),kmsk0(lonr,lats_node_r_max)
2098     !
2099           kmsk=nint(sfc_fld%slmsk)
2100           kmsk0=0
2101     !
2102     !     ngrid2d=1
2103     !
2104           IF(FHOUR.GT.ZHOUR) THEN
2105             RTIME=1./(3600.*(FHOUR-ZHOUR))
2106           ELSE
2107             RTIME=0.
2108           ENDIF
2109     !
2110     !..........................................................
2111     !
2112           ngrid2d = 0
2113           if ( g2d_fld%du%nfld > 0 ) then
2114             do  k = 1, g2d_fld%du%nfld
2115               glolal = RTIME*1.e6*g2d_fld%du%diag(k)%flds
2116               ngrid2d=ngrid2d+1
2117               CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,
2118          &                   lonsperlar,buff_mult_pieceg(1,1,ngrid2d))
2119             enddo
2120           endif
2121     !
2122     !..........................................................
2123     !
2124           if ( g2d_fld%su%nfld > 0 ) then
2125             do  k = 1, g2d_fld%su%nfld
2126               glolal = RTIME*1.e6*g2d_fld%su%diag(k)%flds
2127               ngrid2d=ngrid2d+1
2128               CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,
2129          &                   lonsperlar,buff_mult_pieceg(1,1,ngrid2d))
2130             enddo
2131           endif
2132     !
2133     !..........................................................
2134     !
2135           if ( g2d_fld%ss%nfld > 0 ) then
2136             do  k = 1, g2d_fld%ss%nfld
2137               glolal = RTIME*1.e6*g2d_fld%ss%diag(k)%flds
2138               ngrid2d=ngrid2d+1
2139               CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,
2140          &                   lonsperlar,buff_mult_pieceg(1,1,ngrid2d))
2141             enddo
2142           endif
2143     !
2144     !..........................................................
2145     !
2146           if ( g2d_fld%oc%nfld > 0 ) then
2147             do  k = 1, g2d_fld%oc%nfld
2148               glolal=RTIME*1.e6*g2d_fld%oc%diag(k)%flds
2149               ngrid2d=ngrid2d+1
2150               CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,
2151          &                   lonsperlar,buff_mult_pieceg(1,1,ngrid2d))
2152             enddo
2153           endif
2154     !
2155     !..........................................................
2156     !
2157           if ( g2d_fld%bc%nfld > 0 ) then
2158             do  k = 1, g2d_fld%bc%nfld
2159               glolal = RTIME*1.e6*g2d_fld%bc%diag(k)%flds
2160               ngrid2d=ngrid2d+1
2161               CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,
2162          &                   lonsperlar,buff_mult_pieceg(1,1,ngrid2d))
2163             enddo
2164           endif
2165     !
2166     !..........................................................
2167     ! 2d met fields (k=01-10) are time-avg;
2168     ! 3d met fields (k=11-24) are instant
2169     ! this change makes comparison easier (flx for 2d, sig for 3d)
2170     !
2171           if ( g2d_fld%met%nfld > 0 ) then
2172             do  k = 1, g2d_fld%met%nfld
2173               if (k .le. 10 ) then                      ! time-avg
2174                  glolal=RTIME*g2d_fld%met%diag(k)%flds
2175               else                                      ! instant
2176                  glolal=g2d_fld%met%diag(k)%flds
2177               endif
2178               ngrid2d=ngrid2d+1
2179               CALL uninterprez(2,kmsk0,buffo,glolal,global_lats_r,
2180          &                   lonsperlar,buff_mult_pieceg(1,1,ngrid2d))
2181             enddo
2182           endif
2183     
2184     !!
2185     
2186           if(me.eq.ioproc)
2187          &   PRINT *,'(wrtaer) GRIB AER FILE WRITTEN ',FHOUR,IDATE,noaer
2188     !!
2189           RETURN
2190           END
2191     !!****
2192     
2193            subroutine flx_only_move(ioproc)
2194     !
2195     !***********************************************************************
2196     !
2197           use resol_def, ONLY: ngrids_flx, ngrids_sfcc, lonr,latr
2198           use mod_state, ONLY: buff_mult_pieces, buff_mult_piecef,
2199          &                     ivar_global_a, ivar_global
2200           use layout1,   ONLY: me, nodes, ipt_lats_node_r, lats_node_r,
2201          &                     lats_node_r_max, nodes_comp
2202           use mpi_def,   ONLY: mpi_r_io, stat, mpi_comm_null, info, 
2203          &                     mc_comp, mpi_integer, mpi_comm_all, liope
2204           implicit none
2205     !
2206           integer ipt_lats_node_rl,nodesr
2207           integer lats_nodes_rl
2208     !      integer lats_nodes_r(nodes),ipt,maxfld,ioproc,nproct
2209           integer ioproc
2210           integer proc,j,lat,msgtag,nproc,i,msgtag1,buff,startlat,ierr
2211           integer illen,ubound,nd1
2212            integer icount
2213            data icount/0/
2214            integer maxlats_comp
2215            save maxlats_comp,icount
2216            integer kllen
2217     !
2218     !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
2219              if(icount .eq. 0) then
2220               if(.not.allocated(ivar_global)) allocate(ivar_global(10))
2221               if(.not.allocated(ivar_global_a)) 
2222          &       allocate(ivar_global_a(10,nodes))
2223              ivar_global(1)=ipt_lats_node_r
2224              ivar_global(2)= lats_node_r
2225              ivar_global(3)=lats_node_r_max
2226              call mpi_gather(ivar_global,10,MPI_INTEGER,
2227          1 ivar_global_a,10,MPI_INTEGER,ioproc,MPI_COMM_ALL,ierr)
2228              icount=icount+1
2229              endif
2230     !!
2231            if(allocated(buff_mult_pieces)) then
2232               deallocate(buff_mult_pieces)
2233            else
2234               maxlats_comp=lats_node_r_max
2235               if(me .eq. ioproc) then
2236                 maxlats_comp=ivar_global_a(3,1)
2237                endif
2238            endif
2239            if(me .eq. ioproc) then
2240     !gwv watch this!!
2241               allocate
2242          1  (buff_mult_pieces(lonr*latr*ngrids_flx))
2243              buff_mult_pieces=0.
2244            endif
2245     !
2246     !  big send
2247            IF (me.ne.ioproc) THEN
2248     !
2249     !         Sending the data
2250              msgtag=me
2251              illen=lats_node_r
2252              kllen=illen*lonr*ngrids_flx
2253     ! send the local grid domain
2254              CALL mpi_send
2255          &(buff_mult_piecef,kllen,MPI_R_IO,ioproc,
2256          &                  msgtag,mc_comp,info)
2257     !jw     &                  msgtag,MPI_COMM_ALL,info)
2258           ELSE
2259              if( MC_COMP .ne. MPI_COMM_NULL) then
2260     ! iotask is also a compute task.  send is replaced with direct
2261     !  array copy
2262      
2263              if(nodes_comp==1) then
2264                buff_mult_pieces(1:lonr*lats_node_r*ngrids_flx)=
2265          1   reshape(buff_mult_piecef(1:lonr,1:lats_node_r,1:ngrids_flx),
2266          1     (/lonr*lats_node_r*ngrids_flx/) )
2267              else
2268     
2269     !  END COMPUTE TASKS PORTION OF LOGIC
2270     !  receiving part of I/O task
2271      
2272     !!
2273     !!     for pes ioproc
2274             nd1=0
2275             DO proc=1,nodes_comp
2276              illen=ivar_global_a(2,proc)
2277              if (proc.ne.ioproc+1) then
2278                msgtag=proc-1
2279                kllen=illen*lonr*ngrids_flx
2280                CALL mpi_recv
2281          1       (buff_mult_pieces(nd1+1),kllen,MPI_R_IO,proc-1,
2282          &                msgtag,mc_comp,stat,info)
2283     !     &                msgtag,MPI_COMM_ALL,stat,info)
2284              else
2285                buff_mult_pieces(nd1+1:nd1+lonr*illen*ngrids_flx)=
2286          1      reshape(buff_mult_piecef(1:lonr,1:illen,1:ngrids_flx),
2287          1       (/lonr*illen*ngrids_flx/) )
2288              endif
2289              nd1=nd1+illen*lonr*ngrids_flx
2290             enddo
2291            endif
2292     
2293           endif
2294     !end ioproc
2295           ENDIF
2296     !
2297           return
2298           end
2299      
2300           SUBROUTINE flx_wrt(IOPROC,cfile,ZHOUR,FHOUR,idate
2301          &,                  global_lats_r,lonsperlar)
2302     !!
2303           use module_nemsio, only: nemsio_open,nemsio_writerec,nemsio_close
2304          &  ,nemsio_gfile, nemsio_init,nemsio_finalize
2305           use resol_def,    ONLY: lonr, latr, levs,ngrids_flx,
2306          & ncld,ntrac,ntcw,ntoz,lsoil, ivssfc,thermodyn_id,sfcpress_id
2307           use layout1,      ONLY: me,idrt
2308           USE machine,      ONLY: kind_io8, kind_io4
2309     !
2310           use gfs_physics_output, only : PHY_INT_STATE_ISCALAR,
2311          &    PHY_INT_STATE_RSCALAR,
2312          &    PHY_INT_STATE_1D_I,PHY_INT_STATE_1D_R,
2313          &    PHY_INT_STATE_2D_R_FLX
2314           implicit none
2315     !!
2316           integer nw,IOPROC
2317           character*16 cfile,NAME2D
2318           real(kind=kind_io8) zhour,fhour
2319           integer idate(4),k,il, ngridss
2320     !
2321           integer i,j,ndim3,N2DR,INDX,idate7(7),kount,nrec
2322           integer nfhour,nfminute,nfsecondn,nfsecondd
2323           logical  :: outtest
2324           integer ::nmetavari,nmetavarr,nmetavarl,nmetaaryi,nmetaaryr
2325           character(16),allocatable :: recname(:),reclevtyp(:)
2326           integer,allocatable :: reclev(:),itr(:)
2327           character(16),allocatable :: variname(:),varrname(:),
2328          &    aryiname(:),aryrname(:)
2329           integer,allocatable :: varival(:),aryilen(:),
2330          &    aryival(:,:)
2331           real(kind=kind_io4),allocatable    :: varrval(:)
2332           real(kind=kind_io4),allocatable    :: buff_mult(:,:,:),tmp(:)
2333           type(nemsio_gfile) gfileout
2334     !
2335     
2336     !!
2337           CHARACTER*8 labfix(4)
2338           real(kind=kind_io4) yhour
2339           integer,save:: version
2340           data version/200501/
2341           INTEGER              GLOBAL_LATS_R(latr), lonsperlar(latr)
2342     !
2343           integer iret
2344           logical first
2345           save first
2346           save  recname, reclevtyp, reclev
2347           save nrec,nmetavari,nmetavarr,nmetaaryi,nmetaaryr,
2348          &     variname,varrname,aryiname,
2349          &     varival,varrval,aryilen,aryival
2350     !jw     &     variname,varrname,aryiname,aryrname,
2351     !jw     &     varival,aryilen,aryrlen,aryival,aryrval,varrval
2352           data first /.true./
2353     !
2354     !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
2355     !
2356     !    Build surface fields in to buff_mult
2357     !
2358           if (me.eq.ioproc) then
2359     !
2360           print *,' begin of flx_wrt '
2361     
2362             allocate(buff_mult(lonr,latr,ngrids_flx))
2363             buff_mult=0.
2364             do ngridss=1,ngrids_flx
2365               print *,' inside flx_wrt calling unsp ngridss=',ngridss
2366               call unsplit2z(ioproc,ngridss,ngrids_flx,
2367          &      buff_mult(1,1,ngridss),global_lats_r)
2368             enddo
2369     !    Building surface field is done
2370     !
2371             if (first) then
2372     !write out nemsio sfc file:
2373               nrec=ngrids_flx
2374               kount=size(PHY_INT_STATE_ISCALAR,2)
2375               do i=1,kount
2376                if(trim(PHY_INT_STATE_ISCALAR(2,i)).eq.'OGFS_PHY'
2377          &     .or.trim(PHY_INT_STATE_ISCALAR(2,i)).eq.'OGFS_FLX')
2378          &        nmetavari=nmetavari+1
2379               enddo
2380               allocate(variname(nmetavari),varival(nmetavari))
2381               j=0
2382               do i=1,kount
2383                if(trim(PHY_INT_STATE_ISCALAR(2,i)).eq.'OGFS_PHY' .or.
2384          &      trim(PHY_INT_STATE_ISCALAR(2,i)).eq.'OGFS_FLX' )then
2385                 j=j+1
2386                 variname(j)=trim(PHY_INT_STATE_ISCALAR(1,i))
2387                 if(trim(variname(j))=='latr') varival(j)=latr
2388                 if(trim(variname(j))=='lonr') varival(j)=lonr
2389                 if(trim(variname(j))=='levs') varival(j)=levs
2390                 if(trim(variname(j))=='ntoz') varival(j)=ntoz
2391                 if(trim(variname(j))=='ntcw') varival(j)=ntcw
2392                 if(trim(variname(j))=='ncld') varival(j)=ncld
2393                 if(trim(variname(j))=='ntrac') varival(j)=ntrac
2394                 if(trim(variname(j))=='thermodyn_id')varival(j)=thermodyn_id
2395                 if(trim(variname(j))=='sfcpress_id') varival(j)=sfcpress_id
2396                 if(trim(variname(j))=='lsoil') varival(j)=lsoil
2397                 if(trim(variname(j))=='idrt') varival(j)=idrt
2398                endif
2399               enddo
2400     !!for real var::
2401               nmetavarr=0
2402               do i=1,kount
2403                if(trim(PHY_INT_STATE_RSCALAR(2,i)).eq.'OGFS_PHY'
2404          &     .or.trim(PHY_INT_STATE_RSCALAR(2,i)).eq.'OGFS_FLX')
2405          &     nmetavarr=nmetavarr+1
2406               enddo
2407               if(nmetavarr>0) then
2408                 allocate(varrname(nmetavarr),varrval(nmetavarr))
2409                 j=0
2410                 do i=1,kount
2411                  if(trim(PHY_INT_STATE_RSCALAR(2,i)).eq.'OGFS_PHY'
2412          &       .or.trim(PHY_INT_STATE_RSCALAR(2,i)).eq.'OGFS_FLX')then
2413                    j=j+1
2414                    varrname(j)=trim(PHY_INT_STATE_RSCALAR(1,i))
2415                    if(trim(varrname(j))=='fhour') varrval(j)=fhour
2416                    if(trim(varrname(j))=='zhour') varrval(j)=zhour
2417                  endif
2418                 enddo
2419               endif
2420     !!for 1D ary::
2421               nmetaaryi=0
2422               do i=1,kount
2423                if(trim(PHY_INT_STATE_1D_I(2,i)).eq.'OGFS_PHY'
2424          &     .or.trim(PHY_INT_STATE_1D_I(2,i)).eq.'OGFS_FLX')
2425          &     nmetaaryi=nmetaaryi+1
2426               enddo
2427               allocate(aryiname(nmetaaryi),aryilen(nmetaaryi))
2428               j=0
2429               do i=1,kount
2430                if(trim(PHY_INT_STATE_1D_I(2,i)).eq.'OGFS_PHY'
2431          &     .or.trim(PHY_INT_STATE_1D_I(2,i)).eq.'OGFS_FLX')then
2432                  j=j+1
2433                  aryiname(j)=trim(PHY_INT_STATE_1D_I(1,i))
2434                  if(trim(aryiname(j))=='IDATE') aryilen(j)=size(idate)
2435                endif
2436               enddo
2437               allocate(aryival(maxval(aryilen),nmetaaryi) )
2438               aryival(1:aryilen(1),1)=idate(:)
2439     !!!for 1D real ary::
2440     !          nmetaaryr=0
2441     !          do i=1,kount
2442     !           if(trim(PHY_INT_STATE_1D_R(2,i)).eq.'OGFS_PHY'
2443     !     &     .or.trim(PHY_INT_STATE_1D_R(2,i)).eq.'OGFS_FLX')
2444     !     &     nmetaaryr=nmetaaryr+1
2445     !          enddo
2446     !          allocate(aryrname(nmetaaryr),aryrlen(nmetaaryr))
2447     !          do i=1,kount
2448     !           if(trim(PHY_INT_STATE_1D_R(2,i)).eq.'OGFS_PHY')
2449     !     &     .or.trim(PHY_INT_STATE_1D_R(2,i)).eq.'OGFS_FLX')then
2450     !             aryrname(i)=trim(PHY_INT_STATE_1D_R(1,i))
2451     !             if(i==1) aryrlen(i)=size(ak5)
2452     !             if(i==2) aryrlen(i)=size(bk5)
2453     !             if(i==3) aryrlen(i)=size(ck5)
2454     !           endif
2455     !          enddo
2456     !          allocate(aryrval(maxval(aryrlen),nmetaaryr)
2457     !          aryrval(1:aryrlen(1),1)=ak5(:)
2458     !          aryrval(1:aryrlen(2),2)=bk5(:)
2459     !          aryrval(1:aryrlen(3),2)=ck5(:)
2460     !
2461     !!for record name, levtyp and lev
2462               allocate (recname(nrec),reclevtyp(nrec),reclev(nrec))
2463               allocate (itr(nrec))
2464               N2DR=0
2465               itr=-99
2466               do i=1,kount
2467                if(trim(PHY_INT_STATE_2D_R_FLX(2,i)).eq.'OGFS_FLX')then
2468                 N2DR=N2DR+1
2469                 NAME2D=trim(PHY_INT_STATE_2D_R_FLX(1,i))
2470                 INDX=INDEX(NAME2D,"_")
2471                 if(indx>0) then
2472                   recname(N2DR)=NAME2D(1:INDX-1)
2473                 else
2474                   recname(N2DR)=NAME2D
2475                 endif
2476     !
2477                 reclevtyp(N2DR)=trim(trim(PHY_INT_STATE_2D_R_FLX(3,i)))
2478                 reclev(N2DR)=1
2479     !
2480     !check time average
2481                if(INDEX(NAME2D,"_ave") >0) then
2482                    itr(N2DR)=3
2483                 elseif(INDEX(NAME2D,"_acc") >0) then
2484                    itr(N2DR)=4
2485                 elseif(INDEX(NAME2D,"_win") >0) then
2486                    itr(N2DR)=2
2487                 endif
2488     
2489                endif
2490               enddo
2491     !
2492     !end first
2493               first=.false.
2494              endif
2495     !
2496             idate7=0
2497             idate7(1)=idate(4)
2498             idate7(2)=idate(2)
2499             idate7(3)=idate(3)
2500             idate7(4)=idate(1)
2501             idate7(7)=100           !denominator for second
2502     !
2503             nfhour=int(fhour)     
2504             nfminute=int((fhour-nfhour)*60)
2505             nfsecondn=int(((fhour-nfhour)*3600-nfminute*60)*100)
2506             nfsecondd=100
2507     !
2508             call nemsio_init()
2509     !
2510             call nemsio_open(gfileout,trim(cfile),'write',
2511          &    iret = iret,
2512          &    modelname='GFS',gdatatype='grib',
2513          &    idate=idate7,nrec=nrec,
2514          &    dimx=lonr,dimy=latr,dimz=levs,ncldt=ncld,nmeta=5,
2515          &    nfhour=nfhour,nfminute=nfminute,nfsecondn=nfsecondn,
2516          &    nfsecondd=nfsecondd,
2517          &    extrameta=.true.,nmetavari=nmetavari,
2518          &    nmetavarr=nmetavarr,
2519          &    nmetaaryi=nmetaaryi,
2520          &    variname=variname,varival=varival,varrname=varrname,
2521          &    varrval=varrval,
2522          &    aryiname=aryiname,aryilen=aryilen,aryival=aryival,
2523          &    ntrac=ntrac,nsoil=lsoil,idrt=idrt,
2524          &    recname=recname,reclevtyp=reclevtyp,reclev=reclev)
2525     !
2526             allocate(tmp(lonr*latr))
2527             yhour=zhour
2528             do i=1,nrec
2529               tmp(:)=reshape(buff_mult(:,:,i),(/lonr*latr/) )
2530               if(itr(i)==-99) then
2531                 call nemsio_writerec(gfileout,i,tmp,iret=iret)
2532               else
2533                 call nemsio_writerec(gfileout,i,tmp,iret=iret,itr=itr(i),
2534          &        zhour=yhour)
2535               endif
2536             enddo
2537             deallocate(tmp)
2538             deallocate(buff_mult)
2539     !
2540             call nemsio_close(gfileout)
2541     !end write pe
2542             call nemsio_finalize()
2543           endif
2544     !
2545           print *,' end of flx_wrt '
2546           return
2547           end
2548     !
2549           INTEGER FUNCTION nfill(C)
2550           implicit none
2551           integer j
2552           CHARACTER*(*) C
2553           NFILL=LEN(C)
2554           DO J=1,NFILL
2555             IF(C(J:J).EQ.' ') THEN
2556               NFILL=J-1
2557               RETURN
2558             ENDIF
2559           ENDDO
2560           RETURN
2561           END
2562      
2563      
2564           SUBROUTINE nst_collect (nst_fld,global_lats_r,lonsperlar)
2565     !!
2566           use resol_def,               ONLY: latr, lonr,ngrids_nst
2567           use mod_state,               ONLY:
2568          &                                   buff_mult_piecenst,ngridnst
2569           use layout1,                 ONLY: lats_node_r,lats_node_r_max
2570           use gfs_physics_nst_var_mod, ONLY: Nst_Var_Data
2571           USE machine,                 ONLY: kind_io8, kind_io4
2572           implicit none
2573     !!
2574           TYPE(Nst_Var_Data)        :: nst_fld
2575     !
2576           INTEGER              GLOBAL_LATS_R(latr)
2577           INTEGER              lonsperlar(latr)
2578     !!
2579           real(kind=kind_io8) buffo(lonr,lats_node_r)
2580           integer kmsk(lonr,lats_node_r_max),kmskcv(lonr,lats_node_r_max)
2581           integer k,il
2582            integer ubound
2583            integer icount
2584             integer  ierr
2585     !!
2586     !
2587           if(allocated(buff_mult_piecenst)) then
2588              continue
2589           else
2590              allocate
2591          1 (buff_mult_piecenst(lonr,lats_node_r_max,1:ngrids_nst+1))
2592           endif
2593     !
2594           kmsk= nint(nst_fld%slmsk)
2595     !
2596     !-- slmsk
2597           ngridnst=1
2598           CALL uninterprez(1,kmsk,buffo,nst_fld%slmsk,
2599          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2600     !
2601     !-- xt
2602           ngridnst=ngridnst+1
2603           CALL uninterprez(1,kmsk,buffo,nst_fld%xt,
2604          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2605     !
2606     !-- xs
2607           ngridnst=ngridnst+1
2608           CALL uninterprez(1,kmsk,buffo,nst_fld%xs,
2609          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2610     !
2611     !-- xu
2612           ngridnst=ngridnst+1
2613           CALL uninterprez(1,kmsk,buffo,nst_fld%xu,
2614          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2615     !
2616     !-- xv
2617           ngridnst=ngridnst+1
2618           CALL uninterprez(1,kmsk,buffo,nst_fld%xv,
2619          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2620     !
2621     !-- 6 xz
2622           ngridnst=ngridnst+1
2623           CALL uninterprez(1,kmsk,buffo,nst_fld%xz,
2624          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2625     !
2626     !-- zm
2627           ngridnst=ngridnst+1
2628           CALL uninterprez(1,kmsk,buffo,nst_fld%zm,
2629          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2630     !
2631     !-- xtts
2632           ngridnst=ngridnst+1
2633           CALL uninterprez(1,kmsk,buffo,nst_fld%xtts,
2634          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2635     !
2636     !-- xzts
2637           ngridnst=ngridnst+1
2638           CALL uninterprez(1,kmsk,buffo,nst_fld%xzts,
2639          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2640     !
2641     !-- 10 dt_cool
2642           ngridnst=ngridnst+1
2643           CALL uninterprez(1,kmsk,buffo,nst_fld%dt_cool,
2644          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2645     !
2646     !-- z_c
2647           ngridnst=ngridnst+1
2648           CALL uninterprez(1,kmsk,buffo,nst_fld%z_c,
2649          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2650     !
2651     !-- c_0
2652           ngridnst=ngridnst+1
2653           CALL uninterprez(1,kmsk,buffo,nst_fld%c_0,
2654          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2655     !
2656     !-- c_d
2657           ngridnst=ngridnst+1
2658           CALL uninterprez(1,kmsk,buffo,nst_fld%c_d,
2659          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2660     !
2661     !-- w_0
2662           ngridnst=ngridnst+1
2663           CALL uninterprez(1,kmsk,buffo,nst_fld%w_0,
2664          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2665     !
2666     !-- w_d
2667           ngridnst=ngridnst+1
2668           CALL uninterprez(1,kmsk,buffo,nst_fld%w_d,
2669          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2670     !
2671     !-- d_conv
2672           ngridnst=ngridnst+1
2673           CALL uninterprez(1,kmsk,buffo,nst_fld%d_conv,
2674          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2675     !
2676     !-- ifd
2677           ngridnst=ngridnst+1
2678           CALL uninterprez(1,kmsk,buffo,nst_fld%ifd,
2679          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2680     !
2681     !-- tref
2682           ngridnst=ngridnst+1
2683           CALL uninterprez(1,kmsk,buffo,nst_fld%tref,
2684          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2685     !
2686     !-- qrain
2687           ngridnst=ngridnst+1
2688           CALL uninterprez(1,kmsk,buffo,nst_fld%qrain,
2689          &       global_lats_r,lonsperlar,buff_mult_piecenst(1,1,ngridnst))
2690     !
2691     
2692           return
2693           end subroutine nst_collect
2694