File: C:\NOAA\NEMS_11731\src\atmos\gfs\libutil\atmos_chem_phy_cpl_comp_mod.F90
1
2 module atmos_chem_phy_cpl_comp_mod
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 use ESMF_MOD
28
29 USE MODULE_ERR_MSG, ONLY: ERR_MSG, MESSAGE_CHECK
30 use MODULE_gfs_machine, ONLY: kind_phys
31
32 use atmos_phy_chem_cpl_comp_mod, only: &
33 GetPointer_tracer_, CkPointer_, &
34 GetPointer_diag_, &
35 lonr, lats_node_r, lats_node_r_max, &
36 lonsperlar_r, im, jm, km, ntrac, &
37 run_DU, run_SU, run_SS, run_OC, run_BC
38
39
40
41 implicit none
42
43
44
45 public :: setservices
46
47 contains
48
49
50
51
52
53
54 subroutine setservices(GC, RC_REG)
55
56
57
58
59
60
61
62
63
64 implicit none
65
66
67
68
69
70 type(ESMF_cplcomp),intent(inout) :: gc
71
72 integer,intent(out) :: rc_reg
73
74
75
76
77
78 integer :: rc=ESMF_success
79
80
81
82
83
84 ="Set Entry Point for chem2phy coupler run"
85
86 call ESMF_CplCompSetEntryPoint(GC &
87 ,ESMF_SETRUN &
88 ,RUN &
89 ,ESMF_SINGLEPHASE &
90 ,rc)
91
92 CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG)
93
94
95
96
97
98
99 IF(RC_REG==ESMF_SUCCESS)THEN
100 WRITE(0,*)'CHEM2PHY CPL SET_SERVICES SUCCEEDED'
101 ELSE
102 WRITE(0,*)'CHEM2PHY CPL SET_SERVICES FAILED RC_REG=',RC_REG
103 ENDIF
104
105
106
107
108
109 end subroutine setservices
110
111
112
113
114
115
116 subroutine run(GC, CHEM_EXP_STATE, PHY_EXP_STATE, CLOCK, RC_CPL)
117
118
119
120
121
122
123
124
125
126 implicit none
127
128
129
130
131
132 type(ESMF_cplcomp),intent(inout) :: GC
133 type(ESMF_state), intent(inout) :: CHEM_EXP_STATE
134 type(ESMF_state), intent(inout) :: PHY_EXP_STATE
135 type(ESMF_clock), intent(in) :: CLOCK
136
137 integer, intent(out) :: RC_CPL
138
139
140
141
142
143 integer :: rc=ESMF_success
144 integer :: item_count_phys, item_count_chem
145 character(20) :: item_name(200)
146 logical, save :: first = .true.
147
148
149 real (ESMF_KIND_R8), pointer, dimension(:,:,:) :: &
150 p_du001, p_du002, p_du003, p_du004, p_du005, &
151 , p_ss002, p_ss003, p_ss004, p_ss005, &
152 , p_so4, p_so2, p_dms, &
153 , p_ocphilic, p_bcphobic, p_bcphilic
154
155
156 real (ESMF_KIND_R8), pointer, dimension(:,:,:) :: &
157 c_du001, c_du002, c_du003, c_du004, c_du005, &
158 , c_ss002, c_ss003, c_ss004, c_ss005, &
159 , c_so4, c_so2, c_dms, &
160 , c_ocphilic, c_bcphobic, c_bcphilic
161
162
163
164
165
166 real(ESMF_KIND_R8), pointer, dimension(:,:) :: p_diag
167
168
169 real(ESMF_KIND_R8), pointer, dimension(:,:) :: c_diag
170
171 logical :: get_attribute
172 integer :: i, j, k, kcount
173 character*10 :: aerosol_list(5), aerosol, tag, vname
174 character*10 :: BundleName, FieldName
175 TYPE(ESMF_FieldBundle) :: Bundle
176 character*10, dimension(30) :: name_lst
177 real, save :: deltim
178 integer,save :: nfld_du, nfld_ss, nfld_su, &
179 nfld_oc, nfld_bc
180 character*10, allocatable, save :: name_du(:), name_ss(:), &
181 name_oc(:), name_bc(:), name_su(:)
182
183 data aerosol_list / 'du', 'su', 'ss', 'oc', 'bc'/
184
185
186
187
188
189
190 IF ( first ) THEN
191
192
193
194 print *, 'CKS=>CHEM2PHY_RUN: im, jm, km=', im, jm, km
195 print *, 'CKS=>CHEM2PHY_RUN: ntrac =', ntrac
196 print *, 'CKS=>CHEM2PHY_RUN: doing_DU =', run_DU
197 print *, 'CKS=>CHEM2PHY_RUN: doing_SU =', run_SU
198 print *, 'CKS=>CHEM2PHY_RUN: doing_SS =', run_SS
199 print *, 'CKS=>CHEM2PHY_RUN: doing_OC =', run_OC
200 print *, 'CKS=>CHEM2PHY_RUN: doing_BC =', run_BC
201 print *, 'CKS=>CHEM2PHY_RUN: lonr =', lonr
202 print *, 'CKS=>CHEM2PHY_RUN: lats_node_r =', lats_node_r
203 print *, 'CKS=>CHEM2PHY_RUN: lats_node_r_max =', lats_node_r_max
204 print *, 'CKS=>CHEM2PHY_RUN: lonsperlar_r =', lonsperlar_r(:)
205
206
207
208
209 (:) = 'xxxxx'
210 kcount = 0
211
212 MESSAGE_CHECK="CHEM2PHY_RUN: get deltim from phy_exp"
213 CALL ESMF_AttributeGet(PHY_EXP_STATE, name = 'deltim', &
214 value = deltim , rc=RC)
215 CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
216
217 lab_setup: DO k = 1, 5
218 aerosol = aerosol_list(k)
219
220 get_attribute = .False.
221 if (aerosol=='du' .and. run_DU ) get_attribute = .True.
222 if (aerosol=='su' .and. run_SU ) get_attribute = .True.
223 if (aerosol=='ss' .and. run_SS ) get_attribute = .True.
224 if (aerosol=='oc' .and. run_OC ) get_attribute = .True.
225 if (aerosol=='bc' .and. run_BC ) get_attribute = .True.
226
227 lab_get_attribute: IF ( get_attribute ) then
228 FieldName = trim(aerosol)//'_nfld'
229 MESSAGE_CHECK="CHEM2PHY_RUN: get attribute from phy_exp"
230 CALL ESMF_AttributeGet(PHY_EXP_STATE, name = FieldName, &
231 value = kcount , rc=RC)
232 CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
233
234 IF ( kcount > 0 ) then
235
236 MESSAGE_CHECK="CHEM2PHY_RUN: get bundle from phy_exp"
237 BundleName='dg'//trim(aerosol)
238 CALL ESMF_StateGet(PHY_EXP_STATE, BundleName, &
239 Bundle, rc=RC)
240 CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
241
242 do i = 1, kcount
243 write(tag, '(i2.2)') i
244 FieldName = trim(BundleName)//'_'//trim(tag)
245 MESSAGE_CHECK="CHEM2PHY_RUN: get attribute from bundle"
246 CALL ESMF_AttributeGet(Bundle, name=FieldName, &
247 value=vname, rc=RC)
248 CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
249 name_lst(i) = trim(vname)
250 enddo
251 ENDIF
252
253 select case ( aerosol )
254 case ( 'du' )
255 nfld_du = kcount
256 allocate(name_du(kcount) )
257 name_du(1:kcount) = name_lst(1:kcount)
258 case ( 'ss' )
259 nfld_ss = kcount
260 allocate(name_ss(kcount) )
261 name_ss(1:kcount) = name_lst(1:kcount)
262 case ( 'su' )
263 nfld_su = kcount
264 allocate(name_su(kcount) )
265 name_su(1:kcount) = name_lst(1:kcount)
266 case ( 'oc' )
267 nfld_oc = kcount
268 allocate(name_oc(kcount) )
269 name_oc(1:kcount) = name_lst(1:kcount)
270 case ( 'bc' )
271 nfld_bc = kcount
272 allocate(name_bc(kcount) )
273 name_bc(1:kcount) = name_lst(1:kcount)
274 end select
275 ENDIF lab_get_attribute
276
277 ENDDO lab_setup
278
279
280 = .false.
281
282 ENDIF
283
284
285
286
287
288 ="CHEM2PHY_RUN: Get ItemCount from phy export state"
289 call ESMF_StateGet(PHY_EXP_STATE &
290 ,itemcount = item_count_phys &
291 ,itemnamelist = item_name &
292 ,rc =rc)
293 CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
294
295 IF ( RC == ESMF_SUCCESS ) THEN
296
297 if (item_count_phys == 0 ) then
298
299 print *, 'CHEM2PHY_RUN: Empty phy export state; Fortran array not filled'
300
301 else
302
303 if ( run_DU ) then
304 call GetPointer_tracer_(PHY_EXP_STATE,'du001', p_du001, rc)
305 call GetPointer_tracer_(PHY_EXP_STATE,'du002', p_du002, rc)
306 call GetPointer_tracer_(PHY_EXP_STATE,'du003', p_du003, rc)
307 call GetPointer_tracer_(PHY_EXP_STATE,'du004', p_du004, rc)
308 call GetPointer_tracer_(PHY_EXP_STATE,'du005', p_du005, rc)
309 endif
310
311 if ( run_SS ) then
312 call GetPointer_tracer_(PHY_EXP_STATE,'ss001', p_ss001, rc)
313 call GetPointer_tracer_(PHY_EXP_STATE,'ss002', p_ss002, rc)
314 call GetPointer_tracer_(PHY_EXP_STATE,'ss003', p_ss003, rc)
315 call GetPointer_tracer_(PHY_EXP_STATE,'ss004', p_ss004, rc)
316 call GetPointer_tracer_(PHY_EXP_STATE,'ss005', p_ss005, rc)
317 endif
318
319 if ( run_SU ) then
320 call GetPointer_tracer_(PHY_EXP_STATE,'MSA', p_msa, rc)
321 call GetPointer_tracer_(PHY_EXP_STATE,'SO4', p_so4, rc)
322 call GetPointer_tracer_(PHY_EXP_STATE,'SO2', p_so2, rc)
323 call GetPointer_tracer_(PHY_EXP_STATE,'DMS', p_dms, rc)
324 endif
325
326 if ( run_OC ) then
327 call GetPointer_tracer_(PHY_EXP_STATE,'OCphobic', p_ocphobic, rc)
328 call GetPointer_tracer_(PHY_EXP_STATE,'OCphilic', p_ocphilic, rc)
329 endif
330
331 if ( run_BC ) then
332 call GetPointer_tracer_(PHY_EXP_STATE,'BCphobic', p_bcphobic, rc)
333 call GetPointer_tracer_(PHY_EXP_STATE,'BCphilic', p_bcphilic, rc)
334 endif
335
336 endif
337
338 ELSE
339
340 print *, 'CHEM2PHY_RUN: phy export state ItemCount failed,', RC
341
342 ENDIF
343
344
345
346
347
348 ="CHEM2PHY_RUN: Get ItemCount from chem export state"
349 call ESMF_StateGet(CHEM_EXP_STATE &
350 ,itemcount = item_count_chem &
351 ,itemnamelist = item_name &
352 ,rc =rc)
353 CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
354
355 IF ( RC == ESMF_SUCCESS ) THEN
356
357 if (item_count_chem == 0 ) then
358
359 print *, 'CHEM2PHY_RUN: Empty chem export state; Fortran array not filled'
360
361 else
362
363 if ( run_DU ) then
364 call GetPointer_tracer_(CHEM_EXP_STATE,'du001', c_du001, rc)
365 call GetPointer_tracer_(CHEM_EXP_STATE,'du002', c_du002, rc)
366 call GetPointer_tracer_(CHEM_EXP_STATE,'du003', c_du003, rc)
367 call GetPointer_tracer_(CHEM_EXP_STATE,'du004', c_du004, rc)
368 call GetPointer_tracer_(CHEM_EXP_STATE,'du005', c_du005, rc)
369 endif
370
371 if ( run_SS ) then
372 call GetPointer_tracer_(CHEM_EXP_STATE,'ss001', c_ss001, rc)
373 call GetPointer_tracer_(CHEM_EXP_STATE,'ss002', c_ss002, rc)
374 call GetPointer_tracer_(CHEM_EXP_STATE,'ss003', c_ss003, rc)
375 call GetPointer_tracer_(CHEM_EXP_STATE,'ss004', c_ss004, rc)
376 call GetPointer_tracer_(CHEM_EXP_STATE,'ss005', c_ss005, rc)
377 endif
378
379 if ( run_SU ) then
380 call GetPointer_tracer_(CHEM_EXP_STATE,'MSA', c_msa, rc)
381 call GetPointer_tracer_(CHEM_EXP_STATE,'SO4', c_so4, rc)
382 call GetPointer_tracer_(CHEM_EXP_STATE,'SO2', c_so2, rc)
383 call GetPointer_tracer_(CHEM_EXP_STATE,'DMS', c_dms, rc)
384 endif
385
386 if ( run_OC ) then
387 call GetPointer_tracer_(CHEM_EXP_STATE,'OCphobic', c_ocphobic, rc)
388 call GetPointer_tracer_(CHEM_EXP_STATE,'OCphilic', c_ocphilic, rc)
389 endif
390
391 if ( run_BC ) then
392 call GetPointer_tracer_(CHEM_EXP_STATE,'BCphobic', c_bcphobic, rc)
393 call GetPointer_tracer_(CHEM_EXP_STATE,'BCphilic', c_bcphilic, rc)
394 endif
395
396 endif
397
398 ELSE
399
400 print *, 'CHEM2PHY_RUN: chem export state ItemCount failed,', RC
401
402 ENDIF
403
404
405
406
407
408
409 IF ( RC_CPL == ESMF_SUCCESS ) THEN
410
411 if (item_count_chem==0 .or. item_count_phys==0) then
412
413 print *, 'CHEM2PHY_RUN: Empty state; Coupling phy_exp with chem_exp skipped'
414
415 else
416
417
418
419
420 if ( run_DU ) then
421 p_du001(:,:,1:km) = c_du001(:,:,km:1:-1)
422 p_du002(:,:,1:km) = c_du002(:,:,km:1:-1)
423 p_du003(:,:,1:km) = c_du003(:,:,km:1:-1)
424 p_du004(:,:,1:km) = c_du004(:,:,km:1:-1)
425 p_du005(:,:,1:km) = c_du005(:,:,km:1:-1)
426 endif
427
428 if ( run_SS ) then
429 p_ss001(:,:,1:km) = c_ss001(:,:,km:1:-1)
430 p_ss002(:,:,1:km) = c_ss002(:,:,km:1:-1)
431 p_ss003(:,:,1:km) = c_ss003(:,:,km:1:-1)
432 p_ss004(:,:,1:km) = c_ss004(:,:,km:1:-1)
433 p_ss005(:,:,1:km) = c_ss005(:,:,km:1:-1)
434 endif
435
436 if ( run_BC ) then
437 p_bcphilic(:,:,1:km) = c_bcphilic(:,:,km:1:-1)
438 p_bcphobic(:,:,1:km) = c_bcphobic(:,:,km:1:-1)
439 endif
440
441 if ( run_OC ) then
442 p_ocphilic(:,:,1:km) = c_ocphilic(:,:,km:1:-1)
443 p_ocphobic(:,:,1:km) = c_ocphobic(:,:,km:1:-1)
444 endif
445
446 if ( run_SU ) then
447 p_msa(:,:,1:km) = c_msa(:,:,km:1:-1)
448 p_so2(:,:,1:km) = c_so2(:,:,km:1:-1)
449 p_so4(:,:,1:km) = c_so4(:,:,km:1:-1)
450 p_dms(:,:,1:km) = c_dms(:,:,km:1:-1)
451 endif
452
453 endif
454
455 ELSE
456
457 print *, 'CHEM2PHY_RUN: Coupling phy_exp with chem_exp skipped'
458
459 ENDIF
460
461
462
463
464 lab_copy: DO k = 1, 5
465 aerosol = aerosol_list(k)
466
467 get_attribute = .False.
468 if (aerosol=='du' .and. run_DU ) get_attribute = .True.
469 if (aerosol=='su' .and. run_SU ) get_attribute = .True.
470 if (aerosol=='ss' .and. run_SS ) get_attribute = .True.
471 if (aerosol=='oc' .and. run_OC ) get_attribute = .True.
472 if (aerosol=='bc' .and. run_BC ) get_attribute = .True.
473
474 lab_get_attribute2: IF ( get_attribute ) then
475
476 select case ( aerosol )
477 case ( 'du' )
478 kcount = nfld_du
479 name_lst(1:kcount) = name_du(1:kcount)
480 case ( 'ss' )
481 kcount = nfld_ss
482 name_lst(1:kcount) = name_ss(1:kcount)
483 case ( 'su' )
484 kcount = nfld_su
485 name_lst(1:kcount) = name_su(1:kcount)
486 case ( 'oc' )
487 kcount = nfld_oc
488 name_lst(1:kcount) = name_oc(1:kcount)
489 case ( 'bc' )
490 kcount = nfld_bc
491 name_lst(1:kcount) = name_bc(1:kcount)
492 end select
493
494 BundleName='dg'//trim(aerosol)
495 do i = 1, kcount
496
497 vname = name_lst(i)
498 nullify(p_diag)
499 MESSAGE_CHECK = "Chem2Phys CPL_RUN: Get Farray from Phy_Exp-"//vname
500 call GetPointer_diag_(PHY_EXP_STATE, BundleName, vname, p_diag, rc)
501 CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
502
503 nullify(c_diag)
504 MESSAGE_CHECK = "Chem2Phys CPL_RUN: Get Farray from Chem_Exp-"//vname
505 call GetPointer_diag_(CHEM_EXP_STATE, 'xxxx', vname, c_diag, rc)
506 CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
507
508
509 (:,:) = p_diag(:,:) + c_diag(:,:)*deltim
510 enddo
511
512 ENDIF lab_get_attribute2
513 ENDDO lab_copy
514
515
516
517
518
519
520 IF(RC_CPL==ESMF_SUCCESS)THEN
521 WRITE(0,*)'CHEM2PHY CPL RUN SUCCEEDED'
522 ELSE
523 WRITE(0,*)'CHEM2PHY CPL RUN FAILED RC_CPL=',RC_CPL
524 ENDIF
525
526 END subroutine run
527
528 END module atmos_chem_phy_cpl_comp_mod
529