1 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
2 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
3 | !----------------------------------------------------------------------- |
---|
4 | ! CVS m_List.F90,v 1.36 2007-11-06 00:03:31 jacob Exp |
---|
5 | ! CVS MCT_2_8_0 |
---|
6 | !BOP ------------------------------------------------------------------- |
---|
7 | ! |
---|
8 | ! !MODULE: m_List - A List Manager |
---|
9 | ! |
---|
10 | ! !DESCRIPTION: A {\em List} is a character buffer comprising |
---|
11 | ! substrings called {\em items} separated by colons, combined with |
---|
12 | ! indexing information describing (1) the starting point in the character |
---|
13 | ! buffer of each substring, and (2) the length of each substring. The |
---|
14 | ! only constraints on the valid list items are (1) the value of an |
---|
15 | ! item does not contain the ``\verb":"'' delimitter, and (2) leading |
---|
16 | ! and trailing blanks are stripped from any character string presented |
---|
17 | ! to define a list item (although any imbeded blanks are retained). |
---|
18 | ! |
---|
19 | ! {\bf Example:} Suppose we wish to define a List containing the |
---|
20 | ! items {\tt 'latitude'}, {\tt 'longitude'}, and {\tt 'pressure'}. |
---|
21 | ! The character buffer of the List containing these items will be the |
---|
22 | ! 27-character string |
---|
23 | ! \begin{verbatim} |
---|
24 | ! 'latitude:longitude:pressure' |
---|
25 | ! \end{verbatim} |
---|
26 | ! and the indexing information is summarized in the table below. |
---|
27 | ! |
---|
28 | !\begin{table}[htbp] |
---|
29 | !\begin{center} |
---|
30 | !\begin{tabular}{|c|c|c|} |
---|
31 | !\hline |
---|
32 | !{\bf Item} & {\bf Starting Point in Buffer} & {\bf Length} \\ |
---|
33 | !\hline |
---|
34 | !{\tt latitude} & 1 & 8 \\ |
---|
35 | !\hline |
---|
36 | !{\tt longitude} & 9 & 9 \\ |
---|
37 | !\hline |
---|
38 | !{\tt pressure} & 20 & 8\\ |
---|
39 | !\hline |
---|
40 | !\end{tabular} |
---|
41 | !\end{center} |
---|
42 | !\end{table} |
---|
43 | ! |
---|
44 | ! One final note: All operations for the {\tt List} datatype are |
---|
45 | ! {\bf case sensitive}. |
---|
46 | ! |
---|
47 | ! !INTERFACE: |
---|
48 | |
---|
49 | module m_List |
---|
50 | |
---|
51 | ! !USES: |
---|
52 | ! |
---|
53 | ! No other Fortran modules are used. |
---|
54 | |
---|
55 | implicit none |
---|
56 | |
---|
57 | private ! except |
---|
58 | |
---|
59 | ! !PUBLIC TYPES: |
---|
60 | |
---|
61 | public :: List ! The class data structure |
---|
62 | |
---|
63 | Type List |
---|
64 | #ifdef SEQUENCE |
---|
65 | sequence |
---|
66 | #endif |
---|
67 | character(len=1),dimension(:),pointer :: bf |
---|
68 | integer, dimension(:,:),pointer :: lc |
---|
69 | End Type List |
---|
70 | |
---|
71 | ! !PUBLIC MEMBER FUNCTIONS: |
---|
72 | |
---|
73 | public :: init |
---|
74 | public :: clean |
---|
75 | public :: nullify |
---|
76 | public :: index |
---|
77 | public :: get_indices |
---|
78 | public :: test_indices |
---|
79 | public :: nitem |
---|
80 | public :: get |
---|
81 | public :: identical |
---|
82 | public :: assignment(=) |
---|
83 | public :: allocated |
---|
84 | public :: copy |
---|
85 | public :: exportToChar |
---|
86 | public :: exportToString |
---|
87 | public :: CharBufferSize |
---|
88 | public :: append |
---|
89 | public :: concatenate |
---|
90 | public :: bcast |
---|
91 | public :: send |
---|
92 | public :: recv |
---|
93 | public :: GetSharedListIndices |
---|
94 | |
---|
95 | interface init ; module procedure & |
---|
96 | init_, & |
---|
97 | initStr_, & |
---|
98 | initstr1_ |
---|
99 | end interface |
---|
100 | interface clean; module procedure clean_; end interface |
---|
101 | interface nullify; module procedure nullify_; end interface |
---|
102 | interface index; module procedure & |
---|
103 | index_, & |
---|
104 | indexStr_ |
---|
105 | end interface |
---|
106 | interface get_indices; module procedure get_indices_; end interface |
---|
107 | interface test_indices; module procedure test_indices_; end interface |
---|
108 | interface nitem; module procedure nitem_; end interface |
---|
109 | interface get ; module procedure & |
---|
110 | get_, & |
---|
111 | getall_, & |
---|
112 | getrange_ |
---|
113 | end interface |
---|
114 | interface identical; module procedure identical_; end interface |
---|
115 | interface assignment(=) |
---|
116 | module procedure copy_ |
---|
117 | end interface |
---|
118 | interface allocated ; module procedure & |
---|
119 | allocated_ |
---|
120 | end interface |
---|
121 | interface copy ; module procedure copy_ ; end interface |
---|
122 | interface exportToChar ; module procedure & |
---|
123 | exportToChar_ |
---|
124 | end interface |
---|
125 | interface exportToString ; module procedure & |
---|
126 | exportToString_ |
---|
127 | end interface |
---|
128 | interface CharBufferSize ; module procedure & |
---|
129 | CharBufferSize_ |
---|
130 | end interface |
---|
131 | interface append ; module procedure append_ ; end interface |
---|
132 | interface concatenate ; module procedure concatenate_ ; end interface |
---|
133 | interface bcast; module procedure bcast_; end interface |
---|
134 | interface send; module procedure send_; end interface |
---|
135 | interface recv; module procedure recv_; end interface |
---|
136 | interface GetSharedListIndices; module procedure & |
---|
137 | GetSharedListIndices_ |
---|
138 | end interface |
---|
139 | |
---|
140 | ! !REVISION HISTORY: |
---|
141 | ! 22Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
142 | ! 16May01 - J. Larson <larson@mcs.anl.gov> - Several changes / fixes: |
---|
143 | ! public interface for copy_(), corrected version of copy_(), |
---|
144 | ! corrected version of bcast_(). |
---|
145 | ! 15Oct01 - J. Larson <larson@mcs.anl.gov> - Added the LOGICAL |
---|
146 | ! function identical_(). |
---|
147 | ! 14Dec01 - J. Larson <larson@mcs.anl.gov> - Added the LOGICAL |
---|
148 | ! function allocated_(). |
---|
149 | ! 13Feb02 - J. Larson <larson@mcs.anl.gov> - Added the List query |
---|
150 | ! functions exportToChar() and CharBufferLength(). |
---|
151 | ! 13Jun02- R.L. Jacob <jacob@mcs.anl.gov> - Move GetSharedListIndices |
---|
152 | ! from mct to this module. |
---|
153 | !EOP ___________________________________________________________________ |
---|
154 | |
---|
155 | character(len=*),parameter :: myname='MCT(MPEU)::m_List' |
---|
156 | |
---|
157 | contains |
---|
158 | |
---|
159 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
160 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
161 | !BOP ------------------------------------------------------------------- |
---|
162 | ! |
---|
163 | ! !IROUTINE: init_ - Initialize a List from a CHARACTER String |
---|
164 | ! |
---|
165 | ! !DESCRIPTION: |
---|
166 | ! |
---|
167 | ! A list is a string in the form of ``\verb"Larry:Moe:Curly"'', |
---|
168 | ! or ``\verb"lat:lon:lev"'', combined with substring location and |
---|
169 | ! length information. Through the initialization call, the |
---|
170 | ! items delimited by ``\verb":"'' are stored as an array of sub- |
---|
171 | ! strings of a long string, accessible through an array of substring |
---|
172 | ! indices. The only constraints now on the valid list entries are, |
---|
173 | ! (1) the value of an entry does not contain ``\verb":"'', and (2) |
---|
174 | ! The leading and the trailing blanks are insignificant, although |
---|
175 | ! any imbeded blanks are. For example, |
---|
176 | ! |
---|
177 | ! \begin{verbatim} |
---|
178 | ! call init_(aList, 'batman :SUPERMAN:Green Lantern: Aquaman') |
---|
179 | ! \end{verbatim} |
---|
180 | ! will result in {\tt aList} having four items: 'batman', 'SUPERMAN', |
---|
181 | ! 'Green Lantern', and 'Aquaman'. That is |
---|
182 | ! \begin{verbatim} |
---|
183 | ! aList%bf = 'batman:SUPERMAN:Green Lantern:Aquaman' |
---|
184 | ! \end{verbatim} |
---|
185 | ! |
---|
186 | ! !INTERFACE: |
---|
187 | |
---|
188 | subroutine init_(aList,Values) |
---|
189 | |
---|
190 | ! !USES: |
---|
191 | ! |
---|
192 | use m_die,only : die |
---|
193 | use m_mall,only : mall_mci,mall_ison |
---|
194 | |
---|
195 | implicit none |
---|
196 | |
---|
197 | ! !INPUT PARAMETERS: |
---|
198 | ! |
---|
199 | character(len=*),intent(in) :: Values ! ":" delimited names |
---|
200 | |
---|
201 | ! !OUTPUT PARAMETERS: |
---|
202 | ! |
---|
203 | type(List),intent(out) :: aList ! an indexed string values |
---|
204 | |
---|
205 | |
---|
206 | ! !REVISION HISTORY: |
---|
207 | ! 22Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
208 | !EOP ___________________________________________________________________ |
---|
209 | |
---|
210 | character(len=*),parameter :: myname_=myname//'::init_' |
---|
211 | character(len=1) :: c |
---|
212 | integer :: ib,ie,id,lb,le,ni,i,ier |
---|
213 | |
---|
214 | ! Pass 1, getting the sizes |
---|
215 | le=0 |
---|
216 | ni=0 |
---|
217 | ib=1 |
---|
218 | ie=0 |
---|
219 | id=0 |
---|
220 | do i=1,len(Values) |
---|
221 | c=Values(i:i) |
---|
222 | select case(c) |
---|
223 | case(' ') |
---|
224 | if(ib==i) ib=i+1 ! moving ib up, starting from the next |
---|
225 | case(':') |
---|
226 | if(ib<=ie) then |
---|
227 | ni=ni+1 |
---|
228 | id=1 ! mark a ':' |
---|
229 | endif |
---|
230 | ib=i+1 ! moving ib up, starting from the next |
---|
231 | case default |
---|
232 | ie=i |
---|
233 | if(id==1) then ! count an earlier marked ':' |
---|
234 | id=0 |
---|
235 | le=le+1 |
---|
236 | endif |
---|
237 | le=le+1 |
---|
238 | end select |
---|
239 | end do |
---|
240 | if(ib<=ie) ni=ni+1 |
---|
241 | |
---|
242 | ! COMPILER MAY NOT SIGNAL AN ERROR IF |
---|
243 | ! ALIST HAS ALREADY BEEN INITIALIZED. |
---|
244 | ! PLEASE CHECK FOR PREVIOUS INITIALIZATION |
---|
245 | |
---|
246 | allocate(aList%bf(le),aList%lc(0:1,ni),stat=ier) |
---|
247 | if(ier /= 0) call die(myname_,'allocate()',ier) |
---|
248 | |
---|
249 | if(mall_ison()) then |
---|
250 | call mall_mci(aList%bf,myname) |
---|
251 | call mall_mci(aList%lc,myname) |
---|
252 | endif |
---|
253 | |
---|
254 | ! Pass 2, copy the value and assign the pointers |
---|
255 | lb=1 |
---|
256 | le=0 |
---|
257 | ni=0 |
---|
258 | ib=1 |
---|
259 | ie=0 |
---|
260 | id=0 |
---|
261 | do i=1,len(Values) |
---|
262 | c=Values(i:i) |
---|
263 | |
---|
264 | select case(c) |
---|
265 | case(' ') |
---|
266 | if(ib==i) ib=i+1 ! moving ib up, starting from the next |
---|
267 | case(':') |
---|
268 | if(ib<=ie) then |
---|
269 | ni=ni+1 |
---|
270 | aList%lc(0:1,ni)=(/lb,le/) |
---|
271 | id=1 ! mark a ':' |
---|
272 | endif |
---|
273 | |
---|
274 | ib=i+1 ! moving ib up, starting from the next |
---|
275 | lb=le+2 ! skip to the next non-':' and non-',' |
---|
276 | case default |
---|
277 | ie=i |
---|
278 | if(id==1) then ! copy an earlier marked ':' |
---|
279 | id=0 |
---|
280 | le=le+1 |
---|
281 | aList%bf(le)=':' |
---|
282 | endif |
---|
283 | |
---|
284 | le=le+1 |
---|
285 | aList%bf(le)=c |
---|
286 | end select |
---|
287 | end do |
---|
288 | if(ib<=ie) then |
---|
289 | ni=ni+1 |
---|
290 | aList%lc(0:1,ni)=(/lb,le/) |
---|
291 | endif |
---|
292 | |
---|
293 | end subroutine init_ |
---|
294 | |
---|
295 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
296 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
297 | !BOP ------------------------------------------------------------------- |
---|
298 | ! |
---|
299 | ! !IROUTINE: initStr_ - Initialize a List Using the String Type |
---|
300 | ! |
---|
301 | ! !DESCRIPTION: This routine initializes a {\tt List} datatype given |
---|
302 | ! an input {\tt String} datatype (see {\tt m\_String} for more |
---|
303 | ! information regarding the {\tt String} type). The contents of the |
---|
304 | ! input {\tt String} argument {\tt pstr} must adhere to the restrictions |
---|
305 | ! stated for character input stated in the prologue of the routine |
---|
306 | ! {\tt init\_()} in this module. |
---|
307 | ! |
---|
308 | ! !INTERFACE: |
---|
309 | |
---|
310 | subroutine initStr_(aList, pstr) |
---|
311 | |
---|
312 | ! !USES: |
---|
313 | ! |
---|
314 | use m_String, only : String,toChar |
---|
315 | |
---|
316 | implicit none |
---|
317 | |
---|
318 | ! !INPUT PARAMETERS: |
---|
319 | ! |
---|
320 | type(String),intent(in) :: pstr |
---|
321 | |
---|
322 | ! !OUTPUT PARAMETERS: |
---|
323 | ! |
---|
324 | type(List),intent(out) :: aList ! an indexed string values |
---|
325 | |
---|
326 | |
---|
327 | ! !REVISION HISTORY: |
---|
328 | ! 23Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
329 | !EOP ___________________________________________________________________ |
---|
330 | |
---|
331 | character(len=*),parameter :: myname_=myname//'::initStr_' |
---|
332 | |
---|
333 | call init_(aList,toChar(pstr)) |
---|
334 | |
---|
335 | end subroutine initStr_ |
---|
336 | |
---|
337 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
338 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
339 | !BOP ------------------------------------------------------------------- |
---|
340 | ! |
---|
341 | ! !IROUTINE: initStr1_ - Initialize a List Using an Array of Strings |
---|
342 | ! |
---|
343 | ! !DESCRIPTION: This routine initializes a {\tt List} datatype given |
---|
344 | ! as input array of {\tt String} datatypes (see {\tt m\_String} for more |
---|
345 | ! information regarding the {\tt String} type). The contents of each |
---|
346 | ! {\tt String} element of the input array {\tt strs} must adhere to the |
---|
347 | ! restrictions stated for character input stated in the prologue of the |
---|
348 | ! routine {\tt init\_()} in this module. Specifically, no element in |
---|
349 | ! {\tt strs} may contain the colon \verb':' delimiter, and any |
---|
350 | ! leading or trailing blanks will be stripped (though embedded blank |
---|
351 | ! spaces will be retained). For example, consider an invocation of |
---|
352 | ! {\tt initStr1\_()} where the array {\tt strs(:)} contains four entries: |
---|
353 | ! {\tt strs(1)='John'}, {\tt strs(2)=' Paul'}, |
---|
354 | ! {\tt strs(3)='George '}, and {\tt strs(4)=' Ringo'}. The resulting |
---|
355 | ! {\tt List} output {\tt aList} will have |
---|
356 | ! \begin{verbatim} |
---|
357 | ! aList%bf = 'John:Paul:George:Ringo' |
---|
358 | ! \end{verbatim} |
---|
359 | ! !INTERFACE: |
---|
360 | |
---|
361 | subroutine initStr1_(aList, strs) |
---|
362 | |
---|
363 | ! !USES: |
---|
364 | ! |
---|
365 | use m_String, only : String,toChar |
---|
366 | use m_String, only : len |
---|
367 | use m_String, only : ptr_chars |
---|
368 | use m_die,only : die |
---|
369 | |
---|
370 | implicit none |
---|
371 | |
---|
372 | ! !INPUT PARAMETERS: |
---|
373 | ! |
---|
374 | type(String),dimension(:),intent(in) :: strs |
---|
375 | |
---|
376 | ! !OUTPUT PARAMETERS: |
---|
377 | ! |
---|
378 | type(List),intent(out) :: aList ! an indexed string values |
---|
379 | |
---|
380 | |
---|
381 | ! !REVISION HISTORY: |
---|
382 | ! 23Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
383 | !EOP ___________________________________________________________________ |
---|
384 | |
---|
385 | character(len=*),parameter :: myname_=myname//'::initStr1_' |
---|
386 | character(len=1),allocatable,dimension(:) :: ch1 |
---|
387 | integer :: ier |
---|
388 | integer :: n,i,lc,le |
---|
389 | |
---|
390 | n=size(strs) |
---|
391 | le=0 |
---|
392 | do i=1,n |
---|
393 | le=le+len(strs(i)) |
---|
394 | end do |
---|
395 | le=le+n-1 ! for n-1 ":"s |
---|
396 | |
---|
397 | allocate(ch1(le),stat=ier) |
---|
398 | if(ier/=0) call die(myname_,'allocate()',ier) |
---|
399 | |
---|
400 | le=0 |
---|
401 | do i=1,n |
---|
402 | if(i>1) then |
---|
403 | le=le+1 |
---|
404 | ch1(le)=':' |
---|
405 | endif |
---|
406 | |
---|
407 | lc=le+1 |
---|
408 | le=le+len(strs(i)) |
---|
409 | ch1(lc:le)=ptr_chars(strs(i)) |
---|
410 | end do |
---|
411 | |
---|
412 | call init_(aList,toChar(ch1)) |
---|
413 | |
---|
414 | deallocate(ch1,stat=ier) |
---|
415 | if(ier/=0) call die(myname_,'deallocate()',ier) |
---|
416 | |
---|
417 | end subroutine initStr1_ |
---|
418 | |
---|
419 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
420 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
421 | !BOP ------------------------------------------------------------------- |
---|
422 | ! |
---|
423 | ! !IROUTINE: clean_ - Deallocate Memory Used by a List |
---|
424 | ! |
---|
425 | ! !DESCRIPTION: This routine deallocates the allocated memory components |
---|
426 | ! of the input/output {\tt List} argument {\tt aList}. Specifically, it |
---|
427 | ! deallocates {\tt aList\%bf} and {\tt aList\%lc}. If the optional |
---|
428 | ! output {\tt INTEGER} arguemnt {\tt stat} is supplied, no warning will |
---|
429 | ! be printed if the Fortran intrinsic {\tt deallocate()} returns with an |
---|
430 | ! error condition. |
---|
431 | ! |
---|
432 | ! !INTERFACE: |
---|
433 | |
---|
434 | subroutine clean_(aList, stat) |
---|
435 | |
---|
436 | ! !USES: |
---|
437 | ! |
---|
438 | use m_die, only : warn |
---|
439 | use m_mall, only : mall_mco,mall_ison |
---|
440 | |
---|
441 | implicit none |
---|
442 | |
---|
443 | ! !INPUT/OUTPUT PARAMETERS: |
---|
444 | ! |
---|
445 | type(List), intent(inout) :: aList |
---|
446 | |
---|
447 | ! !OUTPUT PARAMETERS: |
---|
448 | ! |
---|
449 | integer, optional, intent(out) :: stat |
---|
450 | |
---|
451 | ! !REVISION HISTORY: |
---|
452 | ! 22Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
453 | ! 1Mar02 - E.T. Ong <eong@mcs.anl.gov> - added stat argument and |
---|
454 | ! removed die to prevent crashes. |
---|
455 | !EOP ___________________________________________________________________ |
---|
456 | |
---|
457 | character(len=*),parameter :: myname_=myname//'::clean_' |
---|
458 | integer :: ier |
---|
459 | |
---|
460 | if(mall_ison()) then |
---|
461 | if(associated(aList%bf)) call mall_mco(aList%bf,myname_) |
---|
462 | if(associated(aList%lc)) call mall_mco(aList%lc,myname_) |
---|
463 | endif |
---|
464 | |
---|
465 | if(associated(aList%bf) .and. associated(aList%lc)) then |
---|
466 | |
---|
467 | deallocate(aList%bf, aList%lc, stat=ier) |
---|
468 | |
---|
469 | if(present(stat)) then |
---|
470 | stat=ier |
---|
471 | else |
---|
472 | if(ier /= 0) call warn(myname_,'deallocate(aList%...)',ier) |
---|
473 | endif |
---|
474 | |
---|
475 | endif |
---|
476 | |
---|
477 | end subroutine clean_ |
---|
478 | |
---|
479 | !--- ------------------------------------------------------------------- |
---|
480 | ! Math + Computer Science Division / Argonne National Laboratory ! |
---|
481 | !BOP ------------------------------------------------------------------- |
---|
482 | ! |
---|
483 | ! !IROUTINE: nullify_ - Nullify Pointers in a List |
---|
484 | ! |
---|
485 | ! !DESCRIPTION: In Fortran 90, pointers may have three states: |
---|
486 | ! (1) {\tt ASSOCIATED}, that is the pointer is pointing at a target, |
---|
487 | ! (2) {\tt UNASSOCIATED}, and (3) {\tt UNINITIALIZED}. On some |
---|
488 | ! platforms, the Fortran intrinsic function {\tt associated()} |
---|
489 | ! will view uninitialized pointers as {\tt UNASSOCIATED} by default. |
---|
490 | ! This is not always the case. It is good programming practice to |
---|
491 | ! nullify pointers if they are not to be used. This routine nullifies |
---|
492 | ! the pointers present in the {\tt List} datatype. |
---|
493 | ! |
---|
494 | ! !INTERFACE: |
---|
495 | |
---|
496 | subroutine nullify_(aList) |
---|
497 | |
---|
498 | ! !USES: |
---|
499 | ! |
---|
500 | use m_die,only : die |
---|
501 | |
---|
502 | implicit none |
---|
503 | |
---|
504 | ! !INPUT/OUTPUT PARAMETERS: |
---|
505 | ! |
---|
506 | type(List),intent(inout) :: aList |
---|
507 | |
---|
508 | ! !REVISION HISTORY: |
---|
509 | ! 18Jun01 - J.W. Larson - <larson@mcs.anl.gov> - initial version |
---|
510 | !EOP ___________________________________________________________________ |
---|
511 | |
---|
512 | character(len=*),parameter :: myname_=myname//'::nullify_' |
---|
513 | |
---|
514 | nullify(aList%bf) |
---|
515 | nullify(aList%lc) |
---|
516 | |
---|
517 | end subroutine nullify_ |
---|
518 | |
---|
519 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
520 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
521 | !BOP ------------------------------------------------------------------- |
---|
522 | ! |
---|
523 | ! !IROUTINE: nitem_ - Return the Number of Items in a List |
---|
524 | ! |
---|
525 | ! !DESCRIPTION: |
---|
526 | ! This function enumerates the number of items in the input {\tt List} |
---|
527 | ! argument {\tt aList}. For example, suppose |
---|
528 | ! \begin{verbatim} |
---|
529 | ! aList%bf = 'John:Paul:George:Ringo' |
---|
530 | ! \end{verbatim} |
---|
531 | ! Then, |
---|
532 | ! $${\tt nitem\_(aList)} = 4 .$$ |
---|
533 | ! |
---|
534 | ! !INTERFACE: |
---|
535 | |
---|
536 | integer function nitem_(aList) |
---|
537 | |
---|
538 | ! !USES: |
---|
539 | ! |
---|
540 | implicit none |
---|
541 | |
---|
542 | ! !INPUT PARAMETERS: |
---|
543 | ! |
---|
544 | type(List),intent(in) :: aList |
---|
545 | |
---|
546 | ! !REVISION HISTORY: |
---|
547 | ! 22Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
548 | ! 10Oct01 - J.W. Larson <larson@mcs.anl.gov> - modified routine to |
---|
549 | ! check pointers aList%bf and aList%lc using the f90 |
---|
550 | ! intrinsic ASSOCIATED before proceeding with the item |
---|
551 | ! count. If these pointers are UNASSOCIATED, an item |
---|
552 | ! count of zero is returned. |
---|
553 | !EOP ___________________________________________________________________ |
---|
554 | |
---|
555 | character(len=*),parameter :: myname_=myname//'::nitem_' |
---|
556 | integer :: NumItems |
---|
557 | |
---|
558 | ! Initialize item count to zero |
---|
559 | |
---|
560 | NumItems = 0 |
---|
561 | |
---|
562 | ! If the List pointers are ASSOCIATED, perform item count: |
---|
563 | |
---|
564 | if(ASSOCIATED(aList%bf) .and. ASSOCIATED(aList%lc)) then |
---|
565 | NumItems = size(aList%lc,2) |
---|
566 | endif |
---|
567 | |
---|
568 | nitem_ = NumItems |
---|
569 | |
---|
570 | end function nitem_ |
---|
571 | |
---|
572 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
573 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
574 | !BOP ------------------------------------------------------------------- |
---|
575 | ! |
---|
576 | ! !IROUTINE: index_ - Return Rank in a List of a Given Item (CHARACTER) |
---|
577 | ! |
---|
578 | ! !DESCRIPTION: |
---|
579 | ! This function returns the rank of an item (defined by the |
---|
580 | ! {\tt CHARACTER} argument {\tt item}) in the input {\tt List} argument |
---|
581 | ! {\tt aList}. If {\tt item} is not present in {\tt aList}, then zero |
---|
582 | ! is returned. For example, suppose |
---|
583 | ! \begin{verbatim} |
---|
584 | ! aList%bf = 'Bob:Carol:Ted:Alice' |
---|
585 | ! \end{verbatim} |
---|
586 | ! Then, ${\tt index\_(aList, 'Ted')}=3$, ${\tt index\_(aList, 'Carol')}=2$, |
---|
587 | ! and ${\tt index\_(aList, 'The Dude')}=0.$ |
---|
588 | ! |
---|
589 | ! !INTERFACE: |
---|
590 | |
---|
591 | integer function index_(aList, item) |
---|
592 | |
---|
593 | ! !USES: |
---|
594 | ! |
---|
595 | use m_String, only : toChar |
---|
596 | |
---|
597 | implicit none |
---|
598 | |
---|
599 | ! !INPUT PARAMETERS: |
---|
600 | ! |
---|
601 | type(List), intent(in) :: aList ! a List of names |
---|
602 | character(len=*),intent(in) :: item ! a given item name |
---|
603 | |
---|
604 | ! !REVISION HISTORY: |
---|
605 | ! 22Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
606 | !EOP ___________________________________________________________________ |
---|
607 | |
---|
608 | character(len=*),parameter :: myname_=myname//'::index_' |
---|
609 | integer :: i,lb,le |
---|
610 | integer :: itemLength, length, nMatch, j |
---|
611 | |
---|
612 | ! How long is the input item name? |
---|
613 | |
---|
614 | itemLength = len(item) |
---|
615 | |
---|
616 | ! Set output to zero (no item match) value: |
---|
617 | |
---|
618 | index_=0 |
---|
619 | |
---|
620 | ! Now, go through the aList one item at a time |
---|
621 | |
---|
622 | ITEM_COMPARE: do i=1,size(aList%lc,2) ! == nitem_(aList) |
---|
623 | |
---|
624 | ! Compute some stats for the current item in aList: |
---|
625 | |
---|
626 | lb=aList%lc(0,i) ! starting index of item in aList%bf |
---|
627 | le=aList%lc(1,i) ! ending index item in aList%bf |
---|
628 | |
---|
629 | length = le -lb + 1 ! length of the current item |
---|
630 | if(length /= itemLength) then ! this list item can't match input item |
---|
631 | |
---|
632 | CYCLE ! that is, jump to the next item in aList... |
---|
633 | |
---|
634 | else ! compare one character at a time... |
---|
635 | |
---|
636 | ! Initialize number of matching characters in the two strings |
---|
637 | |
---|
638 | nMatch = 0 |
---|
639 | |
---|
640 | ! Now, compare item to the current item in aList one character |
---|
641 | ! at a time: |
---|
642 | |
---|
643 | CHAR_COMPARE: do j=1,length |
---|
644 | if(aList%bf(lb+j-1) == item(j:j)) then ! a match for this character |
---|
645 | nMatch = nMatch + 1 |
---|
646 | else |
---|
647 | EXIT |
---|
648 | endif |
---|
649 | end do CHAR_COMPARE |
---|
650 | |
---|
651 | ! Check the number of leading characters in the current item in aList |
---|
652 | ! that match the input item. If it is equal to the item length, then |
---|
653 | ! we have found a match and are finished. Otherwise, we cycle on to |
---|
654 | ! the next item in aList. |
---|
655 | |
---|
656 | if(nMatch == itemLength) then |
---|
657 | index_ = i |
---|
658 | EXIT |
---|
659 | endif |
---|
660 | |
---|
661 | ! Old code that does not work with V. of the IBM |
---|
662 | ! if(item==toChar(aList%bf(lb:le))) then |
---|
663 | ! index_=i |
---|
664 | ! exit |
---|
665 | endif |
---|
666 | end do ITEM_COMPARE |
---|
667 | |
---|
668 | end function index_ |
---|
669 | |
---|
670 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
671 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
672 | !BOP ------------------------------------------------------------------- |
---|
673 | ! |
---|
674 | ! !IROUTINE: indexStr_ - Return Rank in a List of a Given Item (String) |
---|
675 | ! |
---|
676 | ! !DESCRIPTION: |
---|
677 | ! This function performs the same operation as the function |
---|
678 | ! {\tt index\_()}, but the item to be indexed is instead presented in |
---|
679 | ! the form of a {\tt String} datatype (see the module {\tt m\_String} |
---|
680 | ! for more information about the {\tt String} type). This routine |
---|
681 | ! searches through the input {\tt List} argument {\tt aList} for an |
---|
682 | ! item that matches the item defined by {\tt itemStr}, and if a match |
---|
683 | ! is found, the rank of the item in the list is returned (see also the |
---|
684 | ! prologue for the routine {\tt index\_()} in this module). If no match |
---|
685 | ! is found, a value of zero is returned. |
---|
686 | ! |
---|
687 | ! !INTERFACE: |
---|
688 | |
---|
689 | integer function indexStr_(aList, itemStr) |
---|
690 | |
---|
691 | ! !USES: |
---|
692 | ! |
---|
693 | use m_String,only : String,toChar |
---|
694 | |
---|
695 | implicit none |
---|
696 | |
---|
697 | ! !INPUT PARAMETERS: |
---|
698 | ! |
---|
699 | type(List), intent(in) :: aList ! a List of names |
---|
700 | type(String), intent(in) :: itemStr |
---|
701 | |
---|
702 | ! !REVISION HISTORY: |
---|
703 | ! 22Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
704 | ! 25Oct02 - R. Jacob <jacob@mcs.anl.gov> - just call index_ above |
---|
705 | !EOP ___________________________________________________________________ |
---|
706 | |
---|
707 | character(len=*),parameter :: myname_=myname//'::indexStr_' |
---|
708 | |
---|
709 | indexStr_=0 |
---|
710 | indexStr_=index_(aList,toChar(itemStr)) |
---|
711 | |
---|
712 | end function indexStr_ |
---|
713 | |
---|
714 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
715 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
716 | !BOP ------------------------------------------------------------------- |
---|
717 | ! |
---|
718 | ! !IROUTINE: allocated_ - Check Pointers in a List for Association Status |
---|
719 | ! |
---|
720 | ! !DESCRIPTION: |
---|
721 | ! This function checks the input {\tt List} argument {\tt inList} to |
---|
722 | ! determine whether or not it has been allocated. It does this by |
---|
723 | ! invoking the Fortran90 intrinsic function {\tt associated()} on the |
---|
724 | ! pointers {\tt inList\%bf} and {\tt inList\%lc}. If both of these |
---|
725 | ! pointers are associated, the return value is {\tt .TRUE.}. |
---|
726 | ! |
---|
727 | ! {\bf N.B.:} In Fortran90, pointers have three different states: |
---|
728 | ! {\tt ASSOCIATED}, {\tt UNASSOCIATED}, and {\tt UNDEFINED}. |
---|
729 | ! If a pointer is {\tt UNDEFINED}, this function may return either |
---|
730 | ! {\tt .TRUE.} or {\tt .FALSE.} values, depending on the Fortran90 |
---|
731 | ! compiler. To avoid such problems, we advise that users invoke the |
---|
732 | ! {\tt List} method {\tt nullify()} to nullify any {\tt List} pointers |
---|
733 | ! for {\tt List} variables that are not initialized. |
---|
734 | ! |
---|
735 | ! !INTERFACE: |
---|
736 | |
---|
737 | logical function allocated_(inList) |
---|
738 | |
---|
739 | ! !USES: |
---|
740 | |
---|
741 | use m_die,only : die |
---|
742 | |
---|
743 | implicit none |
---|
744 | |
---|
745 | ! !INPUT PARAMETERS: |
---|
746 | |
---|
747 | type(List), intent(in) :: inList |
---|
748 | |
---|
749 | ! !REVISION HISTORY: |
---|
750 | ! 14Dec01 - J. Larson <larson@mcs.anl.gov> - inital version |
---|
751 | !EOP ___________________________________________________________________ |
---|
752 | |
---|
753 | character(len=*),parameter :: myname_=myname//'::allocated_' |
---|
754 | |
---|
755 | allocated_ = associated(inList%bf) .and. associated(inList%lc) |
---|
756 | |
---|
757 | end function allocated_ |
---|
758 | |
---|
759 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
760 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
761 | !BOP ------------------------------------------------------------------- |
---|
762 | ! |
---|
763 | ! !IROUTINE: copy_ - Copy a List |
---|
764 | ! |
---|
765 | ! !DESCRIPTION: |
---|
766 | ! This routine copies the contents of the input {\tt List} argument |
---|
767 | ! {\tt xL} into the output {\tt List} argument {\tt yL}. |
---|
768 | ! |
---|
769 | ! !INTERFACE: |
---|
770 | |
---|
771 | subroutine copy_(yL,xL) ! yL=xL |
---|
772 | |
---|
773 | ! !USES: |
---|
774 | ! |
---|
775 | use m_die,only : die |
---|
776 | use m_stdio |
---|
777 | use m_String ,only : String |
---|
778 | use m_String ,only : String_clean |
---|
779 | use m_mall,only : mall_mci,mall_ison |
---|
780 | |
---|
781 | implicit none |
---|
782 | |
---|
783 | ! !INPUT PARAMETERS: |
---|
784 | ! |
---|
785 | type(List),intent(in) :: xL |
---|
786 | |
---|
787 | ! !OUTPUT PARAMETERS: |
---|
788 | ! |
---|
789 | type(List),intent(out) :: yL |
---|
790 | |
---|
791 | |
---|
792 | ! !REVISION HISTORY: |
---|
793 | ! 22Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
794 | ! 16May01 - J. Larson <larson@mcs.anl.gov> - simpler, working |
---|
795 | ! version that exploits the String datatype (see m_String) |
---|
796 | ! 1Aug02 - Larson/Ong - Added logic for correct copying of blank |
---|
797 | ! Lists. |
---|
798 | !EOP ___________________________________________________________________ |
---|
799 | |
---|
800 | character(len=*),parameter :: myname_=myname//'::copy_' |
---|
801 | type(String) DummStr |
---|
802 | |
---|
803 | if(size(xL%lc,2) > 0) then |
---|
804 | |
---|
805 | ! Download input List info from xL to String DummStr |
---|
806 | |
---|
807 | call getall_(DummStr,xL) |
---|
808 | |
---|
809 | ! Initialize yL from DummStr |
---|
810 | |
---|
811 | call initStr_(yL,DummStr) |
---|
812 | |
---|
813 | call String_clean(DummStr) |
---|
814 | |
---|
815 | else |
---|
816 | if(size(xL%lc,2) < 0) then ! serious error... |
---|
817 | write(stderr,'(2a,i8)') myname_, & |
---|
818 | ':: FATAL size(xL%lc,2) = ',size(xL%lc,2) |
---|
819 | endif |
---|
820 | ! Initialize yL as a blank list |
---|
821 | call init_(yL, ' ') |
---|
822 | endif |
---|
823 | |
---|
824 | end subroutine copy_ |
---|
825 | |
---|
826 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
827 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
828 | !BOP ------------------------------------------------------------------- |
---|
829 | ! |
---|
830 | ! !IROUTINE: exportToChar_ - Export List to a CHARACTER |
---|
831 | ! |
---|
832 | ! !DESCRIPTION: This function returns the character buffer portion of |
---|
833 | ! the input {\tt List} argument {\tt inList}---that is, the contents of |
---|
834 | ! {\tt inList\%bf}---as a {\tt CHARACTER} (suitable for printing). An |
---|
835 | ! example of the use of this function is: |
---|
836 | ! \begin{verbatim} |
---|
837 | ! write(stdout,'(1a)') exportToChar(inList) |
---|
838 | ! \end{verbatim} |
---|
839 | ! which writes the contents of {\tt inList\%bf} to the Fortran device |
---|
840 | ! {\tt stdout}. |
---|
841 | ! |
---|
842 | ! !INTERFACE: |
---|
843 | |
---|
844 | function exportToChar_(inList) |
---|
845 | |
---|
846 | ! !USES: |
---|
847 | ! |
---|
848 | use m_die, only : die |
---|
849 | use m_stdio, only : stderr |
---|
850 | use m_String, only : String |
---|
851 | use m_String, only : String_ToChar => toChar |
---|
852 | use m_String, only : String_clean |
---|
853 | |
---|
854 | implicit none |
---|
855 | |
---|
856 | ! ! INPUT PARAMETERS: |
---|
857 | |
---|
858 | type(List), intent(in) :: inList |
---|
859 | |
---|
860 | ! ! OUTPUT PARAMETERS: |
---|
861 | |
---|
862 | character(len=size(inList%bf,1)) :: exportToChar_ |
---|
863 | |
---|
864 | ! !REVISION HISTORY: |
---|
865 | ! 13Feb02 - J. Larson <larson@mcs.anl.gov> - initial version. |
---|
866 | ! 06Jun03 - R. Jacob <jacob@mcs.anl.gov> - return blank if List is not allocated |
---|
867 | !EOP ___________________________________________________________________ |
---|
868 | |
---|
869 | character(len=*),parameter :: myname_=myname//'::exportToChar_' |
---|
870 | type(String) DummStr |
---|
871 | |
---|
872 | ! Download input List info from inList to String DummStr |
---|
873 | if(allocated_(inList)) then |
---|
874 | call getall_(DummStr,inList) |
---|
875 | exportToChar_ = String_ToChar(DummStr) |
---|
876 | call String_clean(DummStr) |
---|
877 | else |
---|
878 | exportToChar_ = '' |
---|
879 | endif |
---|
880 | |
---|
881 | end function exportToChar_ |
---|
882 | |
---|
883 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
884 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
885 | !BOP ------------------------------------------------------------------- |
---|
886 | ! |
---|
887 | ! !IROUTINE: exportToString_ - Export List to a String |
---|
888 | ! |
---|
889 | ! !DESCRIPTION: This function returns the character buffer portion of |
---|
890 | ! the input {\tt List} argument {\tt inList}---that is, the contents of |
---|
891 | ! {\tt inList\%bf}---as a {\tt String} (see the mpeu module m\_String |
---|
892 | ! for more information regarding the {\tt String} type). This function |
---|
893 | ! was created to circumvent problems with implementing inheritance of |
---|
894 | ! the function {\tt exportToChar\_()} to other datatypes build on top |
---|
895 | ! of the {\tt List} type. |
---|
896 | ! |
---|
897 | ! !INTERFACE: |
---|
898 | |
---|
899 | function exportToString_(inList) |
---|
900 | |
---|
901 | ! !USES: |
---|
902 | ! |
---|
903 | use m_die, only : die |
---|
904 | use m_stdio, only : stderr |
---|
905 | |
---|
906 | use m_String, only : String |
---|
907 | use m_String, only : String_init => init |
---|
908 | |
---|
909 | implicit none |
---|
910 | |
---|
911 | ! ! INPUT PARAMETERS: |
---|
912 | |
---|
913 | type(List), intent(in) :: inList |
---|
914 | |
---|
915 | ! ! OUTPUT PARAMETERS: |
---|
916 | |
---|
917 | type(String) :: exportToString_ |
---|
918 | |
---|
919 | ! !REVISION HISTORY: |
---|
920 | ! 14Aug02 - J. Larson <larson@mcs.anl.gov> - initial version. |
---|
921 | !EOP ___________________________________________________________________ |
---|
922 | |
---|
923 | character(len=*),parameter :: myname_=myname//'::exportToString_' |
---|
924 | |
---|
925 | if(allocated_(inList)) then |
---|
926 | call getall_(exportToString_, inList) |
---|
927 | else |
---|
928 | call String_init(exportToString_, 'NOTHING') |
---|
929 | endif |
---|
930 | |
---|
931 | end function exportToString_ |
---|
932 | |
---|
933 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
934 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
935 | !BOP ------------------------------------------------------------------- |
---|
936 | ! |
---|
937 | ! !IROUTINE: CharBufferSize_ - Return size of a List's Character Buffer |
---|
938 | ! |
---|
939 | ! !DESCRIPTION: This function returns the length of the character |
---|
940 | ! buffer portion of the input {\tt List} argument {\tt inList} (that |
---|
941 | ! is, the number of characters stored in {\tt inList\%bf}) as an |
---|
942 | ! {\tt INTEGER}. Suppose for the sake of argument that {\tt inList} |
---|
943 | ! was created using the following call to {\tt init\_()}: |
---|
944 | ! \begin{verbatim} |
---|
945 | ! call init_(inList, 'Groucho:Harpo:Chico:Zeppo') |
---|
946 | ! \end{verbatim} |
---|
947 | ! Then, using the above example value of {\tt inList}, we can use |
---|
948 | ! {\tt CharBufferSize\_()} as follows: |
---|
949 | ! \begin{verbatim} |
---|
950 | ! integer :: BufferLength |
---|
951 | ! BufferLength = CharBufferSize(inList) |
---|
952 | ! \end{verbatim} |
---|
953 | ! and the resulting value of {\tt BufferLength} will be 25. |
---|
954 | ! |
---|
955 | ! !INTERFACE: |
---|
956 | |
---|
957 | integer function CharBufferSize_(inList) |
---|
958 | |
---|
959 | ! !USES: |
---|
960 | ! |
---|
961 | use m_die, only : die |
---|
962 | use m_stdio, only : stderr |
---|
963 | |
---|
964 | implicit none |
---|
965 | |
---|
966 | ! ! INPUT PARAMETERS: |
---|
967 | |
---|
968 | type(List), intent(in) :: inList |
---|
969 | |
---|
970 | ! !REVISION HISTORY: |
---|
971 | ! 13Feb02 - J. Larson <larson@mcs.anl.gov> - initial version. |
---|
972 | !EOP ___________________________________________________________________ |
---|
973 | |
---|
974 | character(len=*),parameter :: myname_=myname//'::CharBufferSize_' |
---|
975 | |
---|
976 | if(allocated_(inList)) then |
---|
977 | CharBufferSize_ = size(inList%bf) |
---|
978 | else |
---|
979 | write(stderr,'(2a)') myname_,":: Argument inList not allocated." |
---|
980 | call die(myname_) |
---|
981 | endif |
---|
982 | |
---|
983 | end function CharBufferSize_ |
---|
984 | |
---|
985 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
986 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
987 | !BOP ------------------------------------------------------------------- |
---|
988 | ! |
---|
989 | ! !IROUTINE: get_ - Retrieve a Numbered Item from a List as a String |
---|
990 | ! |
---|
991 | ! !DESCRIPTION: |
---|
992 | ! This routine retrieves a numbered item (defined by the input |
---|
993 | ! {\tt INTEGER} argument {\tt ith}) from the input {\tt List} argument |
---|
994 | ! {\tt aList}, and returns it in the output {\tt String} argument |
---|
995 | ! {\tt itemStr} (see the module {\tt m\_String} for more information |
---|
996 | ! about the {\tt String} type). If the argument {\tt ith} is nonpositive, |
---|
997 | ! or greater than the number of items in {\tt aList}, a String containing |
---|
998 | ! one blank space is returned. |
---|
999 | ! |
---|
1000 | ! !INTERFACE: |
---|
1001 | |
---|
1002 | subroutine get_(itemStr, ith, aList) |
---|
1003 | |
---|
1004 | ! !USES: |
---|
1005 | ! |
---|
1006 | use m_String, only : String, init, toChar |
---|
1007 | |
---|
1008 | implicit none |
---|
1009 | |
---|
1010 | ! !INPUT PARAMETERS: |
---|
1011 | ! |
---|
1012 | integer, intent(in) :: ith |
---|
1013 | type(List), intent(in) :: aList |
---|
1014 | |
---|
1015 | ! !OUTPUT PARAMETERS: |
---|
1016 | ! |
---|
1017 | type(String),intent(out) :: itemStr |
---|
1018 | |
---|
1019 | |
---|
1020 | ! !REVISION HISTORY: |
---|
1021 | ! 23Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
1022 | ! 14May07 - Larson, Jacob - add space to else case string so function |
---|
1023 | ! matches documentation. |
---|
1024 | !EOP ___________________________________________________________________ |
---|
1025 | |
---|
1026 | character(len=*),parameter :: myname_=myname//'::get_' |
---|
1027 | integer :: lb,le |
---|
1028 | |
---|
1029 | if(ith>0 .and. ith <= size(aList%lc,2)) then |
---|
1030 | lb=aList%lc(0,ith) |
---|
1031 | le=aList%lc(1,ith) |
---|
1032 | call init(itemStr,toChar(aList%bf(lb:le))) |
---|
1033 | else |
---|
1034 | call init(itemStr,' ') |
---|
1035 | endif |
---|
1036 | |
---|
1037 | end subroutine get_ |
---|
1038 | |
---|
1039 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
1040 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
1041 | !BOP ------------------------------------------------------------------- |
---|
1042 | ! |
---|
1043 | ! !IROUTINE: getall_ - Return all Items from a List as one String |
---|
1044 | ! |
---|
1045 | ! !DESCRIPTION: |
---|
1046 | ! This routine returns all the items from the input {\tt List} argument |
---|
1047 | ! {\tt aList} in the output {\tt String} argument {\tt itemStr} (see |
---|
1048 | ! the module {\tt m\_String} for more information about the {\tt String} |
---|
1049 | ! type). The contents of the character buffer in {\tt itemStr} will |
---|
1050 | ! be the all of the items in {\tt aList}, separated by the colon delimiter. |
---|
1051 | ! |
---|
1052 | ! !INTERFACE: |
---|
1053 | |
---|
1054 | subroutine getall_(itemStr, aList) |
---|
1055 | |
---|
1056 | ! !USES: |
---|
1057 | ! |
---|
1058 | use m_String, only : String, init, toChar |
---|
1059 | |
---|
1060 | implicit none |
---|
1061 | |
---|
1062 | ! !INPUT PARAMETERS: |
---|
1063 | ! |
---|
1064 | type(List), intent(in) :: aList |
---|
1065 | |
---|
1066 | ! !OUTPUT PARAMETERS: |
---|
1067 | ! |
---|
1068 | type(String), intent(out) :: itemStr |
---|
1069 | |
---|
1070 | |
---|
1071 | ! !REVISION HISTORY: |
---|
1072 | ! 23Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
1073 | !EOP ___________________________________________________________________ |
---|
1074 | |
---|
1075 | character(len=*),parameter :: myname_=myname//'::getall_' |
---|
1076 | integer :: lb,le,ni |
---|
1077 | |
---|
1078 | ni=size(aList%lc,2) |
---|
1079 | lb=aList%lc(0,1) |
---|
1080 | le=aList%lc(1,ni) |
---|
1081 | call init(itemStr,toChar(aList%bf(lb:le))) |
---|
1082 | |
---|
1083 | end subroutine getall_ |
---|
1084 | |
---|
1085 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
1086 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
1087 | !BOP ------------------------------------------------------------------- |
---|
1088 | ! |
---|
1089 | ! !IROUTINE: getrange_ - Return a Range of Items from a List as one String |
---|
1090 | ! |
---|
1091 | ! !DESCRIPTION: |
---|
1092 | ! This routine returns all the items ranked {\tt i1} through {\tt i2} |
---|
1093 | ! from the input {\tt List} argument {\tt aList} in the output |
---|
1094 | ! {\tt String} argument {\tt itemStr} (see the module {\tt m\_String} |
---|
1095 | ! for more information about the {\tt String} type). The contents of |
---|
1096 | ! the character buffer in {\tt itemStr} will be items in {\tt i1} through |
---|
1097 | ! {\tt i2} {\tt aList}, separated by the colon delimiter. |
---|
1098 | ! |
---|
1099 | ! !INTERFACE: |
---|
1100 | |
---|
1101 | subroutine getrange_(itemStr, i1, i2, aList) |
---|
1102 | |
---|
1103 | ! !USES: |
---|
1104 | ! |
---|
1105 | use m_die, only : die |
---|
1106 | use m_stdio, only : stderr |
---|
1107 | use m_String, only : String,init,toChar |
---|
1108 | |
---|
1109 | implicit none |
---|
1110 | |
---|
1111 | ! !INPUT PARAMETERS: |
---|
1112 | ! |
---|
1113 | integer, intent(in) :: i1 |
---|
1114 | integer, intent(in) :: i2 |
---|
1115 | type(List), intent(in) :: aList |
---|
1116 | |
---|
1117 | ! !OUTPUT PARAMETERS: |
---|
1118 | ! |
---|
1119 | type(String),intent(out) :: itemStr |
---|
1120 | |
---|
1121 | ! !REVISION HISTORY: |
---|
1122 | ! 23Apr98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
1123 | ! 26Jul02 - J. Larson - Added argument checks. |
---|
1124 | !EOP ___________________________________________________________________ |
---|
1125 | |
---|
1126 | character(len=*),parameter :: myname_=myname//'::getrange_' |
---|
1127 | integer :: lb,le,ni |
---|
1128 | |
---|
1129 | ! Argument Sanity Checks: |
---|
1130 | |
---|
1131 | if(.not. allocated_(aList)) then |
---|
1132 | write(stderr,'(2a)') myname_, & |
---|
1133 | ':: FATAL--List argument aList is not initialized.' |
---|
1134 | call die(myname_) |
---|
1135 | endif |
---|
1136 | |
---|
1137 | ! is i2 >= i1 as we assume? |
---|
1138 | |
---|
1139 | if(i1 > i2) then |
---|
1140 | write(stderr,'(2a,2(a,i8))') myname_, & |
---|
1141 | ':: FATAL. Starting/Ending item ranks are out of order; ', & |
---|
1142 | 'i2 must be greater or equal to i1. i1 =',i1,' i2 = ',i2 |
---|
1143 | call die(myname_) |
---|
1144 | endif |
---|
1145 | |
---|
1146 | ni=size(aList%lc,2) ! the number of items in aList... |
---|
1147 | |
---|
1148 | ! is i1 or i2 too big? |
---|
1149 | |
---|
1150 | if(i1 > ni) then |
---|
1151 | write(stderr,'(2a,2(a,i8))') myname_, & |
---|
1152 | ':: FATAL--i1 is greater than the number of items in ', & |
---|
1153 | 'The List argument aList: i1 =',i1,' ni = ',ni |
---|
1154 | call die(myname_) |
---|
1155 | endif |
---|
1156 | |
---|
1157 | if(i2 > ni) then |
---|
1158 | write(stderr,'(2a,2(a,i8))') myname_, & |
---|
1159 | ':: FATAL--i2 is greater than the number of items in ', & |
---|
1160 | 'The List argument aList: i2 =',i2,' ni = ',ni |
---|
1161 | call die(myname_) |
---|
1162 | endif |
---|
1163 | |
---|
1164 | ! End of Argument Sanity Checks. |
---|
1165 | |
---|
1166 | lb=aList%lc(0,max(1,i1)) |
---|
1167 | le=aList%lc(1,min(ni,i2)) |
---|
1168 | call init(itemStr,toChar(aList%bf(lb:le))) |
---|
1169 | |
---|
1170 | end subroutine getrange_ |
---|
1171 | |
---|
1172 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
1173 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
1174 | !BOP ------------------------------------------------------------------- |
---|
1175 | ! |
---|
1176 | ! !IROUTINE: identical_ - Compare Two Lists for Equality |
---|
1177 | ! |
---|
1178 | ! !DESCRIPTION: |
---|
1179 | ! This function compares the string buffer and indexing information in |
---|
1180 | ! the two input {\tt List} arguments {\tt yL} and {\tt xL}. If the |
---|
1181 | ! string buffers and index buffers of {\tt yL} and {\tt xL} match, this |
---|
1182 | ! function returns a value of {\tt .TRUE.} Otherwise, it returns a |
---|
1183 | ! value of {\tt .FALSE.} |
---|
1184 | ! |
---|
1185 | ! !INTERFACE: |
---|
1186 | |
---|
1187 | logical function identical_(yL, xL) |
---|
1188 | |
---|
1189 | ! !USES: |
---|
1190 | ! |
---|
1191 | use m_die,only : die |
---|
1192 | use m_String ,only : String |
---|
1193 | use m_String ,only : String_clean |
---|
1194 | |
---|
1195 | implicit none |
---|
1196 | |
---|
1197 | ! !INPUT PARAMETERS: |
---|
1198 | ! |
---|
1199 | type(List), intent(in) :: yL |
---|
1200 | type(List), intent(in) :: xL |
---|
1201 | |
---|
1202 | ! !REVISION HISTORY: |
---|
1203 | ! 14Oct01 - J. Larson <larson@mcs.anl.gov> - original version |
---|
1204 | !EOP ___________________________________________________________________ |
---|
1205 | |
---|
1206 | character(len=*),parameter :: myname_=myname//'::identical_' |
---|
1207 | |
---|
1208 | logical :: myIdentical |
---|
1209 | type(String) :: DummStr |
---|
1210 | integer :: n, NumItems |
---|
1211 | |
---|
1212 | ! Compare the number of the items in the Lists xL and yL. |
---|
1213 | ! If they differ, myIdentical is set to .FALSE. and we are |
---|
1214 | ! finished. If both Lists sport the same number of items, |
---|
1215 | ! we must compare them one-by-one... |
---|
1216 | |
---|
1217 | myIdentical = .FALSE. |
---|
1218 | |
---|
1219 | if(nitem_(yL) == nitem_(xL)) then |
---|
1220 | |
---|
1221 | NumItems = nitem_(yL) |
---|
1222 | |
---|
1223 | COMPARE_LOOP: do n=1,NumItems |
---|
1224 | |
---|
1225 | call get_(DummStr, n, yL) ! retrieve nth tag as a String |
---|
1226 | |
---|
1227 | if( indexStr_(xL, Dummstr) /= n ) then ! a discrepency spotted. |
---|
1228 | call String_clean(Dummstr) |
---|
1229 | myIdentical = .FALSE. |
---|
1230 | EXIT |
---|
1231 | else |
---|
1232 | call String_clean(Dummstr) |
---|
1233 | endif |
---|
1234 | |
---|
1235 | myIdentical = .TRUE. ! we survived the whole test process. |
---|
1236 | |
---|
1237 | end do COMPARE_LOOP |
---|
1238 | |
---|
1239 | endif |
---|
1240 | |
---|
1241 | identical_ = myIdentical |
---|
1242 | |
---|
1243 | end function identical_ |
---|
1244 | |
---|
1245 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
1246 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
1247 | !BOP ------------------------------------------------------------------- |
---|
1248 | ! |
---|
1249 | ! !IROUTINE: get_indices_ - Index Multiple Items in a List |
---|
1250 | ! |
---|
1251 | ! !DESCRIPTION: This routine takes as input a {\tt List} argument |
---|
1252 | ! {\tt aList}, and a {\tt CHARACTER} string {Values}, which is a colon- |
---|
1253 | ! delimited string of items, and returns an {\tt INTEGER} array |
---|
1254 | ! {\tt indices(:)}, which contain the rank of each item in {\tt aList}. |
---|
1255 | ! For example, suppose {\tt aList} was created from the character string |
---|
1256 | ! \begin{verbatim} |
---|
1257 | ! 'happy:sleepy:sneezey:grumpy:dopey::bashful:doc' |
---|
1258 | ! \end{verbatim} |
---|
1259 | ! and get\_indices\_() is invoked as follows: |
---|
1260 | ! \begin{verbatim} |
---|
1261 | ! call get_indices_(indices, aList, 'sleepy:grumpy:bashful:doc') |
---|
1262 | ! \end{verbatim} |
---|
1263 | ! The array {\tt indices(:)} will be returned with 4 entries: |
---|
1264 | ! ${\tt indices(1)}=2$, ${\tt indices(2)}=4$, ${\tt indices(3)}=6$, and |
---|
1265 | ! ${\tt indices(4)}=7$. |
---|
1266 | ! |
---|
1267 | ! {\bf N.B.}: This routine operates on the assumption that each of the |
---|
1268 | ! substrings in the colon-delimited string {\tt Values} is an item in |
---|
1269 | ! {\tt aList}. If this assumption is invalid, this routine terminates |
---|
1270 | ! execution with an error message. |
---|
1271 | ! |
---|
1272 | ! {\bf N.B.}: The pointer {\tt indices} must be {\tt UNASSOCIATED} on entry |
---|
1273 | ! to this routine, and will be {\tt ASSOCIATED} upon return. After this pointer |
---|
1274 | ! is no longer needed, it should be deallocated. Failure to do so will result |
---|
1275 | ! in a memory leak. |
---|
1276 | ! |
---|
1277 | ! !INTERFACE: |
---|
1278 | |
---|
1279 | subroutine get_indices_(indices, aList, Values) |
---|
1280 | |
---|
1281 | ! !USES: |
---|
1282 | ! |
---|
1283 | use m_stdio |
---|
1284 | use m_die |
---|
1285 | use m_String, only : String |
---|
1286 | use m_String, only : String_clean => clean |
---|
1287 | use m_String, only : String_toChar => toChar |
---|
1288 | |
---|
1289 | implicit none |
---|
1290 | |
---|
1291 | ! !INPUT PARAMETERS: |
---|
1292 | ! |
---|
1293 | type(List), intent(in) :: aList ! an indexed string values |
---|
1294 | character(len=*), intent(in) :: Values ! ":" delimited names |
---|
1295 | |
---|
1296 | ! !OUTPUT PARAMETERS: |
---|
1297 | ! |
---|
1298 | integer, dimension(:), pointer :: indices |
---|
1299 | |
---|
1300 | ! !REVISION HISTORY: |
---|
1301 | ! 31May98 - Jing Guo <guo@thunder> - initial prototype/prolog/code |
---|
1302 | ! 12Feb03 - J. Larson <larson@mcs.anl.gov> Working refactored version |
---|
1303 | !EOP ___________________________________________________________________ |
---|
1304 | |
---|
1305 | character(len=*),parameter :: myname_=myname//'::get_indices_' |
---|
1306 | type(List) :: tList |
---|
1307 | type(String) :: tStr |
---|
1308 | integer :: i, ierr, n |
---|
1309 | |
---|
1310 | ! Create working list based on input colon-delimited string |
---|
1311 | |
---|
1312 | call init_(tList, values) |
---|
1313 | |
---|
1314 | |
---|
1315 | ! Count items in tList and allocate indices(:) accordingly |
---|
1316 | |
---|
1317 | n = nitem_(tList) |
---|
1318 | |
---|
1319 | if(n > nitem_(aList)) then |
---|
1320 | write(stderr,'(5a,2(i8,a))') myname_, & |
---|
1321 | ':: FATAL--more items in argument Values than aList! Input string', & |
---|
1322 | 'Values = "',Values,'" has ',n,' items. aList has ',nitem_(aList), & |
---|
1323 | ' items.' |
---|
1324 | call die(myname_) |
---|
1325 | endif |
---|
1326 | allocate(indices(n), stat=ierr) |
---|
1327 | if(ierr /= 0) then |
---|
1328 | write(stderr,'(2a,i8,a)') myname_, & |
---|
1329 | ':: FATAL--allocate(indices(...) failed with stat=',ierr,& |
---|
1330 | '. On entry to this routine, this pointer must be NULL.' |
---|
1331 | call die(myname_) |
---|
1332 | endif |
---|
1333 | |
---|
1334 | ! Retrieve each item from tList as a String and index it |
---|
1335 | |
---|
1336 | do i=1,n |
---|
1337 | call get_(tStr,i,tList) |
---|
1338 | indices(i) = indexStr_(aList,tStr) |
---|
1339 | if(indices(i) == 0) then ! ith item not present in aList! |
---|
1340 | write(stderr,'(4a)') myname_, & |
---|
1341 | ':: FATAL--item "',String_toChar(tStr),'" not found.' |
---|
1342 | call die(myname_) |
---|
1343 | endif |
---|
1344 | call String_clean(tStr) |
---|
1345 | end do |
---|
1346 | |
---|
1347 | ! Clean up temporary List tList |
---|
1348 | |
---|
1349 | call clean_(tList) |
---|
1350 | |
---|
1351 | end subroutine get_indices_ |
---|
1352 | |
---|
1353 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
1354 | ! NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS ! |
---|
1355 | !BOP ------------------------------------------------------------------- |
---|
1356 | ! |
---|
1357 | ! !IROUTINE: test_indices_ - Test/Index Multiple Items in a List |
---|
1358 | ! |
---|
1359 | ! !DESCRIPTION: This routine takes as input a {\tt List} argument |
---|
1360 | ! {\tt aList}, and a {\tt CHARACTER} string {Values}, which is a colon- |
---|
1361 | ! delimited string of items, and returns an {\tt INTEGER} array |
---|
1362 | ! {\tt indices(:)}, which contain the rank of each item in {\tt aList}. |
---|
1363 | ! For example, suppose {\tt aList} was created from the character string |
---|
1364 | ! \begin{verbatim} |
---|
1365 | ! 'happy:sleepy:sneezey:grumpy:dopey::bashful:doc' |
---|
1366 | ! \end{verbatim} |
---|
1367 | ! and {\tt test\_indices\_()} is invoked as follows: |
---|
1368 | ! \begin{verbatim} |
---|
1369 | ! call test_indices_(indices, aList, 'sleepy:grumpy:bashful:doc') |
---|
1370 | ! \end{verbatim} |
---|
1371 | ! The array {\tt indices(:)} will be returned with 4 entries: |
---|
1372 | ! ${\tt indices(1)}=2$, ${\tt indices(2)}=4$, ${\tt indices(3)}=6$, and |
---|
1373 | ! ${\tt indices(4)}=7$. |
---|
1374 | ! |
---|
1375 | ! Now suppose {\tt test\_indices\_()} is invoked as follows: |
---|
1376 | ! \begin{verbatim} |
---|
1377 | ! call test_indices_(indices, aList, 'sleepy:grumpy:bashful:Snow White') |
---|
1378 | ! \end{verbatim} |
---|
1379 | ! The array {\tt indices(:)} will be returned with 4 entries: |
---|
1380 | ! ${\tt indices(1)}=2$, ${\tt indices(2)}=4$, ${\tt indices(3)}=6$, and |
---|
1381 | ! ${\tt indices(4)}=0$. |
---|
1382 | ! |
---|
1383 | ! {\bf N.B.}: This routine operates on the assumption that one or more |
---|
1384 | ! of the substrings in the colon-delimited string {\tt Values} is may not |
---|
1385 | ! be an item in {\tt aList}. If an item in {\tt Values} is {\em not} in |
---|
1386 | ! {\tt aList}, its corresponding entry in {\tt indices(:)} is set to zero. |
---|
1387 | ! |
---|
1388 | ! {\bf N.B.}: The pointer {\tt indices} must be {\tt UNASSOCIATED} on entry |
---|
1389 | ! to this routine, and will be {\tt ASSOCIATED} upon return. After this pointer |
---|
1390 | ! is no longer needed, it should be deallocated. Failure to do so will result |
---|
1391 | ! in a memory leak. |
---|
1392 | ! |
---|
1393 | ! !INTERFACE: |
---|
1394 | |
---|
1395 | subroutine test_indices_(indices, aList, Values) |
---|
1396 | |
---|
1397 | ! !USES: |
---|
1398 | ! |
---|
1399 | use m_stdio |
---|
1400 | use m_die |
---|
1401 | use m_String, only : String |
---|
1402 | use m_String, only : String_clean => clean |
---|
1403 | use m_String, only : String_toChar => toChar |
---|
1404 | |
---|
1405 | implicit none |
---|
1406 | |
---|
1407 | ! !INPUT PARAMETERS: |
---|
1408 | ! |
---|
1409 | type(List), intent(in) :: aList ! an indexed string values |
---|
1410 | character(len=*), intent(in) :: Values ! ":" delimited names |
---|
1411 | |
---|
1412 | ! !OUTPUT PARAMETERS: |
---|
1413 | ! |
---|
1414 | integer, dimension(:), pointer :: indices |
---|
1415 | |
---|
1416 | ! !REVISION HISTORY: |
---|
1417 | ! 12Feb03 - J. Larson <larson@mcs.anl.gov> Working refactored version |
---|
1418 | !EOP ___________________________________________________________________ |
---|
1419 | |
---|
1420 | character(len=*),parameter :: myname_=myname//'::test_indices_' |
---|
1421 | type(List) :: tList |
---|
1422 | type(String) :: tStr |
---|
1423 | integer :: i, ierr, n |
---|
1424 | |
---|
1425 | ! Create working list based on input colon-delimited string |
---|
1426 | |
---|
1427 | call init_(tList, values) |
---|
1428 | |
---|
1429 | |
---|
1430 | ! Count items in tList and allocate indices(:) accordingly |
---|
1431 | |
---|
1432 | n = nitem_(tList) |
---|
1433 | allocate(indices(n), stat=ierr) |
---|
1434 | if(ierr /= 0) then |
---|
1435 | write(stderr,'(2a,i8,a)') myname_, & |
---|
1436 | ':: FATAL--allocate(indices(...) failed with stat=',ierr,& |
---|
1437 | '. On entry to this routine, this pointer must be NULL.' |
---|
1438 | call die(myname_) |
---|
1439 | endif |
---|
1440 | |
---|
1441 | ! Retrieve each item from tList as a String and index it |
---|
1442 | |
---|
1443 | do i=1,n |
---|
1444 | call get_(tStr,i,tList) |
---|
1445 | indices(i) = indexStr_(aList,tStr) |
---|
1446 | call String_clean(tStr) |
---|
1447 | end do |
---|
1448 | |
---|
1449 | ! Clean up temporary List tList |
---|
1450 | |
---|
1451 | call clean_(tList) |
---|
1452 | |
---|
1453 | end subroutine test_indices_ |
---|
1454 | |
---|
1455 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
1456 | ! Math and Computer Science Division, Argonne National Laboratory ! |
---|
1457 | !BOP ------------------------------------------------------------------- |
---|
1458 | ! |
---|
1459 | ! !IROUTINE: append_ - Append One List Onto the End of Another |
---|
1460 | ! |
---|
1461 | ! !DESCRIPTION: This routine takes two {\tt List} arguments |
---|
1462 | ! {\tt iList1} and {\tt iList2}, and appends {\tt List2} onto |
---|
1463 | ! the end of {\tt List1}. |
---|
1464 | ! |
---|
1465 | ! {\bf N.B.}: There is no check for shared items in the arguments |
---|
1466 | ! {\tt List1} and {\tt List2}. It is the user's responsibility to |
---|
1467 | ! ensure {\tt List1} and {\tt List2} share no items. If this routine |
---|
1468 | ! is invoked in such a manner that {\tt List1} and {\tt List2} share |
---|
1469 | ! common items, the resultant value of {\tt List1} will produce |
---|
1470 | ! ambiguous results for some of the {\tt List} query functions. |
---|
1471 | ! |
---|
1472 | ! {\bf N.B.}: The outcome of this routine is order dependent. That is, |
---|
1473 | ! the entries of {\tt iList2} will follow the {\em input} entries in |
---|
1474 | ! {\tt iList1}. |
---|
1475 | ! |
---|
1476 | ! !INTERFACE: |
---|
1477 | |
---|
1478 | subroutine append_(iList1, iList2) |
---|
1479 | ! |
---|
1480 | ! !USES: |
---|
1481 | ! |
---|
1482 | use m_stdio |
---|
1483 | use m_die, only : die |
---|
1484 | |
---|
1485 | use m_mpif90 |
---|
1486 | |
---|
1487 | use m_String, only: String |
---|
1488 | use m_String, only: String_toChar => toChar |
---|
1489 | use m_String, only: String_len |
---|
1490 | use m_String, only: String_clean => clean |
---|
1491 | |
---|
1492 | implicit none |
---|
1493 | |
---|
1494 | ! !INPUT PARAMETERS: |
---|
1495 | ! |
---|
1496 | type(List), intent(in) :: iList2 |
---|
1497 | |
---|
1498 | ! !INPUT/OUTPUT PARAMETERS: |
---|
1499 | ! |
---|
1500 | type(List), intent(inout) :: iList1 |
---|
1501 | |
---|
1502 | ! !REVISION HISTORY: |
---|
1503 | ! 6Aug02 - J. Larson - Initial version |
---|
1504 | !EOP ___________________________________________________________________ |
---|
1505 | |
---|
1506 | character(len=*),parameter :: myname_=myname//'::append_' |
---|
1507 | |
---|
1508 | type(List) :: DummyList |
---|
1509 | |
---|
1510 | call copy_(DummyList, iList1) |
---|
1511 | call clean_(iList1) |
---|
1512 | call concatenate(DummyList, iList2, iList1) |
---|
1513 | call clean_(DummyList) |
---|
1514 | |
---|
1515 | end subroutine append_ |
---|
1516 | |
---|
1517 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
1518 | ! Math and Computer Science Division, Argonne National Laboratory ! |
---|
1519 | !BOP ------------------------------------------------------------------- |
---|
1520 | ! |
---|
1521 | ! !IROUTINE: concatenate_ - Concatenates two Lists to form a Third List. |
---|
1522 | ! |
---|
1523 | ! !DESCRIPTION: This routine takes two input {\tt List} arguments |
---|
1524 | ! {\tt iList1} and {\tt iList2}, and concatenates them, producing an |
---|
1525 | ! output {\tt List} argument {\tt oList}. |
---|
1526 | ! |
---|
1527 | ! {\bf N.B.}: The nature of this routine is such that one must |
---|
1528 | ! {\bf never} supply as the actual value of {\tt oList} the same |
---|
1529 | ! value supplied for either {\tt iList1} or {\tt iList2}. |
---|
1530 | ! |
---|
1531 | ! {\bf N.B.}: The outcome of this routine is order dependent. That is, |
---|
1532 | ! the entries of {\tt iList2} will follow {\tt iList1}. |
---|
1533 | ! |
---|
1534 | ! !INTERFACE: |
---|
1535 | |
---|
1536 | subroutine concatenate_(iList1, iList2, oList) |
---|
1537 | ! |
---|
1538 | ! !USES: |
---|
1539 | ! |
---|
1540 | use m_stdio |
---|
1541 | use m_die, only : die |
---|
1542 | |
---|
1543 | use m_mpif90 |
---|
1544 | |
---|
1545 | use m_String, only: String |
---|
1546 | use m_String, only: String_init => init |
---|
1547 | use m_String, only: String_clean => clean |
---|
1548 | |
---|
1549 | implicit none |
---|
1550 | |
---|
1551 | ! !INPUT PARAMETERS: |
---|
1552 | ! |
---|
1553 | type(List), intent(in) :: iList1 |
---|
1554 | type(List), intent(in) :: iList2 |
---|
1555 | |
---|
1556 | ! !OUTPUT PARAMETERS: |
---|
1557 | ! |
---|
1558 | type(List), intent(out) :: oList |
---|
1559 | |
---|
1560 | ! !BUGS: For now, the List concatenate algorithm relies on fixed-length |
---|
1561 | ! CHARACTER variables as intermediate storage. The lengths of these |
---|
1562 | ! scratch variables is hard-wired to 10000, which should be large enough |
---|
1563 | ! for most applications. This undesirable feature should be corrected |
---|
1564 | ! ASAP. |
---|
1565 | ! |
---|
1566 | ! !REVISION HISTORY: |
---|
1567 | ! 8May01 - J.W. Larson - initial version. |
---|
1568 | ! 17May01 - J.W. Larson - Re-worked and tested successfully. |
---|
1569 | ! 17Jul02 - E. Ong - fixed the bug mentioned above |
---|
1570 | !EOP ___________________________________________________________________ |
---|
1571 | |
---|
1572 | character(len=*),parameter :: myname_=myname//'::concatenate_' |
---|
1573 | |
---|
1574 | character, dimension(:), allocatable :: CatBuff |
---|
1575 | integer :: CatBuffLength, i, ierr, Length1, Length2 |
---|
1576 | type(String) :: CatString |
---|
1577 | |
---|
1578 | ! First, handle the case of either iList1 and/or iList2 being |
---|
1579 | ! null |
---|
1580 | |
---|
1581 | if((nitem_(iList1) == 0) .or. (nitem_(iList2) == 0)) then |
---|
1582 | |
---|
1583 | if((nitem_(iList1) == 0) .and. (nitem_(iList2) == 0)) then |
---|
1584 | call init_(oList,'') |
---|
1585 | else |
---|
1586 | if((nitem_(iList1) == 0) .and. (nitem_(iList2) > 0)) then |
---|
1587 | call copy_(oList, iList2) |
---|
1588 | endif |
---|
1589 | if((nitem_(iList1) > 0) .and. (nitem_(iList2) == 0)) then |
---|
1590 | call copy_(oList,iList1) |
---|
1591 | endif |
---|
1592 | endif |
---|
1593 | |
---|
1594 | else ! both lists are non-null |
---|
1595 | |
---|
1596 | ! Step one: Get lengths of character buffers of iList1 and iList2: |
---|
1597 | |
---|
1598 | Length1 = CharBufferSize_(iList1) |
---|
1599 | Length2 = CharBufferSize_(iList2) |
---|
1600 | |
---|
1601 | ! Step two: create CatBuff(:) as workspace |
---|
1602 | |
---|
1603 | CatBuffLength = Length1 + Length2 + 1 |
---|
1604 | allocate(CatBuff(CatBuffLength), stat=ierr) |
---|
1605 | if(ierr /= 0) then |
---|
1606 | write(stderr,'(2a,i8)') myname_, & |
---|
1607 | ':: FATAL--allocate(CatBuff(...) failed. ierr=',ierr |
---|
1608 | call die(myname_) |
---|
1609 | endif |
---|
1610 | |
---|
1611 | ! Step three: concatenate CHARACTERs with the colon separator |
---|
1612 | ! into CatBuff(:) |
---|
1613 | |
---|
1614 | do i=1,Length1 |
---|
1615 | CatBuff(i) = iList1%bf(i) |
---|
1616 | end do |
---|
1617 | |
---|
1618 | CatBuff(Length1 + 1) = ':' |
---|
1619 | |
---|
1620 | do i=1,Length2 |
---|
1621 | CatBuff(Length1 + 1 + i) = iList2%bf(i) |
---|
1622 | end do |
---|
1623 | |
---|
1624 | ! Step four: initialize a String CatString: |
---|
1625 | |
---|
1626 | call String_init(CatString, CatBuff) |
---|
1627 | |
---|
1628 | ! Step five: initialize oList: |
---|
1629 | |
---|
1630 | call initStr_(oList, CatString) |
---|
1631 | |
---|
1632 | ! The concatenation is complete. Now, clean up |
---|
1633 | |
---|
1634 | call String_clean(CatString) |
---|
1635 | |
---|
1636 | deallocate(CatBuff,stat=ierr) |
---|
1637 | if(ierr /= 0) then |
---|
1638 | write(stderr,'(2a,i8)') myname_, & |
---|
1639 | ':: FATAL--deallocate(CatBuff) failed. ierr=',ierr |
---|
1640 | call die(myname_) |
---|
1641 | endif |
---|
1642 | |
---|
1643 | endif |
---|
1644 | |
---|
1645 | end subroutine concatenate_ |
---|
1646 | |
---|
1647 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
1648 | ! Math and Computer Science Division, Argonne National Laboratory ! |
---|
1649 | !BOP ------------------------------------------------------------------- |
---|
1650 | ! |
---|
1651 | ! !IROUTINE: bcast_ - MPI Broadcast for the List Type |
---|
1652 | ! |
---|
1653 | ! !DESCRIPTION: This routine takes an input {\tt List} argument |
---|
1654 | ! {\tt iList} (on input, valid on the root only), and broadcasts it. |
---|
1655 | ! |
---|
1656 | ! {\bf N.B.}: The outcome of this routine, {\tt ioList} on non-root |
---|
1657 | ! processes, represents allocated memory. When this {\tt List} is |
---|
1658 | ! no longer needed, it must be deallocated by invoking the routine |
---|
1659 | ! {\tt List\_clean()}. Failure to do so will cause a memory leak. |
---|
1660 | ! |
---|
1661 | ! !INTERFACE: |
---|
1662 | |
---|
1663 | subroutine bcast_(ioList, root, comm, status) |
---|
1664 | ! |
---|
1665 | ! !USES: |
---|
1666 | ! |
---|
1667 | use m_stdio, only : stderr |
---|
1668 | use m_die, only : MP_perr_die, die |
---|
1669 | |
---|
1670 | use m_String, only: String |
---|
1671 | use m_String, only: String_bcast => bcast |
---|
1672 | use m_String, only: String_clean => clean |
---|
1673 | |
---|
1674 | use m_mpif90 |
---|
1675 | |
---|
1676 | implicit none |
---|
1677 | |
---|
1678 | ! !INPUT PARAMETERS: |
---|
1679 | ! |
---|
1680 | integer, intent(in) :: root |
---|
1681 | integer, intent(in) :: comm |
---|
1682 | |
---|
1683 | ! !INPUT/OUTPUT PARAMETERS: |
---|
1684 | ! |
---|
1685 | type(List), intent(inout) :: ioList |
---|
1686 | |
---|
1687 | |
---|
1688 | ! !OUTPUT PARAMETERS: |
---|
1689 | ! |
---|
1690 | integer, optional, intent(out) :: status |
---|
1691 | |
---|
1692 | ! !REVISION HISTORY: |
---|
1693 | ! 7May01 - J.W. Larson - initial version. |
---|
1694 | ! 14May01 - R.L. Jacob - fix error checking |
---|
1695 | ! 16May01 - J.W. Larson - new, simpler String-based algorigthm |
---|
1696 | ! (see m_String for details), which works properly on |
---|
1697 | ! the SGI platform. |
---|
1698 | ! 13Jun01 - J.W. Larson <larson@mcs.anl.gov> - Initialize status |
---|
1699 | ! (if present). |
---|
1700 | !EOP ___________________________________________________________________ |
---|
1701 | |
---|
1702 | character(len=*),parameter :: myname_=myname//'::bcast_' |
---|
1703 | integer :: myID, ierr |
---|
1704 | type(String) :: DummStr |
---|
1705 | |
---|
1706 | ! Initialize status (if present) |
---|
1707 | |
---|
1708 | if(present(status)) status = 0 |
---|
1709 | |
---|
1710 | ! Which process am I? |
---|
1711 | |
---|
1712 | call MPI_COMM_RANK(comm, myID, ierr) |
---|
1713 | if(ierr /= 0) then |
---|
1714 | if(present(status)) then |
---|
1715 | status = ierr |
---|
1716 | write(stderr,'(2a,i4)') myname_,":: MPI_COMM_RANK(), ierr=",ierr |
---|
1717 | return |
---|
1718 | else |
---|
1719 | call MP_perr_die(myname_,"MPI_COMM_RANK()",ierr) |
---|
1720 | endif |
---|
1721 | endif |
---|
1722 | |
---|
1723 | ! on the root, convert ioList into the String variable DummStr |
---|
1724 | |
---|
1725 | if(myID == root) then |
---|
1726 | if(CharBufferSize_(ioList) <= 0) then |
---|
1727 | call die(myname_, 'Attempting to broadcast an empty list!',& |
---|
1728 | CharBufferSize_(ioList)) |
---|
1729 | endif |
---|
1730 | call getall_(DummStr, ioList) |
---|
1731 | endif |
---|
1732 | |
---|
1733 | ! Broadcast DummStr |
---|
1734 | |
---|
1735 | call String_bcast(DummStr, root, comm, ierr) |
---|
1736 | if(ierr /= 0) then |
---|
1737 | if(present(status)) then |
---|
1738 | status = ierr |
---|
1739 | write(stderr,'(2a,i4)') myname_,":: call String_bcast(), ierr=",ierr |
---|
1740 | return |
---|
1741 | else |
---|
1742 | call MP_perr_die(myname_,"String_bcast() failed, stat=",ierr) |
---|
1743 | endif |
---|
1744 | endif |
---|
1745 | |
---|
1746 | ! Initialize ioList off the root using DummStr |
---|
1747 | |
---|
1748 | if(myID /= root) then |
---|
1749 | call initStr_(ioList, DummStr) |
---|
1750 | endif |
---|
1751 | |
---|
1752 | ! And now, the List broadcast is complete. |
---|
1753 | |
---|
1754 | call String_clean(DummStr) |
---|
1755 | |
---|
1756 | end subroutine bcast_ |
---|
1757 | |
---|
1758 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
1759 | ! Math and Computer Science Division, Argonne National Laboratory ! |
---|
1760 | !BOP ------------------------------------------------------------------- |
---|
1761 | ! |
---|
1762 | ! !IROUTINE: send_ - MPI Point-to-Point Send for the List Type |
---|
1763 | ! |
---|
1764 | ! !DESCRIPTION: This routine takes an input {\tt List} argument |
---|
1765 | ! {\tt inList} and sends it to processor {\tt dest} on the communicator |
---|
1766 | ! associated with the fortran 90 {\tt INTEGER} handle {\tt comm}. The |
---|
1767 | ! message is tagged by the input {\tt INTEGER} argument {\tt TagBase}. |
---|
1768 | ! The success (failure) of this operation is reported in the zero |
---|
1769 | ! (nonzero) optional output argument {\tt status}. |
---|
1770 | ! |
---|
1771 | ! {\bf N.B.}: One must avoid assigning elsewhere the MPI tag values |
---|
1772 | ! {\tt TagBase} and {\tt TagBase+1}. This is because {\tt send\_()} |
---|
1773 | ! performs the send of the {\tt List} as a pair of operations. The |
---|
1774 | ! first send is the number of characters in {\tt inList\%bf}, and is |
---|
1775 | ! given MPI tag value {\tt TagBase}. The second send is the |
---|
1776 | ! {\tt CHARACTER} data present in {\tt inList\%bf}, and is given MPI |
---|
1777 | ! tag value {\tt TagBase+1}. |
---|
1778 | ! |
---|
1779 | ! !INTERFACE: |
---|
1780 | |
---|
1781 | subroutine send_(inList, dest, TagBase, comm, status) |
---|
1782 | ! |
---|
1783 | ! !USES: |
---|
1784 | ! |
---|
1785 | use m_stdio |
---|
1786 | use m_die, only : MP_perr_die |
---|
1787 | |
---|
1788 | use m_mpif90 |
---|
1789 | |
---|
1790 | use m_String, only: String |
---|
1791 | use m_String, only: String_toChar => toChar |
---|
1792 | use m_String, only: String_len |
---|
1793 | use m_String, only: String_clean => clean |
---|
1794 | |
---|
1795 | implicit none |
---|
1796 | |
---|
1797 | ! !INPUT PARAMETERS: |
---|
1798 | ! |
---|
1799 | type(List), intent(in) :: inList |
---|
1800 | integer, intent(in) :: dest |
---|
1801 | integer, intent(in) :: TagBase |
---|
1802 | integer, intent(in) :: comm |
---|
1803 | |
---|
1804 | ! !OUTPUT PARAMETERS: |
---|
1805 | ! |
---|
1806 | integer, optional, intent(out) :: status |
---|
1807 | |
---|
1808 | ! !REVISION HISTORY: |
---|
1809 | ! 6Jun01 - J.W. Larson - initial version. |
---|
1810 | ! 13Jun01 - J.W. Larson <larson@mcs.anl.gov> - Initialize status |
---|
1811 | ! (if present). |
---|
1812 | !EOP ___________________________________________________________________ |
---|
1813 | |
---|
1814 | character(len=*),parameter :: myname_=myname//'::send_' |
---|
1815 | |
---|
1816 | type(String) :: DummStr |
---|
1817 | integer :: ierr, length |
---|
1818 | |
---|
1819 | ! Set status flag to zero (success) if present: |
---|
1820 | |
---|
1821 | if(present(status)) status = 0 |
---|
1822 | |
---|
1823 | ! Step 1. Extract CHARACTER buffer from inList and store it |
---|
1824 | ! in String variable DummStr, determine its length. |
---|
1825 | |
---|
1826 | call getall_(DummStr, inList) |
---|
1827 | length = String_len(DummStr) |
---|
1828 | |
---|
1829 | ! Step 2. Send Length of String DummStr to process dest. |
---|
1830 | |
---|
1831 | call MPI_SEND(length, 1, MP_type(length), dest, TagBase, comm, ierr) |
---|
1832 | if(ierr /= 0) then |
---|
1833 | if(present(status)) then |
---|
1834 | write(stderr,'(2a,i8)') myname_, & |
---|
1835 | ':: MPI_SEND(length...) failed. ierror=', ierr |
---|
1836 | status = ierr |
---|
1837 | return |
---|
1838 | else |
---|
1839 | call MP_perr_die(myname_,':: MPI_SEND(length...) failed',ierr) |
---|
1840 | endif |
---|
1841 | endif |
---|
1842 | |
---|
1843 | ! Step 3. Send CHARACTER portion of String DummStr |
---|
1844 | ! to process dest. |
---|
1845 | |
---|
1846 | call MPI_SEND(DummStr%c(1), length, MP_CHARACTER, dest, TagBase+1, & |
---|
1847 | comm, ierr) |
---|
1848 | if(ierr /= 0) then |
---|
1849 | if(present(status)) then |
---|
1850 | write(stderr,'(2a,i8)') myname_, & |
---|
1851 | ':: MPI_SEND(DummStr%c...) failed. ierror=', ierr |
---|
1852 | status = ierr |
---|
1853 | return |
---|
1854 | else |
---|
1855 | call MP_perr_die(myname_,':: MPI_SEND(DummStr%c...) failed',ierr) |
---|
1856 | endif |
---|
1857 | endif |
---|
1858 | |
---|
1859 | end subroutine send_ |
---|
1860 | |
---|
1861 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
1862 | ! Math and Computer Science Division, Argonne National Laboratory ! |
---|
1863 | !BOP ------------------------------------------------------------------- |
---|
1864 | ! |
---|
1865 | ! !IROUTINE: recv_ - MPI Point-to-Point Receive for the List Type |
---|
1866 | ! |
---|
1867 | ! !DESCRIPTION: This routine receives the output {\tt List} argument |
---|
1868 | ! {\tt outList} from processor {\tt source} on the communicator associated |
---|
1869 | ! with the fortran 90 {\tt INTEGER} handle {\tt comm}. The message is |
---|
1870 | ! tagged by the input {\tt INTEGER} argument {\tt TagBase}. The success |
---|
1871 | ! (failure) of this operation is reported in the zero (nonzero) optional |
---|
1872 | ! output argument {\tt status}. |
---|
1873 | ! |
---|
1874 | ! {\bf N.B.}: One must avoid assigning elsewhere the MPI tag values |
---|
1875 | ! {\tt TagBase} and {\tt TagBase+1}. This is because {\tt recv\_()} |
---|
1876 | ! performs the receive of the {\tt List} as a pair of operations. The |
---|
1877 | ! first receive is the number of characters in {\tt outList\%bf}, and |
---|
1878 | ! is given MPI tag value {\tt TagBase}. The second receive is the |
---|
1879 | ! {\tt CHARACTER} data present in {\tt outList\%bf}, and is given MPI |
---|
1880 | ! tag value {\tt TagBase+1}. |
---|
1881 | ! |
---|
1882 | ! !INTERFACE: |
---|
1883 | |
---|
1884 | subroutine recv_(outList, source, TagBase, comm, status) |
---|
1885 | ! |
---|
1886 | ! !USES: |
---|
1887 | ! |
---|
1888 | use m_stdio, only : stderr |
---|
1889 | use m_die, only : MP_perr_die |
---|
1890 | |
---|
1891 | use m_mpif90 |
---|
1892 | |
---|
1893 | use m_String, only : String |
---|
1894 | |
---|
1895 | implicit none |
---|
1896 | |
---|
1897 | ! !INPUT PARAMETERS: |
---|
1898 | ! |
---|
1899 | integer, intent(in) :: source |
---|
1900 | integer, intent(in) :: TagBase |
---|
1901 | integer, intent(in) :: comm |
---|
1902 | |
---|
1903 | ! !OUTPUT PARAMETERS: |
---|
1904 | ! |
---|
1905 | type(List), intent(out) :: outList |
---|
1906 | integer, optional, intent(out) :: status |
---|
1907 | |
---|
1908 | ! !REVISION HISTORY: |
---|
1909 | ! 6Jun01 - J.W. Larson - initial version. |
---|
1910 | ! 11Jun01 - R. Jacob - small bug fix; status in MPI_RECV |
---|
1911 | ! 13Jun01 - J.W. Larson <larson@mcs.anl.gov> - Initialize status |
---|
1912 | ! (if present). |
---|
1913 | !EOP ___________________________________________________________________ |
---|
1914 | |
---|
1915 | character(len=*),parameter :: myname_=myname//'::recv_' |
---|
1916 | |
---|
1917 | integer :: ierr, length |
---|
1918 | integer :: MPstatus(MP_STATUS_SIZE) |
---|
1919 | type(String) :: DummStr |
---|
1920 | |
---|
1921 | ! Initialize status to zero (success), if present. |
---|
1922 | |
---|
1923 | if(present(status)) status = 0 |
---|
1924 | |
---|
1925 | ! Step 1. Receive Length of String DummStr from process source. |
---|
1926 | |
---|
1927 | call MPI_RECV(length, 1, MP_type(length), source, TagBase, comm, & |
---|
1928 | MPstatus, ierr) |
---|
1929 | if(ierr /= 0) then |
---|
1930 | if(present(status)) then |
---|
1931 | write(stderr,'(2a,i8)') myname_, & |
---|
1932 | ':: MPI_RECV(length...) failed. ierror=', ierr |
---|
1933 | status = ierr |
---|
1934 | return |
---|
1935 | else |
---|
1936 | call MP_perr_die(myname_,':: MPI_RECV(length...) failed',ierr) |
---|
1937 | endif |
---|
1938 | endif |
---|
1939 | |
---|
1940 | allocate(DummStr%c(length), stat=ierr) |
---|
1941 | |
---|
1942 | ! Step 2. Send CHARACTER portion of String DummStr |
---|
1943 | ! to process dest. |
---|
1944 | |
---|
1945 | call MPI_RECV(DummStr%c(1), length, MP_CHARACTER, source, TagBase+1, & |
---|
1946 | comm, MPstatus, ierr) |
---|
1947 | if(ierr /= 0) then |
---|
1948 | if(present(status)) then |
---|
1949 | write(stderr,'(2a,i8)') myname_, & |
---|
1950 | ':: MPI_RECV(DummStr%c...) failed. ierror=', ierr |
---|
1951 | status = ierr |
---|
1952 | return |
---|
1953 | else |
---|
1954 | call MP_perr_die(myname_,':: MPI_RECV(DummStr%c...) failed',ierr) |
---|
1955 | endif |
---|
1956 | endif |
---|
1957 | |
---|
1958 | ! Step 3. Initialize outList. |
---|
1959 | |
---|
1960 | call initStr_(outList, DummStr) |
---|
1961 | |
---|
1962 | end subroutine recv_ |
---|
1963 | |
---|
1964 | !~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ |
---|
1965 | ! Math and Computer Science Division, Argonne National Laboratory ! |
---|
1966 | !BOP ------------------------------------------------------------------- |
---|
1967 | ! |
---|
1968 | ! !IROUTINE: GetSharedListIndices_ - Index Shared Items for Two Lists |
---|
1969 | ! |
---|
1970 | ! !DESCRIPTION: {\tt GetSharedListIndices\_()} compares two user- |
---|
1971 | ! supplied {\tt List} arguments {\tt List1} and {\tt Lis2} to determine: |
---|
1972 | ! the number of shared items {\tt NumShared}, and arrays of the locations |
---|
1973 | ! {\tt Indices1} and {\tt Indices2} in {\tt List1} and {\tt List2}, |
---|
1974 | ! respectively. |
---|
1975 | ! |
---|
1976 | ! {\bf N.B.:} This routine returns two allocated arrays: {\tt Indices1(:)} |
---|
1977 | ! and {\tt Indices2(:)}. Both of these arrays must be deallocated once they |
---|
1978 | ! are no longer needed. Failure to do this will create a memory leak. |
---|
1979 | ! |
---|
1980 | ! !INTERFACE: |
---|
1981 | |
---|
1982 | subroutine GetSharedListIndices_(List1, List2, NumShared, Indices1, & |
---|
1983 | Indices2) |
---|
1984 | |
---|
1985 | ! |
---|
1986 | ! !USES: |
---|
1987 | ! |
---|
1988 | use m_die, only : MP_perr_die, die, warn |
---|
1989 | |
---|
1990 | use m_String, only : String |
---|
1991 | use m_String, only : String_clean => clean |
---|
1992 | |
---|
1993 | implicit none |
---|
1994 | |
---|
1995 | ! !INPUT PARAMETERS: |
---|
1996 | ! |
---|
1997 | type(List), intent(in) :: List1 |
---|
1998 | type(List), intent(in) :: List2 |
---|
1999 | |
---|
2000 | ! !OUTPUT PARAMETERS: |
---|
2001 | ! |
---|
2002 | integer, intent(out) :: NumShared |
---|
2003 | |
---|
2004 | integer,dimension(:), pointer :: Indices1 |
---|
2005 | integer,dimension(:), pointer :: Indices2 |
---|
2006 | |
---|
2007 | ! !REVISION HISTORY: |
---|
2008 | ! 7Feb01 - J.W. Larson <larson@mcs.anl.gov> - initial version |
---|
2009 | !EOP ___________________________________________________________________ |
---|
2010 | |
---|
2011 | character(len=*),parameter :: myname_=myname//'::GetSharedListIndices_' |
---|
2012 | |
---|
2013 | ! Error flag |
---|
2014 | integer :: ierr |
---|
2015 | |
---|
2016 | ! number of items in List1 and List2, respectively: |
---|
2017 | integer :: nitem1, nitem2 |
---|
2018 | |
---|
2019 | ! MAXIMUM number of matches possible: |
---|
2020 | integer :: NumSharedMax |
---|
2021 | |
---|
2022 | ! Temporary storage for a string tag retrieved from a list: |
---|
2023 | type(String) :: tag |
---|
2024 | |
---|
2025 | ! Loop counters / temporary indices: |
---|
2026 | integer :: n1, n2 |
---|
2027 | |
---|
2028 | ! Determine the number of items in each list: |
---|
2029 | |
---|
2030 | nitem1 = nitem_(List1) |
---|
2031 | nitem2 = nitem_(List2) |
---|
2032 | |
---|
2033 | ! The maximum number of list item matches possible |
---|
2034 | ! is the minimum(nitem1,nitem2): |
---|
2035 | |
---|
2036 | NumSharedMax = min(nitem1,nitem2) |
---|
2037 | |
---|
2038 | ! Allocate sufficient space for the matches we may find: |
---|
2039 | |
---|
2040 | allocate(Indices1(NumSharedMax), Indices2(NumSharedMax), stat=ierr) |
---|
2041 | if(ierr /= 0) call die(myname_,'allocate() Indices1 and 2',ierr) |
---|
2042 | |
---|
2043 | ! Initialize the counter for the number of matches found: |
---|
2044 | |
---|
2045 | NumShared = 0 |
---|
2046 | |
---|
2047 | ! Scan through the two lists. For the sake of speed, loop |
---|
2048 | ! over the shorter of the two lists... |
---|
2049 | |
---|
2050 | if(nitem1 <= nitem2) then ! List1 is shorter--scan it... |
---|
2051 | |
---|
2052 | do n1=1,NumSharedMax |
---|
2053 | |
---|
2054 | ! Retrieve string tag n1 from List1: |
---|
2055 | call get_(tag, n1, List1) |
---|
2056 | |
---|
2057 | ! Index this tag WRT List2--a nonzero value signifies a match |
---|
2058 | n2 = indexStr_(List2, tag) |
---|
2059 | |
---|
2060 | ! Clear out tag for the next iteration... |
---|
2061 | call String_clean(tag) |
---|
2062 | |
---|
2063 | ! If we have a hit, update NumShared, and load the indices |
---|
2064 | ! n1 and n2 in Indices1 and Indices2, respectively... |
---|
2065 | |
---|
2066 | if((0 < n2) .and. (n2 <= nitem2)) then |
---|
2067 | NumShared = NumShared + 1 |
---|
2068 | Indices1(NumShared) = n1 |
---|
2069 | Indices2(NumShared) = n2 |
---|
2070 | endif |
---|
2071 | |
---|
2072 | end do ! do n1=1,NumSharedMax |
---|
2073 | |
---|
2074 | else ! List1 is shorter--scan it... |
---|
2075 | |
---|
2076 | do n2=1,NumSharedMax |
---|
2077 | |
---|
2078 | ! Retrieve string tag n2 from List2: |
---|
2079 | call get_(tag, n2, List2) |
---|
2080 | |
---|
2081 | ! Index this tag WRT List1--a nonzero value signifies a match |
---|
2082 | n1 = indexStr_(List1, tag) |
---|
2083 | |
---|
2084 | ! Clear out tag for the next iteration... |
---|
2085 | call String_clean(tag) |
---|
2086 | |
---|
2087 | ! If we have a hit, update NumShared, and load the indices |
---|
2088 | ! n1 and n2 in Indices1 and Indices2, respectively... |
---|
2089 | |
---|
2090 | if((0 < n1) .and. (n1 <= nitem1)) then |
---|
2091 | NumShared = NumShared + 1 |
---|
2092 | Indices1(NumShared) = n1 |
---|
2093 | Indices2(NumShared) = n2 |
---|
2094 | endif |
---|
2095 | |
---|
2096 | end do ! do n2=1,NumSharedMax |
---|
2097 | |
---|
2098 | endif ! if(nitem1 <= nitem2)... |
---|
2099 | |
---|
2100 | end subroutine GetSharedListIndices_ |
---|
2101 | |
---|
2102 | end module m_List |
---|
2103 | !. |
---|
2104 | |
---|
2105 | |
---|
2106 | |
---|
2107 | |
---|
2108 | |
---|
2109 | |
---|
2110 | |
---|
2111 | |
---|
2112 | |
---|