-
Notifications
You must be signed in to change notification settings - Fork 1
/
m_AttrVect.F90
4114 lines (3334 loc) · 135 KB
/
m_AttrVect.F90
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Math and Computer Science Division, Argonne National Laboratory !
!-----------------------------------------------------------------------
! CVS $Id$
! CVS $Name$
!BOP -------------------------------------------------------------------
!
! !MODULE: m_AttrVect - Multi-field Storage
!
! !DESCRIPTION:
!
! An {\em attribute vector} is a scheme for storing bundles of integer
! and real data vectors, indexed by the names of the fields stored in
! {\tt List} format (see the mpeu module {\tt m\_List} for more
! information about the {\tt List} datatype). The ordering of the
! fieldnames in the integer and real attribute {\tt List} components
! ({\tt AttrVect\%iList} and {\tt AttrVect\%rList}, respectively)
! corresponds to the storage order of the attributes in their respective
! data buffers (the components {\tt AttrVect\%iAttr(:,:)} and
! {\tt AttrVect\%rAttr(:,:)}, respectively). The organization of
! the fieldnames in {\tt List} format, along with the direct mapping
! between {\tt List} items and locations in the data buffer, allows
! the user to have {\em random access} to the field data. This
! approach also allows the user to set the number and the names of fields
! stored in an {\tt AttrVect} at run-time.
!
! The {\tt AttrVect} stores field data in a {\em pointwise} fashion
! (that is, the data are grouped so that all the integer or real data
! associated with an individual point are adjacent to each other in memory.
! This amounts to the having the integer and real field data arrays in
! the {\tt AttrVect} (the components {\tt AttrVect\%iAttr(:,:)} and
! {\tt AttrVect\%rAttr(:,:)}, respectively) having the attribute index
! as the major (or fastest-varying) index. A prime example of this is
! observational data input to a data assimilation system. In the Model
! Coupling Toolkit, this datatype is the fundamental type for storing
! field data exchanged by component models, and forms a basis for other
! MCT datatypes that encapsulate time accumulation/averaging buffers (the
! {\tt Accumulator} datatype defined in the module {\tt m\_Accumulator}),
! coordinate grid information (the {\tt GeneralGrid} datatype defined in
! the module {\tt m\_GeneralGrid}), and sparse interpolation matrices
! (the {\tt SparseMatrix} datatype defined in the module
! {\tt m\_SparseMatrix}).
!
! The attribute vector is implemented in Fortran 90 using the
! {\tt AttrVect} derived type. This module contains the definition
! of the {\tt AttrVect}, and the numerous methods that service it. There
! are a number of initialization (creation) schemes, and a routine for
! zeroing out the elements of an {\tt AttrVect}. There is a method
! to {\em clean} up allocated memory used by an {\tt AttrVect}
! (destruction). There are numerous query methods that return: the
! number of datapoints (or {\em length}; the numbers of integer and
! real attributes; the data buffer index of a given real or integer
! attribute; and return the lists of real and integer attributes. There
! also exist methods for exporting a given attribute as a one-dimensional
! array and importing a given attribute from a one-dimensional array.
! There is a method for copying attributes from one {\tt AttrVect} to
! another. There is also a method for cross-indexing the attributes in
! two {\tt AttrVect} variables. In addition, there are methods that
! return those cross-indexed attributes along with some auxiliary data
! in a {\tt AVSharedIndicesOneType} or {\tt AVSharedIndices} structure.
! Finally, there are methods for sorting and permuting {\tt AttrVect}
! entries using a MergeSort scheme keyed by the attributes of the {\tt
! AttrVect}.
!
! !INTERFACE:
module m_AttrVect
!
! !USES:
!
use m_realkinds,only : SP,DP,FP ! Real types definitions
use m_List, only : List ! Support for rList and iList components.
implicit none
private ! except
! !PUBLIC TYPES:
public :: AttrVect ! The class data structure
public :: AVSharedIndicesOneType ! Data structure recording shared indices between
! two attribute vectors, for a single data type
! (e.g., shared real attributes)
public :: AVSharedIndices ! Data structure recording shared indices between two
! attribute vectors, for all data types
type AttrVect
#ifdef SEQUENCE
sequence
#endif
type(List) :: iList
type(List) :: rList
integer,dimension(:,:),pointer :: iAttr
real(FP) ,dimension(:,:),pointer :: rAttr
end type AttrVect
type AVSharedIndicesOneType
integer :: num_indices ! number of shared items
logical :: contiguous ! true if index segments are contiguous in memory
character*7 :: data_flag ! data type flag (e.g., 'REAL' or 'INTEGER')
! arrays of indices to storage locations of shared attributes between the two
! attribute vectors:
integer, dimension(:), pointer :: aVindices1
integer, dimension(:), pointer :: aVindices2
end type AVSharedIndicesOneType
type AVSharedIndices
type(AVSharedIndicesOneType) :: shared_real ! shared indices of type REAL
type(AVSharedIndicesOneType) :: shared_integer ! shared indices of type INTEGER
end type AVSharedIndices
! !PUBLIC MEMBER FUNCTIONS:
public :: init ! create a local vector
public :: clean ! clean the local vector
public :: zero ! zero the local vector
public :: lsize ! size of the local vector
public :: nIAttr ! number of integer attributes on local
public :: nRAttr ! number of real attributes on local
public :: indexIA ! index the integer attributes
public :: indexRA ! index the real attributes
public :: getIList ! return list of integer attributes
public :: getRList ! return list of real attributes
public :: exportIList ! export INTEGER attibute List
public :: exportRList ! export REAL attibute List
public :: exportIListToChar ! export INTEGER attibute List as Char
public :: exportRListToChar ! export REAL attibute List as Char
public :: appendIAttr ! append INTEGER attribute List
public :: appendRAttr ! append REAL attribute List
public :: exportIAttr ! export INTEGER attribute to vector
public :: exportRAttr ! export REAL attribute to vector
public :: importIAttr ! import INTEGER attribute from vector
public :: importRAttr ! import REAL attribute from vector
public :: Copy ! copy attributes from one Av to another
public :: RCopy ! copy real attributes from one Av to another
public :: ICopy ! copy integer attributes from one Av to another
!-------------------added by Ma---------------------
public :: Add
!---------------------------------------------------
public :: Sort ! sort entries, and return permutation
public :: Permute ! permute entries
public :: Unpermute ! Unpermute entries
public :: SortPermute ! sort and permute entries
public :: SharedAttrIndexList ! Cross-indices of shared
! attributes of two AttrVects
public :: SharedIndices ! Given two AttrVects, create an AVSharedIndices structure
public :: SharedIndicesOneType ! Given two AttrVects, create an
! AVSharedIndicesOneType structure for a single type
public :: cleanSharedIndices ! clean a AVSharedIndices structure
public :: cleanSharedIndicesOneType ! clean a AVSharedIndicesOneType structure
interface init ; module procedure &
init_, &
initv_, &
initl_
end interface
interface clean ; module procedure clean_ ; end interface
interface zero ; module procedure zero_ ; end interface
interface lsize ; module procedure lsize_ ; end interface
interface nIAttr ; module procedure nIAttr_ ; end interface
interface nRAttr ; module procedure nRAttr_ ; end interface
interface indexIA; module procedure indexIA_; end interface
interface indexRA; module procedure indexRA_; end interface
interface getIList; module procedure getIList_; end interface
interface getRList; module procedure getRList_; end interface
interface exportIList; module procedure exportIList_; end interface
interface exportRList; module procedure exportRList_; end interface
interface exportIListToChar
module procedure exportIListToChar_
end interface
interface exportRListToChar
module procedure exportRListToChar_
end interface
interface appendIAttr ; module procedure appendIAttr_ ; end interface
interface appendRAttr ; module procedure appendRAttr_ ; end interface
interface exportIAttr; module procedure exportIAttr_; end interface
interface exportRAttr; module procedure &
exportRAttrSP_, &
exportRAttrDP_
end interface
interface importIAttr; module procedure importIAttr_; end interface
interface importRAttr; module procedure &
importRAttrSP_, &
importRAttrDP_
end interface
interface Copy ; module procedure Copy_ ; end interface
interface RCopy ; module procedure &
RCopy_, &
RCopyL_
end interface
interface ICopy ; module procedure &
ICopy_, &
ICopyL_
end interface
!------------------added by Ma-------------------
interface Add ; module procedure Add_ ; end interface
!------------------------------------------------
interface Sort ; module procedure Sort_ ; end interface
interface Permute ; module procedure Permute_ ; end interface
interface Unpermute ; module procedure Unpermute_ ; end interface
interface SortPermute ; module procedure SortPermute_ ; end interface
interface SharedAttrIndexList ; module procedure &
aVaVSharedAttrIndexList_
end interface
interface SharedIndices ; module procedure SharedIndices_ ; end interface
interface SharedIndicesOneType ; module procedure SharedIndicesOneType_ ; end interface
interface cleanSharedIndices ; module procedure cleanSharedIndices_ ; end interface
interface cleanSharedIndicesOneType ; module procedure cleanSharedIndicesOneType_ ; end interface
! !REVISION HISTORY:
! 10Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
! 10Oct00 - J.W. Larson <larson@mcs.anl.gov> - made getIList
! and getRList functions public and added appropriate
! interface definitions
! 20Oct00 - J.W. Larson <larson@mcs.anl.gov> - added Sort,
! Permute, and SortPermute functions.
! 09May01 - J.W. Larson <larson@mcs.anl.gov> - added initl_().
! 19Oct01 - J.W. Larson <larson@mcs.anl.gov> - added routines
! exportIattr(), exportRAttr(), importIAttr(),
! and importRAttr(). Also cleaned up module and
! routine prologues.
! 13Dec01 - J.W. Larson <larson@mcs.anl.gov> - made importIAttr()
! and importRAttr() public (bug fix).
! 14Dec01 - J.W. Larson <larson@mcs.anl.gov> - added exportIList()
! and exportRList().
! 14Feb02 - J.W. Larson <larson@mcs.anl.gov> - added CHARCTER
! functions exportIListToChar() and exportRListToChar()
! 26Feb02 - J.W. Larson <larson@mcs.anl.gov> - corrected of usage
! of m_die routines throughout this module.
! 16Apr02 - J.W. Larson <larson@mcs.anl.gov> - added the method
! LocalReduce(), and the public data members AttrVectSUM,
! AttrVectMIN, and AttrVectMAX.
! 7May02 - J.W. Larson <larson@mcs.anl.gov> - Refactoring. Moved
! LocalReduce() and the public data members AttrVectSUM,
! AttrVectMIN, and AttrVectMAX to a new module named
! m_AttrVectReduce.
! 12Jun02 - R.L. Jacob <jacob@mcs.anl.gov> - add Copy function
! 13Jun02 - R.L. Jacob <jacob@mcs.anl.gov> - move aVavSharedAttrIndexList
! to this module from old m_SharedAttrIndicies
! 28Apr11 - W.J. Sacks <sacks@ucar.edu> - added AVSharedIndices and
! AVSharedIndicesOneType derived types, and associated
! subroutines
! 10Apr12 - W.J. Sacks <sacks@ucar.edu> - modified AVSharedIndices code
! to be Fortran-90 compliant
!EOP ___________________________________________________________________
character(len=*),parameter :: myname='MCT::m_AttrVect'
contains
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Math and Computer Science Division, Argonne National Laboratory !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: init_ - Initialize an AttrVect Given Attribute Lists and Length
!
! !DESCRIPTION:
! This routine creates an {\tt AttrVect} (the output argument {\tt aV})
! using the optional input {\tt CHARACTER} arguments {\tt iList}, and
! {\tt rList} to define its integer and real attributes, respectively.
! The optional input {\tt INTEGER} argument {\tt lsize} defines the
! number of points for which we are storing attributes, or the
! {\em length} of {\tt aV}. The expected form for the arguments
! {\tt iList} and {\tt rList} are colon-delimited strings where each
! substring defines an attribute. Suppose we wish to store {\tt N}
! observations that have the real attributes {\tt 'latitude'},
! {\tt 'longitude'}, {\tt pressure}, {\tt 'u-wind'}, and
! {\tt 'v-wind'}. Suppose we also wish to store the integer
! attributes {\tt 'hour'}, {\tt 'day'}, {\tt 'month'}, {\tt 'year'},
! and {\tt 'data source'}. This can be accomplished by invoking
! {\tt init\_()} as follows:
! \begin{verbatim}
! call init_(aV, 'hour:day:month:year:data source', &
! 'latitude:longitude:pressure:u-wind:v-wind', N)
! \end{verbatim}
! The resulting {\tt AttrVect} {\tt aV} will have five integer
! attributes, five real attributes, and length {\tt N}.
!
! !INTERFACE:
subroutine init_(aV, iList, rList, lsize)
!
! !USES:
!
use m_List, only : List
use m_List, only : init,nitem
use m_List, only : List_nullify => nullify
use m_mall
use m_die
implicit none
! !INPUT PARAMETERS:
!
character(len=*), optional, intent(in) :: iList
character(len=*), optional, intent(in) :: rList
integer, optional, intent(in) :: lsize
! !OUTPUT PARAMETERS:
!
type(AttrVect), intent(out) :: aV
! !REVISION HISTORY:
! 09Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
! 09Oct01 - J.W. Larson <larson@mcs.anl.gov> - added feature to
! nullify all pointers before usage. This was done to
! accomodate behavior of the f90 ASSOCIATED intrinsic
! function on the AIX platform.
! 07Dec01 - E.T. Ong <eong@mcs.anl.gov> - added support for
! intialization with blank character strings for iList
! and rList
!EOP ___________________________________________________________________
!
character(len=*),parameter :: myname_=myname//'::init_'
integer :: nIA,nRA,n,ier
! Initially, nullify all pointers in the AttrVect aV:
nullify(aV%iAttr)
nullify(aV%rAttr)
call List_nullify(aV%iList)
call List_nullify(aV%rList)
if(present(rList)) then
if(len_trim(rList) > 0) then
call init(aV%rList,rList) ! init.List()
endif
endif
if(present(iList)) then
if(len_trim(iList) > 0) then
call init(aV%iList,iList) ! init.List()
endif
endif
nIA=nitem(aV%iList) ! nitem.List()
nRA=nitem(aV%rList) ! nitem.List()
n=0
if(present(lsize)) n=lsize
allocate( aV%iAttr(nIA,n),aV%rAttr(nRA,n), stat=ier)
if(ier /= 0) call die(myname_,'allocate()',ier)
#ifdef MALL_ON
call mall_ci(size(transfer(aV%iAttr,(/1/)),myname_)
call mall_ci(size(transfer(aV%rAttr,(/1/)),myname_)
#endif
end subroutine init_
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Math and Computer Science Division, Argonne National Laboratory !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: initv_ - Initialize One AttrVect from Another
!
! !DESCRIPTION: This routine takes an input {\tt AttrVect} argument
! {\tt bV}, and uses its attribute list information to create an output
! {\tt AttrVect} variable {\tt aV}. The length of {\tt aV} is defined
! by the input {\tt INTEGER} argument {\tt lsize}.
!
! !INTERFACE:
subroutine initv_(aV, bV, lsize)
!
! !USES:
!
use m_String, only : String,char
use m_String, only : String_clean => clean
use m_List, only : get
use m_List, only : List_nullify => nullify
use m_die
use m_stdio
implicit none
! !INPUT PARAMETERS:
!
type(AttrVect),intent(in) :: bV
integer, intent(in) :: lsize
! !OUTPUT PARAMETERS:
!
type(AttrVect),intent(out) :: aV
! !REVISION HISTORY:
! 22Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
! 17May01 - R. Jacob <jacob@mcs.anl.gov> - add a check to see if
! input argument has been defined. SGI will dump
! core if its not.
! 10Oct01 - J. Larson <larson@mcs.anl.gov> - Nullify all pointers
! in ouput AttrVect aV before initializing aV.
! 19Sep08 - J. Wolfe <jwolfe@ucar.edu> - plug memory leak from not deallocating
! strings.
!EOP ___________________________________________________________________
character(len=*),parameter :: myname_=myname//'::initv_'
type(String) :: iLStr,rLStr
! Step One: Nullify all pointers in aV. We will set
! only the pointers we really need for aV based on those
! currently ASSOCIATED in bV.
call List_nullify(aV%iList)
call List_nullify(aV%rList)
nullify(aV%iAttr)
nullify(aV%rAttr)
! Convert the two Lists to two Strings
if(.not.associated(bv%iList%bf) .and. &
.not.associated(bv%rList%bf)) then
write(stderr,'(2a)')myname_, &
'MCTERROR: Trying to initialize a new AttrVect off an undefined AttrVect'
call die(myname_,'undefined input argument',0)
endif
if(associated(bv%iList%bf)) then
call get(iLStr,bv%iList)
endif
if(associated(bv%rList%bf)) then
call get(rLStr,bv%rList)
endif
! Initialize the AttrVect aV depending on which parts of
! the input bV are valid:
if(associated(bv%iList%bf) .and. associated(bv%rList%bf)) then
call init_(aV,iList=char(iLStr),rList=char(rLStr),lsize=lsize)
endif
if(.not.associated(bv%iList%bf) .and. associated(bv%rList%bf)) then
call init_(aV,rList=char(rLStr),lsize=lsize)
endif
if(associated(bv%iList%bf) .and. .not.associated(bv%rList%bf)) then
call init_(aV,iList=char(iLStr),lsize=lsize)
endif
if(associated(bv%iList%bf)) then
call String_clean(iLStr)
endif
if(associated(bv%rList%bf)) then
call String_clean(rLStr)
endif
end subroutine initv_
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Math and Computer Science Division, Argonne National Laboratory !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: initl_ - Initialize an AttrVect Using the List Type
!
! !DESCRIPTION: This routine initializes an {\tt AttrVect} directly
! from input {\tt List} data type arguments {\tt iList} and {\tt rList}
! (see the module {\tt m\_List} in mpeu for further details), and an
! input length {\tt lsize}. The resulting {\tt AttrVect} is returned in
! the argument {\tt aV}.
!
! {\bf N.B.}: If the user supplies an empty list for the arguments
! {\tt iList} ({\tt rList}), then {\tt aV} will be created only with
! {\tt REAL} ({\tt INTEGER}) attributes. If both arguments {\tt iList}
! and {\tt rList} are empty, the routine will terminate execution and
! report an error.
!
! {\bf N.B.}: The outcome of this routine, {\tt aV} represents
! allocated memory. When this {\tt AttrVect} is no longer needed,
! it must be deallocated by invoking the routine {\tt AttrVect\_clean()}.
! Failure to do so will spawn a memory leak.
!
! !INTERFACE:
subroutine initl_(aV, iList, rList, lsize)
!
! !USES:
!
use m_die
use m_stdio
use m_String, only : String
use m_String, only : String_clean => clean
use m_String, only : String_toChar => toChar
use m_List, only : List
use m_List, only : List_nitem => nitem
use m_List, only : List_exportToChar => exportToChar
implicit none
! !INPUT PARAMETERS:
!
type(List), intent(in) :: iList
type(List), intent(in) :: rList
integer, intent(in) :: lsize
! !OUTPUT PARAMETERS:
!
type(AttrVect), intent(out) :: aV
! !REVISION HISTORY:
! 09May98 - J.W. Larson <larson@mcs.anl.gov> - initial version.
! 08Aug01 - E.T. Ong <eong@mcs.anl.gov> - change list assignment(=)
! to list copy to avoid compiler errors with pgf90.
! 10Oct01 - J. Larson <larson@mcs.anl.gov> - Nullify all pointers
! in ouput AttrVect aV before initializing aV. Also,
! greater caution taken regarding validity of input
! arguments iList and rList.
! 15May08 - J. Larson <larson@mcs.anl.gov> - Simplify to use
! the init_ routine. Better argument checking.
!EOP ___________________________________________________________________
!
character(len=*),parameter :: myname_=myname//'::initl_'
! Basic argument sanity checks:
if (List_nitem(iList) < 0) then
write(stderr,'(2a,i8,a)') myname_, &
':: FATAL: List argument iList has a negative number ( ',List_nitem(iList), &
' ) of attributes!'
call die(myname_)
endif
if (List_nitem(rList) < 0) then
write(stderr,'(2a,i8,a)') myname_, &
':: FATAL: List argument rList has a negative number ( ',List_nitem(rList), &
' ) of attributes!'
call die(myname_)
endif
if ((List_nitem(iList) > 0) .and. (List_nitem(rList) > 0)) then
call init_(aV, List_exportToChar(iList), List_exportToChar(rList), lsize)
else ! Then solely REAL or solely INTEGER attributes:
if (List_nitem(iList) > 0) then ! solely INTEGER attributes
call init_(aV, iList=List_exportToChar(iList), lsize=lsize)
endif ! if (List_nitem(iList) > 0) then...
if (List_nitem(rList) > 0) then ! solely REAL attributes
call init_(aV, rList=List_exportToChar(rList), lsize=lsize)
endif ! if (List_nitem(rList) > 0) then...
endif ! if ((List_nitem(iList) > 0) .and. (List_nitem(rList) > 0)) then...
end subroutine initl_
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Math and Computer Science Division, Argonne National Laboratory !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: clean_ - Deallocate Allocated Memory Structures of an AttrVect
!
! !DESCRIPTION:
! This routine deallocates the allocated memory structures of the
! input/output {\tt AttrVect} argument {\tt aV}. This amounts to
! cleaning the {\tt List} structures {\tt aV\%iList} and {\tt av\%rList},
! and deallocating the arrays {\tt aV\%iAttr(:,:)} and
! {\tt aV\%rAttr(:,:)}. The success (failure) of this operation is
! signified by a zero (non-zero) value of the optional {\tt INTEGER}
! output argument {\tt stat}. If {\tt clean\_()} is invoked without
! supplying {\tt stat}, and any of the deallocation operations fail,
! the routine will terminate with an error message.
!
! !INTERFACE:
subroutine clean_(aV, stat)
!
! !USES:
!
use m_mall
use m_stdio
use m_die
use m_List, only : List_clean => clean
implicit none
! !INPUT/OUTPUT PARAMETERS:
!
type(AttrVect), intent(inout) :: aV
! !OUTPUT PARAMETERS:
!
integer, optional, intent(out) :: stat
! !REVISION HISTORY:
! 09Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
! 10Oct01 - J. Larson <larson@mcs.anl.gov> - various fixes to
! prevent deallocation of UNASSOCIATED pointers.
! 01Mar01 - E.T. Ong <eong@mcs.anl.gov> - removed dies to prevent
! crashes when cleaning uninitialized attrvects. Added
! optional stat argument.
!EOP ___________________________________________________________________
character(len=*),parameter :: myname_=myname//'::clean_'
integer :: ier
! Note that an undefined pointer may either crash the process
! or return either .true. or .false. to the associated() test.
! One should therefore avoid using the function on an
! undefined pointer.
! Clean up INTEGER attribute list:
if(present(stat)) stat=0
if(associated(aV%iList%bf)) then
if(present(stat)) then
call List_clean(aV%iList,ier)
if(ier/=0) stat=ier
else
call List_clean(aV%iList)
endif
endif
! Clean up REAL attribute list:
if(associated(aV%rList%bf)) then
if(present(stat)) then
call List_clean(aV%rList,ier)
if(ier/=0) stat=ier
else
call List_clean(aV%rList)
endif
endif
! Clean up INTEGER attributes:
if(associated(aV%iAttr)) then
#ifdef MALL_ON
call mall_co(size(transfer(aV%iAttr,(/1/)),myname_)
#endif
deallocate(aV%iAttr,stat=ier)
if(ier /= 0) then
if(present(stat)) then
stat=ier
else
call warn(myname_,'deallocate(aV%iAttr)',ier)
endif
endif
endif ! if(associated(aV%iAttr))...
! Clean up REAL attributes:
if(associated(aV%rAttr)) then
#ifdef MALL_ON
call mall_co(size(transfer(aV%rAttr,(/1/)),myname_)
#endif
deallocate(aV%rAttr,stat=ier)
if(ier /= 0) then
if(present(stat)) then
stat=ier
else
call warn(myname_,'deallocate(aV%rAttr)',ier)
endif
endif
endif ! if(associated(aV%rAttr))...
end subroutine clean_
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Math and Computer Science Division, Argonne National Laboratory !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: lsize_ - Length of an AttrVect
!
! !DESCRIPTION:
! This function returns the number of elements, or {\em length} of the
! input {\tt AttrVect} argument {\tt aV}. This function examines the
! length of the second dimension of the arrays {\tt aV\%iAttr(:,:)}
! and {\tt aV\%rAttr(:,:)}. If neither {\tt aV\%iAttr(:,:)} nor
! {\tt aV\%rAttr(:,:)} are associated, then ${\tt lsize\_(aV)} = 0$.
! If {\tt aV\%iAttr(:,:)} is associated, but {\tt aV\%rAttr(:,:)} is
! not, then ${\tt lsize\_(aV)} = {\tt size(aV\%iAttr,2)}$. If
! {\tt aV\%iAttr(:,:)} is not associated, but {\tt aV\%rAttr(:,:)} is,
! then ${\tt lsize\_(aV)} = {\tt size(aV\%rAttr,2)}$. If both
! {\tt aV\%iAttr(:,:)} and {\tt aV\%rAttr(:,:)} are associated, the
! function {\tt lsize\_()} will do one of two things: If
! ${\tt size(aV\%iAttr,2)} = {\tt size(aV\%rAttr,2)}$, this equal value
! will be returned. If ${\tt size(aV\%iAttr,2)} \neq
! {\tt size(aV\%rAttr,2)}$, termination with an error message will occur.
!
! !INTERFACE:
integer function lsize_(aV)
! !USES:
use m_List, only : List
use m_List, only : List_allocated => allocated
use m_stdio, only : stderr
use m_die
implicit none
! !INPUT PARAMETERS:
!
type(AttrVect), intent(in) :: aV
! !REVISION HISTORY:
! 09Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
! 10Oct01 - J. Larson <larson@mcs.anl.gov> - made code more robust
! to handle cases where the length of either aV%iAttr or
! aV%rAttr is zero, but the other is positive.
!EOP ___________________________________________________________________
character(len=*),parameter :: myname_=myname//'::lsize_'
integer :: iLength, rLength
! One should try to avoid using this function on an undefined
! or disassocated pointer. However, it is understandable
! that an undefined or disassocated pointer has a size 0, if
! the associated() test sucesses.
lsize_=0
if(List_allocated(aV%iList) .and. associated(aV%iAttr)) then
iLength = size(aV%iAttr,2)
else
iLength = 0
endif
if(List_allocated(aV%rList) .and. associated(aV%rAttr)) then
rLength = size(aV%rAttr,2)
else
rLength = 0
endif
if(iLength /= rLength) then
if((rLength > 0) .and. (iLength > 0)) then
call die(myname_,'attribute array length mismatch', &
iLength-rLength)
endif
if((rLength > 0) .and. (iLength == 0)) then
lsize_ = rLength
endif
if((iLength > 0) .and. (rLength == 0)) then
lsize_ = iLength
endif
endif
if(iLength == rLength) lsize_ = iLength
end function lsize_
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Math and Computer Science Division, Argonne National Laboratory
!BOP -------------------------------------------------------------------
!
! !IROUTINE: zero_ - Set AttrVect Field Data to Zero
!
! !DESCRIPTION:
! This routine sets all of the point values of the integer and real
! attributes of an the input/output {\tt AttrVect} argument {\tt aV}
! to zero. The default action is to set the values of all the real and
! integer attributes to zero. The user may prevent the zeroing of the
! real (integer) attributes invoking {\tt zero\_()} with the optional
! {\tt LOGICAL} argument {\tt zeroReals} ({\tt zeroInts}) set with value
! {\tt .FALSE.}
!
! !INTERFACE:
subroutine zero_(aV, zeroReals, zeroInts)
! !USES:
use m_die,only : die
use m_stdio,only : stderr
use m_List, only : List
use m_List, only : List_allocated => allocated
implicit none
! !INPUT PARAMETERS:
logical, optional, intent(IN) :: zeroReals
logical, optional, intent(IN) :: zeroInts
! !INPUT/OUTPUT PARAMETERS:
!
type(AttrVect), intent(INOUT) :: aV
! !REVISION HISTORY:
! 17May01 - R. Jacob <jacob@mcs.anl.gov> - initial prototype/code
! 15Oct01 - J. Larson <larson@mcs.anl.gov> - switched loop order
! for cache optimization.
! 03Dec01 - E.T. Ong <eong@mcs.anl.gov> - eliminated looping method of
! of zeroing. "Compiler assignment" of attrvect performs faster
! on the IBM SP with mpxlf90 compiler.
! 05Jan10 - R. Jacob <jacob@mcs.anl.gov> - zeroing an uninitialized aV is no
! longer a fatal error.
!EOP ___________________________________________________________________
character(len=*),parameter :: myname_=myname//'::zero_'
logical myZeroReals, myZeroInts
if(present(zeroReals)) then
myZeroReals = zeroReals
else
myZeroReals = .TRUE.
endif
if(present(zeroInts)) then
myZeroInts = zeroInts
else
myZeroInts = .TRUE.
endif
! if((.not. List_allocated(aV%iList)) .and. (.not. List_allocated(aV%rList))) then
! write(stderr,'(2a)')myname_, &
! 'MCTERROR: Trying to zero an uninitialized AttrVect'
! call die(myname_)
! endif
if(myZeroInts) then ! zero out INTEGER attributes
if(List_allocated(aV%iList)) then
!CDIR COLLAPSE
if(associated(aV%iAttr) .and. (nIAttr_(aV)>0)) aV%iAttr=0
endif
endif
if(myZeroReals) then ! zero out REAL attributes
if(List_allocated(aV%rList)) then
!CDIR COLLAPSE
if(associated(aV%rAttr) .and. (nRAttr_(aV)>0)) aV%rAttr=0._FP
endif
endif
end subroutine zero_
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Math and Computer Science Division, Argonne National Laboratory !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: nIAttr_ - Return the Number of Integer Attributes
!
! !DESCRIPTION:
! This integer function returns the number of integer attributes
! present in the input {\tt AttrVect} argument {\tt aV}.
!
! !INTERFACE:
integer function nIAttr_(aV)
!
! !USES:
!
use m_List, only : nitem
implicit none
! !INPUT PARAMETERS:
!
type(AttrVect),intent(in) :: aV
! !REVISION HISTORY:
! 22Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
! 10Oct01 - J. Larson <larson@mcs.anl.gov> - made code more robust
! by checking status of pointers in aV%iList
!EOP ___________________________________________________________________
character(len=*),parameter :: myname_=myname//'::nIAttr_'
if(associated(aV%iList%bf)) then
nIAttr_ = nitem(aV%iList)
else
nIAttr_ = 0
endif
end function nIAttr_
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Math and Computer Science Division, Argonne National Laboratory !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: nRAttr_ - Return the Number of Real Attributes
!
! !DESCRIPTION:
! This integer function returns the number of real attributes
! present in the input {\tt AttrVect} argument {\tt aV}.
! !INTERFACE:
integer function nRAttr_(aV)
!
! !USES:
!
use m_List, only : nitem
implicit none
! !INPUT PARAMETERS:
!
type(AttrVect),intent(in) :: aV
! !REVISION HISTORY:
! 22Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
! 10Oct01 - J. Larson <larson@mcs.anl.gov> - made code more robust
! by checking status of pointers in aV%iList
!EOP ___________________________________________________________________
character(len=*),parameter :: myname_=myname//'::nRAttr_'
if(associated(aV%rList%bf)) then
nRAttr_ = nitem(aV%rList)
else
nRAttr_ = 0
endif
end function nRAttr_
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Math and Computer Science Division, Argonne National Laboratory !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: getIList_ - Retrieve the Name of a Numbered Integer Attribute
!
! !DESCRIPTION:
! This routine returns the name of the {\tt ith} integer attribute of
! the input {\tt AttrVect} argument {\tt aVect}. The name is returned
! in the output {\tt String} argument {\tt item} (see the mpeu module
! {\tt m\_String} for more information regarding the {\tt String} type).
!
! !INTERFACE:
subroutine getIList_(item, ith, aVect)
!
! !USES:
!
use m_String, only : String
use m_List, only : get
implicit none
! !INPUT PARAMETERS:
!
integer, intent(in) :: ith
type(AttrVect),intent(in) :: aVect
! !OUTPUT PARAMETERS:
!
type(String),intent(out) :: item
! !REVISION HISTORY:
! 24Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code
!EOP ___________________________________________________________________
character(len=*),parameter :: myname_=myname//'::getIList_'
call get(item, ith, aVect%iList)
end subroutine getIList_
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! Math and Computer Science Division, Argonne National Laboratory !
!BOP -------------------------------------------------------------------
!
! !IROUTINE: getRList_ - Retrieve the Name of a Numbered Real Attribute
!
! !DESCRIPTION:
! This routine returns the name of the {\tt ith} real attribute of
! the input {\tt AttrVect} argument {\tt aVect}. The name is returned
! in the output {\tt String} argument {\tt item} (see the mpeu module
! {\tt m\_String} for more information regarding the {\tt String} type).
!
! !INTERFACE:
subroutine getRList_(item, ith, aVect)
!
! !USES: