62 integer,
private,
parameter :: r4 = kind(1.0)
63 integer,
private,
parameter :: r8 = kind(1.0d0)
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"
71 character(len=12),
private,
save :: realfmt=
"(es16.9,2A)"
73 private :: reg_rnames, day_of_week, find_unit
89 SUBROUTINE open_r_file(fname, mxlevel, mxcomp, digits)
105 character(len=*),
intent(IN) :: fname
106 integer,
optional,
intent(IN) :: mxlevel, mxcomp, digits
108 character(len=120) :: string1, string2, string3
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."
118 first_element = .true.
120 if (
present(mxlevel))
then
125 if (
present(mxcomp))
then
130 if (
present(digits))
then
135 write(realfmt,
"(A, i0, A, i0, A)")
"(es", dig+7,
".", dig,
",2a)"
137 allocate(names(maxcomp,maxlevel))
138 allocate(nnames(maxlevel))
142 call find_unit(iunit)
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)
150 write(unit=iunit,fmt=500)
151 500
format(
"structure(list(")
154 END SUBROUTINE open_r_file
156 SUBROUTINE reg_rnames(name0)
163 character(len=*) :: name0
166 if (level > maxlevel)
then
167 write(*,500) level, maxlevel
168 500
format(
" Error: Too many levels in reg_rnames. Level=", &
171 elseif (level == 0)
then
172 write(*,*)
"Error: Level can't be zero in reg_rnames."
177 if (level==prevlevel)
then
179 elseif (level < prevlevel)
then
181 elseif (level == prevlevel + 1)
then
187 write(*,510) level, prevlevel
188 510
format(
"Note: Level change unexpected in reg_rnames. Current level=",i0,
", and previous level=",i0)
194 nnames(level) = nnames(level) + 1
196 names(nnames(level), level) = name0
199 END SUBROUTINE reg_rnames
201 SUBROUTINE open_r_info_list(name, date)
214 character(len=*),
intent(IN) :: name
215 logical,
intent(IN),
optional :: date
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
223 call reg_rnames(name)
226 if (
present(date))
then
233 if (first_element)
then
234 first_element = .false.
236 write(iunit,510,advance=
'NO') comma
239 write(iunit,500,advance=
"NO") name
240 500
format(/,a,
'= structure(list',/,
'(')
245 call date_and_time(values=datime)
247 wkday = day_of_week(datime(1),datime(2),datime(3))
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)
254 write(iunit,520) trim(date_string)
255 520
format(
'date ="' , a,
'"' )
257 call reg_rnames(
"date")
258 first_element = .false.
260 first_element = .true.
264 end subroutine open_r_info_list
266 SUBROUTINE open_r_vector(name)
275 character(len=*),
intent(IN) :: name
278 call reg_rnames(trim(name))
281 if (first_element)
then
282 first_element = .false.
284 write(iunit,510,advance=
'NO') comma
286 write(iunit,500,advance=
"NO") name, equals
287 500
format(/,2a,
"structure(",/,
"c(")
290 first_element = .true.
293 END SUBROUTINE open_r_vector
295 SUBROUTINE wrt_r_item(name, x, ix, ax, na, last)
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
318 character(len=16) :: xtype
321 if (
present(last))
then
328 if (
present(na))
then
338 elseif (
present(ix))
then
340 elseif (
present(ax))
then
343 if (xtype==
"none")
then
346 if (isna) xtype =
"missing"
350 call reg_rnames(name)
353 if (first_element)
then
354 first_element = .false.
356 write(iunit,510,advance=
'NO') comma
360 write(iunit, realfmt, advance=
"NO") x
362 write(iunit, 520, advance=
"NO") ix
364 write(iunit,530, advance=
"NO") quote, trim(ax), quote
366 write(iunit, 540, advance=
"NO") nachar
371 write(iunit,570, advance=
"NO") rparen, comma, lparen
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
378 write(iunit,510) rparen,rparen
390 570
format(2a,/,
".Names=c", a)
392 END SUBROUTINE wrt_r_item
394 SUBROUTINE wrt_r_matrix (name, x, ix, na, rownames, colnames, rowids, colids)
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
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
427 call reg_rnames(name)
434 nrow =
size(x, dim=1)
435 ncol =
size(x, dim=2)
436 elseif (
present(ix))
then
438 nrow =
size(ix, dim=1)
439 ncol =
size(ix, dim=2)
441 if (xtype==
"none")
then
442 write(*,410) trim(name)
445 410
format(1x,
"Error: no data supplied to wrt_r_matrix for object name", 1x, a)
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)
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)
463 allocate(rname(nrow))
464 allocate(cname(ncol))
467 wrtrownames = .false.
469 if (
present(rownames))
then
471 rname(:) = rownames(:)
472 elseif (
present(rowids))
then
477 write(rname(irow),
'(I0)') rowids(irow)
482 wrtcolnames = .false.
484 if (
present(colnames))
then
486 cname(:) = colnames(:)
487 elseif (
present(colids))
then
491 write(cname(icol),
'(I0)') colids(icol)
496 if (first_element)
then
497 first_element = .false.
499 write(iunit, 499, advance=
"NO") comma
501 write(iunit,500) name, equals
503 500
format(/, 2a,
"structure(c(")
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
514 write(iunit,realfmt, advance=
"NO") x(irow,icol), comma
516 write(iunit,520, advance=
"NO") ix(irow,icol), comma
520 if (isna(irow,icol))
then
521 write(iunit,505, advance=
"NO") nachar, rparen, comma
525 write(iunit,realfmt, advance=
"NO") x(irow,icol), rparen, comma
527 write(iunit,520, advance=
"NO") ix(irow,icol), rparen, comma
532 write(iunit,530,advance=
"NO")
539 write(iunit, 600, advance =
"NO") nrow, comma, ncol
540 600
format(
".Dim = c(", i0, a, i0,
"), ")
543 write(iunit, 620, advance =
"NO")
544 620
format(
".Dimnames = list(")
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
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
570 680
format(3a,
")))")
573 deallocate(rname, cname, isna)
575 END SUBROUTINE wrt_r_matrix
577 SUBROUTINE wrt_r_complete_vector (name, x, ix, ax, na, el_names, el_ids)
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
602 integer :: nrow, irow
603 character(len=32),
dimension(:),
allocatable :: names
604 character(len=16) :: xtype
605 logical,
dimension(:),
allocatable :: isna
609 call reg_rnames(name)
617 elseif (
present(ix))
then
620 elseif (
present(ax))
then
624 if (xtype==
"none")
then
625 write(*,410) trim(name)
628 410
format(1x,
"Error: no data supplied to wrt_r_truevector for object name", 1x, a)
632 if (
present(na))
then
633 if (
size(na) /= nrow)
then
634 write(*,415) trim(name)
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)
646 allocate(names(nrow))
651 if (
present(el_names))
then
653 names(:) = el_names(:)
654 elseif (
present(el_ids))
then
659 write(names(irow),
'(I0)') el_ids(irow)
664 if (first_element)
then
665 first_element = .false.
667 write(iunit, fmt=
"(A)", advance=
"NO") comma
669 write(iunit,500) name, equals
670 500
format(/, 2a,
"structure(c(")
674 if (irow < nrow)
then
676 write(iunit,505, advance=
"NO") nachar, comma
680 write(iunit, realfmt, advance=
"NO") x(irow), comma
682 write(iunit, 520, advance=
"NO") ix(irow), comma
684 write(iunit, 505, advance=
"NO") quote, trim(ax(irow)), quote, comma
689 write(iunit, 505, advance=
"NO") nachar, rparen, comma
693 write(iunit, realfmt, advance=
"NO") x(irow), rparen, comma
695 write(iunit, 520, advance=
"NO") ix(irow), rparen, comma
697 write(iunit, 505, advance=
"NO") quote, trim(ax(irow)), quote, rparen, comma
702 write(iunit,530,advance=
"NO")
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
717 620
format(
".Names = c(")
720 660
format(
".Names = NULL)")
722 deallocate(names, isna)
724 END SUBROUTINE wrt_r_complete_vector
726 SUBROUTINE open_r_df(name)
735 character(len=*),
intent(IN) :: name
737 call reg_rnames(trim(name))
742 write(iunit,500) comma, name, equals,
"structure(list"
746 END SUBROUTINE open_r_df
748 SUBROUTINE wrt_r_df_col(name, x, ix, ax, na, last, rownames, rowids, rowbounds)
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
775 character(len=16) :: xtype
777 character(len=9) :: rntype
778 logical,
dimension(:),
allocatable :: isna
782 if (
present(last)) lst = last
785 if (len_trim(name) < 1)
then
789 call reg_rnames(name)
791 400
format(1x,
"ERROR: Name must be specified in wrt_r_df_col.")
798 elseif (
present(ix))
then
801 elseif (
present(ax))
then
806 if (xtype==
"none")
then
810 410
format(1x,
"Error: no data supplied to wrt_r_df_col.")
814 if (
present(na))
then
815 if (
size(na) /= nrow)
then
816 write(*,415)
size(na), nrow
819 isna(1:nrow) = na(1:nrow)
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)
828 if (nnames(level)==1)
then
831 if (nrow /= dflen)
then
832 write(*,420) dflen, nrow
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)
841 if (
present(rownames))
then
843 elseif (
present(rowbounds))
then
845 elseif (
present(rowids))
then
853 if (nnames(level) == 1)
then
854 write(iunit,500, advance=
"no") lparen
856 write(iunit,500, advance=
"no") comma
861 write(iunit,500, advance=
"no") trim(name), equals,
"c", lparen
864 do_wrtvals:
do i = 1, nrow
865 if (mod(i,10) == 0)
write(iunit,500)
867 write(iunit,500,advance=
"NO") nachar
868 if (i < nrow)
write(iunit,500,advance=
"NO") comma
872 write(iunit,realfmt,advance=
"NO") x(i)
874 write(iunit,512,advance=
"NO") ix(i)
876 write(iunit,514,advance=
"NO") quote, trim(ax(i)), quote
878 if (i < nrow)
write(iunit,500,advance=
"NO") comma
882 write(iunit,500) rparen
887 if_last:
if (lst)
then
889 write(iunit,520, advance=
"NO") rparen, comma,
".Names = c("
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
896 write(iunit,500) rparen,comma
900 write(iunit,530, advance=
"NO")
904 write(iunit, 535, advance=
"NO") nrow, rparen, comma
906 write(iunit, 550, advance=
"NO")
908 write(iunit,500,advance=
"NO") quote, trim(rownames(i)), quote
909 if (i < nrow)
write(iunit, 500, advance=
"NO") comma
911 write(iunit, 500) rparen, comma
913 write(iunit, 560, advance=
"NO")
915 write(iunit,560,advance=
"NO") rowids(i)
916 if (i < nrow)
write(iunit, 500, advance=
"NO") comma
919 write(iunit, 540, advance=
"NO") rowbounds(1), rowbounds(2), comma
921 write(*,*)
" Faulty value of 'rntype' in 'wrt_r_df_col'."
925 write(iunit,500)
'class="data.frame")'
929 530
format(
"row.names=")
930 535
format(
"c(NA,", i0, 2a, 1x)
931 540
format(i0,
":", i0, a, 1x)
938 END SUBROUTINE wrt_r_df_col
940 SUBROUTINE open_r_list(name)
947 character(len=*),
intent(IN) :: name
950 call reg_rnames(trim(name))
955 if (first_element)
then
956 first_element = .false.
958 write(iunit,510,advance=
'NO') comma
960 write(iunit,500) name, equals,
"structure(list("
964 first_element = .true.
967 END SUBROUTINE open_r_list
969 SUBROUTINE close_r_list
979 write(iunit,500,advance=
"NO") rparen, comma,
".Names = c("
984 write(unit=iunit,fmt=510, advance=
"no") quote, &
985 trim(names(i,level)), quote
987 write(unit=iunit, fmt=510, advance=
"no") comma
989 write(unit=iunit, fmt=510) rparen, rparen
996 END SUBROUTINE close_r_list
998 SUBROUTINE wrt_r_comment(text)
1005 character(len=*),
intent(IN) :: text
1008 write(iunit,500) trim(text)
1009 500
format(
"### ",a)
1012 END SUBROUTINE wrt_r_comment
1014 SUBROUTINE close_r_file
1023 write(unit=iunit,fmt=500, advance=
"no") rparen, comma, lparen
1024 500
format(2a,//,
" .Names = c", a)
1027 write(unit=iunit,fmt=510, advance=
"no") quote, trim(names(i,1)), quote
1029 write(unit=iunit, fmt=510, advance=
"no") comma
1031 write(unit=iunit, fmt=510) rparen, rparen
1037 deallocate(names, nnames)
1039 END SUBROUTINE close_r_file
1041 subroutine find_unit(iu)
1049 inquire(unit=i,opened=used)
1050 if (.not. used)
then
1057 end subroutine find_unit
1059 FUNCTION day_of_week(year, month, day)
RESULT(weekday)
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 '/)
1087 IF (day < 1 .OR. day > max_days(month))
RETURN
1090 yr = yr - 100*hundreds
1095 day_ptr = mod(day + (26*mnth - 2)/10 + 5*hundreds + yr + (yr/4) + &
1097 weekday = day_name(day_ptr)
1100 END FUNCTION day_of_week