The R Project SVN – R – Diff – /trunk/src/main/xxxpr.f



      subroutine intpr(label, nchar, data, ndata)
      integer nchar, ndata
      character*(*) label
      integer data(ndata)
      integer nc
      EXTERNAL intpr0
      nc = nchar
      if(nc .lt. 0) nc = len(label)
      call intpr0(label, nc, data, ndata)
      end
 
      subroutine realpr(label, nchar, data, ndata)
      integer nchar, ndata
      character*(*) label
      real data(ndata)
      integer nc
      EXTERNAL realp0
      nc = nchar
      if(nc .lt. 0) nc = len(label)
      call realp0(label, nc, data, ndata)
      end
 
      subroutine dblepr(label, nchar, data, ndata)
      integer nchar, ndata
      character*(*) label
      double precision data(ndata)
      integer nc
      EXTERNAL dblep0
      nc = nchar
      if(nc .lt. 0) nc = len(label)
      call dblep0(label, nc, data, ndata)
      end
 

      subroutine intpr1(label, nchar, var)
      integer nchar
      character*(*) label
      integer var, data(1)
      integer nc
      EXTERNAL intpr0
      nc = nchar
      if(nc .lt. 0) nc = len(label)
      data(1) = var
      call intpr0(label, nc, data, 1)
      end

      subroutine realpr1(label, nchar, var)
      integer nchar
      character*(*) label
      real var, data(1)
      integer nc
      EXTERNAL realp0
      nc = nchar
      if(nc .lt. 0) nc = len(label)
      data(1) = var
      call realp0(label, nc, data, 1)
      end

      subroutine dblepr1(label, nchar, var)
      integer nchar
      character*(*) label
      double precision var, data(1)
      integer nc
      EXTERNAL dblep0
      nc = nchar
      if(nc .lt. 0) nc = len(label)
      data(1) = var
      call dblep0(label, nc, data, 1)
      end

      subroutine labelpr(label, nchar)
      integer nchar
      character*(*) label
      integer data(1)
      integer nc
      EXTERNAL intpr0
      nc = nchar
      if(nc .lt. 0) nc = len(label)
      data(1) = 0
      call intpr0(label, nc, data, 0)
      end
 
C R-only Fortran versions of error and warning
      subroutine rexit(msg)
      character*(*) msg
      EXTERNAL rexitc
      call rexitc(msg, len(msg))
      end
 
      subroutine rwarn(msg)
      character*(*) msg
      EXTERNAL rwarnc
      call rwarnc(msg, len(msg))
      end

