para_fixio

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

1            SUBROUTINE PARA_FIXIO_W(IOPROC,sfc_fld, cfile,xhour,idate,
2          &         lats_nodes_r,global_lats_r,lonsperlar,
3          &         phy_f3d,phy_f2d,ngptc,nblck,ens_nam)
4     !!
5           use resol_def,     ONLY: latr, lonr, levs, lsoil, ivssfc_restart,
6          &                         num_p2d, num_p3d
7           use layout1,       ONLY: lats_node_r, me,ipt_lats_node_r,nodes
8           use module_nemsio
9           use gfs_physics_sfc_flx_mod, ONLY: Sfc_Var_Data
10           USE machine,   ONLY: kind_io4, kind_ior, kind_io8,kind_phys
11           implicit none
12     !!
13           TYPE(Sfc_Var_Data),intent(in)    :: sfc_fld
14           integer,intent(in)               :: idate(4),ioproc
15           real(kind=kind_io8),intent(in)   :: xhour
16           character*(*),intent(in)         :: cfile,ens_nam
17           INTEGER,intent(in)               :: lats_nodes_r(nodes)
18           INTEGER,intent(in)               :: GLOBAL_LATS_R(latr)
19           INTEGER,intent(in)               :: lonsperlar(latr)
20     !
21           integer,intent(in) :: ngptc, nblck
22           REAL (KIND=KIND_phys),intent(in) ::
23          &            phy_f3d(ngptc,levs,nblck,LATS_NODE_R,num_p3d)
24          &,           phy_f2d(LONR,LATS_NODE_R,num_p2d)
25     !
26     !!
27           real(kind=kind_io8),allocatable:: bfo(:,:)
28           integer k,lan,i,nphyfld,fieldsize
29     !!
30           integer,save:: version
31     !
32           CHARACTER*2 nump3d,nump2d
33           type(nemsio_gfile)  :: gfile
34     !
35           integer iret,nrec,nmetavari,nmetavarr8,nmetaaryi,nmetaaryr8,
36          &    idate7(7),nmeta,jrec,l,nsfcrec,nrecs,nrecs1
37           integer nfhour,nfminute,nfsecondn,nfsecondd,nsoil
38           character(16),allocatable :: variname(:),varr8name(:)
39           character(16),allocatable :: aryiname(:),aryr8name(:)
40           integer,allocatable :: varival(:),aryilen(:),aryr8len(:),
41          &     aryival(:,:)
42           real(kind=kind_io8),allocatable :: varr8val(:),aryr8val(:,:)
43           character(16),allocatable :: recname(:),reclevtyp(:)
44           integer,allocatable :: reclev(:)
45           logical first
46           sAve first,nsoil,nmetavari,variname,varival,
47          &     nmetavarr8,varr8name,varr8val,nmetaaryi,aryiname,aryilen,
48          &     aryival,nmetaaryr8,aryr8name,aryr8len,aryr8val,
49          &     nmeta,nrec,nrecs,nrecs1,recname,reclevtyp,reclev
50           data first /.true./
51     !
52     !@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
53     !
54     !      print *,'in para_fix_w'
55           nsfcrec=31
56           fieldsize=sum(lonsperlar)
57           nphyfld=nsfcrec+3*lsoil+num_p2d+num_p3d*levs
58           allocate(bfo(fieldsize,nphyfld))
59     !
60           call fld_collect(sfc_fld,phy_f2d,phy_f3d,ngptc,nblck,
61          &  fieldsize,nphyfld,bfo,lats_nodes_r,global_lats_r,lonsperlar,
62          &  ioproc,nsfcrec)
63     !       write(0,*)'after fld_collect'
64     !
65           if (me.eq.ioproc) then
66             if (first) then
67               nsoil   = lsoil
68               nmeta=5
69     
70               nmetavari=2
71               allocate(variname(nmetavari),varival(nmetavari))
72               variname=(/'ivs   ','irealf'/)
73               varival=(/ivssfc_restart, 2/)
74     !          print *,'after vari'
75     
76               nmetaaryi=1
77               allocate(aryiname(nmetaaryi),aryilen(nmetaaryi))
78               aryiname(1)='lpl'
79               aryilen(1)=latr/2
80               allocate(aryival(maxval(aryilen),nmetaaryi))
81               aryival(1:latr/2,1)=lonsperlar(1:latr/2)
82     !          print *,'after aryi'
83     !
84               nmetaaryr8=1
85               allocate(aryr8name(nmetaaryr8),aryr8len(nmetaaryr8))
86               aryr8name(1)='zsoil'
87               aryr8len(1)=lsoil
88               allocate(aryr8val(maxval(aryr8len),nmetaaryr8))
89               if (lsoil .eq. 4) then
90                 aryr8val(1:lsoil,1) = (/-0.1,-0.4,-1.0,-2.0/)
91               elseif (lsoil .eq. 2) then
92                 aryr8val(1:lsoil,1) = (/-0.1,-2.0/)
93               endif
94     !          print *,'after aryr8'
95     !
96               nmetavarr8=1
97               allocate(varr8name(nmetavarr8),varr8val(nmetavarr8))
98               varr8name=(/'fhour'/)
99               print *,'after varr'
100     !
101               nrecs=nsfcrec
102               nrecs1=nrecs+1
103               nrec=nrecs+3*nsoil+num_p3d*levs+num_p2d
104     !          write(0,*)'after nrec=',nrec,'nsoil=',nsoil,'num_p3d=',
105     !     &      num_p3d,'num_p2d=',num_p2d
106               allocate(recname(nrec),reclevtyp(nrec),reclev(nrec))
107     !record name
108               RECNAME(1)='tmp'
109               RECNAME(2)='weasd'
110               RECNAME(3)='tg3'
111               RECNAME(4)='sfcr'
112     !          RECNAME(5)='tcdc'
113     !          RECNAME(6)='pres'
114     !          RECNAME(7)='pres'
115               RECNAME(5)='alvsf'
116               RECNAME(6)='alvwf'
117               RECNAME(7)='alnsf'
118               RECNAME(8)='alnwf'
119               RECNAME(9)='land'
120               RECNAME(10)='veg'
121               RECNAME(11)='cnwat'
122               RECNAME(12)='f10m'
123     !          RECNAME(13)='tmp'
124     !          RECNAME(14)='spfh'
125               RECNAME(13)='vtype'
126               RECNAME(14)='sotyp'
127               RECNAME(15)='facsf'
128               RECNAME(16)='facwf'
129               RECNAME(17)='fricv'
130               RECNAME(18)='ffhh'
131               RECNAME(19)='ffmm'
132               RECNAME(20)='icetk'
133               RECNAME(21)='icec'
134               RECNAME(22)='tisfc'
135               RECNAME(23)='tprcp'
136               RECNAME(24)='crain'
137               RECNAME(25)='snod'
138               RECNAME(26)='shdmin'
139               RECNAME(27)='shdmax'
140               RECNAME(28)='sltyp'
141               RECNAME(29)='salbd'
142               RECNAME(30)='orog'
143               RECNAME(31)='sncovr'
144     !
145               RECNAME(nrecs1:nrecs+NSOIL)='smc'
146               RECNAME(NSOIL+nrecs1:nrecs+2*NSOIL)='stc'
147               RECNAME(2*NSOIL+nrecs1:nrecs+3*NSOIL)='slc'
148               DO k=1,num_p2d
149                 write(nump2d,'(I2.2)')k
150                 RECNAME(3*NSOIL+nrecs+k)='phyf2d_'//nump2d
151               enddo
152               DO k=1,num_p3d
153                 write(nump3d,'(I2.2)')k
154                 RECNAME(3*NSOIL+num_p2d+nrecs1+(k-1)*levs:
155          &        nrecs+3*NSOIL+num_p2d+k*levs)='phyf3d_'//nump3d
156               enddo
157     !          print *,'after recname=',recname(36:40),recname(46:50)
158     !
159               RECLEVTYP(1:nrecs)='sfc'
160               RECLEVTYP(12)='10 m above gnd'
161               RECLEVTYP(nrecs1:nrecs+3*nsoil)='soil layer'
162               RECLEVTYP(nrecs1+3*nsoil:nrecs+3*nsoil+num_p2d)='sfc'
163               RECLEVTYP(nrecs1+3*nsoil+num_p2d:nrecs+
164          &       3*nsoil+num_p3d*levs+num_p2d)='mid layer'
165     !          print *,'after reclevtyp=',reclevtyp(36:40),reclevtyp(46:50)
166     !
167               RECLEV(1:nrecs)=1
168               DO K=1,NSOIL
169                 RECLEV(K+nrecs)=K
170                 RECLEV(NSOIL+K+nrecs)=K
171                 RECLEV(2*NSOIL+K+nrecs)=K
172               ENDDO
173               RECLEV(nrecs1+3*nsoil:nrecs+3*nsoil+num_p2d)=1
174               do l=1,num_p3d
175               DO K=1,levs
176                 RECLEV(nrecs+3*nsoil+num_p2d+(l-1)*levs+k)=k
177               enddo
178               enddo
179     !          print *,'after reclev=',reclev(36:40),reclev(46:50)
180     !
181     !endif first 
182             endif
183     !
184             varr8val(1)=xhour
185     !
186             idate7(1:6)=0;idate7(7)=1
187             idate7(1)=idate(4)
188             idate7(2:3)=idate(2:3)
189             idate7(4)=idate(1)
190             nfhour=int(xhour)
191             nfminute=int((xhour-nfhour)*60.)
192             nfsecondn=int((xhour-nfhour)*3600.-nfminute*60.)
193             nfsecondd=1
194     !
195             PRINT 99,xhour,IDATE
196     99      FORMAT(1H ,'in fixio HOUR=',f8.2,3x,'IDATE=',
197          &  4(1X,I4))
198     !!
199     ! open nemsio sfc restart file
200             call nemsio_init()
201     !
202             write(0,*)'before nemsio_open for restart file'
203             call nemsio_open(gfile,trim(cfile),'write',iret,   
204          & modelname='GFS',gdatatype='bin8',idate=idate7,nfhour=nfhour, 
205          & nfminute=nfminute,nfsecondn=nfsecondn,nfsecondd=nfsecondd,   
206          & dimx=fieldsize,dimy=1,dimz=levs,nsoil=nsoil,nrec=nrec,         
207          & nmeta=5,recname=recname,reclevtyp=reclevtyp,reclev=reclev,   
208          & extrameta=.true.,nmetavari=nmetavari,nmetaaryi=nmetaaryi,    
209          & nmetaaryr8=nmetaaryr8,nmetavarr8=nmetavarr8,variname=variname,   
210          & varival=varival,varr8name=varr8name,varr8val=varr8val,         
211          & aryiname=aryiname,aryilen=aryilen,aryival=aryival, 
212          & aryr8name=aryr8name,aryr8len=aryr8len,aryr8val=aryr8val) 
213     
214            print *,'after restart nemsio_open, iret=',iret
215     
216             do jrec=1,nrec
217               call nemsio_writerec(gfile,jrec,bfo(:,jrec),iret=iret)
218             enddo
219             deallocate(bfo)
220     !
221             call nemsio_close(gfile)
222             call nemsio_finalize()
223     !
224     ! endof ioproc
225           ENDIF
226     !
227           if(first) first=.false.
228              
229           return
230           end
231