libsim Versione 7.2.6
for2r.f90
1!==============================================================================
2! FOR2R.F90 -- MODULE COMPRISING FOR2R PACKAGE
3! Author:
4! Michael H. Prager
5! NOAA, Beaufort, NC
6! mike.prager@noaa.gov
7! Date annotated:
8! June 7, 2005
9! Date last revised:
10! See change log immediately below
11! Language:
12! Fortran 95 (standard conforming)
13! Purpose:
14! This module file has functions for writing R-compatible data output.
15! Output is written into a file that R can read with the dget() function.
16! Example from R prompt:
17! > myvar = dget("myfile.txt")
18! Other files required: none
19! With thanks to the following for collaboration or bug reports:
20! Jennifer Martin
21! Andi Stephens
22! John Zedlewski
23!==============================================================================
24! Change log
25! 07 Jun 2005: v.0.1 First functioning version (info, vector, matrix).
26! 08 Jun 2005: v.0.2 Added data frames and lists.
27! 09 Jun 2005: v.0.21 Tidied up code & documentation; added comment subroutine.
28! 10 Jun 2005: v.0.22 Fixed bugs; added integer type to matrix and data frame.
29! Added character type to data frame.
30! 13 Jun 2005: v.0.23 Changed reals to double precision. Added missing value option
31! to s_vec_wrt. Revised info item to include name & date options.
32! 14 Jun 2005 v.0.25 Changed NA vars from integer to logical. Added NAs option
33! with matrices. Put real format into var "realfmt"
34! 16 June 2005 v.0.26 Added SAVE to several module variables in case this is
35! used by a subroutine that goes out of scope.
36! 23 Aug 2005 v.0.27 Added character type to s_vec_wrt.
37! 15 Apr 2006 v.0.28 Routine names changed by A. Stephens
38! 05 Jun 2006 v.0.90 Added missing "trim" to wrt_r_item.
39! 08 Aug 2006 v.0.91 Changed name of "info" writing routine
40! 09 Aug 2006 V.1.00 Updated version number to 1.00 for release
41! 14 Aug 2006 V.1.01 Reduced to one file (eliminated two modules) for distribution.
42! 08 Sep 2006 V.1.02 Changed error messages to reflect routine names (Andi).
43! 08 Sep 2006 v.1.03 Added wrt_r_complete_vector.
44! 12 Jan 2007 v.1.04 Fixed several routines to eliminate extra commas (first_element)
45! 28 Feb 2007 v.1.05 Fixed bug (reported by John Zedlewski) in which a data frame
46! without row names was not written correctly. Lines 887ff.
47! 1 Mar 2007 v.1.06 Added argument "rowbounds" to wrt_r_df_col.
48! 11 Mar 2007 v.1.07 No changes
49! 20 Oct 2007 v.1.1 Revised info list functions to allow using it to write
50! any list of scalars.
51! 12 Sep 2008 v.1.2 Change to prevent extra comma for nested lists.
52!==============================================================================
53! Possible future improvements:
54! * Allow matrices of character data.
55! * Allow N-dimensional arrays for N > 2.
56! * More error checking for proper sequence of calls
57! * Optional auto reallocation of "names" matrix when full
58!==============================================================================
59MODULE for2r
60 ! The following are module variables, available to all contained procedures
61 implicit none
62 integer, private, parameter :: r4 = kind(1.0) !--real single precision
63 integer, private, parameter :: r8 = kind(1.0d0) !--real double precision
64 integer, save, private :: iunit, dflen, level, prevlevel, maxlevel, maxcomp
65 logical, save, private :: first_element = .false.
66 character(len=32), allocatable, private, save :: names(:,:)
67 integer, allocatable, save, private :: nnames(:)
68 character, parameter, private :: comma=",", lparen="(", rparen=")", equals="=",quote=""""
69 character(len=*),parameter, private :: nachar="NA", version="1.2" ! <==== VERSION
70 ! Note--the following format determines default precision of the data transfer:
71 character(len=12), private, save :: realfmt="(es16.9,2A)"
72 ! Declare one routine as private
73 private :: reg_rnames, day_of_week, find_unit
74 !------------------------------------------------------------------------------
75 ! --- IMPORTANT VARIABLES ---
76 ! NCOMP Total number of components, subcomponents written
77 ! LEVEL Current nesting level. 1=master object, 2=subobject, etc.
78 ! This should be incremented/decremented by any object
79 ! that stores subobject names!
80 ! MAXLEVEL Maximumum number of levels for which storage of
81 ! object names is allocated
82 ! MAXCOMP Maximumum number of components (per level) for which storage
83 ! of object names is allocated
84 ! NAMES Array of character strings containing names of components
85 ! DFLEN Used by data-frame routines to store working column length
86
87CONTAINS
88!------------------------------------------------------------------------------
89 SUBROUTINE open_r_file(fname, mxlevel, mxcomp, digits)
90 ! M.H. Prager, March 2004; revised June, 2005
91 ! mike.prager@noaa.gov
92 !
93 ! Open a file to hold an R data object and initialize the object
94 ! Also allocate array to hold component levels
95 ! ARGUMENTS
96 ! fname - Name of file for output
97 ! mxlevel - maximum nesting level of components within components
98 ! mxcomp - maximum number of components within a level
99 ! (e.g., cols within dataframe)
100 ! (e.g., components within main outer object)
101 ! digits - digits after decimal point in real format for writing
102
103 implicit none
104 ! Arguments
105 character(len=*), intent(IN) :: fname
106 integer, optional, intent(IN) :: mxlevel, mxcomp, digits
107 ! Local variables
108 character(len=120) :: string1, string2, string3
109 integer :: dig
110
111 string1 = "This file written with For2R version " // version //"."
112 string2 = "Read this file into R or S with x=dget('" // trim(fname) // "')."
113 string3 = "For2R written by Mike.Prager@noaa.gov. Please credit author and report bugs/improvements."
114
115 ! Initialize level variables
116 level = 1
117 prevlevel = 0
118 first_element = .true.
119 ! Check arguments and set defaults if not given. Store values in local variables.
120 if (present(mxlevel)) then
121 maxlevel = mxlevel
122 else
123 maxlevel = 6
124 endif
125 if (present(mxcomp)) then
126 maxcomp = mxcomp
127 else
128 maxcomp = 128
129 endif
130 if (present(digits)) then
131 dig = digits
132 else
133 dig = 7
134 endif
135 write(realfmt, "(A, i0, A, i0, A)") "(es", dig+7, ".", dig, ",2a)"
136 ! Allocate arrays to hold names & number of names
137 allocate(names(maxcomp,maxlevel))
138 allocate(nnames(maxlevel))
139 names = ""
140 nnames = 0
141 ! Open the file for output
142 call find_unit(iunit)
143
144 open(file=fname, unit=iunit, action="WRITE")
145 call wrt_r_comment(string1)
146 call wrt_r_comment(string2)
147 call wrt_r_comment(string3)
148 write(iunit,*)
149 ! Write the beginning of the structure
150 write(unit=iunit,fmt=500)
151 500 format("structure(list(")
152 !
153 return
154 END SUBROUTINE open_r_file
155!==============================================================================
156 SUBROUTINE reg_rnames(name0)
157 ! M.H. Prager, March 2004; revised June, 2005
158 ! mike.prager@noaa.gov
159 !
160 ! Subroutine to keep track of names of the components in the R structure.
161
162 implicit none
163 character(len=*) :: name0
164
165 ! Check for invalid nesting levels
166 if (level > maxlevel) then
167 write(*,500) level, maxlevel
168500 format(" Error: Too many levels in reg_rnames. Level=", &
169 i0," and max=",i0)
170 stop
171 elseif (level == 0) then
172 write(*,*) "Error: Level can't be zero in reg_rnames."
173 stop
174 endif
175
176 ! See if level has changed and if so, take appropriate action:
177 if (level==prevlevel) then
178 continue
179 elseif (level < prevlevel) then
180 prevlevel = level
181 elseif (level == prevlevel + 1) then
182 ! initialize new level
183 names(:,level) = ""
184 nnames(level) = 0
185 prevlevel = level
186 else
187 write(*,510) level, prevlevel
188510 format("Note: Level change unexpected in reg_rnames. Current level=",i0,", and previous level=",i0)
189 prevlevel = level
190! stop
191 endif
192
193 ! Keep count of the number of names at this level:
194 nnames(level) = nnames(level) + 1
195 ! Store the current name in the NAMES array:
196 names(nnames(level), level) = name0
197
198 return
199 END SUBROUTINE reg_rnames
200!================================================================================
201 SUBROUTINE open_r_info_list(name, date)
202 ! M.H. Prager, December 2004; revised June, 2005
203 ! mike.prager@noaa.gov
204 !
205 ! Initialize an INFO object and write its DATE subobject.
206 ! All main R objects are assumed to begin with an INFO object.
207 !
208 ! The INFO object contains descriptive information about the data structure.
209 ! It ALWAYS contains the date as the first item, and it MUST contain
210 ! at least one other items
211 !-----
212 implicit none
213 ! Arguments
214 character(len=*), intent(IN) :: name
215 logical, intent(IN),optional :: date
216 ! Local variables
217 character(len=3),parameter,dimension(12) :: month = &
218 (/"Jan","Feb","Mar","Apr","May","Jun","Jul","Aug","Sep","Oct","Nov","Dec"/)
219 character :: wkday*9, date_string*48
220 integer :: datime(8)
221 logical :: dte
222 !-------
223 call reg_rnames(name)
224 level = level + 1
225
226 if (present(date)) then
227 dte = date
228 else
229 dte = .true.
230 endif
231
232 ! Write output to start the "info" subobject (a list)
233 if (first_element) then
234 first_element = .false.
235 else
236 write(iunit,510,advance='NO') comma
237 endif
238
239 write(iunit,500,advance="NO") name
240500 format(/,a,'= structure(list',/,'(')
241510 format(a)
242
243 if (dte) then
244 !... Get date & time (F90 style) ***
245 call date_and_time(values=datime)
246 !... Get day of week from a function
247 wkday = day_of_week(datime(1),datime(2),datime(3))
248 ! Use Fortran's interal write to put the date and time information into
249 ! a character variable named "date_string"
250 write(date_string,400) trim(wkday), comma, datime(3), month(datime(2)), &
251 datime(1), datime(5), datime(6), datime(7)
252400 format (a,a,1x,i2.2,1x,a3,1x,i4," at ",i2.2,":",i2.2,":",i2.2)
253 ! Now write the date to the INFO object:
254 write(iunit,520) trim(date_string)
255520 format('date ="' , a, '"' )
256 ! Save the name:
257 call reg_rnames("date")
258 first_element = .false.
259 else
260 first_element = .true.
261 endif
262
263 return
264 end subroutine open_r_info_list
265!==============================================================================
266 SUBROUTINE open_r_vector(name)
267 ! M.H. Prager, June, 2005
268 ! mike.prager@noaa.gov
269 !
270 ! Initialize a vector object
271 ! ARGUMENT
272 ! name - name of the vector object (character)
273
274 implicit none
275 character(len=*), intent(IN) :: name
276
277 ! Register name of vector
278 call reg_rnames(trim(name))
279 level = level + 1
280
281 if (first_element) then
282 first_element = .false.
283 else
284 write(iunit,510,advance='NO') comma
285 endif
286 write(iunit,500,advance="NO") name, equals
287500 format(/,2a, "structure(",/,"c(")
288510 format(a)
289
290 first_element = .true.
291
292 return
293 END SUBROUTINE open_r_vector
294!==============================================================================
295 SUBROUTINE wrt_r_item(name, x, ix, ax, na, last)
296 ! M.H. Prager, June, 2005
297 ! mike.prager@noaa.gov
298
299 ! Write one element of a numeric vector or list
300 ! The element must have a name
301 ! ARGUMENTS:
302 ! name - name of the data item (character)
303 ! x - the datum itself (if real)
304 ! ix - the datum itself (if integer)
305 ! ax - the datum itself (if character)
306 ! last - set to .TRUE. if this is the last item in this vector
307
308 implicit none
309 ! Arguments
310 character(len=*), intent(IN) :: name
311 real(r8), intent(IN), optional :: x
312 integer, intent(IN), optional :: ix
313 character(len=*), intent(IN), optional :: ax
314 logical, optional, intent(IN) :: last, na
315 ! Local variables
316 integer :: i
317 logical :: lst, isna
318 character(len=16) :: xtype
319
320 ! Initialize variable LST depending on argument LAST
321 if (present(last)) then
322 lst = last
323 else
324 lst = .false.
325 endif
326
327 ! Initialize variable ISNA depending on argument NA
328 if (present(na)) then
329 isna = na
330 else
331 isna = .false.
332 endif
333
334 ! Set type of input data
335 xtype = "none"
336 if (present(x)) then
337 xtype = "real"
338 elseif (present(ix)) then
339 xtype = "integer"
340 elseif (present(ax)) then
341 xtype = "character"
342 endif
343 if (xtype=="none") then
344 isna = .true.
345 endif
346 if (isna) xtype = "missing"
347
348 ! Register (save) the name of the item. This is done first so
349 ! that reg_Rnames can initialize this level's name count.
350 call reg_rnames(name)
351
352 ! Write the VALUE of the item.
353 if (first_element) then
354 first_element = .false.
355 else
356 write(iunit,510,advance='NO') comma
357 endif
358 select case(xtype)
359 case("real")
360 write(iunit, realfmt, advance="NO") x
361 case("integer")
362 write(iunit, 520, advance="NO") ix
363 case("character")
364 write(iunit,530, advance="NO") quote, trim(ax), quote
365 case("missing")
366 write(iunit, 540, advance="NO") nachar
367 endselect
368
369 if (lst) then
370 ! Write the NAMES of the information items
371 write(iunit,570, advance="NO") rparen, comma, lparen
372
373 do i=1,nnames(level)
374 write(iunit,530, advance="no") quote, trim(names(i,level)),quote
375 if (i < nnames(level)) then
376 write(iunit,510, advance="no") comma
377 else
378 write(iunit,510) rparen,rparen
379 endif
380 enddo
381
382 ! Reset level since this is done.
383 level = level - 1 ! Should now be 1
384 endif
385
386510 format(2a)
387520 format(i0)
388530 format(3a)
389540 format(a)
390570 format(2a,/,".Names=c", a)
391
392 END SUBROUTINE wrt_r_item
393!==============================================================================
394 SUBROUTINE wrt_r_matrix (name, x, ix, na, rownames, colnames, rowids, colids)
395 ! M. H. Prager, June 2005
396 ! mike.prager@noaa.gov
397 !
398 ! Write a matrix subobject to the R data object
399 !
400 ! ARGUMENTS
401 ! x : the matrix itself (if real)
402 ! ix : the matrix itself (if integer)
403 ! na : missing-value mask (missing if .true.)
404 ! rownames : array of row names (character)
405 ! colnames : same, for columns
406 ! rowids : array of row names as integers (e.g., years)
407 ! colids : same, for columns
408 ! NOTE: Either rownames OR rowids OR neither can be given.
409 ! [The same applies to columns.]
410
411 implicit none
412 ! Passed arguments:
413 character(len=*), intent(IN) :: name
414 real(r8), dimension(:,:), intent(IN), optional :: x
415 integer, dimension(:,:), intent(IN), optional :: ix
416 logical, dimension(:,:), intent(IN), optional :: na
417 character(len=*), dimension(:), intent(IN), optional :: rownames, colnames
418 integer, dimension(:), intent(IN), optional :: rowids, colids
419 ! Local variables:
420 integer :: nrow, ncol, irow, icol
421 character(len=32), dimension(:), allocatable :: rname, cname
422 character(len=16) :: xtype
423 logical, dimension(:,:), allocatable :: isna
424 logical :: wrtrownames, wrtcolnames
425
426 ! Register (store) name of matrix
427 call reg_rnames(name)
428
429 ! Set type of input data
430 ! Get number of rows and columns
431 xtype = "none"
432 if (present(x)) then
433 xtype = "real"
434 nrow = size(x, dim=1)
435 ncol = size(x, dim=2)
436 elseif (present(ix)) then
437 xtype = "integer"
438 nrow = size(ix, dim=1)
439 ncol = size(ix, dim=2)
440 endif
441 if (xtype=="none") then
442 write(*,410) trim(name)
443 stop
444 endif
445410 format(1x,"Error: no data supplied to wrt_r_matrix for object name", 1x, a)
446
447 !...Check availability & compatibility of missing-value mask
448 allocate(isna(nrow,ncol))
449 if (present(na)) then
450 if ((size(na,1) /= nrow) .or. (size(na,2) /= ncol)) then
451 write(*,415) trim(name)
452 stop
453 else
454 isna(:,:) = na(:,:)
455 endif
456 else ! Argument NA was not present
457 isna(:,:) = .false.
458 endif
459415 format(1x,"Error: Size of missing-values matrix does not match size of data", &
460 " matrix in wrt_r_matrix for object name",1x,a)
461
462 ! Allocate temporary storage for names:
463 allocate(rname(nrow))
464 allocate(cname(ncol))
465
466 ! Check for presence of row names and copy into char vector:
467 wrtrownames = .false.
468 ! If character rownames are given, copy into "rname" array:
469 if (present(rownames)) then
470 wrtrownames = .true.
471 rname(:) = rownames(:)
472 elseif (present(rowids)) then
473 ! If integer row IDs are given, convert to character with
474 ! internal write and copy into "rname" array:
475 wrtrownames = .true.
476 do irow = 1, nrow
477 write(rname(irow), '(I0)') rowids(irow)
478 enddo
479 endif
480
481 ! Check for presence of col names and copy into char vector:
482 wrtcolnames = .false.
483 ! If colnames are given, copy into "cname" array
484 if (present(colnames)) then
485 wrtcolnames = .true.
486 cname(:) = colnames(:)
487 elseif (present(colids)) then
488 ! If col IDs are given, convert to character with internal write:
489 wrtcolnames = .true.
490 do icol = 1, ncol
491 write(cname(icol), '(I0)') colids(icol)
492 enddo
493 endif
494
495 ! Write output to start the matrix:
496 if (first_element) then
497 first_element = .false.
498 else
499 write(iunit, 499, advance="NO") comma
500 endif
501 write(iunit,500) name, equals
502499 format(a)
503500 format(/, 2a, "structure(c(")
504
505 ! Write the data
506 cols: do icol = 1, ncol
507 rows: do irow = 1, nrow
508 if (icol < ncol .or. irow < nrow) then
509 if (isna(irow,icol)) then
510 write(iunit,505, advance="NO") nachar, comma
511 else
512 select case(xtype)
513 case("real")
514 write(iunit,realfmt, advance="NO") x(irow,icol), comma
515 case("integer")
516 write(iunit,520, advance="NO") ix(irow,icol), comma
517 endselect
518 endif
519 else ! final value of matrix
520 if (isna(irow,icol)) then
521 write(iunit,505, advance="NO") nachar, rparen, comma
522 else
523 select case(xtype)
524 case("real")
525 write(iunit,realfmt, advance="NO") x(irow,icol), rparen, comma
526 case("integer")
527 write(iunit,520, advance="NO") ix(irow,icol), rparen, comma
528 endselect
529 endif
530 endif
531 enddo rows
532 write(iunit,530,advance="NO") ! Newline
533 enddo cols
534505 format(3a)
535520 format(i0, 2a)
536530 format(/)
537
538 ! Write the dimensioning information:
539 write(iunit, 600, advance = "NO") nrow, comma, ncol
540600 format(".Dim = c(", i0, a, i0, "), ")
541
542 ! Write heading for the dimnames:
543 write(iunit, 620, advance = "NO")
544620 format(".Dimnames = list(")
545
546 ! Write the row names
547 if (wrtrownames) then
548 write(iunit, 630, advance="NO")
549 write(iunit,640, advance="NO") &
550 (quote, trim(rname(irow)), quote, comma, irow = 1, nrow-1)
551 write(iunit, 650) quote, trim(rname(nrow)), quote
552 else
553 write(iunit,660)
554 endif
555
556630 format("c(")
557640 format(40a)
558650 format(3a, "),")
559660 format("NULL,")
560
561 ! Write the column names
562 if (wrtcolnames) then
563 write(iunit, 630, advance="NO")
564 write(iunit,640, advance="NO") &
565 (quote, trim(cname(icol)), quote, comma, icol = 1, ncol-1)
566 write(iunit,680) quote, trim(cname(ncol)), quote
567 else
568 write(iunit,690)
569 endif
570680 format(3a, ")))")
571690 format("NULL))")
572
573 deallocate(rname, cname, isna)
574 return
575 END SUBROUTINE wrt_r_matrix
576!==============================================================================
577 SUBROUTINE wrt_r_complete_vector (name, x, ix, ax, na, el_names, el_ids)
578 ! M. H. Prager, Sept 2006
579 ! mike.prager@noaa.gov
580 !
581 ! Write an R vector (all at once) to the R data object
582 ! (Derived from wrt_r_matrix)
583 !
584 ! ARGUMENTS
585 ! x : the vector itself (if real)
586 ! ix : the vector itself (if integer)
587 ! na : missing-value mask (missing if .true.)
588 ! el_names : array of element names (character)
589 ! el_ids : array of element names as integers (e.g., years)
590 ! NOTE: Either vnames OR vids OR neither can be given.
591
592 implicit none
593 ! Passed arguments:
594 character(len=*), intent(IN) :: name
595 real(r8), dimension(:), intent(IN), optional :: x
596 integer, dimension(:), intent(IN), optional :: ix
597 character(len=*), dimension(:), intent(IN), optional :: ax
598 logical, dimension(:), intent(IN), optional :: na
599 character(len=*), dimension(:), intent(IN), optional :: el_names
600 integer, dimension(:), intent(IN), optional :: el_ids
601 ! Local variables:
602 integer :: nrow, irow
603 character(len=32), dimension(:), allocatable :: names
604 character(len=16) :: xtype
605 logical, dimension(:), allocatable :: isna
606 logical :: wrtnames
607
608 ! Register (store) name of matrix
609 call reg_rnames(name)
610
611 ! Set type of input data
612 ! Get number of elements in vector
613 xtype = "none"
614 if (present(x)) then
615 xtype = "real"
616 nrow = size(x)
617 elseif (present(ix)) then
618 xtype = "integer"
619 nrow = size(ix)
620 elseif (present(ax)) then
621 xtype = "character"
622 nrow = size(ax)
623 endif
624 if (xtype=="none") then
625 write(*,410) trim(name)
626 stop
627 endif
628410 format(1x,"Error: no data supplied to wrt_r_truevector for object name", 1x, a)
629
630 !...Check availability & compatibility of missing-value mask array
631 allocate(isna(nrow))
632 if (present(na)) then
633 if (size(na) /= nrow) then
634 write(*,415) trim(name)
635 stop
636 else
637 isna(:) = na(:)
638 endif
639 else ! Argument NA was not present
640 isna(:) = .false.
641 endif
642415 format(1x,"Error: Size of missing-values matrix does not match size of data", &
643 " matrix in wrt_r_matrix for object name", 1x, a)
644
645 ! Allocate temporary storage for names:
646 allocate(names(nrow))
647
648 ! Check for presence of row names and copy into char vector:
649 wrtnames = .false.
650 ! If character rownames are given, copy into "names" array:
651 if (present(el_names)) then
652 wrtnames = .true.
653 names(:) = el_names(:)
654 elseif (present(el_ids)) then
655 ! If integer row IDs are given, convert to character with
656 ! internal write and copy into "rname" array:
657 wrtnames = .true.
658 do irow = 1, nrow
659 write(names(irow), '(I0)') el_ids(irow)
660 enddo
661 endif
662
663 ! Write output to start the vector
664 if (first_element) then
665 first_element = .false.
666 else
667 write(iunit, fmt="(A)", advance="NO") comma
668 endif
669 write(iunit,500) name, equals
670500 format(/, 2a, "structure(c(")
671
672 ! Write the data
673 do irow = 1, nrow
674 if (irow < nrow) then
675 if (isna(irow)) then
676 write(iunit,505, advance="NO") nachar, comma
677 else
678 select case(xtype)
679 case("real")
680 write(iunit, realfmt, advance="NO") x(irow), comma
681 case("integer")
682 write(iunit, 520, advance="NO") ix(irow), comma
683 case("character")
684 write(iunit, 505, advance="NO") quote, trim(ax(irow)), quote, comma
685 endselect
686 endif
687 else ! final value of matrix
688 if (isna(irow)) then
689 write(iunit, 505, advance="NO") nachar, rparen, comma
690 else
691 select case(xtype)
692 case("real")
693 write(iunit, realfmt, advance="NO") x(irow), rparen, comma
694 case("integer")
695 write(iunit, 520, advance="NO") ix(irow), rparen, comma
696 case("character")
697 write(iunit, 505, advance="NO") quote, trim(ax(irow)), quote, rparen, comma
698 endselect
699 endif
700 endif
701 enddo
702 write(iunit,530,advance="NO") ! Newline
703505 format(5a)
704520 format(i0, 2a)
705530 format(/)
706
707 if (wrtnames) then
708 ! Write the element names & close the vector
709 write(iunit, 620)
710 write(iunit, 640, advance="NO") (quote, trim(names(irow)), quote, comma, irow = 1, nrow-1)
711 write(iunit, 650) quote, trim(names(nrow)), quote
712 else
713 ! Write NULL names & close the vector
714 write(iunit, 660)
715 endif
716
717620 format(".Names = c(")
718640 format(40a)
719650 format(3a, "))")
720660 format(".Names = NULL)")
721
722 deallocate(names, isna)
723 return
724 END SUBROUTINE wrt_r_complete_vector
725!==============================================================================
726 SUBROUTINE open_r_df(name)
727 ! M.H. Prager, June 2005
728 ! mike.prager@noaa.gov
729 !
730 ! Initialize a data frame
731 ! ARGUMENT:
732 ! name - name of data frame (R compatible)
733
734 implicit none
735 character(len=*), intent(IN) :: name
736
737 call reg_rnames(trim(name)) ! Register name of data frame
738 dflen = 0 ! Initialize number of rows in DF
739 level = level + 1 ! We are up one level
740
741 ! Write output to start the data frame subobject
742 write(iunit,500) comma, name, equals, "structure(list"
743500 format(/,4a)
744
745 return
746 END SUBROUTINE open_r_df
747!==============================================================================
748 SUBROUTINE wrt_r_df_col(name, x, ix, ax, na, last, rownames, rowids, rowbounds)
749 ! M.H. Prager, June 2005
750 ! mike.prager@noaa.gov
751 !
752 ! Write a real, numeric column to a data frame.
753 ! ARGUMENTS:
754 ! name - name to use for this column of the data frame
755 ! x - Real; vector of real values to write to df column.
756 ! na - Logical; vector of same length as x.
757 ! If .true., value in x is missing.
758 ! last - Logical; set .TRUE. if last column to finalize data frame
759
760 implicit none
761 ! Arguments
762 character(len=*), intent(IN) :: name
763 real(r8), intent(IN), optional :: x(:)
764 integer, intent(IN), optional :: ix(:)
765 logical, intent(IN), optional :: na(:)
766 character(len=*), intent(IN), optional :: ax(:)
767 logical, intent(IN), optional :: last
768 character(len=*), dimension(:), intent(IN), optional :: rownames
769 integer, dimension(:), intent(IN), optional :: rowids
770 integer, dimension(2), intent(IN), optional :: rowbounds
771
772 ! Local variables
773 integer :: i, nrow
774 logical :: lst
775 character(len=16) :: xtype
776 !character(len=32), dimension(:), allocatable :: rname
777 character(len=9) :: rntype
778 logical, dimension(:), allocatable :: isna
779
780 ! Set flag if user says this is the last variable
781 lst = .false. ! Default is .false.
782 if (present(last)) lst = last ! Use user value if given
783
784 ! Register (save) the name of the column
785 if (len_trim(name) < 1) then
786 write(*,400)
787 stop
788 else
789 call reg_rnames(name)
790 endif
791400 format(1x,"ERROR: Name must be specified in wrt_r_df_col.")
792
793 ! Set type of input data and length of data column
794 xtype = "none"
795 if (present(x)) then
796 xtype = "real"
797 nrow = size(x)
798 elseif (present(ix)) then
799 xtype = "integer"
800 nrow = size(ix)
801 elseif (present(ax)) then
802 xtype = "character"
803 nrow = size(ax)
804 endif
805
806 if (xtype=="none") then
807 write(*,410)
808 stop
809 endif
810410 format(1x,"Error: no data supplied to wrt_r_df_col.")
811
812 !...Check availability & compatibility of missing-value mask
813 allocate(isna(nrow))
814 if (present(na)) then
815 if (size(na) /= nrow) then
816 write(*,415) size(na), nrow
817 stop
818 else
819 isna(1:nrow) = na(1:nrow)
820 endif
821 else ! Argument NA was not present
822 isna(:) = .false.
823 endif
824415 format(1x,"Error: Size of missing-values array does not match size of data", &
825 " array in wrt_r_df_col.",/,t2, "Sizes are",1x,i0,1x,"and",1x,i0)
826
827 !...Store column length if first col; otherwise check against first col
828 if (nnames(level)==1) then
829 dflen = nrow
830 else
831 if (nrow /= dflen) then
832 write(*,420) dflen, nrow
833 stop
834 endif
835 endif
836420 format(1x,"Error: Column lengths do not match in wrt_r_df_col."/&
837 t2, "Lengths of column 1 is",1x,i0,1x,"and current length is",1x,i0)
838
839 ! If last column, check for passed row names & set indicator:
840 if (lst) then
841 if (present(rownames)) then
842 rntype = "character"
843 elseif (present(rowbounds)) then
844 rntype = "bounds"
845 elseif (present(rowids)) then
846 rntype = "integer"
847 else
848 rntype = "none"
849 endif
850 endif
851
852 !...If this is the first column, write a left paren; otherwise, a comma:
853 if (nnames(level) == 1) then
854 write(iunit,500, advance="no") lparen
855 else
856 write(iunit,500, advance="no") comma
857 endif
858500 format(4a)
859
860 !...Initialize the column:
861 write(iunit,500, advance="no") trim(name), equals, "c", lparen
862
863 !...Write the VALUEs of the column
864 do_wrtvals: do i = 1, nrow
865 if (mod(i,10) == 0) write(iunit,500) ! newline
866 if (isna(i)) then
867 write(iunit,500,advance="NO") nachar
868 if (i < nrow) write(iunit,500,advance="NO") comma
869 else
870 select case (xtype)
871 case("real")
872 write(iunit,realfmt,advance="NO") x(i)
873 case("integer")
874 write(iunit,512,advance="NO") ix(i)
875 case("character")
876 write(iunit,514,advance="NO") quote, trim(ax(i)), quote
877 endselect
878 if (i < nrow) write(iunit,500,advance="NO") comma
879 endif
880 enddo do_wrtvals
881 ! Write closing punctuation for column
882 write(iunit,500) rparen
883512 format(i0)
884514 format(3a)
885
886 !----- This section executes for last column only ------
887 if_last: if (lst) then
888 !...Write header for variable (column) names:
889 write(iunit,520, advance="NO") rparen, comma,".Names = c("
890 !...Write column names:
891 do i=1, nnames(level)
892 write(iunit,500, advance="no") quote, trim(names(i,level)), quote
893 if (i<nnames(level)) then
894 write(iunit,500, advance="no") comma
895 else
896 write(iunit,500) rparen,comma
897 endif
898 enddo
899 !...Write header for row names:
900 write(iunit,530, advance="NO")
901 !...Write row names:
902 select case (rntype)
903 case ("none")
904 write(iunit, 535, advance="NO") nrow, rparen, comma
905 case ("character")
906 write(iunit, 550, advance="NO")
907 do i = 1, nrow
908 write(iunit,500,advance="NO") quote, trim(rownames(i)), quote
909 if (i < nrow) write(iunit, 500, advance="NO") comma
910 enddo
911 write(iunit, 500) rparen, comma
912 case ("integer")
913 write(iunit, 560, advance="NO")
914 do i = 1, nrow
915 write(iunit,560,advance="NO") rowids(i)
916 if (i < nrow) write(iunit, 500, advance="NO") comma
917 end do
918 case ("bounds")
919 write(iunit, 540, advance="NO") rowbounds(1), rowbounds(2), comma
920 case default
921 write(*,*) " Faulty value of 'rntype' in 'wrt_r_df_col'."
922 stop
923 endselect
924 !...Write closing information:
925 write(iunit,500) 'class="data.frame")'
926 level = level - 1
927 endif if_last
928520 format(2a,/,a)
929530 format("row.names=")
930535 format("c(NA,", i0, 2a, 1x)
931540 format(i0, ":", i0, a, 1x)
932550 format("c(")
933560 format(i0)
934
935 deallocate(isna)
936 return
937
938 END SUBROUTINE wrt_r_df_col
939!==============================================================================
940 SUBROUTINE open_r_list(name)
941 ! M.H. Prager, June, 2005
942 ! mike.prager@noaa.gov
943 !
944 ! Initialize a LIST object
945 !
946 implicit none
947 character(len=*), intent(IN) :: name
948
949 ! Register name of list
950 call reg_rnames(trim(name))
951 level = level + 1
952
953 ! Write output to start the list subobject:
954 ! Write the VALUE of the item.
955 if (first_element) then
956 first_element = .false.
957 else
958 write(iunit,510,advance='NO') comma
959 endif
960 write(iunit,500) name, equals, "structure(list("
961500 format(/,4a)
962510 format(a)
963
964 first_element = .true.
965
966 return
967 END SUBROUTINE open_r_list
968!==============================================================================
969 SUBROUTINE close_r_list
970 ! M.H. Prager, June, 2005
971 ! mike.prager@noaa.gov
972 !
973 ! Finalize a LIST object by writing names of components
974 !
975 implicit none
976 integer :: i, nn
977
978 ! Write output to start the vector subobject:
979 write(iunit,500,advance="NO") rparen, comma, ".Names = c("
980500 format(a,/,2a)
981 ! Write the names of the components of the list:
982 nn = nnames(level)
983 do i = 1, nn
984 write(unit=iunit,fmt=510, advance="no") quote, &
985 trim(names(i,level)), quote
986 if (i<nn) then
987 write(unit=iunit, fmt=510, advance="no") comma
988 else
989 write(unit=iunit, fmt=510) rparen, rparen
990 endif
991 end do
992510 format(3a)
993
994 level = level - 1
995 return
996 END SUBROUTINE close_r_list
997!==============================================================================
998 SUBROUTINE wrt_r_comment(text)
999 ! M.H. Prager, June, 2005
1000 ! mike.prager@noaa.gov
1001 !
1002 ! Write a comment
1003 !
1004 implicit none
1005 character(len=*), intent(IN) :: text
1006
1007 ! Write comment to the output object:
1008 write(iunit,500) trim(text)
1009500 format("### ",a)
1010
1011 return
1012 END SUBROUTINE wrt_r_comment
1013!==============================================================================
1014 SUBROUTINE close_r_file
1015 ! M. H. Prager, March 2004
1016 ! mike.prager@noaa.gov
1017 !
1018 ! Write the component names to finalize the object
1019 ! and close the file
1020 implicit none
1021 integer i, nn
1022 !
1023 write(unit=iunit,fmt=500, advance="no") rparen, comma, lparen
1024500 format(2a,//, " .Names = c", a)
1025 nn = nnames(1)
1026 do i = 1, nn
1027 write(unit=iunit,fmt=510, advance="no") quote, trim(names(i,1)), quote
1028 if (i<nn) then
1029 write(unit=iunit, fmt=510, advance="no") comma
1030 else
1031 write(unit=iunit, fmt=510) rparen, rparen
1032 endif
1033 end do
1034510 format(3a)
1035
1036 close(unit=iunit)
1037 deallocate(names, nnames)
1038 return
1039 END SUBROUTINE close_r_file
1040!--------------------------------------------------------------------
1041 subroutine find_unit(iu)
1042 ! Finds and returns first unit number not already connected to a file
1043 ! Returns -999 if no unit number available
1044 implicit none
1045 integer i, iu
1046 logical used
1047
1048 do i=10,1000
1049 inquire(unit=i,opened=used)
1050 if (.not. used) then
1051 iu = i
1052 exit ! leave do loop
1053 endif
1054 iu = -999
1055 enddo
1056 return
1057 end subroutine find_unit
1058!--------------------------------------------------------------------
1059 FUNCTION day_of_week(year, month, day) RESULT(weekday)
1060
1061 ! Function added to module by MHP. Obtained from Alan J. Miller.
1062 ! Calculate day of week, allowing for leap years.
1063 ! Correct back to October 1752 (11 days were left out of September 1752).
1064
1065 implicit none
1066 integer, intent(IN) :: year, month, day
1067 character(len=9) :: weekday
1068 INTEGER :: yr, mnth, hundreds, day_ptr
1069 INTEGER,PARAMETER :: max_days(12) = (/31,29,31,30,31,30,31,31,30,31,30,31/)
1070 CHARACTER(LEN=9),parameter :: day_name(0:6) = (/ 'Sunday ', 'Monday ','Tuesday ', &
1071 'Wednesday', 'Thursday ', 'Friday ','Saturday '/)
1072
1073 ! Number the months starting from March; January & February are
1074 ! treated as months 11 & 12 of the previous year.
1075
1076 mnth = month - 2
1077 IF (mnth <= 0) THEN
1078 mnth = mnth + 12
1079 yr = year - 1
1080 ELSE
1081 yr = year
1082 END IF
1083
1084 ! Check for legal day of month.
1085 ! N.B. Allows 29 days in February even when not a leap year.
1086
1087 IF (day < 1 .OR. day > max_days(month)) RETURN
1088
1089 hundreds = yr/100
1090 yr = yr - 100*hundreds
1091
1092 ! The days are numbered from Sunday (0) to Saturday (6).
1093 ! The function mod(n,7) returns the remainder after n is divided by 7.
1094
1095 day_ptr = mod(day + (26*mnth - 2)/10 + 5*hundreds + yr + (yr/4) + &
1096 (hundreds/4), 7)
1097 weekday = day_name(day_ptr)
1098
1099 RETURN
1100 END FUNCTION day_of_week
1101END MODULE for2r
1102!==============================================================================

Generated with Doxygen.