Skip to content
This repository was archived by the owner on Oct 23, 2020. It is now read-only.

Commit aa40163

Browse files
mgdudamgduda
committed
Merge branch 'framework/duplicate_attlist' into develop
This merge adds routines to duplicate an individual attribute list, making a copy of every attribute within the attribute list. Additionally, this merge updates the duplicate field routines to also duplicate all attributes attached to the field. Finally, tests are added to the test core for duplicating attribute lists. * framework/duplicate_attlist: Add field tests module and attribute lists test routine Update duplicate field routines to duplicate attribute lists Add routine to duplicate attribute lists
2 parents 9020bdc + aba723b commit aa40163

File tree

7 files changed

+261
-16
lines changed

7 files changed

+261
-16
lines changed

‎src/core_test/Makefile

Lines changed: 4 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
11
.SUFFIXES: .F .o
22

3-
OBJS = mpas_test_core.o mpas_test_core_interface.o mpas_test_core_halo_exch.o mpas_test_core_streams.o
3+
OBJS = mpas_test_core.o mpas_test_core_interface.o mpas_test_core_halo_exch.o mpas_test_core_streams.o mpas_test_core_field_tests.o
44

55
all: core_test
66

@@ -27,10 +27,12 @@ post_build:
2727

2828
mpas_test_core_interface: mpas_test_core.o
2929

30-
mpas_test_core.o: mpas_test_core_halo_exch.o mpas_test_core_streams.o
30+
mpas_test_core.o: mpas_test_core_halo_exch.o mpas_test_core_streams.o mpas_test_core_field_tests.o
3131

3232
mpas_test_core_halo_exch.o:
3333

34+
mpas_test_core_field_tests.o:
35+
3436
clean:
3537
$(RM) *.o *.mod *.f90 libdycore.a
3638
$(RM) Registry_processed.xml

‎src/core_test/mpas_test_core.F

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ module test_core
1111
use mpas_timekeeping
1212

1313
use test_core_halo_exch
14+
use test_core_field_tests
1415
use mpas_stream_manager
1516

