File: C:\NOAA\NEMS_11731\src\atmos\gfs\libutil\atmos_phy_chem_cpl_comp_mod.F90

1     !
2           module atmos_phy_chem_cpl_comp_mod
3     
4     !-----------------------------------------------------------------------
5     !
6     !** This module holds the phy-to-chem coupler's register and run routines
7     !** -> setservices (registers init and run) is called by GOCART_SETUP
8     !** -> init associates tracer bundle in phy export state with iAERO bundle 
9     !**    in chem import state;
10     !** -> run transfers/converts data from phy export state to chem import state
11     !
12     !! Code Revision:
13     !! 11Nov 2009     Sarah Lu, First Crack
14     !! 18Nov 2009     Sarah Lu, Revise coupler run to do data copy
15     !! 29Dec 2009     Sarah Lu, Comments added for clarification
16     !! 01Feb 2010     Sarah Lu, Extend to include all 2d/3d fields needed by
17     !!                          GOCART
18     !! 07Feb 2010     Sarah Lu, Add getrh subroutine
19     !! 11Feb 2010     Sarah Lu, Add get_attribute subroutine to retrieve tracer
20     !!                          specification 
21     !! 12Feb 2010     Sarah Lu, Include chemical tracers
22     !! 06Mar 2010     Sarah Lu, Flip vertical profile index from bottom-up to
23     !!                          top-down; add Init routine
24     !! 12Mar 2010     Sarah Lu, Clean up phy2chem run
25     !! 13Mar 2010     Sarah Lu, Use m_chars: set statename to lower case
26     !! 16Mar 2010     Sarah Lu, Add FillDefault_ and patch_; Make dimension and
27     !!                          tracer specification public (to chem2phy coupler)
28     !! 23Mar 2010     Sarah Lu, Call rtc to track run-time-clock; debug print optional
29     !! 09Apr 2010     Sarah Lu, Clean up the code
30     !! 09May 2010     Sarah Lu, Revise species name for SU, OC, and BC
31     !! 13May 2010     Sarah Lu, Change GetPointer_3D_ from private to public
32     !! 09Jun 2010     Sarah Lu, Remove ref to m_chars/lowercase; add g_fixchar
33     !! 10Jun 2010     Sarah Lu, Remove aerosol tarcer pointer for iAERO
34     !! 30Jun 2010     Sarah Lu, Revise g_fixchar to allow longer char string
35     !! 04Aug 2010     Sarah Lu, run_DU[SU,SS,OC,BC] are determined from chemReg
36     !! 09Sep 2010     Sarah Lu, wet1 is exported from phys, no longer calculated
37     !!                          in the phy-to-chem coupler; correct how cn_prcp
38     !!                          and ncn_prcp are computed
39     !! 10Oct 2010     Sarah Lu, pass g2d_fld%met from chem_imp to phys_exp
40     !! 15Oct 2010     Sarah Lu, pass fscav from chem_imp to phys_exp
41     !! 16Oct 2010     Sarah Lu, change g2d_fld%met from instant to accumulated 
42     !! 08Nov 2010     Sarah Lu, set zle floor values to hs; aer_diag fields
43     !!                          are modified
44     !! 14Nov 2010     Sarah Lu, pass deltim from phy_exp to chem_imp in init
45     !! 29Dec 2010     Sarah Lu, Fields not used by GOCART are removed from diag
46     !-----------------------------------------------------------------------
47     
48           use ESMF_MOD
49     
50           USE MODULE_ERR_MSG, ONLY: ERR_MSG, MESSAGE_CHECK
51           use MODULE_gfs_machine,  ONLY: kind_phys
52           use MODULE_gfs_physcons, ONLY: con_rd,  con_fvirt, con_g, &
53                                          con_eps, con_epsm1
54           use MODULE_gfs_tropp,    ONLY: tpause
55           use MODULE_gfs_funcphys
56     
57           USE Chem_RegistryMod
58     
59     !-----------------------------------------------------------------------
60     !
61           implicit none
62           SAVE
63     !
64     !-----------------------------------------------------------------------
65     !
66     !     Gaussian grid 
67           integer(ESMF_KIND_I4),allocatable,public :: lonsperlar_r(:)
68           integer, public               :: lonr, lats_node_r, lats_node_r_max
69           integer, public               :: im, jm, km
70     
71     !     Tracer specification
72           integer, public               :: ntrac
73           logical, public               :: run_DU, run_SU, run_SS, run_OC, run_BC
74           character(10), allocatable    :: spec(:)
75     
76     ! --- public interface
77           public::  SetServices, GetPointer_tracer_, CkPointer_, GetPointer_3D_, &
78                     GetPointer_diag_
79     
80           private
81           TYPE(Chem_Registry)          :: chemReg      !<-- The GOCART Chem_Registry
82           logical, parameter           :: lckprnt = .false.
83     
84           contains
85     
86     !
87     !-----------------------------------------------------------------------
88     !#######################################################################
89     !-----------------------------------------------------------------------
90     !
91           subroutine setservices(GC, RC_REG)
92     !
93     !-----------------------------------------------------------------------
94     !!
95     !! This routine register the coupler component's init and run routines    
96     !!
97     !! Code Revision:
98     !! 11Nov 2009     Sarah Lu, First Crack
99     !! 06Mar 2010     Sarah Lu, Register init routine
100     !-----------------------------------------------------------------------
101     !
102           implicit none
103     !
104     !-----------------------------------------------------------------------
105     !***  argument variables
106     !-----------------------------------------------------------------------
107     !
108           type(ESMF_cplcomp),intent(inout) :: gc         ! coupler component
109     !
110           integer,intent(out) :: rc_reg                  ! return code for register
111     !
112     !-----------------------------------------------------------------------
113     !***  local variables
114     !-----------------------------------------------------------------------
115     !
116           integer :: rc=ESMF_success                     ! the error signal variable
117     
118     !-----------------------------------------------------------------------
119     !***  register the coupler component's init routine
120     !-----------------------------------------------------------------------
121     !
122           MESSAGE_CHECK="Set Entry Point for phy2chem coupler init"
123     
124           call ESMF_CplCompSetEntryPoint(GC                        & !<-- The gridded component
125                                         ,ESMF_SETINIT              & !<-- Predefined subroutine type
126                                         ,INIT                      & !<-- User's subroutineName
127                                         ,ESMF_SINGLEPHASE          &
128                                         ,rc)
129     
130           CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG)
131     
132     !-----------------------------------------------------------------------
133     !***  register the coupler component's run routine
134     !-----------------------------------------------------------------------
135     !
136           MESSAGE_CHECK="Set Entry Point for phy2chem coupler run"
137     
138           call ESMF_CplCompSetEntryPoint(GC                        & !<-- The gridded component
139                                         ,ESMF_SETRUN               & !<-- Predefined subroutine type
140                                         ,RUN                       & !<-- User's subroutineName
141                                         ,ESMF_SINGLEPHASE          &
142                                         ,rc)
143     
144           CALL ERR_MSG(RC,MESSAGE_CHECK,RC_REG)
145     
146     !-----------------------------------------------------------------------
147     !***  Check the final error signal variable 
148     !-----------------------------------------------------------------------
149     !
150           IF(RC_REG==ESMF_SUCCESS)THEN
151             WRITE(0,*)'PHY2CHEM CPL SET_SERVICES SUCCEEDED'
152           ELSE
153             WRITE(0,*)'PHY2CHEM CPL SET_SERVICES FAILED RC_REG=',RC_REG
154           ENDIF
155     
156     !
157     !-----------------------------------------------------------------------
158     !-----------------------------------------------------------------------
159     !
160           end subroutine setservices
161     
162     !-----------------------------------------------------------------------
163     !#######################################################################
164     !-----------------------------------------------------------------------
165     !
166           subroutine init(GC, PHY_EXP_STATE, CHEM_IMP_STATE, CLOCK, RC_CPL)
167     !
168     !-----------------------------------------------------------------------
169     !!
170     !! This routine associates tracer arrays in chem import state (iAERO bundle)
171     !! to phy export state (tracers bundle)
172     !!
173     !! Code Revision:
174     !! 06Mar 2010     Sarah Lu, First Crack
175     !! 04Aug 2010     Sarah Lu, Determine run_DU[SU,SS,OC,BC] from ChemRegistry
176     !! 14Nov 2010     Sarah Lu, Pass deltim from phy_exp to chem_imp
177     !-----------------------------------------------------------------------
178     
179           implicit none
180     !
181     !-----------------------------------------------------------------------
182     !***  argument variables
183     !-----------------------------------------------------------------------
184     
185           type(ESMF_cplcomp),intent(inout) :: GC
186           type(ESMF_state),  intent(inout) :: PHY_EXP_STATE
187           type(ESMF_state),  intent(inout) :: CHEM_IMP_STATE
188           type(ESMF_clock),  intent(in)    :: CLOCK
189     !
190           integer,           intent(out)   :: RC_CPL
191     !
192     !-----------------------------------------------------------------------
193     !***  local variables
194     !-----------------------------------------------------------------------
195     
196           integer                       :: rc=ESMF_success  ! the error signal variable
197           integer                       :: IERR, N, L
198           type(ESMF_FieldBundle)        :: Bundle, iBundle
199           type(ESMF_Field)              :: Field
200           character(len=ESMF_MAXSTR)    :: vname
201           real                          :: deltim
202     !
203     !-----------------------------------------------------------------------
204     !***  Read Chem_Registry to retrive tracer name
205     !-----------------------------------------------------------------------
206     
207           print *, 'PHY2CHEM_INIT: get ChemReg '
208           chemReg = Chem_RegistryCreate ( IERR )             !<-- read Chem_Registry
209     
210     !-----------------------------------------------------------------------
211     !***  Pass tracer bundle from physics export to chemistry import
212     !-----------------------------------------------------------------------
213     
214           MESSAGE_CHECK="PHY2CHEM_INIT: get tracer bundle from phy exp"
215           call ESMF_StateGet(PHY_EXP_STATE, 'tracers', iBundle, RC=RC)
216           CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
217     
218           MESSAGE_CHECK="PHY2CHEM_INIT: get iAERO bundle from chem imp"
219           call ESMF_StateGet(CHEM_IMP_STATE, 'iAERO', Bundle, RC=RC)
220           CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
221     
222           allocate ( spec(chemReg%n_GOCART) )
223           do L = 1, chemReg%n_GOCART
224     
225              N = chemReg%i_GOCART + L - 1
226     
227              vname = chemReg%vname(N)
228              spec(L) = vname
229              MESSAGE_CHECK="PHY2CHEM_INIT: get field from tracers: "//vname
230              call ESMF_FieldBundleGet(iBundle, NAME=vname, FIELD=Field, rc = RC )
231              CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
232     
233              MESSAGE_CHECK="PHY2CHEM_INIT: add field to iAero: "//vname
234              call ESMF_FieldBundleAdd(Bundle, Field, rc=RC )
235              CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
236     
237           end do
238     !
239     !-----------------------------------------------------------------------
240     !***  Determine what module(s) to be included in the simulation
241     !-----------------------------------------------------------------------
242     
243           run_DU = chemReg%doing_DU
244           run_SU = chemReg%doing_SU
245           run_OC = chemReg%doing_OC
246           run_BC = chemReg%doing_BC
247           run_SS = chemReg%doing_SS
248     
249     !
250     !-----------------------------------------------------------------------
251     !***  Destroy Chem_Registry 
252     !-----------------------------------------------------------------------
253     
254           call Chem_RegistryDestroy ( chemReg, IERR )
255     
256     
257     !-----------------------------------------------------------------------
258     !***  Pass time-step from phy_exp to chem_imp
259     !-----------------------------------------------------------------------
260     
261           MESSAGE_CHECK="PHY2CHEM_INIT: get deltim from phy_exp"
262           CALL ESMF_AttributeGet(PHY_EXP_STATE, name = 'deltim',  &
263                                  value = deltim , rc=RC)
264           CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
265     
266           MESSAGE_CHECK="PHY2CHEM_INIT: add deltim to chem_imp"
267           CALL ESMF_AttributeSet(CHEM_IMP_STATE, name = 'deltim',  &
268                                  value = deltim , rc=RC)
269           CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
270     
271     !-----------------------------------------------------------------------
272     !***  Check the final error signal variable
273     !-----------------------------------------------------------------------
274     !
275           IF(RC_CPL==ESMF_SUCCESS)THEN
276             WRITE(0,*)'PHY2CHEM CPL INIT SUCCEEDED'
277           ELSE
278             WRITE(0,*)'PHY2CHEM CPL INIT FAILED RC_CPL=',RC_CPL
279           ENDIF
280     !
281           end subroutine init
282     
283     
284     !-----------------------------------------------------------------------
285     !#######################################################################
286     !-----------------------------------------------------------------------
287     !
288           subroutine run(GC, PHY_EXP_STATE, CHEM_IMP_STATE, CLOCK, RC_CPL)
289     !
290     !-----------------------------------------------------------------------
291     !!
292     !! This routine transfer/convert data from phy_exp state to chem_imp state
293     !!
294     !! Code Revision:
295     !! 18Nov 2009     Sarah Lu, First Crack
296     !! 29Dec 2009     Sarah Lu, Comments added for clarification
297     !! 01Feb 2010     Sarah Lu, Transfer/convert fields from phy export state 
298     !!                          to GOCART import state
299     !! 11Feb 2010     Sarah Lu, Add get_attribute
300     !! 06Mar 2010     Sarah Lu, Flip vertical profile index from bottom-up to
301     !!                          top-down
302     !! 12Mar 2010     Sarah Lu, Code clean up
303     !! 16Mar 2010     Sarah Lu, Add FillDefault_ and patch_; correct how vertical
304     !!                          index is flipped for 3D arrays
305     !! 23Mar 2010     Sarah Lu, Track run-time-clock; debug print optional
306     !! 09Api 2010     Sarah Lu, Remove some rtc tracking print
307     !-----------------------------------------------------------------------
308     !
309           implicit none
310     !
311     !-----------------------------------------------------------------------
312     !***  argument variables
313     !-----------------------------------------------------------------------
314     
315           type(ESMF_cplcomp),intent(inout) :: GC
316           type(ESMF_state),  intent(inout) :: PHY_EXP_STATE    ! coupler import state
317           type(ESMF_state),  intent(inout) :: CHEM_IMP_STATE   ! coupler export state
318           type(ESMF_clock),  intent(in)    :: CLOCK
319     !
320           integer,           intent(out)   :: RC_CPL
321     
322     !-----------------------------------------------------------------------
323     !***  local variables
324     !-----------------------------------------------------------------------
325     !
326           real, save                       :: deltim
327           real                             :: fscav
328     !
329           integer                          :: rc=ESMF_success  ! the error signal variable
330           integer                          :: i, j, k, n
331           integer                          :: item_count_phys, item_count_chem
332           character(20)                    :: item_name(100)
333           logical, save                    :: first =  .true.
334           real(ESMF_KIND_R8), pointer      :: Array(:,:,:)
335           type(ESMF_Field)                 :: Field
336     
337     !
338           integer, parameter               :: nfld_2d  = 18          
339           integer, parameter               :: nfld_3d  = 10         
340           integer, parameter               :: nfld_trc = 5           
341           character(8)                     :: vname_2d (nfld_2d)    
342           character(8)                     :: vname_3d (nfld_3d)   
343           character(8)                     :: vname_trc(nfld_trc) 
344     
345           real(kind=8) :: rtc
346           real(kind=8) :: t1, t1_i, t1_o, t2, t2_i, t2_o
347     
348     ! Fortran array for phy export state
349           real(ESMF_KIND_R8), pointer, dimension(:,:) ::                    &
350                    p_slmsk, p_hpbl,  p_wet1,  p_stype,  p_vtype, p_vfrac,   &
351                    p_rain,  p_rainc, p_dtsfci,p_tsea,   p_stc1,  p_u10m,    &
352                    p_v10m,  p_ustar, p_zorl,  p_hs,     p_ps
353     
354           real (ESMF_KIND_R8), pointer, dimension(:,:,:) ::                  &
355                    p_t, p_u, p_v, p_p, p_dp, p_fcld, p_dqdt
356     
357           real (ESMF_KIND_R8), pointer, dimension(:,:,:) ::                  &
358                    p_spfh, p_o3mr,                                           & ! met tracers
359                    p_du001, p_du002, p_du003, p_du004, p_du005,              & ! DU
360                    p_ss001, p_ss002, p_ss003, p_ss004, p_ss005,              & ! SS
361                    p_msa,   p_so4,   p_so2,   p_dms,                         & ! SU
362                    p_ocphobic, p_ocphilic, p_bcphobic, p_bcphilic              ! OC/BC
363     
364     ! Fortran array for chem import state
365           real(ESMF_KIND_R8), pointer, dimension(:,:) ::          &
366                    c_lwi,   c_zpbl, c_frlake,  c_fraci,  c_wet1, c_lai,     &
367                    c_grn,   c_cn_prcp, c_ncn_prcp, c_sh, c_ta,   c_tsoil1,  & 
368                    c_u10m,  c_v10m,  c_ustar,  c_z0h,  c_tropp, c_ps
369     
370           real (ESMF_KIND_R8), pointer, dimension(:,:,:) :: c_ple, c_zle,   &
371                    c_airdens, c_t, c_u, c_v, c_fcld, c_dqdt
372     
373           real (ESMF_KIND_R8), pointer, dimension(:,:,:) ::  c_o3, c_rh2       ! met tracers
374     !
375     !---  Add the following for 2d aerosol diag fields ---
376     !  Fortran data pointer for phy export state
377           real(ESMF_KIND_R8), pointer, dimension(:,:) ::  p_diag
378     
379     !  Fortran data pointer for chem import state
380           real(ESMF_KIND_R8), pointer, dimension(:,:) ::  c_diag
381     
382           TYPE(ESMF_FieldBundle)  :: Bundle, iBundle
383           character*10            :: tag, vname
384           character*10            :: BundleName, FieldName
385           integer                 :: kcount
386           integer, save           :: nfld_met
387           character*10, dimension(30)  :: name_lst
388           character*10,  allocatable, save  :: name_met(:)
389     !
390     ! local variables for conversion
391           real       :: ptp, utp, vtp, ttp, htp, shrtp, tv1, dz
392           real (ESMF_KIND_R8), allocatable, dimension(:), save ::           &
393                                   prsln, sh, rh, shs, rho, pi, h
394     !
395           real(kind=kind_phys), parameter :: rovg = con_rd / con_g
396           real(kind=kind_phys), parameter :: qmin = 1.0e-10
397           real(ESMF_KIND_R8),   parameter :: f_one = 1.0
398           real(ESMF_KIND_R8),   parameter :: f_zero = 0.0
399     !
400           data vname_2d /'TROPP', 'LWI', 'ZPBL', 'FRLAKE',     &       
401                          'FRACI', 'WET1', 'LAI', 'GRN', 'TA',  &     
402                          'CN_PRCP', 'NCN_PRCP', 'PS', 'SH',    &    
403                          'TSOIL1', 'U10M',  'V10M','USTAR','Z0H'/ 
404     
405           data vname_3d /'PLE', 'ZLE' , 'AIRDENS', 'FCLD', 'DQDT', &   
406                          'T', 'U', 'V', 'O3', 'RH2'  /               
407     
408           data vname_trc/'du001', 'du002',                         & 
409                          'du003', 'du004', 'du005' /            
410     
411     !---------------------------------------------
412     !* Determine dimension/tracer and allocate local arrays
413     !---------------------------------------------
414     !
415           IF ( FIRST ) THEN
416     !
417     !  --- Retrieve attributes (lat/lon and tracer specification) 
418             MESSAGE_CHECK = 'PHY2CHEM_RUN: Retrive phy_exp attributes'
419             call get_attribute(PHY_EXP_STATE, RC)
420             CALL ERR_MSG(RC, MESSAGE_CHECK, RC_CPL)
421     !
422             MESSAGE_CHECK = 'PHY2CHEM_RUN: Retrive field t from phy export'
423             call ESMF_StateGet(PHY_EXP_STATE , 't', Field, rc=RC)
424             CALL ERR_MSG(RC, MESSAGE_CHECK, RC_CPL)
425     !
426             nullify(Array)
427             MESSAGE_CHECK = 'PHY2CHEM_RUN: Get Fortran data pointer from t'
428             CALL ESMF_FieldGet(field=Field, localDe=0, farray=Array, rc = RC)
429             CALL ERR_MSG(RC, MESSAGE_CHECK, RC_CPL)
430     
431     !       Determine dimension in x-, y-, and z-direction
432             im = size(Array, dim=1)
433             jm = size(Array, dim=2)
434             km = size(Array, dim=3)
435     
436     !  --- Retrieve deltim
437             MESSAGE_CHECK="PHY2CHEM_RUN: get deltim from phy_exp"
438             CALL ESMF_AttributeGet(PHY_EXP_STATE, name = 'deltim',  &
439                                    value = deltim , rc=RC)
440             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
441     
442     
443     !  ---  allocate arrays at mid layers
444             allocate (                               &
445                          sh   (km),                  &
446                          rh   (km),                  &
447                          rho  (km),                  &
448                          shs  (km)                   &
449                         ) 
450     !  ---  allocate arrays at interfaces
451             allocate (                               &
452                          prsln(0:km),                &
453                          pi   (0:km),                &
454                          h    (0:km)                 &
455                         )
456     !
457     !  ---  Compute all physics function tables
458     !
459             print *, 'PHY2CHEM_RUN: Compute all physics function tables'
460             call gfuncphys      
461     
462     !
463     !  ---  Retrive g2d_fld%met from the bundle attribute
464     !
465             FieldName = 'met_nfld'
466             MESSAGE_CHECK="PHY2CHEM_RUN: get attribute from phy_exp"
467             CALL ESMF_AttributeGet(PHY_EXP_STATE, name = FieldName,  &
468                                    value = kcount , rc=RC)
469             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
470     
471             if ( kcount > 0 ) then
472     
473               MESSAGE_CHECK="PHY2CHEM_RUN: get bundle from phy_exp"
474               BundleName='dgmet'
475               CALL ESMF_StateGet(PHY_EXP_STATE, BundleName, &
476                                  Bundle, rc=RC)
477               CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
478     
479               do i = 1, kcount
480                 write(tag, '(i2.2)') i
481                 FieldName = trim(BundleName)//'_'//trim(tag)
482                 MESSAGE_CHECK="PHY2CHEM_RUN: get attribute from bundle"
483                 CALL ESMF_AttributeGet(Bundle, name=FieldName,   &
484                                        value=vname, rc=RC)
485                 CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
486                 name_lst(i) = trim(vname)
487               enddo
488     
489               nfld_met = kcount
490               allocate(name_met(kcount) )
491               name_met(1:kcount) = name_lst(1:kcount)
492     
493             endif
494     
495     !
496     !  ---  Retrive fscav from the chem_imp and pass to phys_exp
497     !
498             MESSAGE_CHECK="PHY2CHEM_RUN: get iBundle from chem_imp"
499             CALL ESMF_StateGet(CHEM_IMP_STATE, 'iAERO', &
500                                iBundle, rc=RC)
501             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
502     
503             MESSAGE_CHECK="PHY2CHEM_RUN: get Bundle from phy_exp"
504             CALL ESMF_StateGet(PHY_EXP_STATE, 'tracers', &
505                                Bundle, rc=RC)
506             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
507     
508             do I = 1, chemReg%n_GOCART
509     
510              N = chemReg%i_GOCART + I - 1
511     
512              vname = spec(N)
513              MESSAGE_CHECK="PHY2CHEM_RUN: Get Field : "//vname
514              call ESMF_FieldBundleGet(iBundle, NAME=vname, FIELD=Field, rc = RC )
515              CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
516     
517              MESSAGE_CHECK="PHY2CHEM_RUN: Get Attribute "
518              CALL ESMF_AttributeGet(Field, NAME="ScavengingFractionPerKm", &
519                                     value = fscav , rc=RC)
520              CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
521     
522              MESSAGE_CHECK="PHY2CHEM_RUN: Get Field : "//vname
523              call ESMF_FieldBundleGet(Bundle, NAME=vname, FIELD=Field, rc = RC )
524              CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
525     
526              MESSAGE_CHECK="PHY2CHEM_RUN: Add Attribute "
527              CALL ESMF_AttributeSet(Field, NAME="ScavengingFractionPerKm", &
528                                     value = fscav , rc=RC)
529              CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
530     
531             enddo
532     
533     
534     ! ---   Debug print (optional)
535             if ( lckprnt ) then
536             print *, 'PHY2CHEM_RUN: im, jm, km=', im, jm, km
537             print *, 'PHY2CHEM_RUN: ntrac    =', ntrac
538     	print *, 'PHY2CHEM_RUN: lonr            =', lonr
539     	print *, 'PHY2CHEM_RUN: lats_node_r     =', lats_node_r
540     	print *, 'PHY2CHEM_RUN: lats_node_r_max =', lats_node_r_max
541     	print *, 'PHY2CHEM_RUN: lonsperlar_r =', lonsperlar_r(:)
542             endif
543     
544           ENDIF
545     !
546     !---------------------------------------------
547     !* Get Fortran array from phy export state
548     !---------------------------------------------
549     
550           t1_i=rtc()
551           MESSAGE_CHECK="PHY2CHEM_RUN: Get ItemCount from phy export state"
552           call ESMF_StateGet(PHY_EXP_STATE                    &
553                             ,itemcount = item_count_phys      &
554                             ,itemnamelist = item_name         &
555                             ,rc   =rc)
556           CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
557     
558           IF ( RC == ESMF_SUCCESS ) THEN
559     
560           if (item_count_phys == 0 ) then
561     
562            print *, 'PHY2CHEM_RUN: Empty phy export state; Fortran array not filled'
563     
564           else
565     
566            call GetPointer_(PHY_EXP_STATE, 'slmsk', p_slmsk, rc)
567            call GetPointer_(PHY_EXP_STATE, 'hpbl',  p_hpbl , rc)
568            call GetPointer_(PHY_EXP_STATE, 'wet1',  p_wet1 , rc)
569            call GetPointer_(PHY_EXP_STATE, 'stype', p_stype, rc)
570            call GetPointer_(PHY_EXP_STATE, 'vtype', p_vtype, rc)
571            call GetPointer_(PHY_EXP_STATE, 'vfrac', p_vfrac, rc)
572            call GetPointer_(PHY_EXP_STATE, 'rain',  p_rain , rc)
573            call GetPointer_(PHY_EXP_STATE, 'rainc', p_rainc, rc)
574            call GetPointer_(PHY_EXP_STATE, 'dtsfci',p_dtsfci,rc)
575            call GetPointer_(PHY_EXP_STATE, 'tsea',  p_tsea , rc)
576            call GetPointer_(PHY_EXP_STATE, 'stc1',  p_stc1 , rc)
577            call GetPointer_(PHY_EXP_STATE, 'u10m',  p_u10m , rc)
578            call GetPointer_(PHY_EXP_STATE, 'v10m',  p_v10m , rc)
579            call GetPointer_(PHY_EXP_STATE, 'ustar', p_ustar, rc)
580            call GetPointer_(PHY_EXP_STATE, 'zorl',  p_zorl , rc)
581            call GetPointer_(PHY_EXP_STATE, 'hs'  ,  p_hs   , rc)
582            call GetPointer_(PHY_EXP_STATE, 'ps'  ,  p_ps   , rc)
583     
584     ! for GFS, vertical index is from surface to toa
585            call GetPointer_3D_(PHY_EXP_STATE, 't' ,  p_t   , rc)
586            call GetPointer_3D_(PHY_EXP_STATE, 'u' ,  p_u   , rc)
587            call GetPointer_3D_(PHY_EXP_STATE, 'v' ,  p_v   , rc)
588            call GetPointer_3D_(PHY_EXP_STATE, 'p' ,  p_p   , rc)
589            call GetPointer_3D_(PHY_EXP_STATE, 'dp',  p_dp  , rc)
590            call GetPointer_3D_(PHY_EXP_STATE, 'fcld',p_fcld , rc)
591            call GetPointer_3D_(PHY_EXP_STATE, 'dqdt',p_dqdt , rc)
592     
593     ! get met + chem tracers
594            call GetPointer_tracer_(PHY_EXP_STATE,'spfh', p_spfh, rc)
595            call GetPointer_tracer_(PHY_EXP_STATE,'o3mr', p_o3mr, rc)
596     
597            if ( run_DU ) then
598             call GetPointer_tracer_(PHY_EXP_STATE,'du001', p_du001, rc)
599             call GetPointer_tracer_(PHY_EXP_STATE,'du002', p_du002, rc)
600             call GetPointer_tracer_(PHY_EXP_STATE,'du003', p_du003, rc)
601             call GetPointer_tracer_(PHY_EXP_STATE,'du004', p_du004, rc)
602             call GetPointer_tracer_(PHY_EXP_STATE,'du005', p_du005, rc)
603            endif 
604     
605            if ( run_SS ) then
606             call GetPointer_tracer_(PHY_EXP_STATE,'ss001', p_ss001, rc)
607             call GetPointer_tracer_(PHY_EXP_STATE,'ss002', p_ss002, rc)
608             call GetPointer_tracer_(PHY_EXP_STATE,'ss003', p_ss003, rc)
609             call GetPointer_tracer_(PHY_EXP_STATE,'ss004', p_ss004, rc)
610             call GetPointer_tracer_(PHY_EXP_STATE,'ss005', p_ss005, rc)
611            endif
612     
613            if ( run_SU ) then
614             call GetPointer_tracer_(PHY_EXP_STATE,'MSA', p_msa, rc)
615             call GetPointer_tracer_(PHY_EXP_STATE,'SO4', p_so4, rc)
616             call GetPointer_tracer_(PHY_EXP_STATE,'SO2', p_so2, rc)
617             call GetPointer_tracer_(PHY_EXP_STATE,'DMS', p_dms, rc)
618            endif
619     
620            if ( run_OC ) then
621             call GetPointer_tracer_(PHY_EXP_STATE,'OCphobic', p_ocphobic, rc)
622             call GetPointer_tracer_(PHY_EXP_STATE,'OCphilic', p_ocphilic, rc)
623            endif
624     
625            if ( run_BC ) then
626             call GetPointer_tracer_(PHY_EXP_STATE,'BCphobic', p_bcphobic, rc)
627             call GetPointer_tracer_(PHY_EXP_STATE,'BCphilic', p_bcphilic, rc)
628            endif
629     
630           endif
631     
632           ELSE
633     
634            print *, 'PHY2CHEM_RUN: phy export state ItemCount failed,', RC
635     
636           ENDIF
637     
638     !---------------------------------------------
639     !* Get Fortran array from gocart import state
640     !---------------------------------------------
641     
642           MESSAGE_CHECK="PHY2CHEM_RUN: Get ItemCount from chem import state"
643           call ESMF_StateGet(CHEM_IMP_STATE                   &
644                             ,itemcount = item_count_chem      &
645                             ,itemnamelist = item_name         &
646                             ,rc= RC)
647           CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
648     
649           IF ( RC == ESMF_SUCCESS ) THEN
650     
651           if (item_count_chem == 0 ) then
652     
653            print *, 'PHY2CHEM_RUN: Empty chem import state; Fortran array not filled'
654     
655           else
656     
657            call GetPointer_(CHEM_IMP_STATE, 'LWI'   ,c_lwi  , rc)
658            call GetPointer_(CHEM_IMP_STATE, 'ZPBL'  ,c_zpbl , rc)
659            call GetPointer_(CHEM_IMP_STATE, 'FRLAKE',c_frlake,rc)
660            call GetPointer_(CHEM_IMP_STATE, 'FRACI' ,c_fraci, rc)
661            call GetPointer_(CHEM_IMP_STATE, 'WET1'  ,c_wet1 , rc)
662            call GetPointer_(CHEM_IMP_STATE, 'LAI'   ,c_lai  , rc)
663            call GetPointer_(CHEM_IMP_STATE, 'GRN'   ,c_grn  , rc)
664            call GetPointer_(CHEM_IMP_STATE, 'CN_PRCP',c_cn_prcp,rc)
665            call GetPointer_(CHEM_IMP_STATE, 'NCN_PRCP',c_ncn_prcp,rc)
666            call GetPointer_(CHEM_IMP_STATE, 'SH'    ,c_sh   , rc)
667            call GetPointer_(CHEM_IMP_STATE, 'TA'    ,c_ta   , rc)
668            call GetPointer_(CHEM_IMP_STATE, 'TSOIL1',c_tsoil1,rc)
669            call GetPointer_(CHEM_IMP_STATE, 'U10M'  ,c_u10m , rc)
670            call GetPointer_(CHEM_IMP_STATE, 'V10M'  ,c_v10m , rc)
671            call GetPointer_(CHEM_IMP_STATE, 'USTAR' ,c_ustar, rc)
672            call GetPointer_(CHEM_IMP_STATE, 'Z0H'   ,c_z0h  , rc)
673            call GetPointer_(CHEM_IMP_STATE, 'TROPP' ,c_tropp, rc)
674            call GetPointer_(CHEM_IMP_STATE, 'PS'    ,c_ps   , rc)
675     
676     ! for GOCART, vertical index is fom toa to surface
677            call GetPointer_3D_(CHEM_IMP_STATE,'PLE', c_ple , rc)
678            call GetPointer_3D_(CHEM_IMP_STATE,'ZLE', c_zle , rc)
679            call GetPointer_3D_(CHEM_IMP_STATE,'AIRDENS',  c_airdens, rc)
680            call GetPointer_3D_(CHEM_IMP_STATE,'T'  , c_t   , rc)
681            call GetPointer_3D_(CHEM_IMP_STATE,'U'  , c_u   , rc)
682            call GetPointer_3D_(CHEM_IMP_STATE,'V'  , c_v   , rc)
683            call GetPointer_3D_(CHEM_IMP_STATE,'FCLD', c_fcld , rc)
684            call GetPointer_3D_(CHEM_IMP_STATE,'DQDT', c_dqdt , rc)
685     
686     ! get met tracers
687            call GetPointer_3D_(CHEM_IMP_STATE,'O3' , c_o3  , rc)
688            call GetPointer_3D_(CHEM_IMP_STATE,'RH2' , c_rh2 , rc)
689     
690     ! chem tracers already pointed to phy export state (tracer bundle)
691     
692           endif
693     
694           ELSE
695     
696            print *, 'PHY2CHEM_RUN: chem import state ItemCount failed,', RC
697     
698           ENDIF
699     
700           t1_o=rtc()
701           t1 = t1_o - t1_i
702     
703     !
704     !---------------------------------------------
705     !* Do the actual coupling 
706     !---------------------------------------------
707     ! 
708           t2_i=rtc()
709           IF ( RC_CPL == ESMF_SUCCESS ) THEN
710     
711            if (item_count_chem==0 .or. item_count_phys==0) then
712     
713             print *, 'PHY2CHEM_RUN: Empty state; Coupling phy_exp with chem_imp skipped'
714     
715            else
716     
717     
718     ! --- fill in default values
719     !      call FillDefault_
720     
721     !
722     ! --- Aerosol tracer fields: flip from bottom-up to top-down
723     !
724            if ( run_DU ) then
725               p_du001(:,:,1:km) = p_du001(:,:,km:1:-1) 
726               p_du002(:,:,1:km) = p_du002(:,:,km:1:-1) 
727               p_du003(:,:,1:km) = p_du003(:,:,km:1:-1) 
728               p_du004(:,:,1:km) = p_du004(:,:,km:1:-1) 
729               p_du005(:,:,1:km) = p_du005(:,:,km:1:-1) 
730            endif
731     
732            if ( run_SS ) then
733               p_ss001(:,:,1:km) = p_ss001(:,:,km:1:-1) 
734               p_ss002(:,:,1:km) = p_ss002(:,:,km:1:-1) 
735               p_ss003(:,:,1:km) = p_ss003(:,:,km:1:-1) 
736               p_ss004(:,:,1:km) = p_ss004(:,:,km:1:-1) 
737               p_ss005(:,:,1:km) = p_ss005(:,:,km:1:-1) 
738            endif
739     
740            if ( run_OC ) then
741               p_ocphobic(:,:,1:km) = p_ocphobic(:,:,km:1:-1) 
742               p_ocphilic(:,:,1:km) = p_ocphilic(:,:,km:1:-1) 
743            endif
744     
745            if ( run_BC ) then
746               p_bcphobic(:,:,1:km) = p_bcphobic(:,:,km:1:-1) 
747               p_bcphilic(:,:,1:km) = p_bcphilic(:,:,km:1:-1) 
748            endif
749     
750            if ( run_SU ) then
751               p_msa (:,:,1:km) = p_msa (:,:,km:1:-1) 
752               p_so2 (:,:,1:km) = p_so2 (:,:,km:1:-1) 
753               p_so4 (:,:,1:km) = p_so4 (:,:,km:1:-1) 
754               p_dms (:,:,1:km) = p_dms (:,:,km:1:-1) 
755            endif
756     
757     ! --- 2D array: data copy
758             c_frlake = 0.                  ! fraction_of_lake (1)
759             c_fraci  = 0.                  ! ice_covered_fraction_of_tile (1)
760             c_lai    = 3.                  ! leaf_area_index (1)
761     !
762             c_zpbl   = p_hpbl              ! boundary layer height (m)
763             c_grn    = p_vfrac             ! greeness_fraction (1)
764             c_sh     = p_dtsfci            ! sensible heat flux (W/m^2)
765             c_ta     = p_tsea              ! surface air Temperature (K)
766             c_tsoil1 = p_stc1              ! soil temperatures layer_1 (k)
767             c_u10m   = p_u10m              ! 10-meter eastward_wind (m s-1)
768             c_v10m   = p_v10m              ! 10-meter northward_wind (m s-1)
769             c_ustar  = p_ustar             ! surface velocity scale (m s-1)
770             c_lwi    = p_slmsk             ! land-ocean-ice mask  (1)
771             c_ps     = p_ps                ! surface pressure (Pa)
772     
773             c_wet1   = p_wet1              ! soil wetness (1)
774     !
775     ! --- 2D array: data copy with unit conversion
776             c_cn_prcp  = 1.E3*p_rainc /deltim            ! surface conv. rain flux (kg/m^2/s)
777             c_ncn_prcp = 1.E3*(p_rain - p_rainc)/deltim  ! Non-conv. precip rate (kg/m^2/s)
778             c_z0h      = p_zorl / 1.E2                   ! surface roughness (m)
779     
780     ! --- 3D array: filp vertical index from bottom-up to top-down
781             c_t (:,:,1:km)      = p_t (:,:,km:1:-1)       ! air temp at mid-layer (K)
782             c_u (:,:,1:km)      = p_u (:,:,km:1:-1)       ! zonal wind at mid-layer (m/s)
783             c_v (:,:,1:km)      = p_v (:,:,km:1:-1)       ! meridian wind at mid-layer (m/s)
784             c_o3(:,:,1:km)      = p_o3mr(:,:,km:1:-1)     ! ozone mixing ratio at mid-layer (kg/kg)
785             c_fcld(:,:,1:km)    = p_fcld(:,:,km:1:-1)     ! cloud cover  (1)
786             c_dqdt(:,:,1:km)    = p_dqdt(:,:,km:1:-1)     ! total moisture tendency (kg/kg/s)
787     ! 
788     ! --- Compute ple, zle, airdens, rh2, tropp, wet1
789             do j = 1, jm
790             do i = 1, im
791     
792     !         local array
793               sh(:) = max( p_spfh(i,j,:), qmin )
794     
795     !         compute air pressure at interface
796               pi(0)=p_ps(i,j)
797               do k=1,km-1
798                 pi(k) = pi(k-1) - p_dp(i,j,k)
799               enddo
800               pi(km) = f_zero
801     
802     !         compute prsln (for thickness computation)
803               do k = 0, km-1                    ! from SFC to TOA
804                 prsln(k) = log(0.01*pi(k))      ! convert from Pa to mb
805               enddo
806               prsln(km)=log(0.01*p_p(i,j,km))   ! convert from Pa to mb
807     
808     !         compute rho (layer air density in kg/m^3), h (interface height in m)
809               h(0) =  max ( p_hs(i,j), 0.0 )
810     !         h(0) =  f_zero
811               do k = 1, km                           ! from SFC to TOA
812                 tv1 = p_t(i,j,k) * (f_one + con_fvirt * sh(k))   ! virtual temp (k)
813                 rho(k) = p_p(i,j,k) /(con_rd * tv1)       ! air density (kg/m3)
814                 dz = rovg * (prsln(k-1)-prsln(k)) * tv1   ! thickness (m)
815                 if ( k == km ) dz = 2.0 * dz
816                 h(k) = h(k-1) + dz        ! geopotential height at interface (m)
817               enddo
818     
819     !         compute rh2 (relative humidity (in percent)
820               call getrh(km,p_p(i,j,:),sh,p_t(i,j,:),shs,rh)
821     
822     !         compute tropp (ptp: tropopause pressure in Pa)
823               call tpause(km,p_p(i,j,:),p_u(i,j,:),p_v(i,j,:),p_t(i,j,:),h, &
824                           ptp,utp,vtp,ttp,htp,shrtp)
825     
826     !         pass local array to chem import
827               c_tropp(i,j)    = ptp
828               c_ple(i,j,0:km) = pi(km:0:-1)               ! air pressure at interface (Pa)
829               c_zle(i,j,0:km) = h (km:0:-1)               ! geopotential height at interface (m)
830               c_airdens(i,j,1:km) = rho(km:1:-1)          ! air density at mid-layer (kg/m3)
831               c_rh2(i,j,1:km) = 0.01* rh(km:1:-1)         ! relative humidity in precent
832     
833             enddo
834             enddo
835     
836            endif
837     
838           ELSE
839     
840            print *, 'PHY2CHEM_RUN: Coupling chem_imp with phy_exp skipped'
841     
842           ENDIF
843           t2_o=rtc()
844           t2 = t2_o - t2_i
845     !
846     ! --- now let's take care 2d aer_diag fields 
847     !
848           BundleName='dgmet'
849           do i = 1, nfld_met
850     
851             vname = name_met(i)
852             nullify(p_diag)
853             MESSAGE_CHECK = "Phys2Chem CPL_RUN: Get Farray from Phy_Exp-"//vname
854             call GetPointer_diag_(PHY_EXP_STATE, BundleName, vname, p_diag, rc)
855             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
856     
857             select case ( vname )
858               case ('xU10M')
859                 p_diag = p_diag + deltim * c_u10m
860               case ('xV10M')
861                 p_diag = p_diag + deltim * c_v10m
862               case ('xUUSTAR')
863                 p_diag = p_diag + deltim * c_ustar
864               case ('xZ0H')
865                 p_diag = p_diag + deltim * c_z0h
866               case ('xLWI')
867                 p_diag = p_diag + deltim * c_lwi
868               case ('xZPBL')
869                 p_diag = p_diag + deltim * c_zpbl
870               case ('xWET1')
871                 p_diag = p_diag + deltim * c_wet1
872               case ('xSH')
873                 p_diag = p_diag + deltim * c_sh
874               case ('xCNPRCP')
875                 p_diag = p_diag + deltim * c_cn_prcp
876               case ('xNCNPRCP')
877                 p_diag = p_diag + deltim * c_ncn_prcp
878     
879     ! change the following from accumulation to instant values;
880     ! dqdt is scaled by 1e6
881     
882               case ('xZLE01')
883                 p_diag = c_zle(:,:,1)
884               case ('xAIRDEN01')
885                 p_diag = c_airdens(:,:,1)
886               case ('xT01')
887                 p_diag = c_t(:,:,1)
888               case ('xU01')
889                 p_diag = c_u(:,:,1)
890               case ('xV01')
891                 p_diag = c_v(:,:,1)
892               case ('xFCLD01')
893                 p_diag = c_fcld(:,:,1)
894               case ('xDQDT01')
895                 p_diag = c_dqdt(:,:,1) * 1.e6
896     
897               case ('xZLE64')
898                 p_diag = c_zle(:,:,64)
899               case ('xAIRDEN64')
900                 p_diag = c_airdens(:,:,64)
901               case ('xT64')
902                 p_diag = c_t(:,:,64)
903               case ('xU64')
904                 p_diag = c_u(:,:,64)
905               case ('xV64')
906                 p_diag = c_v(:,:,64)
907               case ('xFCLD64')
908                 p_diag = c_fcld(:,:,64)
909               case ('xDQDT64')
910                 p_diag = c_dqdt(:,:,64) * 1.e6
911     
912             end select   
913     
914           enddo    ! kcount-loop
915     
916     
917     !
918     !
919     !---------------------------------------------
920     !** Patch the array with valid values for chemistry import
921     !---------------------------------------------
922             call patch_
923     !  ---  inputs:  (in scope variables)
924     !  ---  outputs: (in scope variables)
925     
926     !! debug print
927           if ( lckprnt ) then
928            print *, 'RTC for Get Array', t1, t1_i, t1_o
929            print *, 'RTC for Computations:', t2, t2_i, t2_o
930     
931            print *, 'PHY2CHEM_RUN: check chem_imp before exit PHY2CHEM_RUN'
932     
933            DO I = 1, nfld_2d
934             call CkPointer_ (CHEM_IMP_STATE, vname_2d(I) , '2D', rc)
935            ENDDO
936     
937            DO I = 1, nfld_3d
938             call CkPointer_ (CHEM_IMP_STATE, vname_3d(I) , '3D',  rc)
939            ENDDO
940     
941            DO I = 1, nfld_trc
942             call CkPointer_ (CHEM_IMP_STATE, vname_trc(I) , 'TR', rc)
943            ENDDO
944           endif
945     !
946     !     Reset first flag
947           FIRST = .False.
948     !
949     !-----------------------------------------------------------------------
950     !***  Check the final error signal variable 
951     !-----------------------------------------------------------------------
952     !
953           IF(RC_CPL==ESMF_SUCCESS)THEN
954             WRITE(0,*)'PHY2CHEM CPL RUN SUCCEEDED'
955           ELSE
956             WRITE(0,*)'PHY2CHEM CPL RUN FAILED RC_CPL=',RC_CPL
957           ENDIF
958     
959     !! 
960           contains 
961     
962     ! ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
963           subroutine FillDefault_
964     
965     !  ---  inputs:  (in scope variables)
966     !  ---  outputs: (in scope variables)
967     
968             do j = 1, jm
969             do i = 1, im
970     
971                 c_PLE(i,j,:) = (/ 1, 2, 3, 4, 6, 8, 11, 15, 21, 27, 36, 47, 61, 79, 101, 130,       &
972                                165, 208, 262, 327, 407, 504, 621, 761, 929, 1127, 1364, 1645,  &
973                                1979, 2373, 2836, 3381, 4017, 4764, 5638, 6660, 7851, 9236,     &
974                                10866, 12783, 15039, 17693, 20792, 24398, 28606, 33388, 37003,  &
975                                40612, 44214, 47816, 51405, 54997, 58584, 62170, 65769, 68147,  &
976                                70540, 72931, 75313, 77711, 79623, 81046, 82485, 83906, 85344,  &
977                                86765, 88201, 89636, 91071, 92516, 93921, 95376 /)       
978     
979                 c_ZLE(i,j,:) = (/ 78676, 74222, 71032, 68578, 66390, 64345, 62371, 60419, 58455, &
980                                 56469, 54463, 52449, 50446, 48476, 46563, 44718, 42946, 41256, &
981                                 39651, 38123, 36656, 35234, 33847, 32499, 31199, 29940, 28704, &
982                                 27494, 26310, 25151, 24017, 22905, 21815, 20745, 19691, 18656, &
983                                 17629, 16609, 15589, 14559, 13514, 12470, 11475, 10487, 9469, &
984                                 8438, 7731, 7076, 6463, 5889, 5348, 4838, 4355, 3898, 3464, &
985                                 3187, 2918, 2656, 2403, 2155, 1963, 1821, 1682, 1546, 1412, &
986                                 280, 1149, 1022, 896, 773, 654, 535, 417 /)
987     
988                 c_AIRDENS(i,j,:) = (/ 2.27987766266e-05, 4.03523445129e-05, 6.19888305664e-05, 8.63075256348e-05, &
989                                     0.000117659568787, 0.000159025192261, 0.000209808349609, 0.000270366668701, &
990                                     0.000345230102539, 0.000439167022705, 0.00055980682373, 0.000717163085938, &
991                                     0.000923156738281, 0.00120162963867, 0.00156402587891, 0.00202178955078, &
992                                     0.00262451171875, 0.00339889526367, 0.00437164306641, 0.00555419921875, &
993                                     0.00694274902344, 0.00857543945312, 0.0105895996094, 0.0131225585938, &
994                                     0.0160827636719, 0.0195617675781, 0.0237731933594, 0.0287780761719, &
995                                     0.0347290039062, 0.0416870117188, 0.0499267578125, 0.0596313476562, &
996                                     0.0711669921875, 0.084716796875, 0.100830078125, 0.11865234375, 0.138671875, &
997                                     0.1630859375, 0.190185546875, 0.22021484375, 0.25927734375, 0.318359375, &
998                                     0.3720703125, 0.42138671875, 0.47265625, 0.521484375, 0.5615234375, &
999                                     0.6005859375, 0.638671875, 0.677734375, 0.71875, 0.759765625, 0.8017578125, &
1000                                     0.8447265625, 0.8798828125, 0.90625, 0.9326171875, 0.958984375, 0.986328125, &
1001                                     1.013671875, 1.03515625, 1.052734375, 1.072265625, 1.08984375, 1.10546875, &
1002                                     1.123046875, 1.140625, 1.162109375, 1.1953125, 1.21875, 1.234375, 1.25 /)
1003     
1004                 c_FCLD(i,j,:) = 1e-2 * &
1005                               (/ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
1006                                  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, &
1007                                  0, 0, 0, 0, 0, 0, 16, 21, 26, 28, 0, 0, 0, 0, 0, 0, 0, &
1008                                  0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0 /)
1009     
1010                 c_DQDT(i,j,:) = 1e-12 * &
1011                               (/ 9, 11, -3, -3, -2, -18, -10, 2, 0, -3, -6, -5, -3, -1, 1, &
1012                                  1, 1, 1, 1, 1, 0, 1, 1, 1, 1, 1, 1, 1, 0, 1, 1, 1, 1, &
1013                                  1, 1, 0, 0, -5, -22, -33, 95, 474, 348, 177, 3377, 11045, &
1014                                  11788, -5267, -7756, -17491, -19790, -10884, -6082, 8120, 4381, &
1015                                  -10346, 8033, 69151, 77650, 61351, 46508, 33936, 23022, 15658, &
1016                                  11598, 6469, 4861, -846, -7974, -30500, -20663, -14930 /)
1017     
1018                 c_T(i,j,:) = (/ 219, 221, 223, 228, 230, 230, 232, 238, 245, 253, 259, 263, &
1019                               264, 262, 258, 253, 247, 239, 233, 229, 227, 227, 226, 223, &
1020                               222, 221, 220, 219, 218, 217, 216, 215, 214, 213, 212, 212, &
1021                               214, 214, 216, 219, 219, 210, 210, 218, 227, 234, 240, 245, &
1022                               250, 254, 257, 260, 262, 263, 265, 266, 267, 268, 269, 270, &
1023                               270, 270, 270, 270, 271, 271, 271, 270, 267, 265, 266, 266 /)
1024     
1025     
1026                 c_U(i,j,:) = (/ -18, -13, 0, 10, 26, 36, 39, 40, 38, 37, 36, 35, 32, 28,    &
1027                                23, 16, 6, -2, -9, -13, -15, -16, -14, -14, -12, -12, -11, &
1028                               -10, -9, -5, -3, -2, 0, 1, 3, 5, 9, 13, 17, 22, 24, 26,     &
1029                                25, 26, 26, 22, 19, 17, 14, 12, 12, 11, 11, 11, 11, 10, 9, &
1030                                 8, 6, 4, 3, 2, 1, 0, -1, -2, -3, -4, -5, -6, -6, -6 /)
1031     
1032                 c_V(i,j,:) = (/ 20, 13, 9, 4, -1, -9, -20, -24, -25, -27, -28, -28, -26,    &
1033                              -25, -27, -28, -28, -28, -27, -27, -25, -23, -19, -15, -11,  &
1034                              -10, -9, -8, -7, -7, -8, -9, -10, -12, -14, -15, -16, -18,   &
1035                              -21, -22, -22, -25, -29, -25, -23, -23, -22, -20, -17, -13,  &
1036                              -9, -6, -4, -4, -4, -3, -2, -1, 0, 0, 0, 1, 1, 1, 2, 2,      &
1037                               3, 3, 3, 4, 4, 3 /)
1038     
1039                 c_O3(i,j,:) = 1.E-9 * & 
1040                             (/ 16182, 9700, 7294, 5781, 4164, 3017, 2440, 2287, 2324, 2514,  &
1041                                2838, 3304, 4030, 4924, 5915, 7033, 8434, 9894, 11101, 11414, &
1042                                10475, 9745, 10058, 9119, 8538, 9238, 9164, 10028, 10132, 10237, &
1043                                9447, 7972, 7174, 5222, 4008, 3296, 2231, 1320, 768, 628, 685, &
1044                                676, 202, 122, 96, 88, 86, 83, 83, 84, 84, 83, 82, 81, 79, &
1045                                79, 77, 76, 77, 80, 84, 87, 89, 90, 89, 88, 83, 76, 69, 65, &
1046                                64, 64 /)
1047      
1048                 c_RH2(i,j,:) = 1e-6 * &
1049                              (/ 1, 2, 2, 2, 3, 4, 4, 3, 4, 4, 4, 4, 4, 4, 4, 6, 18, 51,          &
1050                                 129, 267, 394, 502, 682, 1135, 1603, 2076, 2820, 3792, 5120,     &
1051                                 6806, 8912, 11597, 15397, 20386, 28168, 29755, 28748, 33875,     &
1052                                 34058, 28657, 43458, 401856, 947266, 932618, 902344, 657227,     &
1053                                 371583, 203370, 235108, 317872, 413086, 511719, 691407, 686524,  &
1054                                 601563, 456055, 475098, 626954, 590821, 483399, 380860, 297852,  &
1055                                 230958, 183594, 144288, 111084, 96558, 136963, 369629, 770508,   &
1056                                 793946, 799805 /)
1057     !           2D
1058     !           --
1059                 c_TROPP(i,j) = 20363.5
1060                 c_LWI(i,j) = 1.
1061                 c_ZPBL(i,j) = 59.
1062                 c_FRLAKE(i,j) = 0.
1063                 c_FRACI(i,j) = 0.
1064                 c_WET1(i,j) = 0.0
1065                 c_LAI(i,j) = 0.280273
1066                 c_GRN(i,j) = 0.5
1067                 c_CN_PRCP(i,j) = 0.0
1068                 c_NCN_PRCP(i,j) = 3.18323e-10
1069                 c_PS(i,j) = 96825.3 
1070                 c_SH(i,j) = -28.548
1071                 c_TSOIL1(i,j) = 260.014
1072                 c_U10M(i,j) = -3.5
1073                 c_V10M(i,j) = 2.8
1074                 c_USTAR(i,j) = 0.29
1075                 c_Z0H(i,j) = 0.02005
1076                 c_TA(i,j) = 270.014
1077     
1078           end do
1079           end do
1080     
1081           end subroutine FillDefault_
1082     
1083           subroutine patch_
1084     
1085     !  ---  inputs:  (in scope variables)
1086     !  ---  outputs: (in scope variables)
1087     
1088     
1089           do j = 1, lats_node_r_max
1090     
1091             if (lonsperlar_r(j) < lonr ) then
1092     
1093     ! fill in 2D array except for frlake, fraci, lai
1094                c_lwi  (lonsperlar_r(j)+1:lonr, j) = c_lwi   (1,1)
1095                c_zpbl (lonsperlar_r(j)+1:lonr, j) = c_zpbl  (1,1)
1096                c_wet1 (lonsperlar_r(j)+1:lonr, j) = c_wet1  (1,1)
1097                c_grn  (lonsperlar_r(j)+1:lonr, j) = c_grn   (1,1)
1098                c_cn_prcp(lonsperlar_r(j)+1:lonr, j) = c_cn_prcp(1,1)
1099                c_ncn_prcp(lonsperlar_r(j)+1:lonr, j)= c_ncn_prcp(1,1)
1100                c_sh   (lonsperlar_r(j)+1:lonr, j) = c_sh    (1,1)
1101                c_ta   (lonsperlar_r(j)+1:lonr, j) = c_ta    (1,1)
1102                c_tsoil1(lonsperlar_r(j)+1:lonr,j) = c_tsoil1(1,1)
1103                c_u10m (lonsperlar_r(j)+1:lonr, j) = c_u10m  (1,1)
1104                c_v10m (lonsperlar_r(j)+1:lonr, j) = c_v10m  (1,1)
1105                c_ustar(lonsperlar_r(j)+1:lonr, j) = c_ustar (1,1)
1106                c_z0h  (lonsperlar_r(j)+1:lonr, j) = c_z0h   (1,1)
1107                c_tropp(lonsperlar_r(j)+1:lonr, j) = c_tropp (1,1)
1108                c_ps   (lonsperlar_r(j)+1:lonr, j) = c_ps    (1,1)
1109     
1110     ! fill in 3D array at interface
1111       	   do k = 0, km
1112                c_ple   (lonsperlar_r(j)+1:lonr, j, k) = c_ple   (1,1,k)
1113                c_zle   (lonsperlar_r(j)+1:lonr, j, k) = c_zle   (1,1,k)
1114                enddo  
1115     
1116     ! fill in 3D array at mid-layer
1117                do k = 1, km
1118                c_airdens(lonsperlar_r(j)+1:lonr,j,k) = c_airdens(1,1,k)
1119                c_t      (lonsperlar_r(j)+1:lonr,j,k) = c_t      (1,1,k)
1120                c_u      (lonsperlar_r(j)+1:lonr,j,k) = c_u      (1,1,k)
1121                c_v      (lonsperlar_r(j)+1:lonr,j,k) = c_v      (1,1,k)
1122                c_fcld   (lonsperlar_r(j)+1:lonr,j,k) = c_fcld   (1,1,k)
1123                c_dqdt   (lonsperlar_r(j)+1:lonr,j,k) = c_dqdt   (1,1,k)
1124     
1125                c_o3    (lonsperlar_r(j)+1:lonr,j,k) = c_o3    (1,1,k)
1126                c_rh2   (lonsperlar_r(j)+1:lonr,j,k) = c_rh2   (1,1,k)
1127                enddo     
1128     
1129             endif
1130           enddo 
1131           RETURN
1132     
1133           end subroutine patch_
1134     
1135           END subroutine run
1136     
1137     !=========================
1138           subroutine get_attribute(STATE, RC_CPL)
1139     
1140     !  ---  input
1141             type(ESMF_State), intent(in)         :: STATE
1142     
1143     !  ---  output
1144             integer, intent(out)                 :: RC_CPL
1145     
1146     !  ---  locals:
1147             type(ESMF_FieldBundle)   :: Bundle
1148             integer                  :: STATUS, RC
1149             character(esmf_maxstr)   :: statename
1150     
1151     ! ---   Retrieve statename
1152             MESSAGE_CHECK='Retrive state name'
1153             call ESMF_StateGet(state=STATE, name=statename, rc=RC )
1154             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
1155     
1156     !  ---  Retrieve lat/lon info
1157             MESSAGE_CHECK = 'Extract lonr attribute from '//trim(statename)
1158             CALL ESMF_AttributeGet(state=STATE, name='lonr'  &
1159                                   ,value=lonr, rc=RC)
1160             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
1161     
1162             MESSAGE_CHECK = 'Extract lats_node_r attribute from '//trim(statename)
1163             CALL ESMF_AttributeGet(state=STATE, name='lats_node_r'  &  
1164                                  ,value=lats_node_r, rc=RC)
1165             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
1166     
1167             MESSAGE_CHECK = 'Extract lats_node_r_max attribute from '//trim(statename)
1168             CALL ESMF_AttributeGet(state=STATE, name='lats_node_r_max'&
1169                                  ,value=lats_node_r_max, rc=RC)
1170             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
1171     
1172             if ( .not. allocated (lonsperlar_r)) then
1173               allocate ( lonsperlar_r(lats_node_r_max))
1174             endif
1175     
1176             MESSAGE_CHECK = 'Extract lonsperlar_r attribute from '//trim(statename)
1177             CALL ESMF_AttributeGet(state=STATE             &  !<-- Name of the state
1178                                ,name ='lonsperlar_r'       &  !<-- Name of the attribute to retrieve
1179                                ,count = lats_node_r_max    &  !<-- Number of values in the attribute
1180                                ,valueList =lonsperlar_r    &  !<-- Value of the attribute
1181                                ,rc   =RC)
1182             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
1183     
1184     ! ---   Retrieve tracer specification
1185             MESSAGE_CHECK = 'Extract tracer bundle from '//trim(statename)
1186             call ESMF_StateGet(state=STATE, ItemName='tracers',    &
1187                                fieldbundle=Bundle, rc = rc )
1188             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
1189     
1190             MESSAGE_CHECK = 'Extract ntrac attribute from '//trim(statename)
1191             CALL ESMF_AttributeGet(Bundle, name  ='ntrac'  & !<-- Name of the attribute to retrieve
1192                                   ,value = ntrac, rc = RC)   !<-- Value of the attribute
1193             CALL ERR_MSG(RC,MESSAGE_CHECK,RC_CPL)
1194     
1195            RETURN
1196           end subroutine get_attribute
1197     
1198     !!! ---------------- ! ------------------ ! ---------------- !----------------!
1199     
1200           subroutine CkPointer_(STATE,NAME,TAG,rc)
1201     
1202     ! --- input/output arguments
1203             type(ESMF_State), intent(IN)    :: STATE
1204             character(len=*), intent(IN)    :: NAME
1205             character(len=*), intent(IN)    :: TAG
1206             integer, intent (OUT)           :: rc
1207     
1208     ! --- locals
1209             integer                         :: rc1, ii, jj, kk
1210             type(ESMF_Field)                :: Field
1211             type(ESMF_FieldBundle)          :: Bundle
1212             character(esmf_maxstr)          :: StateName, BundleName, LName
1213             real(ESMF_KIND_R8), pointer     :: Array2D(:,:), Array3D(:,:,:)
1214     !
1215             MESSAGE_CHECK='Retrive state name'
1216             call ESMF_StateGet(state=State, name=statename, rc=rc1)
1217             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1218     
1219     !       select case ( lowercase(statename))
1220             call g_fixchar(StateName, LName, 2)
1221             select case ( Lname  )
1222             case ( 'physics export') 
1223                BundleName='tracers'
1224             case ( 'chemistry import') 
1225                BundleName='iAERO'
1226             case ( 'chemistry export') 
1227                BundleName='AERO'
1228             end select
1229     !
1230             if ( TAG == '2D' ) then
1231               MESSAGE_CHECK = 'Extract '//NAME//' from '//statename
1232               call ESMF_StateGet(state=STATE, itemName=NAME, field=Field, rc=rc1)
1233               CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1234     
1235               nullify(Array2D)
1236               MESSAGE_CHECK = 'Get 2d Fortran data pointer from '//NAME
1237               CALL ESMF_FieldGet(field=Field, localDe=0, farray=Array2D, rc=rc1)
1238               CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1239     !
1240               ii = size(Array2D, dim=1)
1241               jj = size(Array2D, dim=2)
1242     !
1243               print *, trim(statename), '/', NAME,':', Array2D(1,1),Array2D(ii,jj), &
1244                                 minval(Array2D),maxval(Array2D)
1245     
1246             ELSEIF (TAG == '3D' ) then
1247               MESSAGE_CHECK = 'Extract '//NAME//' from '//statename
1248               call ESMF_StateGet(state=STATE, itemName=NAME, field=Field, rc=rc1)
1249               CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1250     
1251               nullify(Array3D)
1252               MESSAGE_CHECK = 'Get 3d Fortran data pointer from '//NAME
1253               CALL ESMF_FieldGet(field=Field, localDe=0, farray=Array3D, rc=rc1)
1254               CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1255     !
1256               ii = size(Array3D, dim=1)
1257               jj = size(Array3D, dim=2)
1258               kk = size(Array3D, dim=3)
1259     !
1260               print *, trim(statename), '/', NAME,':', Array3D(1,1,1),Array3D(ii,jj,kk), &
1261                                 minval(Array3D),maxval(Array3D)
1262     
1263             ELSEIF (TAG == 'TR' ) then
1264               MESSAGE_CHECK = 'Extract '//trim(BundleName)//' from '//statename
1265               call ESMF_StateGet(state=State, ItemName=BundleName, fieldbundle=Bundle, rc=rc1)
1266               CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1267     !
1268               MESSAGE_CHECK = 'Extract '//NAME//' from '//trim(BundleName)
1269               CALL ESMF_FieldBundleGet(bundle=Bundle, name=NAME, field=Field, rc=rc1)
1270               CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1271     
1272     !
1273     !
1274               nullify(Array3D)
1275               MESSAGE_CHECK = 'Get 3d Fortran data pointer from '//NAME
1276               CALL ESMF_FieldGet(field=Field, localDe=0, farray=Array3D, rc=rc1)
1277               CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1278     !
1279               ii = size(Array3D, dim=1)
1280               jj = size(Array3D, dim=2)
1281               kk = size(Array3D, dim=3)
1282     !
1283               print*, trim(statename), '/', NAME,':', Array3D(1,1,1),Array3D(ii,jj,kk), &
1284                                 minval(Array3D),maxval(Array3D)
1285     
1286             ELSE
1287     
1288               print *, 'PHY2CHEM_RUN: Unknown data type, abort now'
1289               call abort
1290     
1291             ENDIF
1292     
1293     
1294             return
1295     !
1296           end subroutine CkPointer_
1297     
1298     !!! ---------------- ! ------------------ ! ---------------- !----------------!
1299     
1300             subroutine GetPointer_ (STATE, NAME, Array, RC)
1301     
1302     ! --- input/output arguments
1303             type(ESMF_State), intent(IN)    :: State
1304             character(len=*), intent(IN)    :: NAME
1305             real(ESMF_KIND_R8), pointer, intent(OUT)  :: Array(:,:)
1306             integer, intent (OUT)           :: rc
1307     
1308     ! --- locals
1309             type(ESMF_Field)                :: Field
1310             integer                         :: rc1
1311             character(esmf_maxstr)          :: statename
1312     !
1313     !===>  ...  begin here
1314     !
1315             MESSAGE_CHECK = 'PHY2CHEM_RUN: Retrive statename'
1316             call ESMF_StateGet(state=State, name=statename, rc=rc1)
1317             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1318     
1319             MESSAGE_CHECK = 'PHY2CHEM_RUN: Extract '//NAME//' from '//statename
1320             call ESMF_StateGet(state=STATE, itemName=NAME, field=Field, rc=rc1)
1321             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1322     !
1323             nullify(Array)
1324             MESSAGE_CHECK = 'PHY2CHEM_RUN: Get Fortran data pointer from '//NAME
1325             CALL ESMF_FieldGet(field=Field, localDe=0, farray=Array, rc=rc1)
1326             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1327     !
1328     !       check i- and j-dimension
1329             if ( lonr .ne. size(Array, dim=1) )  print *, 'ERROR !',   &
1330                  'Invalid lonr:',  lonr, size(Array,dim=1)
1331             if (lats_node_r_max .ne. size(Array, dim=2)) print *, 'ERROR !', &
1332                  'Invalid lats_node_r_max', lats_node_r_max, size(Array,dim=2)
1333     
1334            end subroutine GetPointer_
1335     
1336     !!! ---------------- ! ------------------ ! ---------------- !----------------!
1337     
1338             subroutine GetPointer_3D_ (STATE, NAME, Array, RC)
1339     
1340     ! --- input/output arguments
1341             type(ESMF_State), intent(IN)    :: State
1342             character(len=*), intent(IN)    :: NAME
1343             real(ESMF_KIND_R8), pointer, intent(OUT)  :: Array(:,:,:)
1344             integer, intent (OUT)           :: rc
1345     
1346     ! --- locals
1347             type(ESMF_Field)                :: Field
1348             integer                         :: rc1
1349             character(esmf_maxstr)          :: statename
1350     !
1351     !===>  ...  begin here
1352     !
1353             MESSAGE_CHECK = 'PHY2CHEM_RUN: Retrive statename'
1354             call ESMF_StateGet(state=State, name=statename, rc=rc1 )
1355             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1356     
1357             MESSAGE_CHECK = 'PHY2CHEM_RUN: Extract '//NAME//' from '//statename
1358             call ESMF_StateGet(state=STATE, itemName=NAME, field=Field, rc=rc1)
1359             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1360     !
1361             nullify(Array)
1362             MESSAGE_CHECK = 'PHY2CHEM_RUN: Get Fortran data pointer from '//NAME
1363             CALL ESMF_FieldGet(field=Field, localDe=0, farray=Array, rc=rc1)
1364             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1365     !
1366     !       check i- and j-dimension
1367             if ( lonr .ne. size(Array, dim=1) )  print *, 'ERROR !',   &
1368                  'Invalid lonr:',  lonr, size(Array,dim=1)
1369             if (lats_node_r_max .ne. size(Array, dim=2)) print *, 'ERROR !', &
1370                  'Invalid lats_node_r_max', lats_node_r_max, size(Array,dim=2)
1371     
1372            end subroutine GetPointer_3D_
1373     
1374     !!! ---------------- ! ------------------ ! ---------------- !----------------!
1375     
1376             subroutine GetPointer_tracer_ (STATE, NAME, Array, RC)
1377     
1378     ! --- input/output arguments
1379             type(ESMF_State), intent(IN)    :: State
1380             character(len=*), intent(IN)    :: NAME
1381             real(ESMF_KIND_R8), pointer, intent(OUT) :: Array(:,:,:)
1382             integer, intent (OUT)           :: rc
1383     
1384     ! --- locals
1385             type(ESMF_Field)                :: Field
1386             type(ESMF_FieldBundle)          :: Bundle
1387             integer                         :: rc1
1388             character(esmf_maxstr)          :: statename, BundleName, Lname
1389     !
1390             character*8                     :: FldName(8)
1391             integer                         :: nameCount, i
1392     !===>  ...  begin here
1393     
1394             MESSAGE_CHECK = 'PHY2CHEM_RUN: Retrive statename'
1395             call ESMF_StateGet(state=State, name=statename, rc=rc1 )
1396             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1397     
1398     !       select case ( lowercase(statename))
1399             call g_fixchar(StateName, LName, 2)
1400             select case ( Lname  )
1401             case ( 'physics export') 
1402                BundleName='tracers'
1403             case ( 'chemistry import') 
1404                BundleName='iAERO'
1405             case ( 'chemistry export') 
1406                BundleName='AERO'
1407             end select
1408     
1409             MESSAGE_CHECK = 'PHY2CHEM_RUN: Extract '//BundleName//' from '//statename
1410             call ESMF_StateGet(state=State, ItemName=BundleName, fieldbundle=Bundle, rc=rc1)
1411             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1412     
1413             MESSAGE_CHECK = 'PHY2CHEM_RUN: Extract '//NAME//' from '//BundleName
1414             CALL ESMF_FieldBundleGet(bundle=Bundle, name=NAME, field=Field, rc=rc1)
1415             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1416     
1417             nullify(Array)
1418             MESSAGE_CHECK = 'PHY2CHEM_RUN: Get Fortran data pointer from '//NAME
1419             CALL ESMF_FieldGet(field=Field, localDe=0, farray=Array, rc = rc1)
1420             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1421     !
1422     !       check i- and j-dimension
1423             if ( lonr .ne. size(Array, dim=1) )  print *, 'ERROR !',   &
1424                  'Invalid lonr:',  lonr, size(Array,dim=1)
1425             if (lats_node_r_max .ne. size(Array, dim=2)) print *, 'ERROR !', &
1426                  'Invalid lats_node_r_max', lats_node_r_max, size(Array,dim=2)
1427     
1428            end subroutine GetPointer_tracer_
1429     
1430     !!! ---------------- ! ------------------ ! ---------------- !----------------!
1431     
1432             subroutine GetPointer_diag_ (STATE, BUNDLENAME, NAME, ARRAY, RC)
1433     
1434     ! --- input/output arguments
1435             type(ESMF_State), intent(IN)    :: STATE
1436             character(len=*), intent(IN)    :: BUNDLENAME
1437             character(len=*), intent(IN)    :: NAME
1438             real(ESMF_KIND_R8), pointer, intent(OUT) :: ARRAY(:,:)
1439             integer, intent (OUT)           :: RC
1440     
1441     ! --- locals
1442             type(ESMF_Field)                :: Field
1443             type(ESMF_FieldBundle)          :: Bundle
1444             integer                         :: rc1
1445     !
1446     !===>  ...  begin here
1447     
1448             IF ( BundleName(1:4) == 'xxxx') then
1449              MESSAGE_CHECK = 'GetPointer_diag: Extract Field '//NAME
1450              CALL ESMF_StateGet(state=State, ItemName=NAME, field=Field, rc=rc1)
1451              CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1452             ELSE
1453              MESSAGE_CHECK = 'GetPointer_diag: Extract Bundle '//BundleName
1454              call ESMF_StateGet(state=State, ItemName=BundleName,  &
1455                                fieldbundle=Bundle, rc=rc1)
1456              CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1457     
1458              MESSAGE_CHECK = 'GetPointer_diag:: Extract Field '//NAME
1459              CALL ESMF_FieldBundleGet(bundle=Bundle, name=NAME, field=Field, rc=rc1)
1460              CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1461             ENDIF
1462     
1463             nullify(Array)
1464             MESSAGE_CHECK = 'GetPointer_diag:: Get Fortran data pointer from '//NAME
1465             CALL ESMF_FieldGet(field=Field, localDe=0, farray=Array, rc = rc1)
1466             CALL ERR_MSG(rc1, MESSAGE_CHECK, rc)
1467     !
1468            end subroutine GetPointer_diag_
1469     
1470     !! adopt getrh routine from /nwprod/sorc/global_postgp.fd/postgp.f
1471     
1472           subroutine getrh(km,p,sh,t,shs,rh)
1473     !
1474     ! Subprogram: getrh      Compute saturation humidity and relative humidity
1475     !   Prgmmr: Iredell      Org: np23        Date: 1999-10-18
1476     !
1477     ! Abstract: This subprogram computes the saturation specific humidity and the
1478     !           relative humidity.  The relative humidity is constrained to be
1479     !           between 0 and 100.
1480     !
1481     ! Program history log:
1482     !   1999-10-18  Mark Iredell
1483     !
1484     ! Usage:  call getrh(km,p,sh,t,shs,rh)
1485     !   Input argument list:
1486     !     km       integer number of levels
1487     !     p        real (km) pressure (Pa)
1488     !     sh       real (km) specific humidity (kg/kg)
1489     !     t        real (km) temperature (K)
1490     !   Output argument list:
1491     !     shs      real (km) saturation specific humidity (kg/kg)
1492     !     rh       real (km) relative humidity (percent)
1493     !
1494     ! Modules used:
1495     !   funcphys       Physical functions
1496     !
1497     ! Files included:
1498     !   physcons.h     Physical constants
1499     !
1500     ! Subprograms called:
1501     !   fpvs           compute saturation vapor pressure
1502     !
1503     ! Attributes:
1504     !   Language: Fortran 90
1505     !
1506     !$$$
1507            implicit none
1508            integer,intent(in):: km
1509            real,intent(in):: p(km),sh(km),t(km)
1510            real,intent(out):: shs(km),rh(km)
1511            real(krealfp) pr,tr,es
1512            integer k
1513     ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1514            do k=1,km
1515              pr=p(k)
1516              tr=t(k)
1517              es=fpvs(tr)
1518              es=min(es,pr)
1519              shs(k)=con_eps*es/(pr+con_epsm1*es)
1520              rh(k)=1.e2*min(max(sh(k)/shs(k),0.),1.)
1521            enddo
1522            end subroutine
1523     !
1524           subroutine g_fixchar(name_in, name_out, option)
1525           implicit none
1526     
1527           character*(*), intent(in)   ::  name_in
1528           character*(*), intent(out)  ::  name_out
1529           integer, intent(in)         ::  option
1530     
1531           character*30                :: temp
1532           integer                     :: i, ic
1533     
1534           name_out= '          '
1535           temp = trim(adjustl(name_in))
1536           do i = 1, len_trim(temp)
1537             ic = IACHAR(temp(i:i))
1538             if(option == 1 ) then             !<--- convert to upper case
1539               if(ic .ge. 97 .and. ic .le. 122) then
1540                 name_out(i:i) = CHAR( IC-32 )
1541               else
1542                 name_out(i:i) = temp(i:i)
1543               endif
1544             endif
1545             if(option == 2 ) then             !<--- convert to lower case
1546               if(ic .ge. 65 .and. ic .le. 90) then
1547                 name_out(i:i) = CHAR( IC+32 )
1548               else
1549                 name_out(i:i) = temp(i:i)
1550               endif
1551             endif
1552     
1553           enddo
1554           name_out=trim(name_out)
1555           return
1556     
1557           end subroutine g_fixchar
1558     
1559     !
1560           END module atmos_phy_chem_cpl_comp_mod
1561     
1562     
1563     
1564