libsim  Versione 7.2.1
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 !==============================================================================
59 MODULE 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 
87 CONTAINS
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
168 500 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
188 510 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
240 500 format(/,a,'= structure(list',/,'(')
241 510 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)
252 400 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)
255 520 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
287 500 format(/,2a, "structure(",/,"c(")
288 510 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 
386 510 format(2a)
387 520 format(i0)
388 530 format(3a)
389 540 format(a)
390 570 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
445 410 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
459 415 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
502 499 format(a)
503 500 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
534 505 format(3a)
535 520 format(i0, 2a)
536 530 format(/)
537 
538  ! Write the dimensioning information:
539  write(iunit, 600, advance = "NO") nrow, comma, ncol
540 600 format(".Dim = c(", i0, a, i0, "), ")
541 
542  ! Write heading for the dimnames:
543  write(iunit, 620, advance = "NO")
544 620 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 
556 630 format("c(")
557 640 format(40a)
558 650 format(3a, "),")
559 660 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
570 680 format(3a, ")))")
571 690 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
628 410 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
642 415 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
670 500 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
703 505 format(5a)
704 520 format(i0, 2a)
705 530 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 
717 620 format(".Names = c(")
718 640 format(40a)
719 650 format(3a, "))")
720 660 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"
743 500 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
791 400 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
810 410 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
824 415 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
836 420 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
858 500 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
883 512 format(i0)
884 514 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
928 520 format(2a,/,a)
929 530 format("row.names=")
930 535 format("c(NA,", i0, 2a, 1x)
931 540 format(i0, ":", i0, a, 1x)
932 550 format("c(")
933 560 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("
961 500 format(/,4a)
962 510 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("
980 500 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
992 510 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)
1009 500 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
1024 500 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
1034 510 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
1101 END MODULE for2r
1102 !==============================================================================

Generated with Doxygen.