!WRF:DRIVER_LAYER:DOMAIN_OBJECT
!
! Following are the routines contained within this MODULE:
! alloc_space_domain 1. Allocate the space for a single domain (constants
! and null terminate pointers).
! 2. Connect the domains as a linked list.
! 3. Store all of the domain constants.
! 4. CALL alloc_space_field.
! alloc_space_field 1. Allocate space for the gridded data required for
! each domain.
! dealloc_space_domain 1. Reconnect linked list nodes since the current
! node is removed.
! 2. CALL dealloc_space_field.
! 3. Deallocate single domain.
! dealloc_space_field 1. Deallocate each of the fields for a particular
! domain.
! first_loc_integer 1. Find the first incidence of a particular
! domain identifier from an array of domain
! identifiers.
MODULE module_domain 183
USE module_driver_constants
USE module_machine
USE module_state_description
USE module_wrf_error
USE esmf_mod
CHARACTER (LEN=80) program_name
! An entire domain. This contains multiple meteorological fields by having
! arrays (such as "data_3d") of pointers for each field. Also inside each
! domain is a link to a couple of other domains, one is just the "next"
! domain that is to be stored, the other is the next domain which happens to
! also be on the "same_level".
TYPE domain_ptr
TYPE(domain), POINTER :: ptr
END TYPE domain_ptr
INTEGER, PARAMETER :: HISTORY_ALARM=1, AUXHIST1_ALARM=2, AUXHIST2_ALARM=3, &
AUXHIST3_ALARM=4, AUXHIST4_ALARM=5, AUXHIST5_ALARM=6, &
AUXINPUT1_ALARM=7, AUXINPUT2_ALARM=8, AUXINPUT3_ALARM=9, &
AUXINPUT4_ALARM=10, AUXINPUT5_ALARM=11, &
RESTART_ALARM=12, BOUNDARY_ALARM=13, ALARM_SUBTIME=14
TYPE domain
! SEE THE INCLUDE FILE FOR DEFINITIONS OF STATE FIELDS WITHIN THE DOMAIN DATA STRUCTURE
#include <state_struct.inc>
INTEGER :: comms( max_comms ), shift_x, shift_y
INTEGER :: id
INTEGER :: domdesc
INTEGER :: communicator
INTEGER :: iocommunicator
INTEGER,POINTER :: mapping(:,:)
INTEGER,POINTER :: i_start(:),i_end(:)
INTEGER,POINTER :: j_start(:),j_end(:)
INTEGER :: max_tiles
INTEGER :: num_tiles ! taken out of namelist 20000908
INTEGER :: num_tiles_x ! taken out of namelist 20000908
INTEGER :: num_tiles_y ! taken out of namelist 20000908
INTEGER :: num_tiles_spec ! place to store number of tiles computed from
! externally specified params
TYPE(domain_ptr) , DIMENSION( : ) , POINTER :: parents
TYPE(domain_ptr) , DIMENSION( : ) , POINTER :: nests
TYPE(domain) , POINTER :: sibling ! overlapped domains at same lev
TYPE(domain) , POINTER :: intermediate_grid
INTEGER :: num_parents, num_nests, num_siblings
INTEGER , DIMENSION( max_parents ) :: child_of_parent
INTEGER , DIMENSION( max_nests ) :: active
TYPE(domain) , POINTER :: next
TYPE(domain) , POINTER :: same_level
LOGICAL , DIMENSION ( 4 ) :: bdy_mask ! which boundaries are on processor
! domain dimensions
INTEGER :: sd31, ed31, sd32, ed32, sd33, ed33, &
sd21, ed21, sd22, ed22, &
sd11, ed11
INTEGER :: sp31, ep31, sp32, ep32, sp33, ep33, &
sp21, ep21, sp22, ep22, &
sp11, ep11, &
sm31, em31, sm32, em32, sm33, em33, &
sm21, em21, sm22, em22, &
sm11, em11, &
sp31x, ep31x, sp32x, ep32x, sp33x, ep33x, &
sp21x, ep21x, sp22x, ep22x, &
sm31x, em31x, sm32x, em32x, sm33x, em33x, &
sm21x, em21x, sm22x, em22x, &
sp31y, ep31y, sp32y, ep32y, sp33y, ep33y, &
sp21y, ep21y, sp22y, ep22y, &
sm31y, em31y, sm32y, em32y, sm33y, em33y, &
sm21y, em21y, sm22y, em22y
Type(ESMF_Clock) :: domain_clock
Type(ESMF_Time) :: start_time, stop_time, current_time
Type(ESMF_Time) :: start_subtime, stop_subtime
Type(ESMF_Time) :: this_bdy_time, next_bdy_time
Type(ESMF_TimeInterval) :: step_time
Type(ESMF_Alarm), pointer :: alarms(:)
END TYPE domain
! Now that a "domain" TYPE exists, we can use it to store a few pointers
! to this type. These are primarily for use in traversing the linked list.
! The "head_grid" is always the pointer to the first domain that is
! allocated. This is available and is not to be changed. The others are
! just temporary pointers.
TYPE(domain) , POINTER :: head_grid , new_grid , next_grid , old_grid
! To facilitate an easy integration of each of the domains that are on the
! same level, we have an array for the head pointer for each level. This
! removed the need to search through the linked list at each time step to
! find which domains are to be active.
TYPE domain_levels
TYPE(domain) , POINTER :: first_domain
END TYPE domain_levels
TYPE(domain_levels) , DIMENSION(max_levels) :: head_for_each_level
CONTAINS
SUBROUTINE get_ijk_from_grid ( grid , & 24
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe )
IMPLICIT NONE
TYPE( domain ), INTENT (IN) :: grid
INTEGER, INTENT(OUT) :: &
ids, ide, jds, jde, kds, kde, &
ims, ime, jms, jme, kms, kme, &
ips, ipe, jps, jpe, kps, kpe
data_ordering : SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
ids = grid%sd31
ide = grid%ed31
jds = grid%sd32
jde = grid%ed32
kds = grid%sd33
kde = grid%ed33
ims = grid%sm31
ime = grid%em31
jms = grid%sm32
jme = grid%em32
kms = grid%sm33
kme = grid%em33
ips = grid%sp31
ipe = grid%ep31
jps = grid%sp32
jpe = grid%ep32
kps = grid%sp33
kpe = grid%ep33
CASE ( DATA_ORDER_YXZ )
ids = grid%sd32
ide = grid%ed32
jds = grid%sd31
jde = grid%ed31
kds = grid%sd33
kde = grid%ed33
ims = grid%sm32
ime = grid%em32
jms = grid%sm31
jme = grid%em31
kms = grid%sm33
kme = grid%em33
ips = grid%sp32
ipe = grid%ep32
jps = grid%sp31
jpe = grid%ep31
kps = grid%sp33
kpe = grid%ep33
CASE ( DATA_ORDER_ZXY )
ids = grid%sd32
ide = grid%ed32
jds = grid%sd33
jde = grid%ed33
kds = grid%sd31
kde = grid%ed31
ims = grid%sm32
ime = grid%em32
jms = grid%sm33
jme = grid%em33
kms = grid%sm31
kme = grid%em31
ips = grid%sp32
ipe = grid%ep32
jps = grid%sp33
jpe = grid%ep33
kps = grid%sp31
kpe = grid%ep31
CASE ( DATA_ORDER_ZYX )
ids = grid%sd33
ide = grid%ed33
jds = grid%sd32
jde = grid%ed32
kds = grid%sd31
kde = grid%ed31
ims = grid%sm33
ime = grid%em33
jms = grid%sm32
jme = grid%em32
kms = grid%sm31
kme = grid%em31
ips = grid%sp33
ipe = grid%ep33
jps = grid%sp32
jpe = grid%ep32
kps = grid%sp31
kpe = grid%ep31
CASE ( DATA_ORDER_XZY )
ids = grid%sd31
ide = grid%ed31
jds = grid%sd33
jde = grid%ed33
kds = grid%sd32
kde = grid%ed32
ims = grid%sm31
ime = grid%em31
jms = grid%sm33
jme = grid%em33
kms = grid%sm32
kme = grid%em32
ips = grid%sp31
ipe = grid%ep31
jps = grid%sp33
jpe = grid%ep33
kps = grid%sp32
kpe = grid%ep32
CASE ( DATA_ORDER_YZX )
ids = grid%sd33
ide = grid%ed33
jds = grid%sd31
jde = grid%ed31
kds = grid%sd32
kde = grid%ed32
ims = grid%sm33
ime = grid%em33
jms = grid%sm31
jme = grid%em31
kms = grid%sm32
kme = grid%em32
ips = grid%sp33
ipe = grid%ep33
jps = grid%sp31
jpe = grid%ep31
kps = grid%sp32
kpe = grid%ep32
END SELECT data_ordering
END SUBROUTINE get_ijk_from_grid
! Default version ; Otherwise module containing interface to DM library will provide
SUBROUTINE wrf_patch_domain( id , domdesc , parent, parent_id , parent_domdesc , & 1,3
sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
sp1x , ep1x , sm1x , em1x , &
sp2x , ep2x , sm2x , em2x , &
sp3x , ep3x , sm3x , em3x , &
sp1y , ep1y , sm1y , em1y , &
sp2y , ep2y , sm2y , em2y , &
sp3y , ep3y , sm3y , em3y , &
bdx , bdy , bdy_mask )
USE module_machine
IMPLICIT NONE
LOGICAL, DIMENSION(4), INTENT(OUT) :: bdy_mask
INTEGER, INTENT(IN) :: sd1 , ed1 , sd2 , ed2 , sd3 , ed3 , bdx , bdy
INTEGER, INTENT(OUT) :: sp1 , ep1 , sp2 , ep2 , sp3 , ep3 , & ! z-xpose (std)
sm1 , em1 , sm2 , em2 , sm3 , em3
INTEGER, INTENT(OUT) :: sp1x , ep1x , sp2x , ep2x , sp3x , ep3x , & ! x-xpose
sm1x , em1x , sm2x , em2x , sm3x , em3x
INTEGER, INTENT(OUT) :: sp1y , ep1y , sp2y , ep2y , sp3y , ep3y , & ! y-xpose
sm1y , em1y , sm2y , em2y , sm3y , em3y
INTEGER, INTENT(IN) :: id , parent_id , parent_domdesc
INTEGER, INTENT(INOUT) :: domdesc
TYPE(domain), POINTER :: parent
!local data
INTEGER spec_bdy_width
CALL get_spec_bdy_width( spec_bdy_width )
#ifndef DM_PARALLEL
bdy_mask = .true. ! only one processor so all 4 boundaries are there
! this is a trivial version -- 1 patch per processor;
! use version in module_dm to compute for DM
sp1 = sd1 ; sp2 = sd2 ; sp3 = sd3
ep1 = ed1 ; ep2 = ed2 ; ep3 = ed3
SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
sm1 = sp1 - bdx ; em1 = ep1 + bdx
sm2 = sp2 - bdy ; em2 = ep2 + bdy
sm3 = sp3 ; em3 = ep3
CASE ( DATA_ORDER_YXZ )
sm1 = sp1 - bdy ; em1 = ep1 + bdy
sm2 = sp2 - bdx ; em2 = ep2 + bdx
sm3 = sp3 ; em3 = ep3
CASE ( DATA_ORDER_ZXY )
sm1 = sp1 ; em1 = ep1
sm2 = sp2 - bdx ; em2 = ep2 + bdx
sm3 = sp3 - bdy ; em3 = ep3 + bdy
CASE ( DATA_ORDER_ZYX )
sm1 = sp1 ; em1 = ep1
sm2 = sp2 - bdy ; em2 = ep2 + bdy
sm3 = sp3 - bdx ; em3 = ep3 + bdx
CASE ( DATA_ORDER_XZY )
sm1 = sp1 - bdx ; em1 = ep1 + bdx
sm2 = sp2 ; em2 = ep2
sm3 = sp3 - bdy ; em3 = ep3 + bdy
CASE ( DATA_ORDER_YZX )
sm1 = sp1 - bdy ; em1 = ep1 + bdy
sm2 = sp2 ; em2 = ep2
sm3 = sp3 - bdx ; em3 = ep3 + bdx
END SELECT
sm1x = sm1 ; em1x = em1 ! just copy
sm2x = sm2 ; em2x = em2
sm3x = sm3 ; em3x = em3
sm1y = sm1 ; em1y = em1 ! just copy
sm2y = sm2 ; em2y = em2
sm3y = sm3 ; em3y = em3
! assigns mostly just to suppress warning messages that INTENT OUT vars not assigned
sp1x = sp1 ; ep1x = ep1 ; sp2x = sp2 ; ep2x = ep2 ; sp3x = sp3 ; ep3x = ep3
sp1y = sp1 ; ep1y = ep1 ; sp2y = sp2 ; ep2y = ep2 ; sp3y = sp3 ; ep3y = ep3
#else
! This is supplied by the package specific version of module_dm, which
! is supplied by the external package and copied into the src directory
! when the code is compiled. The cp command will be found in the externals
! target of the configure.wrf file for this architecture. Eg: for RSL
! routine is defined in external/RSL/module_dm.F .
! Note, it would be very nice to be able to pass parent to this routine;
! however, there doesn't seem to be a way to do that in F90. That is because
! to pass a pointer to a domain structure, this call requires an interface
! definition for wrf_dm_patch_domain (otherwise it will try to convert the
! pointer to something). In order to provide an interface definition, we
! would need to either USE module_dm or use an interface block. In either
! case it generates a circular USE reference, since module_dm uses
! module_domain. JM 20020416
CALL wrf_dm_patch_domain( id , domdesc , parent_id , parent_domdesc , &
sd1 , ed1 , sp1 , ep1 , sm1 , em1 , &
sd2 , ed2 , sp2 , ep2 , sm2 , em2 , &
sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
sp1x , ep1x , sm1x , em1x , &
sp2x , ep2x , sm2x , em2x , &
sp3x , ep3x , sm3x , em3x , &
sp1y , ep1y , sm1y , em1y , &
sp2y , ep2y , sm2y , em2y , &
sp3y , ep3y , sm3y , em3y , &
bdx , bdy )
SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
bdy_mask( P_XSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
bdy_mask( P_YSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
bdy_mask( P_XEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
bdy_mask( P_YEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
CASE ( DATA_ORDER_YXZ )
bdy_mask( P_XSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
bdy_mask( P_YSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
bdy_mask( P_XEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
bdy_mask( P_YEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
CASE ( DATA_ORDER_ZXY )
bdy_mask( P_XSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
bdy_mask( P_YSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
bdy_mask( P_XEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
bdy_mask( P_YEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
CASE ( DATA_ORDER_ZYX )
bdy_mask( P_XSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
bdy_mask( P_YSB ) = ( sp2 <= sd2 .AND. sd2 <= ep2 .AND. sp2 <= sd2+spec_bdy_width-1 .AND. sd2+spec_bdy_width-1 <= ep2 )
bdy_mask( P_XEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
bdy_mask( P_YEB ) = ( sp2 <= ed2 .AND. ed2 <= ep2 .AND. sp2 <= ed2-spec_bdy_width-1 .AND. ed2-spec_bdy_width-1 <= ep2 )
CASE ( DATA_ORDER_XZY )
bdy_mask( P_XSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
bdy_mask( P_YSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
bdy_mask( P_XEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
bdy_mask( P_YEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
CASE ( DATA_ORDER_YZX )
bdy_mask( P_XSB ) = ( sp3 <= sd3 .AND. sd3 <= ep3 .AND. sp3 <= sd3+spec_bdy_width-1 .AND. sd3+spec_bdy_width-1 <= ep3 )
bdy_mask( P_YSB ) = ( sp1 <= sd1 .AND. sd1 <= ep1 .AND. sp1 <= sd1+spec_bdy_width-1 .AND. sd1+spec_bdy_width-1 <= ep1 )
bdy_mask( P_XEB ) = ( sp3 <= ed3 .AND. ed3 <= ep3 .AND. sp3 <= ed3-spec_bdy_width-1 .AND. ed3-spec_bdy_width-1 <= ep3 )
bdy_mask( P_YEB ) = ( sp1 <= ed1 .AND. ed1 <= ep1 .AND. sp1 <= ed1-spec_bdy_width-1 .AND. ed1-spec_bdy_width-1 <= ep1 )
END SELECT
#endif
RETURN
END SUBROUTINE wrf_patch_domain
!
! This subroutine is used to ALLOCATE the separate TYPE(domain) space for
! each domain that is required. This routine is called initially from a
! routine after the input information is available. This routine is also
! called during the model run whenever new domains are requested.
! This routine uses the information contained in the MODULE declarations,
! most important of which is the pointer to the head of the linked list
! ("head_grid"). All of the data in the argument list is input that is
! transferred to the domain for permanent storage. The pointers are
! nullified prior to use.
! This routine calls the SUBROUTINE to ALLOCATE the space for each of the
! required meteorological fields, alloc_space_fields.
SUBROUTINE alloc_and_configure_domain ( domain_id , grid , parent, kid ) 10,44
IMPLICIT NONE
! Input data.
INTEGER , INTENT(IN) :: domain_id
TYPE( domain ) , POINTER :: grid
TYPE( domain ) , POINTER :: parent
INTEGER , INTENT(IN) :: kid ! which kid of parent am I?
! Local data.
INTEGER :: sd1 , ed1 , sp1 , ep1 , sm1 , em1
INTEGER :: sd2 , ed2 , sp2 , ep2 , sm2 , em2
INTEGER :: sd3 , ed3 , sp3 , ep3 , sm3 , em3
INTEGER :: sd1x , ed1x , sp1x , ep1x , sm1x , em1x
INTEGER :: sd2x , ed2x , sp2x , ep2x , sm2x , em2x
INTEGER :: sd3x , ed3x , sp3x , ep3x , sm3x , em3x
INTEGER :: sd1y , ed1y , sp1y , ep1y , sm1y , em1y
INTEGER :: sd2y , ed2y , sp2y , ep2y , sm2y , em2y
INTEGER :: sd3y , ed3y , sp3y , ep3y , sm3y , em3y
TYPE(domain) , POINTER :: new_grid
INTEGER :: i
INTEGER :: parent_id , parent_domdesc , new_domdesc
INTEGER :: bdyzone_x , bdyzone_y
! This next step uses information that is listed in the registry as namelist_derived
! to properly size the domain and the patches; this in turn is stored in the new_grid
! data structure
data_ordering : SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
CALL get_s_we( domain_id , sd1 )
CALL get_e_we( domain_id , ed1 )
CALL get_s_sn( domain_id , sd2 )
CALL get_e_sn( domain_id , ed2 )
CALL get_s_vert( domain_id , sd3 )
CALL get_e_vert( domain_id , ed3 )
CASE ( DATA_ORDER_YXZ )
CALL get_s_sn( domain_id , sd1 )
CALL get_e_sn( domain_id , ed1 )
CALL get_s_we( domain_id , sd2 )
CALL get_e_we( domain_id , ed2 )
CALL get_s_vert( domain_id , sd3 )
CALL get_e_vert( domain_id , ed3 )
CASE ( DATA_ORDER_ZXY )
CALL get_s_vert( domain_id , sd1 )
CALL get_e_vert( domain_id , ed1 )
CALL get_s_we( domain_id , sd2 )
CALL get_e_we( domain_id , ed2 )
CALL get_s_sn( domain_id , sd3 )
CALL get_e_sn( domain_id , ed3 )
CASE ( DATA_ORDER_ZYX )
CALL get_s_vert( domain_id , sd1 )
CALL get_e_vert( domain_id , ed1 )
CALL get_s_sn( domain_id , sd2 )
CALL get_e_sn( domain_id , ed2 )
CALL get_s_we( domain_id , sd3 )
CALL get_e_we( domain_id , ed3 )
CASE ( DATA_ORDER_XZY )
CALL get_s_we( domain_id , sd1 )
CALL get_e_we( domain_id , ed1 )
CALL get_s_vert( domain_id , sd2 )
CALL get_e_vert( domain_id , ed2 )
CALL get_s_sn( domain_id , sd3 )
CALL get_e_sn( domain_id , ed3 )
CASE ( DATA_ORDER_YZX )
CALL get_s_sn( domain_id , sd1 )
CALL get_e_sn( domain_id , ed1 )
CALL get_s_vert( domain_id , sd2 )
CALL get_e_vert( domain_id , ed2 )
CALL get_s_we( domain_id , sd3 )
CALL get_e_we( domain_id , ed3 )
END SELECT data_ordering
if ( num_time_levels > 3 ) then
WRITE ( wrf_err_message , * ) 'module_domain: alloc_and_configure_domain: Incorrect value for num_time_levels ', &
num_time_levels
CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
endif
IF (ASSOCIATED(parent)) THEN
parent_id = parent%id
parent_domdesc = parent%domdesc
ELSE
parent_id = -1
parent_domdesc = -1
ENDIF
CALL get_bdyzone_x( bdyzone_x )
CALL get_bdyzone_y( bdyzone_y )
ALLOCATE ( new_grid )
ALLOCATE ( new_grid%parents( max_parents ) )
ALLOCATE ( new_grid%nests( max_nests ) )
ALLOCATE ( new_grid%alarms( ESMF_MAX_ALARMS ) )
NULLIFY( new_grid%sibling )
DO i = 1, max_nests
NULLIFY( new_grid%nests(i)%ptr )
ENDDO
NULLIFY (new_grid%next)
NULLIFY (new_grid%same_level)
NULLIFY (new_grid%i_start)
NULLIFY (new_grid%j_start)
NULLIFY (new_grid%i_end)
NULLIFY (new_grid%j_end)
! set up the pointers that represent the nest hierarchy
! set this up *prior* to calling the patching or allocation
! routines so that implementations of these routines can
! traverse the nest hierarchy (through the root head_grid)
! if they need to
IF ( domain_id .NE. 1 ) THEN
new_grid%parents(1)%ptr => parent
new_grid%num_parents = 1
parent%nests(kid)%ptr => new_grid
new_grid%child_of_parent(1) = kid ! note assumption that nest can have only 1 parent
parent%num_nests = parent%num_nests + 1
END IF
new_grid%id = domain_id ! this needs to be assigned prior to calling wrf_patch_domain
CALL wrf_patch_domain( domain_id , new_domdesc , parent, parent_id, parent_domdesc , &
sd1 , ed1 , sp1 , ep1 , sm1 , em1 , & ! z-xpose dims
sd2 , ed2 , sp2 , ep2 , sm2 , em2 , & ! (standard)
sd3 , ed3 , sp3 , ep3 , sm3 , em3 , &
sp1x , ep1x , sm1x , em1x , & ! x-xpose dims
sp2x , ep2x , sm2x , em2x , &
sp3x , ep3x , sm3x , em3x , &
sp1y , ep1y , sm1y , em1y , & ! y-xpose dims
sp2y , ep2y , sm2y , em2y , &
sp3y , ep3y , sm3y , em3y , &
bdyzone_x , bdyzone_y , new_grid%bdy_mask &
)
new_grid%domdesc = new_domdesc
new_grid%num_nests = 0
new_grid%num_siblings = 0
new_grid%num_parents = 0
new_grid%max_tiles = 0
new_grid%num_tiles_spec = 0
write(0,*)'calling alloc_space_field in module_domain'
CALL alloc_space_field ( new_grid, domain_id , &
sd1, ed1, sd2, ed2, sd3, ed3, &
sm1, em1, sm2, em2, sm3, em3, &
sm1x, em1x, sm2x, em2x, sm3x, em3x, & ! x-xpose
sm1y, em1y, sm2y, em2y, sm3y, em3y & ! y-xpose
)
write(0,*)'back from alloc_space_field in module_domain'
new_grid%sd31 = sd1
new_grid%ed31 = ed1
new_grid%sp31 = sp1
new_grid%ep31 = ep1
new_grid%sm31 = sm1
new_grid%em31 = em1
new_grid%sd32 = sd2
new_grid%ed32 = ed2
new_grid%sp32 = sp2
new_grid%ep32 = ep2
new_grid%sm32 = sm2
new_grid%em32 = em2
new_grid%sd33 = sd3
new_grid%ed33 = ed3
new_grid%sp33 = sp3
new_grid%ep33 = ep3
new_grid%sm33 = sm3
new_grid%em33 = em3
new_grid%sp31x = sp1x
new_grid%ep31x = ep1x
new_grid%sm31x = sm1x
new_grid%em31x = em1x
new_grid%sp32x = sp2x
new_grid%ep32x = ep2x
new_grid%sm32x = sm2x
new_grid%em32x = em2x
new_grid%sp33x = sp3x
new_grid%ep33x = ep3x
new_grid%sm33x = sm3x
new_grid%em33x = em3x
new_grid%sp31y = sp1y
new_grid%ep31y = ep1y
new_grid%sm31y = sm1y
new_grid%em31y = em1y
new_grid%sp32y = sp2y
new_grid%ep32y = ep2y
new_grid%sm32y = sm2y
new_grid%em32y = em2y
new_grid%sp33y = sp3y
new_grid%ep33y = ep3y
new_grid%sm33y = sm3y
new_grid%em33y = em3y
SELECT CASE ( model_data_order )
CASE ( DATA_ORDER_XYZ )
new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
new_grid%em21 = em1 ; new_grid%em22 = em2 ;
new_grid%sd11 = sd1
new_grid%ed11 = ed1
new_grid%sp11 = sp1
new_grid%ep11 = ep1
new_grid%sm11 = sm1
new_grid%em11 = em1
CASE ( DATA_ORDER_YXZ )
new_grid%sd21 = sd1 ; new_grid%sd22 = sd2 ;
new_grid%ed21 = ed1 ; new_grid%ed22 = ed2 ;
new_grid%sp21 = sp1 ; new_grid%sp22 = sp2 ;
new_grid%ep21 = ep1 ; new_grid%ep22 = ep2 ;
new_grid%sm21 = sm1 ; new_grid%sm22 = sm2 ;
new_grid%em21 = em1 ; new_grid%em22 = em2 ;
new_grid%sd11 = sd1
new_grid%ed11 = ed1
new_grid%sp11 = sp1
new_grid%ep11 = ep1
new_grid%sm11 = sm1
new_grid%em11 = em1
CASE ( DATA_ORDER_ZXY )
new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
new_grid%em21 = em2 ; new_grid%em22 = em3 ;
new_grid%sd11 = sd2
new_grid%ed11 = ed2
new_grid%sp11 = sp2
new_grid%ep11 = ep2
new_grid%sm11 = sm2
new_grid%em11 = em2
CASE ( DATA_ORDER_ZYX )
new_grid%sd21 = sd2 ; new_grid%sd22 = sd3 ;
new_grid%ed21 = ed2 ; new_grid%ed22 = ed3 ;
new_grid%sp21 = sp2 ; new_grid%sp22 = sp3 ;
new_grid%ep21 = ep2 ; new_grid%ep22 = ep3 ;
new_grid%sm21 = sm2 ; new_grid%sm22 = sm3 ;
new_grid%em21 = em2 ; new_grid%em22 = em3 ;
new_grid%sd11 = sd2
new_grid%ed11 = ed2
new_grid%sp11 = sp2
new_grid%ep11 = ep2
new_grid%sm11 = sm2
new_grid%em11 = em2
CASE ( DATA_ORDER_XZY )
new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
new_grid%em21 = em1 ; new_grid%em22 = em3 ;
new_grid%sd11 = sd1
new_grid%ed11 = ed1
new_grid%sp11 = sp1
new_grid%ep11 = ep1
new_grid%sm11 = sm1
new_grid%em11 = em1
CASE ( DATA_ORDER_YZX )
new_grid%sd21 = sd1 ; new_grid%sd22 = sd3 ;
new_grid%ed21 = ed1 ; new_grid%ed22 = ed3 ;
new_grid%sp21 = sp1 ; new_grid%sp22 = sp3 ;
new_grid%ep21 = ep1 ; new_grid%ep22 = ep3 ;
new_grid%sm21 = sm1 ; new_grid%sm22 = sm3 ;
new_grid%em21 = em1 ; new_grid%em22 = em3 ;
new_grid%sd11 = sd1
new_grid%ed11 = ed1
new_grid%sp11 = sp1
new_grid%ep11 = ep1
new_grid%sm11 = sm1
new_grid%em11 = em1
END SELECT
CALL med_add_config_info_to_grid ( new_grid ) ! this is a mediation layer routine
! Some miscellaneous state that is in the Registry but not namelist data
new_grid%tiled = .false.
new_grid%patched = .false.
NULLIFY(new_grid%mapping)
! This next set of includes causes all but the namelist_derived variables to be
! properly assigned to the new_grid record
grid => new_grid
#ifdef DM_PARALLEL
CALL wrf_get_dm_communicator ( grid%communicator )
CALL wrf_dm_define_comms( grid )
#endif
END SUBROUTINE alloc_and_configure_domain
!
! This routine ALLOCATEs the required space for the meteorological fields
! for a specific domain. The fields are simply ALLOCATEd as an -1. They
! are referenced as wind, temperature, moisture, etc. in routines that are
! below this top-level of data allocation and management (in the solve routine
! and below).
SUBROUTINE alloc_space_field ( grid, id, & 2,12
sd31, ed31, sd32, ed32, sd33, ed33, &
sm31 , em31 , sm32 , em32 , sm33 , em33 , &
sm31x, em31x, sm32x, em32x, sm33x, em33x, &
sm31y, em31y, sm32y, em32y, sm33y, em33y )
USE module_configure
IMPLICIT NONE
! Input data.
TYPE(domain) , POINTER :: grid
INTEGER , INTENT(IN) :: id
INTEGER , INTENT(IN) :: sd31, ed31, sd32, ed32, sd33, ed33
INTEGER , INTENT(IN) :: sm31, em31, sm32, em32, sm33, em33
INTEGER , INTENT(IN) :: sm31x, em31x, sm32x, em32x, sm33x, em33x
INTEGER , INTENT(IN) :: sm31y, em31y, sm32y, em32y, sm33y, em33y
! Local data.
INTEGER dyn_opt, idum1, idum2, spec_bdy_width
INTEGER num_bytes_allocated
REAL initial_data_value
CHARACTER (LEN=256) message
!declare ierr variable for error checking ALLOCATE calls
INTEGER ierr
INTEGER :: loop
CALL get_initial_data_value ( initial_data_value )
CALL get_dyn_opt( dyn_opt )
CALL get_spec_bdy_width( spec_bdy_width )
CALL set_scalar_indices_from_config( id , idum1 , idum2 )
num_bytes_allocated = 0
IF ( .FALSE. ) THEN
#if (EM_CORE == 1)
ELSE IF ( dyn_opt == DYN_EM ) THEN
CALL wrf_message ( 'DYNAMICS OPTION: Eulerian Mass Coordinate ')
# include <em_allocs.inc>
#endif
#if (SLT_CORE == 1)
ELSE IF ( dyn_opt == DYN_SLT ) THEN
CALL wrf_message ( 'DYNAMICS OPTION: semi-Implicit SLT' )
# include <slt_allocs.inc>
#endif
#if (NMM_CORE == 1)
ELSE IF ( dyn_opt == DYN_NMM ) THEN
CALL wrf_message ( 'DYNAMICS OPTION: nmm dyncore' )
# include <nmm_allocs.inc>
#endif
#if (GRAPS_CORE == 1)
ELSE IF ( dyn_opt == DYN_GRAPS ) THEN
CALL wrf_message ( 'DYNAMICS OPTION: graps dyncore' )
# include <graps_allocs.inc>
#endif
#if (COAMPS_CORE == 1)
ELSE IF ( dyn_opt == DYN_COAMPS ) THEN
CALL wrf_message ( 'DYNAMICS OPTION: coamps dyncore' )
# include <coamps_allocs.inc>
#endif
!### 13. Edit frame/module_domain.F to add case for DYN_EXP to
!### alloc_space_field. (This is a bug;
!### one should never have to edit the framework code; will fix this in
!### coming versions). Same goes for share/start_domain.F, although this
!### is not a framework routine.
#if (EXP_CORE==1)
ELSE IF ( dyn_opt == DYN_EXP ) THEN
CALL wrf_message ( 'DYNAMICS OPTION: experimental dyncore' )
# include <exp_allocs.inc>
#endif
ELSE
WRITE( wrf_err_message , * )'Invalid specification of dynamics: dyn_opt = ',dyn_opt
CALL wrf_error_fatal ( TRIM ( wrf_err_message ) )
ENDIF
WRITE(message,*)'alloc_space_field: domain ',id,' ',num_bytes_allocated
CALL wrf_message( message )
END SUBROUTINE alloc_space_field
!
! This routine is used to DEALLOCATE space for a single domain. First
! the pointers in the linked list are fixed (so the one in the middle can
! be removed). Second, the field data are all removed through a CALL to
! the dealloc_space_domain routine. Finally, the pointer to the domain
! itself is DEALLOCATEd.
SUBROUTINE dealloc_space_domain ( id ),2
IMPLICIT NONE
! Input data.
INTEGER , INTENT(IN) :: id
! Local data.
TYPE(domain) , POINTER :: grid
LOGICAL :: found
! Initializations required to start the routine.
grid => head_grid
old_grid => head_grid
found = .FALSE.
! The identity of the domain to delete is based upon the "id".
! We search all of the possible grids. It is required to find a domain
! otherwise it is a fatal error.
find_grid : DO WHILE ( ASSOCIATED(grid) )
IF ( grid%id == id ) THEN
found = .TRUE.
old_grid%next => grid%next
CALL dealloc_space_field ( grid )
DEALLOCATE(grid)
EXIT find_grid
END IF
old_grid => grid
grid => grid%next
END DO find_grid
IF ( .NOT. found ) THEN
WRITE ( wrf_err_message , * ) 'module_domain: dealloc_space_domain: Could not de-allocate grid id ',id
CALL wrf_error_fatal ( TRIM( wrf_err_message ) )
END IF
END SUBROUTINE dealloc_space_domain
!
! This routine DEALLOCATEs each gridded field for this domain. For each type of
! different array (1d, 2d, 3d, etc.), the space for each pointer is DEALLOCATEd
! for every -1 (i.e., each different meteorological field).
SUBROUTINE dealloc_space_field ( grid ) 1
IMPLICIT NONE
! Input data.
TYPE(domain) , POINTER :: grid
! Local data.
INTEGER :: loop
END SUBROUTINE dealloc_space_field
!
!
RECURSIVE SUBROUTINE find_grid_by_id ( id, in_grid, result_grid ) 3,1
IMPLICIT NONE
INTEGER, INTENT(IN) :: id
TYPE(domain), POINTER :: in_grid
TYPE(domain), POINTER :: result_grid
TYPE(domain), POINTER :: grid_ptr
INTEGER :: kid
LOGICAL :: found
found = .FALSE.
IF ( ASSOCIATED( in_grid ) ) THEN
IF ( in_grid%id .EQ. id ) THEN
result_grid => in_grid
ELSE
grid_ptr => in_grid
DO WHILE ( ASSOCIATED( grid_ptr ) .AND. .NOT. found )
DO kid = 1, max_nests
IF ( ASSOCIATED( grid_ptr%nests(kid)%ptr ) .AND. .NOT. found ) THEN
CALL find_grid_by_id ( id, grid_ptr%nests(kid)%ptr, result_grid )
IF ( ASSOCIATED( result_grid ) ) THEN
IF ( result_grid%id .EQ. id ) found = .TRUE.
ENDIF
ENDIF
ENDDO
IF ( .NOT. found ) grid_ptr => grid_ptr%sibling
ENDDO
ENDIF
ENDIF
RETURN
END SUBROUTINE find_grid_by_id
! This routine is used to find a specific domain identifier in an array
! of domain identifiers.
FUNCTION first_loc_integer ( array , search ) RESULT ( loc )
IMPLICIT NONE
! Input data.
INTEGER , INTENT(IN) , DIMENSION(:) :: array
INTEGER , INTENT(IN) :: search
! Output data.
INTEGER :: loc
! Local data.
INTEGER :: loop
loc = -1
find : DO loop = 1 , SIZE(array)
IF ( search == array(loop) ) THEN
loc = loop
EXIT find
END IF
END DO find
END FUNCTION first_loc_integer
!
SUBROUTINE init_module_domain 1
END SUBROUTINE init_module_domain
END MODULE module_domain