Rev 77842	Rev 84708
Line 24...	Line 24...
24	`subroutine intpr(label, nchar, data, ndata)`	24	`subroutine intpr(label, nchar, data, ndata)`
25	`integer nchar, ndata`	25	`integer nchar, ndata`
26	`character() label`	26	`character() label`
27	`integer data(ndata)`	27	`integer data(ndata)`
28	`integer nc`	28	`integer nc`
-		29	`EXTERNAL intpr0`
29	`nc = nchar`	30	`nc = nchar`
30	`if(nc .lt. 0) nc = len(label)`	31	`if(nc .lt. 0) nc = len(label)`
31	`call intpr0(label, nc, data, ndata)`	32	`call intpr0(label, nc, data, ndata)`
32	`end`	33	`end`
33		34
34	`subroutine realpr(label, nchar, data, ndata)`	35	`subroutine realpr(label, nchar, data, ndata)`
35	`integer nchar, ndata`	36	`integer nchar, ndata`
36	`character() label`	37	`character() label`
37	`real data(ndata)`	38	`real data(ndata)`
38	`integer nc`	39	`integer nc`
-		40	`EXTERNAL realp0`
39	`nc = nchar`	41	`nc = nchar`
40	`if(nc .lt. 0) nc = len(label)`	42	`if(nc .lt. 0) nc = len(label)`
41	`call realp0(label, nc, data, ndata)`	43	`call realp0(label, nc, data, ndata)`
42	`end`	44	`end`
43		45
44	`subroutine dblepr(label, nchar, data, ndata)`	46	`subroutine dblepr(label, nchar, data, ndata)`
45	`integer nchar, ndata`	47	`integer nchar, ndata`
46	`character() label`	48	`character() label`
47	`double precision data(ndata)`	49	`double precision data(ndata)`
48	`integer nc`	50	`integer nc`
-		51	`EXTERNAL dblep0`
49	`nc = nchar`	52	`nc = nchar`
50	`if(nc .lt. 0) nc = len(label)`	53	`if(nc .lt. 0) nc = len(label)`
51	`call dblep0(label, nc, data, ndata)`	54	`call dblep0(label, nc, data, ndata)`
52	`end`	55	`end`
53		56
Line 55...	Line 58...
55	`subroutine intpr1(label, nchar, var)`	58	`subroutine intpr1(label, nchar, var)`
56	`integer nchar`	59	`integer nchar`
57	`character() label`	60	`character() label`
58	`integer var, data(1)`	61	`integer var, data(1)`
59	`integer nc`	62	`integer nc`
-		63	`EXTERNAL intpr0`
60	`nc = nchar`	64	`nc = nchar`
61	`if(nc .lt. 0) nc = len(label)`	65	`if(nc .lt. 0) nc = len(label)`
62	`data(1) = var`	66	`data(1) = var`
63	`call intpr0(label, nc, data, 1)`	67	`call intpr0(label, nc, data, 1)`
64	`end`	68	`end`
Line 66...	Line 70...
66	`subroutine realpr1(label, nchar, var)`	70	`subroutine realpr1(label, nchar, var)`
67	`integer nchar`	71	`integer nchar`
68	`character() label`	72	`character() label`
69	`real var, data(1)`	73	`real var, data(1)`
70	`integer nc`	74	`integer nc`
-		75	`EXTERNAL realp0`
71	`nc = nchar`	76	`nc = nchar`
72	`if(nc .lt. 0) nc = len(label)`	77	`if(nc .lt. 0) nc = len(label)`
73	`data(1) = var`	78	`data(1) = var`
74	`call realp0(label, nc, data, 1)`	79	`call realp0(label, nc, data, 1)`
75	`end`	80	`end`
Line 77...	Line 82...
77	`subroutine dblepr1(label, nchar, var)`	82	`subroutine dblepr1(label, nchar, var)`
78	`integer nchar`	83	`integer nchar`
79	`character() label`	84	`character() label`
80	`double precision var, data(1)`	85	`double precision var, data(1)`
81	`integer nc`	86	`integer nc`
-		87	`EXTERNAL dblep0`
82	`nc = nchar`	88	`nc = nchar`
83	`if(nc .lt. 0) nc = len(label)`	89	`if(nc .lt. 0) nc = len(label)`
84	`data(1) = var`	90	`data(1) = var`
85	`call dblep0(label, nc, data, 1)`	91	`call dblep0(label, nc, data, 1)`
86	`end`	92	`end`
Line 88...	Line 94...
88	`subroutine labelpr(label, nchar)`	94	`subroutine labelpr(label, nchar)`
89	`integer nchar`	95	`integer nchar`
90	`character() label`	96	`character() label`
91	`integer data(1)`	97	`integer data(1)`
92	`integer nc`	98	`integer nc`
-		99	`EXTERNAL intpr0`
93	`nc = nchar`	100	`nc = nchar`
94	`if(nc .lt. 0) nc = len(label)`	101	`if(nc .lt. 0) nc = len(label)`
95	`data(1) = 0`	102	`data(1) = 0`
96	`call intpr0(label, nc, data, 0)`	103	`call intpr0(label, nc, data, 0)`
97	`end`	104	`end`
98		105
99	`C R-only Fortran versions of error and warning`	106	`C R-only Fortran versions of error and warning`
100	`subroutine rexit(msg)`	107	`subroutine rexit(msg)`
101	`character() msg`	108	`character() msg`
-		109	`EXTERNAL rexitc`
102	`call rexitc(msg, len(msg))`	110	`call rexitc(msg, len(msg))`
103	`end`	111	`end`
104		112
105	`subroutine rwarn(msg)`	113	`subroutine rwarn(msg)`
106	`character() msg`	114	`character() msg`
-		115	`EXTERNAL rwarnc`
107	`call rwarnc(msg, len(msg))`	116	`call rwarnc(msg, len(msg))`
108	`end`	117	`end`

The R Project SVN R

(root)/trunk/src/main/xxxpr.f @ 63243 – Rev 77842 → 84708