1617
type (MPAS_Clock_type), pointer :: clock
@@ -122,6 +123,14 @@ function test_core_run(domain) result(iErr)!{{{
122123
write(stderrUnit, *) ' * Halo Exchange Test: FAILURE'
123124
end if
124125

126+
!$omp parallel default(firstprivate) shared(domain, threadErrs)
127+
call test_core_test_fields(domain, threadErrs, ierr)
128+
if ( iErr == 0 ) then
129+
write(stderrUnit, *) ' * Field Tests: SUCCESS'
130+
else
131+
write(stderrUnit, *) ' * Field Tests: FAILURE'
132+
end if !$omp end parallel
133+
125134
call test_core_streams_test(domain, threadErrs, iErr)
126135
if ( iErr == 0 ) then
127136
write(stderrUnit, *) 'Stream I/O tests: SUCCESS'

‎src/core_test/mpas_test_core_field_tests.F

Lines changed: 164 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,164 @@
1+
! Copyright (c) 2013, Los Alamos National Security, LLC (LANS)
2+
! and the University Corporation for Atmospheric Research (UCAR).
3+
!
4+
! Unless noted otherwise source code is licensed under the BSD license.
5+
! Additional copyright and license information can be found in the LICENSE file
6+
! distributed with this code, or at http://mpas-dev.github.com/license.html
7+
!
8+
9+
!#define HALO_EXCH_DEBUG
10+
11+
module test_core_field_tests
12+
13+
use mpas_derived_types
14+
use mpas_pool_routines
15+
use mpas_field_routines
16+
use mpas_dmpar
17+
use mpas_threading
18+
use mpas_io_units
19+
use mpas_timer
20+
use mpas_attlist
21+
22+
implicit none
23+
private
24+
25+
public :: test_core_test_fields
26+
27+
contains
28+
29+
!***********************************************************************
30+
!
31+
! routine test_core_test_fields
32+
!
33+
!> \brief MPAS Test Core field tests routine
34+
!> \author Doug Jacobsen
35+
!> \date 04/26/2016
36+
!> \details
37+
!> This routine performs tests related to field types.
38+
!
39+
!-----------------------------------------------------------------------
40+
subroutine test_core_test_fields(domain, threadErrs, err)!{{{
41+
42+
type (domain_type), intent(inout) :: domain
43+
integer, dimension(:), intent(out) :: threadErrs
44+
integer, intent(out) :: err
45+
46+
integer :: threadNum
47+
integer :: iErr
48+
49+
err = 0
50+
51+
threadNum = mpas_threading_get_thread_num()
52+
53+
call mpas_timer_start('field tests')
54+
if ( threadNum == 0 ) then
55+
write(stderrUnit, *) ' - Performing attribute list tests'
56+
end if
57+
call test_core_attribute_list_test(domain, threadErrs, iErr)
58+
call mpas_threading_barrier()
59+
if ( threadNum == 0 ) then
60+
write(stderrUnit, *) ' -- Return code: ', iErr
61+
err = ior(err, iErr)
62+
end if
63+
64+
call mpas_timer_stop('field tests')
65+
66+
end subroutine test_core_test_fields!}}}
67+
68+
!***********************************************************************
69+
!
70+
! routine test_core_attribute_list_test
71+
!
72+
!> \brief MPAS Test Core attribute list tests routine
73+
!> \author Doug Jacobsen
74+
!> \date 04/26/2016
75+
!> \details
76+
!> This routine performs tests of attribute lists.
77+
!
78+
!-----------------------------------------------------------------------
79+
subroutine test_core_attribute_list_test(domain, threadErrs, ierr)!{{{
80+
type (domain_type), intent(inout) :: domain
81+
integer, dimension(:), intent(out) :: threadErrs
82+
integer, intent(out) :: ierr
83+
84+
type ( att_list_type ), pointer :: srcList, destList
85+
integer :: srcInt, destInt
86+
integer, dimension(:), pointer :: srcIntA, destIntA
87+
real (kind=RKIND) :: srcReal, destReal
88+
real (kind=RKIND), dimension(:), pointer :: srcRealA, destRealA
89+
character (len=StrKIND) :: srcText, destText
90+
91+
integer :: threadNum
92+
93+
iErr = 0
94+
95+
threadNum = mpas_threading_get_thread_num()
96+
97+
if ( threadNum == 0 ) then
98+
allocate(srcList)
99+
nullify(destList)
100+
101+
allocate(srcIntA(3))
102+
allocate(srcRealA(5))
103+
104+
srcInt = 3
105+
srcIntA(:) = 4
106+
srcReal = 5.0_RKIND
107+
srcRealA(:) = 6.0_RKIND
108+
srcText = 'testingString'
109+
110+
call mpas_add_att(srcList, 'testInt', srcInt)
111+
call mpas_add_att(srcList, 'testIntA', srcIntA)
112+
call mpas_add_att(srcList, 'testReal', srcReal)
113+
call mpas_add_att(srcList, 'testRealA', srcRealA)
114+
call mpas_add_att(srcList, 'testText', srcText)
115+
116+
call mpas_duplicate_attlist(srcList, destList)
117+
118+
call mpas_get_att(destList, 'testInt', destInt)
119+
call mpas_get_att(destList, 'testIntA', destIntA)
120+
call mpas_get_att(destList, 'testReal', destReal)
121+
call mpas_get_att(destList, 'testRealA', destRealA)
122+
call mpas_get_att(destList, 'testText', destText)
123+
124+
destIntA(:) = destIntA(:) - srcIntA(:)
125+
destRealA(:) = destRealA(:) - srcRealA(:)
126+
127+
if ( srcInt /= destInt ) then
128+
threadErrs( threadNum ) = 1
129+
write(stderrUnit, *) ' ERROR: Duplicate int does not match'
130+
end if
131+
132+
if ( sum(destIntA) /= 0 ) then
133+
threadErrs( threadNum ) = 1
134+
write(stderrUnit, *) ' ERROR: Duplicate int array does not match'
135+
end if
136+
137+
if ( srcReal /= destReal ) then
138+
threadErrs( threadNum ) = 1
139+
write(stderrUnit, *) ' ERROR: Duplicate real does not match'
140+
end if
141+
142+
if ( sum(destRealA) /= 0.0_RKIND ) then
143+
threadErrs( threadNum ) = 1
144+
write(stderrUnit, *) ' ERROR: Duplicate real array does not match'
145+
end if
146+
147+
if ( trim(srcText) /= trim(destText) ) then
148+
threadErrs( threadNum ) = 1
149+
write(stderrUnit, *) ' ERROR: Duplicate string does not match'
150+
end if
151+
152+
call mpas_deallocate_attlist(srcList)
153+
call mpas_deallocate_attlist(destList)
154+
end if
155+
156+
call mpas_threading_barrier()
157+
158+
if ( sum(threadErrs) /= 0 ) then
159+
iErr = 1
160+
end if
161+
162+
end subroutine test_core_attribute_list_test!}}}
163+
164+
end module test_core_field_tests

‎src/framework/duplicate_field_array.inc

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,16 @@
5656
else
5757
nullify(dst_cursor % array)
5858
end if
59+
60+
if ( associated(dst_cursor % attLists) ) then
61+
deallocate(dst_cursor % attLists)
62+
end if
63+
64+
allocate(dst_cursor % attLists( size(src_cursor % attLists) ) )
65+
66+
do iConstituent = 1, size(src_cursor % attLists)
67+
call mpas_duplicate_attlist(src_cursor % attLists(iConstituent) % attList, dst_cursor % attLists(iConstituent) % attList)
68+
end do
5969
end if
6070
if ( dst_cursor % isActive .and. src_cursor % isActive ) then
6171
dst_cursor % array = src_cursor % array

‎src/framework/duplicate_field_scalar.inc

Lines changed: 11 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -44,11 +44,21 @@
4444
dst_cursor % sendList => src_cursor % sendList
4545
dst_cursor % recvList => src_cursor % recvList
4646
dst_cursor % copyList => src_cursor % copyList
47+
48+
if ( associated(dst_cursor % attLists) ) then
49+
deallocate(dst_cursor % attLists)
50+
end if
51+
52+
allocate(dst_cursor % attLists( size(src_cursor % attLists) ) )
53+
54+
do iConstituent = 1, size(src_cursor % attLists)
55+
call mpas_duplicate_attlist(src_cursor % attLists(iConstituent) % attList, dst_cursor % attLists(iConstituent) % attList)
56+
end do
4757
end if
4858
if ( dst_cursor % isActive .and. src_cursor % isActive ) then
4959
dst_cursor % scalar = src_cursor % scalar
5060
end if
51-
61+
5262
! src_cursor => src_cursor % next
5363
! if (.not. local_copy_only) then
5464
! dst_cursor => dst_cursor % next

‎src/framework/mpas_attlist.F

Lines changed: 50 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -460,6 +460,56 @@ subroutine mpas_get_att_text(attList, attName, attValue, ierr)!{{{
460460

461461
end subroutine mpas_get_att_text!}}}
462462

463+
!***********************************************************************
464+
!
465+
! routine mpas_duplicate_attlist
466+
!
467+
!> \brief MPAS duplicate attribute list routine
468+
!> \author Doug Jacobsen
469+
!> \date 04/26/2016
470+
!> \details
471+
!> This routine creates a copy of an attribute list, and returns it as destAttList.
472+
!> This routine assumes that destAttList is empty, however it will remove every
473+
!> attribute from destAttList before it attempts to copy into it.
474+
!
475+
!-----------------------------------------------------------------------
476+
subroutine mpas_duplicate_attlist(srcAttList, destAttList, ierr)!{{{
477+
478+
implicit none
479+
480+
type ( att_list_type ), pointer :: srcAttList !< Input: Source attribute list
481+
type ( att_list_type ), pointer :: destAttList !< Output: Destination attribute list
482+
integer, intent(out), optional :: ierr !< Optional Output: Error code
483+
484+
type ( att_list_type ), pointer :: srcCursor
485+
486+
if ( present(ierr) ) ierr = 0
487+
488+
if ( associated(destAttList) ) then
489+
call mpas_deallocate_attlist(destAttList)
490+
end if
491+
492+
allocate(destAttList)
493+
494+
srcCursor => srcAttList
495+
do while ( associated(srcCursor) )
496+
if ( srcCursor % attType == MPAS_ATT_INT ) then
497+
call mpas_add_att(destAttList, srcCursor % attName, srcCursor % attValueInt)
498+
else if ( srcCursor % attType == MPAS_ATT_INTA ) then
499+
call mpas_add_att(destAttList, srcCursor % attName, srcCursor % attValueIntA)
500+
else if ( srcCursor % attType == MPAS_ATT_REAL ) then
501+
call mpas_add_att(destAttList, srcCursor % attName, srcCursor % attValueReal)
502+
else if ( srcCursor % attType == MPAS_ATT_REALA ) then
503+
call mpas_add_att(destAttList, srcCursor % attName, srcCursor % attValueRealA)
504+
else if ( srcCursor % attType == MPAS_ATT_TEXT ) then
505+
call mpas_add_att(destAttList, srcCursor % attName, srcCursor % attValueText)
506+
end if
507+
508+
srcCursor => srcCursor % next
509+
end do
510+
511+
end subroutine mpas_duplicate_attlist!}}}
512+
463513
!***********************************************************************
464514
!
465515
! routine mpas_remove_att

0 commit comments

Comments
 (0)