forked from NOAA-EMC/fv3atm
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathpost_nems_routines.F90
285 lines (278 loc) · 8.68 KB
/
post_nems_routines.F90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
!-----------------------------------------------------------------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-----------------------------------------------------------------------
!
subroutine post_alctvars(imi,jmi,lmi,mype,nwtlpes,lead_write, mpicomp, &
jts,jte,jtsgrp,jtegrp)
!
!
! revision history:
! Jul 2019 Jun Wang: allocate arrays for post processing
!
!
!-----------------------------------------------------------------------
!*** allocate post variables
!-----------------------------------------------------------------------
!
use vrbls4d
use vrbls3d
use vrbls2d
use soil
use masks, only: lmv, lmh, htm, vtm
use ctlblk_mod, only: im, jm, lm, im_jm, lp1, grib, gdsdegr, me, &
ioform, jsta, jend, jsta_m, jsta_m2, &
jend_m, jend_m2, jvend_2u, jsta_2l, jend_2u, iup, idn, &
icnt, idsp, mpi_comm_comp, num_servers, &
num_procs
!
!-----------------------------------------------------------------------
!
use mpi
!
implicit none
!
!-----------------------------------------------------------------------
!
integer,intent(in) :: imi,jmi,lmi,mype,nwtlpes,mpicomp
integer,intent(in) :: lead_write
integer,intent(in) :: jts,jte
integer,intent(in) :: jtsgrp(nwtlpes),jtegrp(nwtlpes)
!
!-----------------------------------------------------------------------
!*** LOCAL VARIABLES
!-----------------------------------------------------------------------
!
integer i,j,l
integer last_write_task
!
!-----------------------------------------------------------------------
!*** get dims from int_state
!-----------------------------------------------------------------------
!
im = imi
jm = jmi
lm = lmi
im_jm = im*jm
lp1 = lm + 1
grib = 'grib2'
! set ndegr
gdsdegr = 1000000.
IOFORM = 'grib'
me = mype-lead_write
last_write_task = lead_write+nwtlpes-1
mpi_comm_comp = mpicomp
num_procs = nwtlpes
num_servers = 0
if(mype==0)print *,'grib=',grib,'ioform=',ioform,'mype=',mype,'me=',me, &
'lead_write=',lead_write,'last_write_task=',last_write_task, &
'num_servers=',num_servers,'num_procs=',NUM_PROCS,'gdsdegr=',gdsdegr, &
'im=',im,jm,lm
!
!-----------------------------------------------------------------------
!*** ALLOCATE THE ARRAYS OF THE POST.
!-----------------------------------------------------------------------
!
jsta = jts
jend = jte
jsta_m = jsta
jsta_m2 = jsta
jend_m = jend
jend_m2 = jend
if ( mype == lead_write ) then
jsta_m = 2
jsta_m2 = 3
end if
if ( mype == last_write_task ) then
jend_m = jm - 1
jend_m2 = jm - 2
end if
!** neighbors
iup = mype + 1 - lead_write
idn = mype - 1 - lead_write
if ( mype == lead_write ) then
idn = MPI_PROC_NULL
end if
if ( mype == last_write_task ) then
iup = MPI_PROC_NULL
end if
! if(mype==0)print *,'lead_write_task=',lead_write,'last taks=',last_write_task, &
! 'idn=',idn,'iup=',iup,'MPI_PROC_NULL=',MPI_PROC_NULL,'jsta=',jsta,'jend=',jend
!
! counts, disps for gatherv and scatterv
!
do i = 1, num_procs
icnt(i-1) = (jtegrp(i)-jtsgrp(i)+1)*im
idsp(i-1) = (jtsgrp(i)-1)*im
! if ( mype .eq. lead_write ) then
! print *, ' i, icnt(i),idsp(i) = ',i-1,icnt(i-1),idsp(i-1)
! end if
enddo
!
! extraction limits -- set to two rows
!
jsta_2l = max(jsta - 2, 1 )
jend_2u = min(jend + 2, jm )
! special for c-grid v
jvend_2u = min(jend + 2, jm+1 )
if(mype==0)print *,'im=',im,'jsta_2l=',jsta_2l,'jend_2u=',jend_2u,'lm=',lm
!
!
! SETS UP MESSAGE PASSING INFO
call allocate_all()
!***
! LMH always = LM for sigma-type vert coord
! LMV always = LM for sigma-type vert coord
do j = jsta_2l, jend_2u
do i = 1, im
lmv ( i, j ) = lm
lmh ( i, j ) = lm
end do
end do
!
! HTM VTM all 1 for sigma-type vert coord
do l = 1, lm
do j = jsta_2l, jend_2u
do i = 1, im
htm ( i, j, l ) = 1.0
vtm ( i, j, l ) = 1.0
end do
end do
end do
end subroutine post_alctvars
!
!---------------------------------------------------------------------
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!---------------------------------------------------------------------
!
subroutine read_postnmlt(kpo,kth,kpv,po,th,pv,nlunit,post_namelist)
!
use ctlblk_mod, only : komax,fileNameD3D,lsm,lsmp1,spl,spldef, &
lsmdef,ALSL,me,d3d_on,gocart_on,hyb_sigp,&
pthresh,novegtype,ivegsrc,icu_physics, &
isf_surface_physics
!
! revision history:
! Jul 2019 Jun Wang: read post namelist
!
implicit none
!---
character (len=*), intent(in) :: post_namelist
integer :: kpo,kth,kpv,nlunit
real :: untcnvt
logical :: popascal
real,dimension(komax) :: po,th,pv
namelist/nampgb/kpo,po,kth,th,kpv,pv,popascal,d3d_on,gocart_on, &
hyb_sigp
integer l,k,iret
!---------------------------------------------------------------------
!
! print *,'in read_postnmlt'
!
! set default for kpo, kth, th, kpv, pv
kpo = 0
po = 0
kth = 6
th = (/310.,320.,350.,450.,550.,650.,(0.,k=kth+1,komax)/) ! isentropic level to output
kpv = 8
pv = (/0.5,-0.5,1.0,-1.0,1.5,-1.5,2.0,-2.0,(0.,k=kpv+1,komax)/)
hyb_sigp = .true.
d3d_on = .false.
gocart_on = .false.
popascal = .false.
!
if (me == 0) print *,' nlunit=',nlunit,' post_namelist=', &
& post_namelist
!jw post namelist is using the same file itag as standalone post
if (nlunit > 0) then
open (unit=nlunit,file=post_namelist)
rewind(nlunit)
! read(nlunit) !skip fileName
! read(nlunit) !skip ioFORM
! read(nlunit) !skip outform
! read(nlunit,'(a19)') DateStr
! read(nlunit) !skil full modelname
read(nlunit,nampgb,iostat=iret,end=119)
endif
119 continue
if (me == 0) then
print*,'komax,iret for nampgb= ',komax,iret
print*,'komax,kpo,kth,th,kpv,pv,popascal== ',komax,kpo &
& ,kth,th(1:kth),kpv,pv(1:kpv),popascal,' gocart_on=',gocart_on
endif
!
! set up pressure level from POSTGPVARS or DEFAULT
if(kpo == 0)then
! use default pressure levels
if (me==0) then
print*,'using default pressure levels,spldef=',(spldef(l),l=1,lsmdef)
endif
lsm = lsmdef
do l=1,lsm
spl(l) = spldef(l)
end do
else
! use POSTGPVARS
if (me==0) then
print*,'using pressure levels from POSTGPVARS'
endif
lsm = kpo
if( .not. popascal ) then
untcnvt = 100.
else
untcnvt = 1.
endif
if(po(lsm)<po(1))then ! post logic assumes asscending
do l=1,lsm
spl(l) = po(lsm-l+1)*untcnvt
end do
else
do l=1,lsm
spl(l) = po(l)*untcnvt
end do
end if
end if
lsmp1 = lsm + 1
pthresh = 0.000001
if (me==0) print*,'LSM, SPL = ',lsm,spl(1:lsm),' pthresh=', &
pthresh
!
! set default novegtype for GFS, need to get this variable from gfs physics
novegtype = 20
ivegsrc = 1
!
! set default CU_PHYSICS for GFS: assigned 4 for SAS
icu_physics = 4
!
! set default GFS LSM physics to 2 for NOAH
isf_surface_physics = 2
if (me==0) print*,'set default value, ivegsrc = ',ivegsrc,'novegtype=',novegtype, &
'icu_physics=',icu_physics,'isf_surface_physics=',isf_surface_physics
! COMPUTE DERIVED MAP OUTPUT CONSTANTS.
!$omp parallel do private(l)
do l = 1,lsm
alsl(l) = log(spl(l))
enddo
!
1000 continue
end subroutine read_postnmlt
!
!---------------------------------------------------------------------
!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
!---------------------------------------------------------------------
!
subroutine post_finalize(post_gribversion)
!
! revision history:
! Jul 2019 Jun Wang: finalize post step
!
use grib2_module, only : grib_info_finalize
!
character(*),intent(in) :: post_gribversion
!
IF(trim(post_gribversion)=='grib2') then
call grib_info_finalize()
ENDIF
!
call de_allocate
!
end subroutine post_finalize