File: C:\NOAA\NEMS_11731\src\atmos\gfs\phys\read_fix.f
1 SUBROUTINE read_mtn_hprim_oz(SLMSK,HPRIME,NEEDORO,ORO,
2 & iozondp,ozplin,global_lats_r,lonsperlar)
3
4
5
6 use resol_def, ONLY: latr, lonr, nmtvr
7 use layout1, ONLY: me, nodes, lats_node_r
8 use ozne_def, ONLY: latsozp, levozp, timeoz, pl_coeff
9 USE machine, ONLY: kind_io8, kind_io4
10 implicit none
11
12
13 integer global_lats_r(latr)
14 integer lonsperlar(latr)
15 real (kind=kind_io8) SLMSK(lonr,lats_node_r),
16 & HPRIME(NMTVR,lonr,lats_node_r),ORO(lonr,lats_node_r)
17
18 integer iozondp
19 real (kind=kind_io8) ozplin(latsozp,levozp,pl_coeff,timeoz)
20
21 real(kind=kind_io4) buff1(lonr,latr),buffm(lonr,latr,nmtvr)
22 real(kind=kind_io8) buffo(lonr,lats_node_r)
23 real(kind=kind_io8) buff2(lonr,lats_node_r)
24 integer kmsk0(lonr,latr)
25 integer i,j,k,nmtn
26 integer needoro
27
28 =0
29
30
31
32 =24
33
34 IF (me.eq.0) THEN
35 READ(nmtn) buffm
36
37
38
39 ENDIF
40 DO k=1,nmtvr
41 call split2d_phys(buffm(1,1,k),buffo,global_lats_r)
42 CALL interpred_phys(1,kmsk0,buffo,buff2,global_lats_r,
43 & lonsperlar)
44 HPRIME(k,:,:)=buff2(:,:)
45 ENDDO
46
47
48
49
50
51
52
53
54
55
56
57
58
59 IF (iozondp.eq.1) CALL readoz_disprd(ozplin)
60
61
62
63 if(needoro.eq.1) then
64
65 IF( me==0) then
66 CALL ORORD(101,lonr,latr,buff1)
67 endif
68 call split2d_phys(buff1,buffo,global_lats_r)
69 CALL interpred_phys(1,kmsk0,buffo,oro,global_lats_r,lonsperlar)
70 endif
71 RETURN
72 END
73
74
75 SUBROUTINE read_sfc_nemsio(sfc_fld,NEEDORO,nread,
76 & cfile,global_lats_r,lonsperlar)
77
78
79
80
81
82 use resol_def, ONLY: latr, latr2, lonr, lsoil
83 use layout1, ONLY: me, nodes, lats_node_r, lats_node_r_max
84 use gfs_physics_sfc_flx_mod, ONLY: Sfc_Var_Data
85 use namelist_soilveg , only: salp_data, snupx
86 use physcons, only : tgice => con_tice
87 USE machine, ONLY: kind_io4, kind_io8
88 use module_nemsio
89 implicit none
90
91 TYPE(Sfc_Var_Data) :: sfc_fld
92 integer global_lats_r(latr)
93 integer lonsperlar(latr)
94
95 integer jump
96 integer needoro
97
98 real(kind=kind_io4) buff1(lonr*latr),buff2(lonr,latr,LSOIL)
99 real(kind=kind_io8) buffo(lonr,lats_node_r_max)
100 real(kind=kind_io8) buff3(lonr,lats_node_r_max)
101 integer nread,i,j,k,ij,idate7(7),lonsfc,latsfc,lplsfc(latr2)
102 character*(*) cfile
103 integer kmsk(lonr,latr),kmskcv(lonr,latr)
104 CHARACTER*8 labfix(4)
105 real t1,t2,timef,rsnow
106 real(4) fhour4
107 type(nemsio_gfile) gfile_in
108 integer iret, vegtyp,lonb4,latb4,nsoil4,ivs4
109 integer size1, size2, size3
110
111
112
113 =timef()
114
115 if(me==0) print *,' nread=',nread,' cfile=',cfile
116 call nemsio_init()
117
118 call nemsio_open(gfile_in,trim(cfile),'read',iret=iret)
119
120 IF (me == 0) THEN
121
122 call nemsio_getheadvar(gfile_in,'fhour',fhour4,iret=iret)
123 call nemsio_getheadvar(gfile_in,'lonb',lonb4,iret=iret)
124 call nemsio_getheadvar(gfile_in,'latb',latb4,iret=iret)
125 call nemsio_getheadvar(gfile_in,'nsoil',nsoil4,iret=iret)
126 call nemsio_getheadvar(gfile_in,'ivs',ivs4,iret=iret)
127 call nemsio_getheadvar(gfile_in,'idate',idate7,iret=iret)
128 if(iret/=0) print *,' after sfcio_srohdc,iret=',iret
129
130
131
132 PRINT 99,nread,fhour4,idate7(1:4),
133 & lonb4,latb4,nsoil4,ivs4,iret
134 99 FORMAT(1H ,'in fixio nread=',i3,2x,'HOUR=',f8.2,3x,'IDATE=',
135 & 4(1X,I4),4x,'lonsfc,latsfc,lsoil,ivssfc,iret=',5i8)
136
137 if(iret.ne.0) goto 5000
138 if(lonb4.ne.lonr) goto 5000
139 if(latb4.ne.latr) goto 5000
140 if(nsoil4.ne.lsoil) goto 5000
141
142 ENDIF
143
144 kmsk = 0
145
146 if(me==0) call nemsio_readrecv(gfile_in,'tmp','sfc',1,buff1,
147 & iret=iret)
148 call split2d_phys(buff1, buffo,global_lats_r)
149 CALL interpred_phys(1,kmsk,buffo,sfc_fld%TSEA,
150 & global_lats_r,lonsperlar)
151
152 DO K=1, LSOIL
153
154 if(me==0) call nemsio_readrecv(gfile_in,'smc','soil layer',k,
155 & buff1,iret=iret)
156 call split2d_phys(buff1, buffo,global_lats_r)
157 CALL interpred_phys(1,kmsk,buffo,buff3,global_lats_r,lonsperlar)
158 sfc_fld%SMC(k,:,:) = buff3(:,:)
159 ENDDO
160
161 if(me==0) call nemsio_readrecv(gfile_in,'weasd','sfc',1,buff1,
162 & iret=iret)
163 call split2d_phys(buff1, buffo,global_lats_r)
164 CALL interpred_phys(1,kmsk,buffo,sfc_fld%SHELEG,
165 & global_lats_r,lonsperlar)
166
167 DO K = 1, LSOIL
168 if(me==0) call nemsio_readrecv(gfile_in,'stc','soil layer',k,
169 & buff1,iret=iret)
170 call split2d_phys(buff1, buffo,global_lats_r)
171 CALL interpred_phys(1,kmsk,buffo,buff3,global_lats_r,lonsperlar)
172 sfc_fld%STC(k,:,:) = buff3(:,:)
173 ENDDO
174
175 if(me==0) call nemsio_readrecv(gfile_in,'tg3','sfc',1,buff1,
176 & iret=iret)
177 call split2d_phys(buff1, buffo,global_lats_r)
178 CALL interpred_phys(1,kmsk,buffo,sfc_fld%TG3,
179 & global_lats_r,lonsperlar)
180
181 if(me==0) call nemsio_readrecv(gfile_in,'sfcr','sfc',1,buff1,
182 & iret=iret)
183 call split2d_phys(buff1, buffo,global_lats_r)
184 CALL interpred_phys(1,kmsk,buffo,sfc_fld%ZORL,
185 & global_lats_r,lonsperlar)
186
187 sfc_fld%cv = 0
188 sfc_fld%cvb = 0
189 sfc_fld%cvt = 0
190
191 if(me==0) call nemsio_readrecv(gfile_in,'alvsf','sfc',1,buff1,
192 & iret=iret)
193
194 call split2d_phys(buff1, buffo,global_lats_r)
195 CALL interpred_phys(1,kmsk,buffo,sfc_fld%ALVSF,
196 & global_lats_r,lonsperlar)
197 if(me==0) call nemsio_readrecv(gfile_in,'alvwf','sfc',1,buff1,
198 & iret=iret)
199
200 call split2d_phys(buff1, buffo,global_lats_r)
201 CALL interpred_phys(1,kmsk,buffo,sfc_fld%ALVWF,
202 & global_lats_r,lonsperlar)
203 if(me==0) call nemsio_readrecv(gfile_in,'alnsf','sfc',1,buff1,
204 & iret=iret)
205
206 call split2d_phys(buff1, buffo,global_lats_r)
207 CALL interpred_phys(1,kmsk,buffo,sfc_fld%ALNSF,
208 & global_lats_r,lonsperlar)
209 if(me==0) call nemsio_readrecv(gfile_in,'alnwf','sfc',1,buff1,
210 & iret=iret)
211
212 call split2d_phys(buff1, buffo,global_lats_r)
213 CALL interpred_phys(1,kmsk,buffo,sfc_fld%ALNWF,
214 & global_lats_r,lonsperlar)
215
216
217 if(me==0) call nemsio_readrecv(gfile_in,'land','sfc',1,buff1,
218 & iret=iret)
219
220 call split2d_phys(buff1, buffo,global_lats_r)
221 CALL interpred_phys(1,kmsk,buffo,sfc_fld%SLMSK,
222 & global_lats_r,lonsperlar)
223
224 if(me==0) call nemsio_readrecv(gfile_in,'veg','sfc',1,buff1,
225 & iret=iret)
226
227 call split2d_phys(buff1, buffo,global_lats_r)
228 CALL interpred_phys(1,kmsk,buffo,sfc_fld%VFRAC,
229 & global_lats_r,lonsperlar)
230
231 if(me==0) call nemsio_readrecv(gfile_in,'cnwat','sfc',1,buff1,
232 & iret=iret)
233
234 call split2d_phys(buff1, buffo,global_lats_r)
235 CALL interpred_phys(1,kmsk,buffo,sfc_fld%CANOPY,
236 & global_lats_r,lonsperlar)
237
238 if(me==0) call nemsio_readrecv(gfile_in,'f10m','sfc',1,buff1,
239 & iret=iret)
240
241 call split2d_phys(buff1, buffo,global_lats_r)
242 CALL interpred_phys(1,kmsk,buffo,sfc_fld%F10M,
243 & global_lats_r,lonsperlar)
244
245 if(me==0) call nemsio_readrecv(gfile_in,'vtype','sfc',1,buff1,
246 & iret=iret)
247
248 call split2d_phys(buff1, buffo,global_lats_r)
249 CALL interpred_phys(1,kmsk,buffo,sfc_fld%VTYPE,
250 & global_lats_r,lonsperlar)
251
252 if(me==0) call nemsio_readrecv(gfile_in,'sotyp','sfc',1,buff1,
253 & iret=iret)
254
255 call split2d_phys(buff1, buffo,global_lats_r)
256 CALL interpred_phys(1,kmsk,buffo,sfc_fld%STYPE,
257 & global_lats_r,lonsperlar)
258
259 if(me==0) call nemsio_readrecv(gfile_in,'facsf','sfc',1,buff1,
260 & iret=iret)
261
262 call split2d_phys(buff1, buffo,global_lats_r)
263 CALL interpred_phys(1,kmsk,buffo,sfc_fld%FACSF,
264 & global_lats_r,lonsperlar)
265 if(me==0) call nemsio_readrecv(gfile_in,'facwf','sfc',1,buff1,
266 & iret=iret)
267
268 call split2d_phys(buff1, buffo,global_lats_r)
269 CALL interpred_phys(1,kmsk,buffo,sfc_fld%FACWF,
270 & global_lats_r,lonsperlar)
271
272
273 if(me==0) call nemsio_readrecv(gfile_in,'fricv','sfc',1,buff1,
274 & iret=iret)
275
276 call split2d_phys(buff1, buffo,global_lats_r)
277 CALL interpred_phys(1,kmsk,buffo,sfc_fld%UUSTAR,
278 & global_lats_r,lonsperlar)
279
280 if(me==0) call nemsio_readrecv(gfile_in,'ffmm','sfc',1,buff1,
281 & iret=iret)
282
283 call split2d_phys(buff1, buffo,global_lats_r)
284 CALL interpred_phys(1,kmsk,buffo,sfc_fld%FFMM,
285 & global_lats_r,lonsperlar)
286
287 if(me==0) call nemsio_readrecv(gfile_in,'ffhh','sfc',1,buff1,
288 & iret=iret)
289
290 call split2d_phys(buff1, buffo,global_lats_r)
291 CALL interpred_phys(1,kmsk,buffo,sfc_fld%FFHH,
292 & global_lats_r,lonsperlar)
293
294
295
296 if(me==0) call nemsio_readrecv(gfile_in,'icetk','sfc',1,buff1,
297 & iret=iret)
298
299 call split2d_phys(buff1, buffo,global_lats_r)
300 CALL interpred_phys(1,kmsk,buffo,sfc_fld%HICE,
301 & global_lats_r,lonsperlar)
302
303 if(me==0) call nemsio_readrecv(gfile_in,'icec','sfc',1,buff1,
304 & iret=iret)
305
306 call split2d_phys(buff1, buffo,global_lats_r)
307 CALL interpred_phys(1,kmsk,buffo,sfc_fld%FICE,
308 & global_lats_r,lonsperlar)
309
310 if(me==0) call nemsio_readrecv(gfile_in,'tisfc','sfc',1,buff1,
311 & iret=iret)
312
313 call split2d_phys(buff1, buffo,global_lats_r)
314 CALL interpred_phys(1,kmsk,buffo,sfc_fld%TISFC,
315 & global_lats_r,lonsperlar)
316 if (lats_node_r > 0 ) then
317 if (sfc_fld%tisfc(1,1) < 0.0) then
318 DO j=1,lats_node_r
319 DO i=1,LONR
320 sfc_fld%TISFC(i,j)= sfc_fld%TSEA(i,j)
321 IF(sfc_fld%SLMSK(i,j) >= 2. .AND.
322 & sfc_fld%FICE(i,j) >= 0.5) THEN
323 sfc_fld%TISFC(i,j) = (sfc_fld%TSEA(i,j)
324 & -tgice*(1.-sfc_fld%FICE(i,j))) / sfc_fld%FICE(i,j)
325 sfc_fld%TISFC(i,j)=MIN(sfc_fld%TISFC(i,j),tgice)
326 ENDIF
327 ENDDO
328 ENDDO
329 endif
330 endif
331
332
333
334
335
336 if(me==0) call nemsio_readrecv(gfile_in,'tprcp','sfc',1,buff1,
337 & iret=iret)
338
339 call split2d_phys(buff1, buffo,global_lats_r)
340 CALL interpred_phys(1,kmsk,buffo,sfc_fld%TPRCP,
341 & global_lats_r,lonsperlar)
342
343
344 if(me==0) call nemsio_readrecv(gfile_in,'crain','sfc',1,buff1,
345 & iret=iret)
346
347 call split2d_phys(buff1, buffo,global_lats_r)
348 CALL interpred_phys(1,kmsk,buffo,sfc_fld%SRFLAG,
349 & global_lats_r,lonsperlar)
350
351
352 if(me==0) call nemsio_readrecv(gfile_in,'snod','sfc',1,buff1,
353 & iret=iret)
354
355 call split2d_phys(buff1, buffo,global_lats_r)
356 CALL interpred_phys(1,kmsk,buffo,sfc_fld%SNWDPH,
357 & global_lats_r,lonsperlar)
358
359
360 DO K=1, LSOIL
361
362 if(me==0) call nemsio_readrecv(gfile_in,'slc','soil layer',k,
363 & buff1,iret=iret)
364 call split2d_phys(buff1, buffo,global_lats_r)
365 CALL interpred_phys(1,kmsk,buffo,buff3,
366 & global_lats_r,lonsperlar)
367 sfc_fld%SLC(k,:,:) = buff3(:,:)
368 ENDDO
369
370
371 if(me==0) call nemsio_readrecv(gfile_in,'shdmin','sfc',1,buff1,
372 & iret=iret)
373
374 call split2d_phys(buff1, buffo,global_lats_r)
375 CALL interpred_phys(1,kmsk,buffo,sfc_fld%SHDMIN,
376 & global_lats_r,lonsperlar)
377
378
379 if(me==0) call nemsio_readrecv(gfile_in,'shdmax','sfc',1,buff1,
380 & iret=iret)
381
382 call split2d_phys(buff1, buffo,global_lats_r)
383 CALL interpred_phys(1,kmsk,buffo,sfc_fld%SHDMAX,
384 & global_lats_r,lonsperlar)
385
386
387 if(me==0) call nemsio_readrecv(gfile_in,'sltyp','sfc',1,buff1,
388 & iret=iret)
389
390 call split2d_phys(buff1, buffo,global_lats_r)
391 CALL interpred_phys(1,kmsk,buffo,sfc_fld%SLOPE,
392 & global_lats_r,lonsperlar)
393
394
395 if(me==0) call nemsio_readrecv(gfile_in,'salbd','sfc',1,buff1,
396 & iret=iret)
397
398 call split2d_phys(buff1, buffo,global_lats_r)
399 CALL interpred_phys(1,kmsk,buffo,sfc_fld%SNOALB,
400 & global_lats_r,lonsperlar)
401
402
403
404 if(needoro == 1) then
405 if (me == 0) then
406 call nemsio_readrecv(gfile_in,'orog','sfc',1,buff1,iret=iret)
407
408 = 1
409 if(all(buff1.ne.-9999.)) needoro=0
410 print *,'read sfc orography'
411 endif
412 call split2d_phys(buff1, buffo,global_lats_r)
413 CALL interpred_phys(1,kmsk,buffo,sfc_fld%ORO,
414 & global_lats_r,lonsperlar)
415 call skip(needoro)
416 endif
417
418
419 DO j=1,lats_node_r
420 DO i=1,LONR
421 sfc_fld%SNCOVR(i,j) = 0.0
422 if (sfc_fld%slmsk(i,j) > 0.001 .AND.
423 & ABS(sfc_fld%VTYPE(i,j)) >= 0.5 ) then
424 vegtyp = sfc_fld%VTYPE(i,j)
425 RSNOW = 0.001*sfc_fld%SHELEG(i,j)/SNUPX(vegtyp)
426 IF (0.001*sfc_fld%SHELEG(i,j) < SNUPX(vegtyp)) THEN
427 sfc_fld%SNCOVR(i,j) = 1.0 - ( EXP(-SALP_DATA*RSNOW)
428 & - RSNOW*EXP(-SALP_DATA))
429 ELSE
430 sfc_fld%SNCOVR(i,j) = 1.0
431 ENDIF
432
433
434
435
436
437 endif
438 ENDDO
439 ENDDO
440
441 IF (me == 0) then
442
443 = timef()
444 print *,'FIXIO TIME ',t2-t1,t1,t2
445 endif
446
447 call nemsio_close(gfile_in,iret=iret)
448
449 call nemsio_finalize()
450
451 RETURN
452 5000 PRINT *, ' error in input in routine read_sfc'
453 STOP
454 END
455
456 SUBROUTINE read_nst(nst_fld, nread, cfile,
457 & global_lats_r, lonsperlar)
458
459
460
461 use namelist_physics_def
462 USE machine, ONLY: kind_ior, kind_io8, kind_rad
463 use nstio_module
464 use resol_def
465 use layout1
466 use mpi_def
467 use gfs_physics_nst_var_mod
468 implicit none
469
470 TYPE(Nst_Var_Data) :: nst_fld
471 integer global_lats_r(latr)
472 integer lonsperlar(latr)
473
474
475
476 real(kind=kind_io4) buff1(lonr,latr)
477 real(kind=kind_io8) buffo(lonr,lats_node_r_max)
478 integer nread,i,j,k,ij,idate(4),lonnst,latnst,lplnst(latr2)
479 character*(*) cfile
480 integer kmsk(lonr,latr)
481 CHARACTER*8 labfix(4)
482 real t1,t2,timef
483 type(nstio_head) head
484 type(nstio_data) data
485 integer iret
486
487
488
489
490 =timef()
491
492 print *,'read nst filem nread=',nread,'cfile=',cfile
493 IF (me == 0) then
494 call nstio_srohdc(nread,cfile,head,data,iret)
495
496 PRINT 99,nread,head%fhour,head%idate,
497 & head%lonb,head%latb,head%lsea,head%ivo,iret,lats_node_r
498 99 FORMAT(1H ,'in fixio nread=',i3,2x,'HOUR=',f8.2,3x,'IDATE=',
499 & 4(1X,I4),4x,'lonnst,latnst,lsea,ivsnst,iret=',6i8)
500
501 if(iret.ne.0) goto 5000
502 if(head%lonb.ne.lonr) goto 5000
503 if(head%latb.ne.latr) goto 5000
504 if(head%lsea.ne.lsea) goto 5000
505
506 ENDIF
507
508 kmsk=0
509
510
511
512 IF (me == 0) buff1=data%xt
513 call split2d_phys(buff1, buffo,global_lats_r)
514 CALL interpred_phys(1,kmsk,buffo,nst_fld%xt,
515 & global_lats_r,lonsperlar)
516
517 IF (me == 0) buff1=data%xs
518 call split2d_phys(buff1, buffo,global_lats_r)
519 CALL interpred_phys(1,kmsk,buffo,nst_fld%xs,
520 & global_lats_r,lonsperlar)
521
522 IF (me == 0) buff1=data%xu
523 call split2d_phys(buff1, buffo,global_lats_r)
524 CALL interpred_phys(1,kmsk,buffo,nst_fld%xu,
525 & global_lats_r,lonsperlar)
526
527 IF (me == 0) buff1=data%xv
528 call split2d_phys(buff1, buffo,global_lats_r)
529 CALL interpred_phys(1,kmsk,buffo,nst_fld%xv,
530 & global_lats_r,lonsperlar)
531
532 IF (me == 0) buff1=data%xz
533 call split2d_phys(buff1, buffo,global_lats_r)
534 CALL interpred_phys(1,kmsk,buffo,nst_fld%xz,
535 & global_lats_r,lonsperlar)
536
537 IF (me == 0) buff1=data%zm
538 call split2d_phys(buff1, buffo,global_lats_r)
539 CALL interpred_phys(1,kmsk,buffo,nst_fld%zm,
540 & global_lats_r,lonsperlar)
541
542 IF (me == 0) buff1=data%xtts
543 call split2d_phys(buff1, buffo,global_lats_r)
544 CALL interpred_phys(1,kmsk,buffo,nst_fld%xtts,
545 & global_lats_r,lonsperlar)
546
547 IF (me == 0) buff1=data%xzts
548 call split2d_phys(buff1, buffo,global_lats_r)
549 CALL interpred_phys(1,kmsk,buffo,nst_fld%xzts,
550 & global_lats_r,lonsperlar)
551
552 IF (me == 0) buff1=data%dt_cool
553 call split2d_phys(buff1, buffo,global_lats_r)
554 CALL interpred_phys(1,kmsk,buffo,nst_fld%dt_cool,
555 & global_lats_r,lonsperlar)
556
557 IF (me == 0) buff1=data%z_c
558 call split2d_phys(buff1, buffo,global_lats_r)
559 CALL interpred_phys(1,kmsk,buffo,nst_fld%z_c,
560 & global_lats_r,lonsperlar)
561
562 IF (me == 0) buff1=data%c_0
563 call split2d_phys(buff1, buffo,global_lats_r)
564 CALL interpred_phys(1,kmsk,buffo,nst_fld%c_0,
565 & global_lats_r,lonsperlar)
566 IF (me == 0) buff1=data%c_d
567 call split2d_phys(buff1, buffo,global_lats_r)
568 CALL interpred_phys(1,kmsk,buffo,nst_fld%c_d,
569 & global_lats_r,lonsperlar)
570
571 IF (me == 0) buff1=data%w_0
572 call split2d_phys(buff1, buffo,global_lats_r)
573 CALL interpred_phys(1,kmsk,buffo,nst_fld%w_0,
574 & global_lats_r,lonsperlar)
575
576 IF (me == 0) buff1=data%w_d
577 call split2d_phys(buff1, buffo,global_lats_r)
578 CALL interpred_phys(1,kmsk,buffo,nst_fld%w_d,
579 & global_lats_r,lonsperlar)
580
581 IF (me == 0) buff1=data%d_conv
582 call split2d_phys(buff1, buffo,global_lats_r)
583 CALL interpred_phys(1,kmsk,buffo,nst_fld%d_conv,
584 & global_lats_r,lonsperlar)
585
586 IF (me == 0) buff1=data%ifd
587 call split2d_phys(buff1, buffo,global_lats_r)
588 CALL interpred_phys(1,kmsk,buffo,nst_fld%ifd,
589 & global_lats_r,lonsperlar)
590
591 IF (me == 0) buff1=data%tref
592 call split2d_phys(buff1, buffo,global_lats_r)
593 CALL interpred_phys(1,kmsk,buffo,nst_fld%tref,
594 & global_lats_r,lonsperlar)
595
596 IF (me == 0) buff1=data%Qrain
597 call split2d_phys(buff1, buffo,global_lats_r)
598 CALL interpred_phys(1,kmsk,buffo,nst_fld%Qrain,
599 & global_lats_r,lonsperlar)
600
601
602 IF (me == 0) then
603 call nstio_axdata(data,iret)
604 t2=timef()
605 print *,'FIXIO for NST TIME ',t2-t1,t1,t2
606 endif
607
608 RETURN
609 5000 PRINT *, ' ERROR IN INPUT IN read_nst'
610 STOP
611 END
612
613 SUBROUTINE set_nst(tsea, nst_fld)
614
615
616
617 use namelist_physics_def
618 USE machine, ONLY: kind_io8
619 use resol_def
620 use layout1
621 use gfs_physics_nst_var_mod
622 use module_nst_parameters, only: z_w_max
623 use mpi_def
624 implicit none
625
626 TYPE(Nst_Var_Data) :: nst_fld
627 real (kind=kind_io8) tsea(lonr,lats_node_r)
628
629 integer i,j,k
630 real t1,t2,timef
631
632
633
634
635 =timef()
636
637
638 %xt = 0.0
639 nst_fld%xs = 0.0
640 nst_fld%xu = 0.0
641 nst_fld%xv = 0.0
642 nst_fld%xz = z_w_max
643 nst_fld%zm = 0.0
644 nst_fld%xtts = 0.0
645 nst_fld%xzts = 0.0
646 nst_fld%dt_cool = 0.0
647 nst_fld%z_c = 0.0
648 nst_fld%c_0 = 0.0
649 nst_fld%c_d = 0.0
650 nst_fld%w_0 = 0.0
651 nst_fld%w_d = 0.0
652 nst_fld%d_conv = 0.0
653 nst_fld%ifd = 0.0
654 nst_fld%Tref(:,1:lats_node_r)= tsea(:,1:lats_node_r)
655 nst_fld%Qrain = 0.0
656
657 =timef()
658
659
660 RETURN
661 END
662
663
664
665 SUBROUTINE nst_reset_nonwater(tsea,nst_fld)
666
667
668
669 use resol_def
670 USE machine, ONLY: kind_io8
671 use layout1
672 use gfs_physics_nst_var_mod
673 use module_nst_parameters, only: z_w_max
674 use mpi_def
675 implicit none
676
677 TYPE(Nst_Var_Data) :: nst_fld
678 real (kind=kind_io8) tsea(lonr,lats_node_r)
679
680 integer i,j
681 real t1,t2,timef
682
683
684
685 =timef()
686
687 do j = 1, lats_node_r
688 do i = 1, lonr
689 if ( nst_fld%slmsk(i,j) /= 0.0 ) then
690 nst_fld%xt(i,j) = 0.0
691 nst_fld%xs(i,j) = 0.0
692 nst_fld%xu(i,j) = 0.0
693 nst_fld%xv(i,j) = 0.0
694 nst_fld%xz(i,j) = z_w_max
695 nst_fld%zm(i,j) = 0.0
696 nst_fld%xtts(i,j) = 0.0
697 nst_fld%xzts(i,j) = 0.0
698 nst_fld%dt_cool(i,j) = 0.0
699 nst_fld%z_c(i,j) = 0.0
700 nst_fld%c_0(i,j) = 0.0
701 nst_fld%c_d(i,j) = 0.0
702 nst_fld%w_0(i,j) = 0.0
703 nst_fld%w_d(i,j) = 0.0
704 nst_fld%d_conv(i,j) = 0.0
705 nst_fld%ifd(i,j) = 0.0
706 nst_fld%Tref(i,j) = tsea(i,j)
707 nst_fld%Qrain(i,j) = 0.0
708 endif
709 enddo
710 enddo
711
712 t2=timef()
713
714
715 RETURN
716 END
717
718
719
720 subroutine interpred_phys(iord,kmsk,f,fi,global_lats_r,lonsperlar)
721
722 use resol_def, ONLY: latr, lonr
723 use layout1, ONLY: ipt_lats_node_r, lats_node_r
724 USE machine, ONLY: kind_io8
725 implicit none
726
727 integer global_lats_r(latr)
728 integer,intent(in):: iord
729 integer,intent(in):: kmsk(lonr,lats_node_r)
730 integer,intent(in):: lonsperlar(latr)
731 real(kind=kind_io8),intent(in):: f(lonr,lats_node_r)
732 real(kind=kind_io8),intent(out):: fi(lonr,lats_node_r)
733 integer j,lons,lat
734
735 do j=1,lats_node_r
736 lat=global_lats_r(ipt_lats_node_r-1+j)
737 lons=lonsperlar(lat)
738 if(lons.ne.lonr) then
739 call intlon_phys(iord,1,1,lonr,lons,
740 & kmsk(1,j),f(1,j),fi(1,j))
741
742 (lons+1:lonr,j)=0.
743 else
744 fi(:,j)=f(:,j)
745 endif
746 enddo
747 end subroutine
748
749
750
751 subroutine intlon_phys(iord,imon,imsk,m1,m2,k1,f1,f2)
752 use machine, ONLY: kind_io8
753 implicit none
754 integer,intent(in):: iord,imon,imsk,m1,m2
755 integer,intent(in):: k1(m1)
756 real (kind=kind_io8),intent(in):: f1(m1)
757 real (kind=kind_io8),intent(out):: f2(m2)
758 integer i2,in,il,ir
759 real (kind=kind_io8) r,x1
760 r=real(m1)/real(m2)
761 do i2=1,m2
762 x1=(i2-1)*r
763 il=int(x1)+1
764 ir=mod(il,m1)+1
765 if(iord.eq.2.and.(imsk.eq.0.or.k1(il).eq.k1(ir))) then
766 f2(i2)=f1(il)*(il-x1)+f1(ir)*(x1-il+1)
767 else
768 in=mod(nint(x1),m1)+1
769 f2(i2)=f1(in)
770 endif
771 enddo
772 end subroutine
773
774
775
776 SUBROUTINE readoz_disprd(ozplin)
777
778 use ozne_def, ONLY: latsozp, levozp, timeoz, pl_coeff, kozpl
779 USE machine, ONLY: kind_phys, kind_io4
780 implicit none
781
782 integer n,k,kk,i
783 real (kind=kind_phys) ozplin(latsozp,levozp,pl_coeff,timeoz)
784 real(kind=kind_io4) tempin(latsozp)
785
786 DO I=1,timeoz
787 do n=1,pl_coeff
788 DO k=1,levozp
789 READ(kozpl) tempin
790 ozplin(:,k,n,i) = tempin(:)
791 ENDDO
792 enddo
793 ENDDO
794
795 RETURN
796 END
797
798
799
800 SUBROUTINE ORORD(LUGB,IORO,JORO,ORO)
801
802 use layout1, ONLY: me
803 USE machine, ONLY: kind_io4, kind_io8
804 implicit none
805
806 integer lugb, ioro, joro, kpdoro, ior, jor, i,k
807 CHARACTER*80 FNOROG
808
809 real (kind=kind_io4) oro(ioro,joro)
810 real (kind=kind_io8) orog(ioro,joro), blnm, bltm
811 logical gausm
812
813 = 'orography'
814 kpdoro = 8
815 IOR = IORO
816 JOR = JORO
817 CALL FIXRDG(LUGB,IOR,JOR,FNOROG,
818 & KPDORO,OROG,GAUSM,BLNM,BLTM,me)
819
820 if (ior .ne. ioro .or. jor .ne. joro) then
821 print *,' orography file not o.k. run aborted'
822 call abort
823 endif
824 ORO = OROG
825
826 RETURN
827 END
828
829
830
831 subroutine split2d_phys(x,xl,global_lats_r)
832
833
834
835 use resol_def, ONLY: latr, lonr
836 use layout1, ONLY: me, nodes, lats_node_r, ipt_lats_node_r
837 use mpi_def, ONLY: info, mpi_r_io, mpi_comm_all
838 USE machine, ONLY: kind_io4, kind_io8
839 implicit none
840
841 real(kind=kind_io4) x(lonr,latr)
842 real (kind=kind_io8) xl(lonr,lats_node_r)
843 real(kind=kind_io4) tmp(lonr,latr)
844 integer global_lats_r(latr)
845 integer nprocf,nodesr
846
847
848 integer proc,j,lat,nproc,i,buff,startlat,ierr
849 integer ifld/0/
850 save ifld
851 real t1,t2,t3,t4,timef,ta,tb
852
853
854
855
856 =0.
857 ifld=ifld+1
858 IF (me==0) THEN
859
860
861
862
863 =0.
864 do j=1,latr
865 do i=1,lonr
866 tmp(i,j)=X(i,j)
867 enddo
868 enddo
869 ENDIF
870 call mpi_bcast
871 1 (tmp,lonr*latr,MPI_R_IO,0,MPI_COMM_ALL,info)
872 call mpi_barrier(mpi_comm_all,info)
873
874 do j=1,lats_node_r
875 lat=global_lats_r(ipt_lats_node_r-1+j)
876 do i=1,lonr
877 xl(i,j)=tmp(i,lat)
878 enddo
879 enddo
880 return
881 end
882
883
884
885 SUBROUTINE skip(jump)
886
887
888
889 use resol_def
890 use layout1
891 use mpi_def
892 implicit none
893
894 integer jump,ipe
895
896 ipe=0
897
898 CALL MPI_BCAST(jump,1,MPI_INTEGER,ipe,MPI_COMM_ALL,info)
899
900 RETURN
901 END
902
903
904
905
906 SUBROUTINE EXCHA(lats_nodes_r,global_lats_r,X1,X2,Y1,Y2)
907
908
909
910 use resol_def, ONLY: latr
911 use layout1, ONLY: nodes, lats_node_r_max, lats_node_r,
912 & ipt_lats_node_r
913 use mpi_def, ONLY: mc_comp, mpi_r_def
914 USE machine, ONLY: kind_io8
915 implicit none
916
917 integer n,i,j,ierr,ilat,lat,node,nsend
918 integer global_lats_r(latr)
919 integer lats_nodes_r(nodes)
920 real(kind=kind_io8) X1(lats_node_r),X2(lats_node_r)
921 real(kind=kind_io8) Y1(latr),Y2(latr)
922
923
924 real(kind=kind_io8) tmps(2,lats_node_r_max,nodes)
925 real(kind=kind_io8) tmpr(2,lats_node_r_max,nodes)
926
927
928
929 if (nodes.ne.1) then
930 do node=1,nodes
931 do i=1,lats_node_r
932 lat=global_lats_r(ipt_lats_node_r-1+i)
933 tmps(1,i,node)=X1(I)
934 tmps(2,i,node)=X2(I)
935 enddo
936 enddo
937
938 =2*lats_node_r_max
939
940
941
942 call mpi_alltoall(tmps,nsend,MPI_R_DEF,
943 x tmpr,nsend,MPI_R_DEF,
944 x MC_COMP,ierr)
945
946 =1
947 do node=1,nodes
948 do i=1,lats_nodes_r(node)
949 lat=global_lats_r(ilat)
950 Y1(lat)=tmpr(1,i,node)
951 Y2(lat)=tmpr(2,i,node)
952 ilat=ilat+1
953 enddo
954 enddo
955
956 ELSE
957 Y1=X1
958 Y2=X2
959 ENDIF
960
961 RETURN
962 END
963
964
965
966 SUBROUTINE SUMLAT(n,X,nodes)
967
968
969
970 use mpi_def, ONLY: MC_COMP, MPI_R_DEF, info, mpi_sum
971 USE machine, ONLY: kind_io8, kind_io4
972 implicit none
973
974 integer n,i,j,np,mr,nodes
975 real(kind=kind_io8) X(n),Y(N)
976 real(kind=kind_io4) Z(n)
977
978
979
980 if (nodes.ne.1) then
981 DO i=1,n
982 Y(i)=X(i)
983 ENDDO
984 CALL mpi_allreduce(Y,X,n,MPI_R_DEF,MPI_SUM,
985 & MC_COMP ,info)
986 endif
987 DO i=1,n
988 Z(i)=X(i)
989 ENDDO
990 DO i=1,n
991 X(i)=Z(i)
992 ENDDO
993
994 RETURN
995 END
996
997
998
999 subroutine unsplit2d_phys(ioproc,x,xl,global_lats_r)
1000
1001
1002
1003 use resol_def, ONLY: latr, lonr
1004 use layout1, ONLY: me, lats_node_r, lats_node_r_max,
1005 & ipt_lats_node_r, nodes
1006 use mpi_def, ONLY: info, mpi_comm_all, liope, mpi_r_io,
1007 & stat
1008 USE machine, ONLY: kind_io4, kind_io8
1009 implicit none
1010
1011 real(kind=kind_io4) x(lonr,latr)
1012 real (kind=kind_io8) xl(lonr,lats_node_r)
1013 real(kind=kind_io4) tmp(lonr,latr+2)
1014 integer global_lats_r(latr),ipt_lats_node_rl,nodesr
1015 integer lats_nodes_rl
1016 integer maxfld,ioproc,nproct
1017 integer proc,j,lat,msgtag,nproc,i,msgtag1,buff,startlat,ierr
1018 integer ifldu/0/
1019 save ifldu
1020 integer illen,ncc
1021 data ncc/0/
1022
1023
1024
1025
1026 =0.
1027 maxfld=50
1028 ifldu=ifldu+1
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101 return
1102 end
1103
1104
1105
1106 subroutine uninterpred(iord,kmsk,f,fi,global_lats_r,lonsperlar)
1107
1108 use resol_def, ONLY: latr, lonr
1109 use layout1, ONLY: lats_node_r, ipt_lats_node_r
1110 USE machine, ONLY: kind_io8
1111 implicit none
1112
1113 integer global_lats_r(latr)
1114 integer,intent(in):: iord
1115 integer,intent(in):: kmsk(lonr,lats_node_r)
1116 integer,intent(in):: lonsperlar(latr)
1117 real(kind=kind_io8),intent(out):: f(lonr,lats_node_r)
1118 real(kind=kind_io8),intent(in):: fi(lonr,lats_node_r)
1119 integer j,lons,lat
1120
1121 do j=1,lats_node_r
1122 lat=global_lats_r(ipt_lats_node_r-1+j)
1123 lons=lonsperlar(lat)
1124 if(lons.ne.lonr) then
1125 call intlon_phys(iord,1,1,lons,lonr,
1126 & kmsk(1,j),fi(1,j),f(1,j))
1127 else
1128 f(:,j)=fi(:,j)
1129 endif
1130 enddo
1131 end subroutine
1132
1133
1134
1135 subroutine uninterprez(iord,kmsk,f,fi,global_lats_r,lonsperlar,
1136 & buff_mult_piecea)
1137
1138 use resol_def, ONLY: latr, lonr
1139 use layout1, ONLY: lats_node_r, ipt_lats_node_r
1140 USE machine, ONLY: kind_io4,kind_io8
1141 implicit none
1142
1143 integer,intent(in):: global_lats_r(latr)
1144 integer,intent(in):: iord
1145 integer,intent(in):: kmsk(lonr,lats_node_r)
1146 integer,intent(in):: lonsperlar(latr)
1147 real(kind=kind_io8),intent(out):: f(lonr,lats_node_r)
1148 real(kind=kind_io8),intent(in):: fi(lonr,lats_node_r)
1149 integer j,lons,lat
1150 integer i,ubound
1151
1152 real(kind=kind_io4),intent(inout) :: buff_mult_piecea
1153 & (1:lonr,1:lats_node_r)
1154
1155 do j=1,lats_node_r
1156 lat=global_lats_r(ipt_lats_node_r-1+j)
1157 lons=lonsperlar(lat)
1158 if(lons.ne.lonr) then
1159 call intlon_phys(iord,1,1,lons,lonr,
1160 & kmsk(1,j),fi(1,j),f(1,j))
1161 else
1162 f(:,j)=fi(:,j)
1163 endif
1164 enddo
1165 do j=1,lats_node_r
1166 do i=1,lonr
1167 buff_mult_piecea(i,j)=f (i,j)
1168 end do
1169 end do
1170 end subroutine
1171
1172
1173
1174 subroutine unsplit2z(ioproc,ngridx,ngridt,x,global_lats_r)
1175
1176
1177
1178 use resol_def, ONLY: lonr,latr
1179 use mod_state, ONLY: ivar_global_a, buff_mult_pieces
1180 use layout1, ONLY: me, nodes_comp
1181 use mpi_def, ONLY: liope
1182 USE machine, ONLY: kind_io4
1183 implicit none
1184
1185 real(kind=kind_io4) x(lonr,latr)
1186 real(kind=kind_io4) tmp(lonr,latr+2)
1187 integer global_lats_r(latr),ipt_lats_node_rl,nodesr,ngridx,ngridt
1188 integer lats_nodes_rl
1189 integer maxfld,ioproc,nproct
1190 integer proc,j,lat,msgtag,nproc,i,msgtag1,buff,startlat,ierr
1191 integer ifldu/0/
1192 save ifldu
1193 integer illen,nd1,nd2
1194 character*8 cna
1195
1196
1197
1198
1199 write(cna,985)600+ngridx
1200 985 format('fort.',i3)
1201 X=0.
1202 maxfld=50
1203 ifldu=ifldu+1
1204
1205 IF (me.ne.ioproc) THEN
1206 continue
1207 ELSE
1208
1209
1210 =nodes_comp
1211 nd1=0
1212 DO proc=1,nproct
1213 ipt_lats_node_rl=ivar_global_a(1,proc)
1214 lats_nodes_rl=ivar_global_a(2,proc)
1215 nd2=nd1+lonr*lats_nodes_rl*(ngridx-1)
1216 do j=1,lats_nodes_rl
1217 lat=global_lats_r(ipt_lats_node_rl-1+j)
1218 do i=1,lonr
1219 x(i,lat)=buff_mult_pieces(nd2+i+(j-1)*lonr)
1220 enddo
1221 enddo
1222 nd1=nd1+lonr*lats_nodes_rl*ngridt
1223 enddo
1224
1225
1226 ENDIF
1227
1228 return
1229 end
1230
1231
1232
1233
1234 subroutine unsplit2d_phys_r(ioproc,x,xl,global_lats_r)
1235
1236
1237
1238 use resol_def, ONLY: latr, lonr
1239 use layout1, ONLY: me, lats_node_r, lats_node_r_max,
1240 & ipt_lats_node_r, nodes
1241 use mpi_def, ONLY: liope, info, stat, mpi_comm_all,
1242 & mpi_r_io_r
1243 USE machine, ONLY: kind_ior, kind_io8
1244 implicit none
1245
1246 real(kind=kind_ior) x(lonr,latr)
1247 real (kind=kind_io8) xl(lonr,lats_node_r)
1248 real(kind=kind_ior) tmp(lonr,latr+2)
1249 integer global_lats_r(latr),ipt_lats_node_rl,nodesr
1250 integer lats_nodes_rl
1251 integer maxfld,ioproc,nproct
1252 integer proc,j,lat,msgtag,nproc,i,msgtag1,buff,startlat,ierr
1253 integer ifldu/0/
1254 save ifldu
1255 integer illen,ncc
1256 data ncc/0/
1257
1258
1259
1260
1261
1262 =50
1263 ifldu=ifldu+1
1264
1265 IF (me.ne.ioproc) THEN
1266
1267
1268
1269 =0.
1270 tmp(lonr,latr+1)=ipt_lats_node_r
1271 tmp(lonr,latr+2)=lats_node_r
1272 do j=1,lats_node_r
1273 do i=1,lonr
1274 tmp(i,j)=XL(i,j)
1275 enddo
1276 enddo
1277 if (.NOT.LIOPE) then
1278 nodesr=nodes
1279 else
1280 nodesr=nodes+1
1281 endif
1282 msgtag=1000+(me+1)*nodesr*maxfld+ifldu
1283 call MPI_SEND(tmp(lonr,latr+1),1,MPI_R_IO_R,ioproc,
1284 & msgtag,MPI_COMM_ALL,info)
1285 call MPI_SEND(tmp(lonr,latr+2),1,MPI_R_IO_R,ioproc,
1286 & msgtag,MPI_COMM_ALL,info)
1287 illen=tmp(lonr,latr+2)
1288
1289 CALL mpi_send(tmp(1,1),illen*lonr,MPI_R_IO_R,ioproc,
1290 & msgtag,MPI_COMM_ALL,info)
1291 ELSE
1292
1293
1294 = 0.0
1295 if (.NOT.LIOPE) then
1296 nproct=nodes
1297 do j=1,lats_node_r
1298 lat=global_lats_r(ipt_lats_node_r-1+j)
1299 do i=1,lonr
1300 x(i,lat)=XL(i,j)
1301 enddo
1302 enddo
1303 else
1304 nproct=nodes-1
1305 endif
1306 DO proc=1,nproct
1307 if (proc.ne.ioproc+1) then
1308 msgtag=1000+proc*nodes*maxfld+ifldu
1309 CALL mpi_recv(tmp(lonr,latr+1),1,MPI_R_IO_R,proc-1,
1310 & msgtag,MPI_COMM_ALL,stat,info)
1311 CALL mpi_recv(tmp(lonr,latr+2),1,MPI_R_IO_R,proc-1,
1312 & msgtag,MPI_COMM_ALL,stat,info)
1313 illen=tmp(lonr,latr+2)
1314 CALL mpi_recv(tmp(1,1),illen*lonr ,MPI_R_IO_R,proc-1,
1315 & msgtag,MPI_COMM_ALL,stat,info)
1316 if (.NOT.LIOPE) then
1317 ipt_lats_node_rl=tmp(lonr,latr+1)
1318 lats_nodes_rl=tmp(lonr,latr+2)
1319 else
1320 ipt_lats_node_rl=tmp(lonr,lats_node_r_max+1)
1321 lats_nodes_rl=tmp(lonr,lats_node_r_max+2)
1322 endif
1323 do j=1,lats_nodes_rl
1324 lat=global_lats_r(ipt_lats_node_rl-1+j)
1325 do i=1,lonr
1326 x(i,lat)=tmp(i,j)
1327 enddo
1328 enddo
1329 endif
1330 enddo
1331
1332 ENDIF
1333 ncc=ncc+1
1334
1335
1336 return
1337 end
1338
1339
1340
1341 subroutine split2d_phys_r(x,xl,global_lats_r)
1342
1343
1344
1345 use resol_def, ONLY: latr, lonr
1346 use layout1, ONLY: me, lats_node_r, ipt_lats_node_r, nodes
1347 use mpi_def, ONLY: liope, mpi_comm_all, info,mpi_r_io_r
1348 USE machine, ONLY: kind_ior, kind_io8
1349 implicit none
1350
1351 real(kind=kind_ior) x(lonr,latr)
1352 real (kind=kind_io8) xl(lonr,lats_node_r)
1353 real(kind=kind_ior) tmp(lonr,latr)
1354 integer global_lats_r(latr)
1355 integer nprocf,nodesr
1356
1357 integer proc,j,lat,nproc,i,buff,startlat,ierr
1358
1359 integer ifld/0/
1360 save ifld
1361 real t1,t2,t3,t4,timef,ta,tb
1362
1363
1364
1365
1366 =0.
1367
1368 =ifld+1
1369
1370 IF (me.eq.0) THEN
1371 ta=timef()
1372 t3=ta
1373
1374 do proc=1,1
1375
1376
1377
1378 =0.
1379 do j=1,latr
1380 do i=1,lonr
1381 tmp(i,j)=X(i,j)
1382 enddo
1383 enddo
1384
1385 =timef()
1386
1387 call mpi_bcast
1388 1 (tmp,lonr*latr,MPI_R_IO_R,nodes-1,MPI_COMM_ALL,info)
1389 call mpi_comm_rank(MPI_COMM_ALL,i,info)
1390
1391
1392 =timef()
1393
1394
1395 format(' SEND TIME ',f10.5)
1396 enddo
1397 t4=timef()
1398 ELSE
1399 if (.NOT.LIOPE) then
1400 nodesr=nodes
1401 else
1402 nodesr=nodes+1
1403 endif
1404
1405
1406 call mpi_bcast
1407 1 (tmp,lonr*latr,MPI_R_IO_R,nodesr-1,MPI_COMM_ALL,info)
1408 call mpi_comm_rank(MPI_COMM_ALL,i,info)
1409
1410
1411
1412 do j=1,lats_node_r
1413 lat=global_lats_r(ipt_lats_node_r-1+j)
1414 do i=1,lonr
1415 xl(i,j)=tmp(i,lat)
1416 enddo
1417 enddo
1418
1419 ENDIF
1420
1421
1422 if (.NOT.LIOPE) then
1423 if (me.eq.nodes-1) then
1424 do j=1,lats_node_r
1425 lat=global_lats_r(ipt_lats_node_r-1+j)
1426 do i=1,lonr
1427 xl(i,j)=X(i,lat)
1428 enddo
1429 enddo
1430 endif
1431 endif
1432
1433 =timef()
1434 call mpi_comm_rank(MPI_COMM_ALL,i,info)
1435
1436
1437 format(' GLOBAL AND SEND TIMES split2d_phys',2f10.5)
1438 return
1439 end
1440
1441
1442
1443
1444 subroutine split2d_rst(x,xl,fieldsize,global_lats_r,lonsperlar)
1445
1446
1447
1448 use resol_def, ONLY: latr, lonr
1449 use layout1, ONLY: me, lats_node_r, ipt_lats_node_r, nodes
1450 use mpi_def, ONLY: liope, mpi_comm_all, info,mpi_r_io_r
1451 USE machine, ONLY: kind_ior, kind_io8
1452 implicit none
1453
1454
1455 integer,intent(in) :: fieldsize,global_lats_r(latr),
1456 & lonsperlar(latr)
1457 real(kind=kind_ior),intent(in) :: x(fieldsize)
1458 real (kind=kind_io8),intent(inout) :: xl(lonr,lats_node_r)
1459 integer j,lat,i,lon
1460
1461
1462
1463
1464
1465
1466 do j=1,lats_node_r
1467 lat=global_lats_r(ipt_lats_node_r-1+j)
1468 if(lat/=1) then
1469 lon=sum(lonsperlar(1:lat-1))
1470 else
1471 lon=0
1472 endif
1473
1474 do i=1,lonsperlar(lat)
1475 xl(i,j)=X(lon+i)
1476 enddo
1477 enddo
1478
1479
1480
1481 format(' GLOBAL AND SEND TIMES split2d_phys',2f10.5)
1482 return
1483 end subroutine split2d_rst
1484
1485
1486
1487
1488 SUBROUTINE read_sfc_r(cfile,sfc_fld,phy_f2d,phy_f3d,num_p3d,
1489 & num_p2d,NGPTC,NBLCK,global_lats_r,lonsperlar,NEEDORO)
1490
1491
1492
1493 use resol_def, ONLY: latr, lonr, latr2, lsoil,levs
1494 use layout1, ONLY: me, nodes, lats_node_r,ipt_lats_node_r
1495 USE machine, ONLY: kind_ior, kind_io8, kind_rad
1496
1497 use gfs_physics_sfc_flx_mod, ONLY: Sfc_Var_Data
1498 use namelist_soilveg , only: salp_data, snupx
1499 use physcons, only : tgice => con_tice
1500 use module_nemsio
1501
1502 implicit none
1503
1504 character(*),intent(in) :: cfile
1505 TYPE(Sfc_Var_Data),intent(inout) :: sfc_fld
1506 integer,intent(in) :: global_lats_r(latr)
1507 integer,intent(in) :: lonsperlar(latr)
1508 integer,intent(in) :: num_p2d,num_p3d,NGPTC,NBLCK
1509 real(kind=kind_rad),intent(inout) ::
1510 & phy_f2d(lonr,lats_node_r,num_p2d),
1511 & phy_f3d(NGPTC,LEVS,NBLCK,lats_node_r,num_p3d)
1512 integer,intent(inout) :: needoro
1513
1514 integer jump
1515
1516 real(kind=kind_io8) buff3(lonr,lats_node_r)
1517
1518 real(kind=kind_ior),allocatable :: buff1(:)
1519
1520 integer i,j,k,im,jm,idate(4),lplsfc(latr2)
1521 real t1,t2,timef,rsnow
1522
1523 type(nemsio_gfile) :: gfile
1524 integer iret, vegtyp,fieldsize,iblk,il,lons_lat,njeff,l,lat,lon
1525 character*2 nump2d,nump3d
1526 character(255) varname
1527
1528
1529
1530 =timef()
1531
1532 call nemsio_init()
1533
1534 call nemsio_open(gfile,trim(cfile),'read',iret=iret)
1535
1536 if(iret/=0) then
1537 PRINT *, ' ERROR in input routine read_sfc_r'
1538 return
1539 endif
1540
1541 call nemsio_getfilehead(gfile,dimx=im,dimy=jm,iret=iret)
1542 fieldsize=im*jm
1543 allocate(buff1(fieldsize))
1544
1545
1546 call nemsio_readrecv(gfile,'tmp','sfc',1,buff1,iret=iret)
1547 call split2d_rst(buff1,sfc_fld%TSEA,fieldsize,global_lats_r,
1548 & lonsperlar)
1549
1550 DO K=1, LSOIL
1551 call nemsio_readrecv(gfile,'smc','soil layer',k,buff1,iret=iret)
1552 call split2d_rst(buff1, sfc_fld%smc(k,:,:),fieldsize,
1553 & global_lats_r,lonsperlar)
1554
1555 ENDDO
1556
1557
1558 call nemsio_readrecv(gfile,'weasd','sfc',1,buff1,iret=iret)
1559 call split2d_rst(buff1,sfc_fld%SHELEG,fieldsize,global_lats_r,
1560 & lonsperlar)
1561
1562 DO K = 1, LSOIL
1563 call nemsio_readrecv(gfile,'stc','soil layer',k,buff1,iret=iret)
1564 call split2d_rst(buff1, sfc_fld%stc(k,:,:),fieldsize,
1565 & global_lats_r,lonsperlar)
1566
1567 ENDDO
1568
1569
1570 call nemsio_readrecv(gfile,'tg3','sfc',1,buff1,iret=iret)
1571 call split2d_rst(buff1,sfc_fld%tg3,fieldsize,global_lats_r,
1572 & lonsperlar)
1573
1574
1575 call nemsio_readrecv(gfile,'sfcr','sfc',1,buff1,iret=iret)
1576 call split2d_rst(buff1,sfc_fld%zorl,fieldsize,global_lats_r,
1577 & lonsperlar)
1578
1579 %cv = 0
1580 sfc_fld%cvb = 0
1581 sfc_fld%cvt = 0
1582
1583
1584
1585 call nemsio_readrecv(gfile,'alvsf','sfc',1,buff1,iret=iret)
1586 call split2d_rst(buff1,sfc_fld%alvsf,fieldsize,global_lats_r,
1587 & lonsperlar)
1588
1589 call nemsio_readrecv(gfile,'alvwf','sfc',1,buff1,iret=iret)
1590 call split2d_rst(buff1,sfc_fld%alvwf,fieldsize,global_lats_r,
1591 & lonsperlar)
1592
1593 call nemsio_readrecv(gfile,'alnsf','sfc',1,buff1,iret=iret)
1594 call split2d_rst(buff1,sfc_fld%alnsf,fieldsize,global_lats_r,
1595 & lonsperlar)
1596
1597 call nemsio_readrecv(gfile,'alnwf','sfc',1,buff1,iret=iret)
1598 call split2d_rst(buff1,sfc_fld%alnwf,fieldsize,global_lats_r,
1599 & lonsperlar)
1600
1601 call nemsio_readrecv(gfile,'land','sfc',1,buff1,iret=iret)
1602 call split2d_rst(buff1,sfc_fld%slmsk,fieldsize,global_lats_r,
1603 & lonsperlar)
1604
1605
1606 call nemsio_readrecv(gfile,'veg','sfc',1,buff1,iret=iret)
1607 call split2d_rst(buff1,sfc_fld%vfrac,fieldsize,global_lats_r,
1608 & lonsperlar)
1609
1610 call nemsio_readrecv(gfile,'cnwat','sfc',1,buff1,iret=iret)
1611 call split2d_rst(buff1,sfc_fld%canopy,fieldsize,global_lats_r,
1612 & lonsperlar)
1613
1614 call nemsio_readrecv(gfile,'f10m','10 m above gnd',1,buff1,
1615 & iret=iret)
1616 call split2d_rst(buff1,sfc_fld%f10m,fieldsize,global_lats_r,
1617 & lonsperlar)
1618
1619 call nemsio_readrecv(gfile,'vtype','sfc',1,buff1,iret=iret)
1620 call split2d_rst(buff1,sfc_fld%vtype,fieldsize,global_lats_r,
1621 & lonsperlar)
1622
1623 call nemsio_readrecv(gfile,'sotyp','sfc',1,buff1,iret=iret)
1624 call split2d_rst(buff1,sfc_fld%stype,fieldsize,global_lats_r,
1625 & lonsperlar)
1626
1627 call nemsio_readrecv(gfile,'facsf','sfc',1,buff1,iret=iret)
1628 call split2d_rst(buff1,sfc_fld%facsf,fieldsize,global_lats_r,
1629 & lonsperlar)
1630
1631 call nemsio_readrecv(gfile,'facwf','sfc',1,buff1,iret=iret)
1632 call split2d_rst(buff1,sfc_fld%facwf,fieldsize,global_lats_r,
1633 & lonsperlar)
1634
1635 call nemsio_readrecv(gfile,'fricv','sfc',1,buff1,iret=iret)
1636 call split2d_rst(buff1,sfc_fld%uustar,fieldsize,global_lats_r,
1637 & lonsperlar)
1638
1639 call nemsio_readrecv(gfile,'ffhh','sfc',1,buff1,iret=iret)
1640 call split2d_rst(buff1,sfc_fld%ffhh,fieldsize,global_lats_r,
1641 & lonsperlar)
1642
1643 call nemsio_readrecv(gfile,'ffmm','sfc',1,buff1,iret=iret)
1644 call split2d_rst(buff1,sfc_fld%ffmm,fieldsize,global_lats_r,
1645 & lonsperlar)
1646
1647 call nemsio_readrecv(gfile,'icetk','sfc',1,buff1,iret=iret)
1648 call split2d_rst(buff1,sfc_fld%hice,fieldsize,global_lats_r,
1649 & lonsperlar)
1650
1651 call nemsio_readrecv(gfile,'icec','sfc',1,buff1,iret=iret)
1652 call split2d_rst(buff1,sfc_fld%fice,fieldsize,global_lats_r,
1653 & lonsperlar)
1654
1655 call nemsio_readrecv(gfile,'tisfc','sfc',1,buff1,iret=iret)
1656 call split2d_rst(buff1,sfc_fld%tisfc,fieldsize,global_lats_r,
1657 & lonsperlar)
1658
1659 if (lats_node_r > 0 ) then
1660 if (sfc_fld%tisfc(1,1) < 0.0) then
1661 DO j=1,lats_node_r
1662 DO i=1,LONR
1663 sfc_fld%TISFC(i,j) = sfc_fld%TSEA(i,j)
1664 IF(sfc_fld%SLMSK(i,j) >= 2. .AND.
1665 & sfc_fld%FICE(i,j) >= 0.5) THEN
1666 sfc_fld%TISFC(i,j) = (sfc_fld%TSEA(i,j)
1667 & -tgice*(1.-sfc_fld%FICE(i,j))) / sfc_fld%FICE(i,j)
1668 sfc_fld%TISFC(i,j) = MIN(sfc_fld%TISFC(i,j),tgice)
1669 ENDIF
1670 ENDDO
1671 ENDDO
1672 endif
1673 endif
1674
1675 call nemsio_readrecv(gfile,'tprcp','sfc',1,buff1,iret=iret)
1676 call split2d_rst(buff1,sfc_fld%tprcp,fieldsize,global_lats_r,
1677 & lonsperlar)
1678
1679 call nemsio_readrecv(gfile,'crain','sfc',1,buff1,iret=iret)
1680 call split2d_rst(buff1,sfc_fld%srflag,fieldsize,global_lats_r,
1681 & lonsperlar)
1682
1683 call nemsio_readrecv(gfile,'snod','sfc',1,buff1,iret=iret)
1684 call split2d_rst(buff1,sfc_fld%SNWDPH,fieldsize,global_lats_r,
1685 & lonsperlar)
1686
1687 DO K=1, LSOIL
1688 call nemsio_readrecv(gfile,'slc','soil layer',k,buff1,iret=iret)
1689 call split2d_rst(buff1,sfc_fld%slc(k,:,:),fieldsize,
1690 & global_latS_r,lonsperlar)
1691
1692 ENDDO
1693
1694 call nemsio_readrecv(gfile,'shdmin','sfc',1,buff1,iret=iret)
1695 call split2d_rst(buff1,sfc_fld%shdmin,fieldsize,global_lats_r,
1696 & lonsperlar)
1697
1698 call nemsio_readrecv(gfile,'shdmax','sfc',1,buff1,iret=iret)
1699 call split2d_rst(buff1,sfc_fld%shdmax,fieldsize,global_lats_r,
1700 & lonsperlar)
1701
1702 call nemsio_readrecv(gfile,'sltyp','sfc',1,buff1,iret=iret)
1703 call split2d_rst(buff1,sfc_fld%slope,fieldsize,global_lats_r,
1704 & lonsperlar)
1705
1706 call nemsio_readrecv(gfile,'salbd','sfc',1,buff1,iret=iret)
1707 call split2d_rst(buff1,sfc_fld%SNOALB,fieldsize,global_lats_r,
1708 & lonsperlar)
1709
1710
1711 if(needoro.eq.1) then
1712 call nemsio_readrecv(gfile,'orog','sfc',1,buff1,iret=iret)
1713 needoro=1
1714 if(any(buff1.eq.-9999.)) needoro=0
1715
1716 call split2d_rst(buff1,sfc_fld%oro,fieldsize,global_lats_r,
1717 & lonsperlar)
1718 call skip(needoro)
1719 endif
1720
1721
1722
1723 %SNCOVR = 0.0
1724 call nemsio_readrecv(gfile,'sncovr','sfc',1,buff1,iret=iret)
1725 if(iret==0)
1726 &call split2d_rst(buff1,sfc_fld%sncovr,fieldsize,global_lats_r,
1727 & lonsperlar)
1728
1729
1730
1731
1732 DO K=1, num_p2d
1733 write(nump2d,'(I2.2)')k
1734 varname='phyf2d_'//nump2d
1735 call nemsio_readrecv(gfile,trim(varname),'sfc',1,buff1,
1736 & iret=iret)
1737
1738 call split2d_rst(buff1,phy_f2d(:,:,k),fieldsize,global_lats_r,
1739 & lonsperlar)
1740 ENDDO
1741
1742
1743 DO K=1, num_p3d
1744 write(nump3d,'(I2.2)')k
1745 varname='phyf3d_'//nump3d
1746 DO L=1, levs
1747 call nemsio_readrecv(gfile,trim(varname),'mid layer',L,
1748 & buff1,iret=iret)
1749
1750 call split2d_rst(buff1,buff3,fieldsize,global_lats_r,
1751 & lonsperlar)
1752
1753 do j=1,lats_node_r
1754 lat = global_lats_r(ipt_lats_node_r-1+j)
1755 lons_lat = lonsperlar(lat)
1756 iblk=0
1757 il=1
1758 do lon=1,lons_lat,NGPTC
1759 NJEFF=MIN(NGPTC,lons_lat-lon+1)
1760 iblk=iblk+1
1761 do i=1,NJEFF
1762 phy_f3d(i,l,iblk,j,k)=buff3(il,j)
1763 il=il+1
1764 enddo
1765 enddo
1766 enddo
1767
1768 ENDDO
1769 ENDDO
1770
1771 call nemsio_close(gfile)
1772 call nemsio_finalize()
1773
1774 =timef()
1775
1776
1777 RETURN
1778
1779 STOP
1780 END
1781
1782 SUBROUTINE read_nst_r(nst_fld, nread, cfile,
1783 & global_lats_r, lonsperlar)
1784
1785
1786
1787 use namelist_physics_def
1788 USE machine, ONLY: kind_ior, kind_io8, kind_rad
1789 use resol_def
1790 use layout1
1791 use mpi_def
1792 use gfs_physics_nst_var_mod
1793 use module_nemsio
1794 implicit none
1795
1796 TYPE(Nst_Var_Data) :: nst_fld
1797 integer global_lats_r(latr)
1798 integer lonsperlar(latr)
1799
1800
1801
1802 real(kind=kind_ior),allocatable :: buff1(:)
1803 real(kind=kind_io8) buffo(lonr,lats_node_r)
1804 integer nread,i,j,k,ij,idate(4),lonnst,latnst,lplnst(latr2)
1805 character*(*) cfile
1806 integer kmsk(lonr,latr)
1807 CHARACTER*8 labfix(4)
1808 real t1,t2,timef
1809
1810 type(nemsio_gfile) :: gfile
1811 integer iret, fieldsize, im, jm
1812 character(255) varname
1813
1814
1815
1816
1817 =timef()
1818
1819 call nemsio_init()
1820
1821 call nemsio_open(gfile,trim(cfile),'read',iret=iret)
1822
1823 if(iret /= 0) then
1824 PRINT *, ' ERROR in input routine read_sfc_r'
1825 return
1826 endif
1827
1828 call nemsio_getfilehead(gfile,dimx=im,dimy=jm,iret=iret)
1829 fieldsize = im*jm
1830 allocate(buff1(fieldsize))
1831
1832
1833
1834 call nemsio_readrecv(gfile,'xt','sfc',1,buff1,iret=iret)
1835 call split2d_rst(buff1,nst_fld%xt,fieldsize,global_lats_r,
1836 & lonsperlar)
1837
1838
1839 call nemsio_readrecv(gfile,'xs','sfc',1,buff1,iret=iret)
1840 call split2d_rst(buff1,nst_fld%xs,fieldsize,global_lats_r,
1841 & lonsperlar)
1842
1843
1844 call nemsio_readrecv(gfile,'xu','sfc',1,buff1,iret=iret)
1845 call split2d_rst(buff1,nst_fld%xu,fieldsize,global_lats_r,
1846 & lonsperlar)
1847
1848
1849 call nemsio_readrecv(gfile,'xv','sfc',1,buff1,iret=iret)
1850 call split2d_rst(buff1,nst_fld%xv,fieldsize,global_lats_r,
1851 & lonsperlar)
1852
1853
1854 call nemsio_readrecv(gfile,'xz','sfc',1,buff1,iret=iret)
1855 call split2d_rst(buff1,nst_fld%xz,fieldsize,global_lats_r,
1856 & lonsperlar)
1857
1858
1859 call nemsio_readrecv(gfile,'zm','sfc',1,buff1,iret=iret)
1860 call split2d_rst(buff1,nst_fld%zm,fieldsize,global_lats_r,
1861 & lonsperlar)
1862
1863
1864
1865
1866
1867
1868
1869
1870
1871
1872
1873
1874 call nemsio_readrecv(gfile,'dtcool','sfc',1,buff1,iret=iret)
1875 call split2d_rst(buff1,nst_fld%dt_cool,fieldsize,global_lats_r,
1876 & lonsperlar)
1877
1878
1879 call nemsio_readrecv(gfile,'zc','sfc',1,buff1,iret=iret)
1880 call split2d_rst(buff1,nst_fld%z_c,fieldsize,global_lats_r,
1881 & lonsperlar)
1882
1883
1884 call nemsio_readrecv(gfile,'c0','sfc',1,buff1,iret=iret)
1885 call split2d_rst(buff1,nst_fld%c_0,fieldsize,global_lats_r,
1886 & lonsperlar)
1887
1888
1889 call nemsio_readrecv(gfile,'cd','sfc',1,buff1,iret=iret)
1890 call split2d_rst(buff1,nst_fld%c_d,fieldsize,global_lats_r,
1891 & lonsperlar)
1892
1893
1894 call nemsio_readrecv(gfile,'w0','sfc',1,buff1,iret=iret)
1895 call split2d_rst(buff1,nst_fld%w_0,fieldsize,global_lats_r,
1896 & lonsperlar)
1897
1898
1899 call nemsio_readrecv(gfile,'wd','sfc',1,buff1,iret=iret)
1900 call split2d_rst(buff1,nst_fld%w_d,fieldsize,global_lats_r,
1901 & lonsperlar)
1902
1903
1904 call nemsio_readrecv(gfile,'dconv','sfc',1,buff1,iret=iret)
1905 call split2d_rst(buff1,nst_fld%xt,fieldsize,global_lats_r,
1906 & lonsperlar)
1907
1908
1909 call nemsio_readrecv(gfile,'ifd','sfc',1,buff1,iret=iret)
1910 call split2d_rst(buff1,nst_fld%ifd,fieldsize,global_lats_r,
1911 & lonsperlar)
1912
1913
1914 call nemsio_readrecv(gfile,'tref','sfc',1,buff1,iret=iret)
1915 call split2d_rst(buff1,nst_fld%tref,fieldsize,global_lats_r,
1916 & lonsperlar)
1917
1918
1919 call nemsio_readrecv(gfile,'Qrain','sfc',1,buff1,iret=iret)
1920 call split2d_rst(buff1,nst_fld%Qrain,fieldsize,global_lats_r,
1921 & lonsperlar)
1922
1923
1924
1925 call nemsio_close(gfile)
1926 call nemsio_finalize()
1927
1928 =timef()
1929
1930
1931 RETURN
1932
1933 STOP
1934 END
1935
1936
1937
1938