1
2
3
4
5
6
7
8
9
10
11 disklow: proc;
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30 dcl (hp, pp) ptr,
31 dummy (0: 7) float bin,
32 dummy1 float bin,
33 disk_price (0:9) float bin,
34 ap pointer,
35 al fixed bin,
36 bchr char (al) based (ap) unal,
37 cs char (16) aligned,
38 tid char (9) aligned,
39 PERCENT_FULL float bin init (0.90e0),
40 NUMBER_LEFT fixed bin init (20),
41 nlow fixed bin init (0),
42 rs_number fixed bin,
43 rs_name char (32),
44 rs_count fixed bin,
45 temp fixed bin (71),
46 dols float bin,
47 tdols float bin init (0.0e0),
48 tqta fixed bin (35) init (0),
49 tuse fixed bin (35) init (0),
50 qta fixed bin (35),
51 use fixed bin (35),
52 (i, np) fixed bin;
53 dcl ec fixed bin (35);
54
55 dcl system_info_$rs_name entry (fixed bin, char (*), fixed bin (35)),
56 system_info_$prices_rs entry (fixed bin,
57 (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, (0: 7) float bin, float bin, float bin),
58 system_info_$max_rs_number entry (fixed bin),
59 search_sat_$rs_number entry (char (*), fixed bin, fixed bin (35)),
60 search_sat_$clean_up entry,
61 get_wdir_ entry () returns (char (168)),
62 cu_$arg_ptr ext entry (fixed bin, ptr, fixed bin, fixed bin (35)),
63 cv_dec_check_ ext entry (char (*), fixed bin (35)) returns (fixed bin (35)),
64 ioa_ ext entry options (variable),
65 hcs_$initiate entry (char (*) aligned, char (*) aligned, char (*) aligned, fixed bin, fixed bin, ptr, fixed bin (35)),
66 hcs_$terminate_noname entry (ptr, fixed bin (35)),
67 com_err_ ext entry options (variable);
68 dcl error_table_$noentry external fixed bin (35);
69
70 dcl (addr, hbound, null) builtin;
71
72 dcl format char (24) int static aligned options (constant) init
73 ("^9a^4x^6d^4x^6d^4x^15.2f");
74
75 %include projfile;
76
77
78
79 call system_info_$max_rs_number (rs_count);
80 ap = addr (ap);
81
82 call cu_$arg_ptr (1, ap, al, ec);
83 if ec = 0 then do;
84 i = cv_dec_check_ (bchr, ec);
85 if ec ^= 0 then do;
86 dec_err: call com_err_ (0, "disklow", "^a is non-numeric.", bchr);
87 return;
88 end;
89 NUMBER_LEFT = i;
90 call cu_$arg_ptr (2, ap, al, ec);
91 if ec = 0 then do;
92 i = cv_dec_check_ (bchr, ec);
93 if ec ^= 0 then go to dec_err;
94 PERCENT_FULL = i/100.0e0;
95 end;
96 end;
97
98 cs = "projfile";
99 call hcs_$initiate ((get_wdir_ ()), cs, "", 0, 1, pp, ec);
100 if pp = null then do;
101 err: call com_err_ (ec, "disklow", cs);
102 return;
103 end;
104
105 do rs_number = 0 to hbound (disk_price, 1);
106 call system_info_$rs_name (rs_number, rs_name, ec);
107 if ec ^= 0 then disk_price (rs_number) = disk_price (0);
108 else call system_info_$prices_rs (rs_number, dummy, dummy, dummy, dummy, disk_price (rs_number), dummy1);
109 end;
110
111 np = projfile.nproj;
112
113 call ioa_ ("Project quota used dollar charge");
114 do i = 1 to np;
115 if id (i) = "" then go to skip;
116 if off (i) ^= 0 then if disk_psec (i) = 0 then go to skip;
117 else tid = "*" || id (i);
118 else tid = id (i);
119 qta = disk_quota (i);
120 use = disk_use (i);
121 temp = disk_psec (i);
122 if rs_count > 0 then do;
123 call search_sat_$rs_number ((id (i)), rs_number, ec);
124 if ec ^= 0 then
125 if ec = error_table_$noentry then
126 call com_err_ (ec, "disklow",
127 "Trying to locate project ""^a"". Default rates will be used.",
128 id (i));
129 else call com_err_ (ec, "disklow", "Accessing the sat. Default rates will be used");
130 end;
131 else rs_number = 0;
132 dols = temp * disk_price (rs_number);
133 tdols = tdols + dols;
134 tqta = tqta + qta;
135 tuse = tuse + use;
136 if use = 0 then go to skip;
137 if qta - use < NUMBER_LEFT then go to p1;
138 if (1.0e0 * use) / qta > PERCENT_FULL then go to p1;
139 go to skip;
140 p1: call ioa_ (format, tid, qta, use, dols);
141 nlow = nlow + 1;
142 skip: end;
143 if nlow = 0 then call ioa_ ("All projects OK.");
144 call ioa_ ("");
145 call ioa_ (format, "TOTAL", tqta, tuse, tdols);
146 call hcs_$terminate_noname (pp, ec);
147 if rs_count > 0 then call search_sat_$clean_up;
148
149 end disklow;