COMPILATION LISTING OF SEGMENT fortran_io_ Compiled by: Multics PL/I Compiler, Release 29, of July 28, 1986 Compiled at: Honeywell Bull, Phx. Az., Sys-M Compiled on: 08/06/87 1110.3 mst Thu Options: optimize map 1 /****^ *********************************************************** 2* * * 3* * Copyright, (C) Honeywell Bull Inc., 1987 * 4* * * 5* * Copyright, (C) Honeywell Information Systems Inc., 1987 * 6* * * 7* * Copyright, (C) Honeywell Limited, 1983 * 8* * * 9* * Copyright (c) 1972 by Massachusetts Institute of * 10* * Technology and Honeywell Information Systems, Inc. * 11* * * 12* *********************************************************** */ 13 14 15 16 /****^ HISTORY COMMENTS: 17* 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), 18* install(86-07-28,MR12.0-1105): 19* Fix fortran bugs 427, 451, 453, 454, 464, and 467. 20* 2) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 21* install(86-07-28,MR12.0-1105): 22* Fix fortran bugs 122 and 490 (SCP6284). 23* 3) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen), 24* install(87-08-06,MR12.1-1069): 25* Implemented SCP 6315: Fortran runtime error handler argument. 26* END HISTORY COMMENTS */ 27 28 29 /* format: style2 */ 30 fortran_io_: 31 procedure options (support); /* This entry must not be referenced */ 32 33 call print_error (fortran_io_error_$fio_sys_error, me, "Wrong fortran_io_$fortran_io_ entry."); 34 35 36 37 /* Written: 6 August 1973, David Levin 38**/ 39 /* Modified: 40* 15 May 87, RW SCP 6315: added the -debug_io argument to call 41* cu_$cl after an I/O error. 42* 22 Jan 86, SH & AG - 490: Add "append" option to the "status" 43* keyword in the "open"statement. 44* 25 Nov 85, RW - 122: Changed max number of items in a format 45* statement to 1023, up from 510 46* 12 Sept 85, BW - 467: Return an error message when attempting 47* to write beyond the end of files attached with -no_end. 48* 09 Sept 85, BW - 427: Remove "kludge_for_no_end" procedure 49* since vfile_ now supports "-no_end" for unstructured 50* files. This also fixes the incorrect opening 51* of a non-existant random binary stream file. 52* 09 Aug 85, BW - 464: Check that user specified filenames, I/O 53* switch names, and attach descriptions aren't blank. 54* 23 May 85, BW - 454: Allow a character string to overwrite itself 55* when used as an internal file. 56* 16 May 85, BW - 453: Make list termination characters ";" and "/" 57* work properly. 58* 07 May 85, BW - 451: Return a "noentry" status code when opening non-existent files with status="old". 59* 22 Jan 85, MM - 448: Make sure that the variable "current" is always 60* initialized by fortran_io_$read_or_write. 61* 27 Aug 84, BW - 440: Fix F-formatting error of numbers between -.5 and 0. 62* 09 May 84, MM - 404: Make "version" entry use fort_version_info 63* 28 Mar 84, MM - Install HFP support. 64* 25 Aug 83, MM - 402: Pad output records to tape_nstd_ to make them 65* word aligned. 66* 19 Aug 83, MM - 400: Fix suppression of newlines in an absout. 67* 14 July 83, MM - 407: Create new entry point: "set_cc_defer" for set_cc 68* command. 69* 14 July 83, MM - 406: Allow fortran_io_ to delete files it didn't create. 70* 14 July 83, MM - 116: Fix defaulting to formatted files. 71* 20 June 83, TO - 405: Speedup getting data type by index conversion table. 72* 04 May 83, MM - 98: Correct error code for 2 open statement errors. 73* 04 May 83, MM - 93: Change the nonstandard fortran character "|" 74* to "I" in one of the error messages. 75* 04 May 83, TO - 372: Fix namelist_io to pick up the runtime_block 76* from the namelist symbol's father (skip back as necessary 77* to find a level 0). 78* 18 Mar 83, HH - Install LA/VLA support. 79* 18 Mar 83, RG - 123: Make 'close_for_stop' realize that a unit can be 80* connected but not attached nor opened by 'fortran_io_'. 81* 10 Mar 83, HH - 101: Prevent F-format output in '77 mode from 82* displaying minus zero. 83* 08 Mar 83, HH - 83/91/95/97: Remove incorrect MR9 fix for bug 83 84* (TR 6459) in blocked files (i.e. change the value of 85* 'open_modes (4).for_output' back to 6) and supply the 86* correct fix: Never use 'sqio' mode for blocked files. 87* 24 Feb 83, HH - 120: Fix list-directed output in '77 mode to supply 88* a leading space for carriage control if the 'carriage' 89* attribute is off. 90* 09 Feb 83, HH - 119: Hang changes to format of list-directed and 91* namelist output off the 'ansi_77' switch, so old programs 92* don't break. 93* 24 Nov 82, HH - 118: Change method of doing I format output 94* conversion because old way failed for Iw.m format when 95* m > 15. (New way is also a little faster.) 96* 23 Nov 82, HH - 116: If FORM is not specified in an OPEN statement 97* in '77 mode, assume 'FORMATTED' unless ACCESS is specified 98* to be 'DIRECT'. 99* 21 Nov 82, HH - 113: Improve list-directed output by suppressing 100* the separator between consecutive items if either is a 101* character value. 102* 21 Nov 82, HH - 112: Improve list-directed output of numbers in F 103* format by requiring at least 1 digit in the fraction part 104* and rounding to suppress trailing 9's in the fraction part. 105* 04 Nov 82, HH - 111: If scale factor is outside legal range for D 106* and E output formats, fill the output field with stars 107* rather than terminating the run. 108* 01 Nov 82, HH - 110: In D, E, F and G input, ignore spaces and zeroes 109* before the first significant digit of the mantissa and 110* after the last nonzero digit of the fraction part. 111* 01 Nov 82, HH - 107: If blanks are null, ignore them in D, E, F, G 112* and I input while building the decimal representation of 113* the input value, rather than by altering the input field. 114* 30 Oct 82, HH - 109: Make list-directed output of double precision 115* values the same as for real values, except allow up to 116* 18 significant digits. 117* 29 Oct 82, HH - 108: Remove the restriction that double precision 118* constants may not be read into integer or real variables 119* with list-directed input. 120* 29 Oct 82, HH - 100: Fix T, TL, TR and X processing in '77 mode 121* so that they alter the position in the record without 122* changing its length or transmitting any characters. 123* 27 Oct 82, HH - 103: Fix logical list-directed input to follow the 124* FORTRAN/77 Standard. 125* 20 Oct 82, TO - 106: Fix internal file write of 'FORMAT ()' to clear 126* first record. 127* 19 Oct 82, TO - 99: Fix inability of list directed character string 128* to span records. 129* 19 Oct 82, TO - 102: Fix formatted output to use an E-type exponent 130* for an 'E' or 'G' format specification, and a D-type 131* exponent for a 'D' format specification, instead of 132* choosing the exponent type according to the data type. 133* 18 Oct 82, TO - 104: Fix bug in 'get_associated_unit', where iocb_ptr 134* not set. 135* 18 Oct 82, TO - 105: Fix bug in 'INQUIRE' where filename not 'ltrim'd. 136* 20 Jul 82, HH - Fix I/O bug 96: A file may randomly be opened for INOUT when either IN or OUT is requested in an 137* OPEN statement. 138* 19 Jul 82, HH - Fix I/O bug 94: DECODE randomly gets 'End of info encountered' because it checks 'internal_file_count', 139* which is only set for internal file reads. 140* 17 Jun 82, HH - Hang simulation of EOF records on the 'ansi_77' switch, so old programs don't break. 141* 19 May 82, HH - Improve NAMELIST and list-directed output: drop extraneous leading spaces and 142* trailing zeroes, and use G-format rather than E-format for real values. 143* 13 May 82, HH - Make ENDFILE try to reopen for output if unit is open for input only. 144* 10 May 82, HH - Add 'version' entrypoint to print the version of the compiler at the 145* last time 'fortran_io_' was modified. 146* 10 May 82, HH - Add 'skip_line_numbers' variable so that the list-directed I/O routines 147* need not access 'runtime_format'. This is necessary since a runtime format 148* is decoded into a working area used by the list-directed I/O routines! 149* 07 May 82, TO - Change 'r' format pre-clear to use substr of spaces, 150* rather than fio_ps.element_p -> words (1) = 0. 151* 29 Apr 82, HH - Treat 'error_table_$asynch_deletion' as 'error_table_$no_record' in 'get_record'. 152* 26 Apr 82, HH - Test for invalid scale factors according to the Standard (cf 13.5.9.2.1). 153* 21 Apr 82, HH - Quote character values in NAMELIST output so they can be read by NAMELIST input. 154* 19 Apr 82, HH - Revise implementation of ENDFILE to conform to the Standard. 155* 25 Mar 82, TO - fix navy test bug 8 - logical input. (2 spots) 156* 17 Mar 82, TO (for MEP) - fix navy test bug 9 - endfile on non-connected file. 157* 13 Nov 81, MEP - fix bug 90, ENDFILE ignored. 158* 6 Nov 81, MEP - finish? INQUIRE, fix bug in t_format (read), and alter stop entry not to use automatic variables 159* it does not initialize (e.g. in based_work_area) 160* 27 Oct 81, MEP - Start of inclusion of INQUIRE statement. 161* 16 Oct 81, CRD - Change open_mode(4).for_output from 6 to 7 so that 162* direct access blocked files get opened in sequential_update 163* mode if reopened for output. 164* 11 Oct 81, Fix open not to break in ansi66 mode for violation of ansi77 rules 165* and change to fortran_open_data.incl.pl1 (alm). 166* 3 Oct 81, MEP - Support for ansi77 internal files. Use of fio_ps.modes = internal_file (like string_io). 167* Aug 81, MEP - ansi77 I/O features. 168* 4 August 1981, CRD - Fix bug 088. 169* 11 June 1981, CRD - Implement repetition counts in list directed 170* input. Also changed store_null not to store anything if 171* in ansi77 mode. 172* 10 June 1981, CRD - Fix bug 87. 173* 8 June 1981, CRD - Fix an unreported bug in which buffer_read may 174* fault while doing list directed input. 175* 15 Oct 1980, CRD - Fix bug 82. get_record was being called for a 176* direct access binary stream read as well as for each 177* element transfer. 178* 14 Oct 1980, CRD - Fix quote doubling bug in list directed input, 179* and use sequential_update rather than 180* sequential_input_output for blocked files to avoid 181* truncating the file on each write. 182* 28 Aug 1980, CRD - Fix many bugs. 183* 15 Aug 1980, MEP - Add code to calculate the namelist part of fortran77 184* character mode stuff. 185* 12 May 1980, MEP - Add code to implement ansi_77 character array io. 186* This causes rewriting of references to char_len, word_len, and 187* the calculation of element_count. This also alters the way in 188* which the element_pointer is updated, i.e. by characters 189* rather than words. 190* 04 Aug 1979, PES - Complete the fix to bug 079, by fixing the case 191* in which the v format requires additional records, whose 192* sequence numbers must also be ignored. This case was 193* inadvertently overlooked in the 22 Jul 79 fix. 194* 22 Jul 1979, PES - Fix bug 079, in which the s format item is 195* ignored in the context "format (s,v)". 196* 13 Jul 1979, CRD - Implement suggested improvement 078 to make 197* namelist input insensitive to case when the program 198* unit is compiled with -fold or -card. 199* 05 Jul 1979, PES - Implement planned feature 074 for "v" format 200* output, which was overlooked in the 13 Jun change. 201* 15 Jun 1979, RAB - fix bug 76 in which an attempt to do a direct 202* access write to an empty blocked file causes a "record not 203* found". Bug was introduced by incomplete fix to bug 67. 204* 13 Jun 1979, PES - fix bug 072 in which fortran_io_ improperly strips trailing blanks 205* when doing formatted output to non-terminal files, causing problems with word 206* oriented i/o modules; implements planned feature 036, in which the "Close files?" 207* query should be eliminated, and planned feature 074, in which upper case 208* characters D, E, F, and T should be used for outputting dp, real, and logical 209* values, for compatibility with other systems; and implements suggested 210* improvement 007, in which fortran_io_ should print a|7 instead of a$a (a|7) 211* in error messages when all the names are the same. 212* 25 May 1979, PES & RAB - fix bug 75 in which an uninitialized variable in fortran_io_ 213* (fortran_open_data.char_str) may cause processing of the open statement to 214* take an out_of_bounds_fault, with a probability which is initially small 215* but which increases with each successive open in a process. 216* 19 Apr 1979, RAB - fix bug 73 in which an attempt to open a non-vfile_ ( such 217* as a tape file) for output causes the file to be initially 218* opened for input, causing errors when doing label checking on 219* an uninitialized volume. 220* 19 Dec 1978, PES - fix bug 67 in which an attempt to read a non_existent record 221* in a blocked file results in the next-higher record which is present being 222* read, with no error indication. This fix (and other parts of the code) 223* assume that direct_access files are being handled by vfile_. Should this 224* cease to be the case, all calls to iox_$control will have to be checked. 225* 13 Sep 78, PES - fix bug 065, in which fio takes a fault_tag_1 if an attempt is 226* made to open a non-existent file; and bug 066, in which an attempt to 227* access beyond the end of a direct_access file should result in the err= 228* branch being taken, if specified. 229* 11 Sep 78, PES - Fix bug 064, in which fio will not accept complex input of the 230* form a=(1.,2.) unless a space is added before the ")". 231* 07 Aug 78, PES - Change signal command_abort_ to call stop_run to interface 232* with run unit facility. 233* 15 Jun 78, DSL - Remove display_fortranio_error (dfe); fix bug in which FORTRAN I/O 234* erroneously treats all files as closed even though the user answered "no" to our 235* query; leave I/O switch attached if connection fails (this includes changing the 236* file closing routines, close_fortran_file, etc., to recognize and properly handle 237* this case). 238* 08 Jun 78, DSL - Fix bug in f-format output in which incorrect format is used if zerodivide 239* is signalled during conversion; fix bug in which /-format is ignored if it is the 240* first field desc. 241* 05 Jun 78, DSL - Implement display_fortranio_error (dfe); create structure for all double 242* word variables; move all "static" declarations to ext proc; change "syntax_error", 243* "too_much_input", "too_much_output", "conversion_error", "bad_char", to entry points. 244* Fix bug in format processing in which an excess right parenthesis causes faults. 245* Recognize "IOS compatability" as a valid open description. 246* 11 May 78, DSL - Fix open to attempt input only opening if incorrect access to write and 247* user did not explicitly request write access; minor change to get_open_field. 248* 25 Apr 78, DSL - Minor change to allow fio to recover if old fio is invoked before new fio. 249* 05 Apr 78, DSL - Only print input record if it is relevant to the error message; insure 250* that rel(frd_$fio_buf_p) >= area_size; use ioa_$ioa_switch to print warnings instead 251* of com_err_ (bug 54); support iostat var for EOF; do not trim white space if 252* $-format is used; use -extend if fio creates attach desc for vfile_ and file is open for 253* output (this also means that the file is rewound after it is opened); file is 254* opened for output if: inout and fio attach desc or empty file; recognize if any 255* type of vfile_ file is empty; on error, print input record using ioa_$ioa_switch 256* rather than com_err_; also, print pointer to bad char; allow "$" and "_" in 257* variable names for namelist input (bug 55). 258* 21 Mar 78, DSL - Convert to new format representation; completely rewrite 259* carriage control code. 260* 06 Feb 78, DSL - Fix char control code to only print one blank line for the 261* format "(1h )". Also fix deferred output to put newlines between its records. 262* 03 Jan 78, DSL - More changes for "static" stack frames. 263* 19 Dec 77, DSL - Changed to support new "static" stack frame. Stack frame 264* for fortran_io_ is pushed the first time any entry point is referenced by a 265* given user stack frame and is popped with the user stack frame. 266* 06 Dec 77, DSL - Bug fixes: Finish handler should be an external entry not an 267* internal entry; proc get_record does not set record_found correctly (introduced 268* on 23 Nov 77). Also, more clean up in formatted I/O. 269* 23 Nov 77, DSL - Bug fixes: correct handling of empty (or nonexistent) files; 270* suppress newline char for structured files; put "-no_end" in attach desc for 271* blocked files. 272* 15 Nov 77, DSL - Fix open statement to recognize unstructured file as possible 273* binary stream file. Also clean up changes started 10/24/77. 274* 24 Oct 77, DSL - some quickie speedups. a) copy format as it is used to minimize 275* number of times it is unpacked. b) change write_a_record to call iox_$put_chars 276* only at the end of the write statement rather than at each newline character. 277* 19 Sep 77, DSL - allow backspace even if file is at BOF; fix list-dir output to 278* print imaginary part of complex value. 279* 07 Sep 77, DSL - implement status specifier for close statement. 280* fix bug in open for nonexistent blocked file. 281* 30 Aug 77, DSL - delete extra comma in namelist output; prevent printing 282* of record on EOF error; file 0 is not closed; change defer_newline to affect 283* generation of all carriage_controllable files. 284* NOTE -- implementation of defer attr conflicts with documentation with this change. 285* 11 Aug 77, DSL - Bug fixes: close_file does not close 0 if nothing else is open; 286* wrong open modes for tape_mult_; EOF on binary files not detected correctly; 287* iostat var must always be set if given; form only allowed when connecting; fix error 288* messages; implement rewind for tape I/O modules. 289* 02 Aug 77, DSL - Change reopen; implement s-format; better treatment of terminal files. 290* 21 Jul 77, DSL - fix bugs; change inplementation for opening a nonexistent file 291* for inout; prevent close files query for fast or dfast; 292* April thru June 1977 David Levin - Completely restructured. Obsolete code removed. */ 293 294 /* This program extensively changed 11/76 to fix many bugs, improve */ 295 /* performance, and change actions performed. --R.Schoeman */ 296 297 298 /* The following comments outline the implementatin of "static" stack frame. Refer to MCR 3153. 299* 300* 301* When a FORTRAN program's stack frame is created and the program performs I/O, 302* stack_frame.ps_ptr is initialized as an ITS pair pointing to the PS for the program. This 303* field is never modified again by the object segment or by pl1_operators_. In this change 304* to the implementation of fortran_io_, I propose using the high-order bit of this field as 305* flag. The bit is ignored if the field is used as an ITS pair and the value of this bit is 306* zero when the ITS pair is stored. 307* 308* All FORTRAN programs reference fortran_io_, the support procedure for FORTRAN I/O, 309* via operator calls (to pl1_operators_, of course). Therefore, all valid references to 310* fortran_io_ support entry points enter fortran_io_ via pl1_operators_. Once in 311* pl1_operators_, the sign of stack_frame.ps_ptr indicates the value of our flag. 312* 313* 314* First Reference to fortran_io_ 315* 316* The first time fortran_io_ is referenced from a (user) stack frame, the sign of 317* stack_frame.ps_ptr is positive because the high-order bit is zero. In this case, a full 318* PL/I call is made to the appropriate support entry point in fortran_io_. (It does not 319* matter which entry point is used to create the stack frame for fortran_io_.) Once within 320* fortran_io_ the following actions are performed in order to implement the "static" stack 321* frame for fortran_io_: 322* 323* 1. Copy fortran_io_'s stack_frame|4 to the user's stack_frame|4. This field is used by 324* PL/I and FORTRAN to determine the true end of the stack frame when a temporary stack 325* extension is freed. By copying this field, a temporary stack extension in the user's 326* stack frame will not cause an accidental freeing of fortran_io_'s stack frame. 327* 328* 2. Store the address of a PL/I goto statement within fortran_io_ at fio_ps.label_addr. 329* This goto statement contains a subscripted reference to a label array, in which the 330* variable mentioned below in item 3 is the subscript, to transfer control to the 331* correct support entry point in fortran_io_. (N.B. - The structure "fio_ps" is in 332* fortran_io_'s stack frame.) 333* 334* 3. Store the address of a fortran_io_ variable at fio_ps.label_index_addr. This 335* variable is used as the subscript of the label array reference mentioned above. Code 336* in pl1_operators_ uses this address to store the value of index register 6. The 337* value of this register identifies the support entry point desired. The variable 338* itself is initialized to zero. 339* 340* 4. Store the address of fortran_io_'s stack frame at fio_ps.stack_frame_p. 341* 342* 5. Store a packed ptr to fio_ps at the user's stack_frame.support_ptr. 343* 344* 6. Set high-order bit of the user's stack_frame.ps_ptr to "1"b. 345* 346* 7. Now that the stack frames are properly set up and control is at the appropriate entry 347* point, fortran_io_ can perform the requested task. 348* 349* 350* Subsequent References to fortran_io_ 351* 352* If the sign of the user's stack_frame.ps_ptr is negative, the high-order bit of the 353* word is "1"b and this indicates that a stack frame already exists for fortran_io_. In 354* this case the following actions are performed instead of a PL/I call: 355* 356* 1. The value of index register 0 is stored at the user's stack_frame.return_ptr+1. This 357* field now forms an ITS pair pointing the return point in the user's program. 358* 359* 2. A pointer to fortran_io_'s stack frame, obtained from fio_ps.stack_frame_p, is stored 360* in the user's stack_frame.next_sp. (Fortran_io_'s stack_frame.prev_sp does not have 361* to be set as it is still valid from when the stack frame was created.) 362* 363* 3. The sp, pr6, is loaded from fio_ps.stack_frame_p. 364* 365* 4. The value of index register 6 is stored indirectly through fio_ps.label_index_addr 366* using a "sxl6" instruction. This sets the value of the fortran_io_ variable, i.e., 367* sets the subscript of the label array reference. 368* 369* Control is now transferred indirectly through fio_ps.label_addr. This results in 370* tranferring to the PL/I goto statement mentioned earlier and the execution of that 371* statement results in a transfer to the appropriate entry point within fortran_io_. 372* 373* 5. Control is now in fortran_io_ with pr6 pointing to the correct stack frame!! Perform 374* the requested task. 375* 376* 377* Returning From fortran_io_ 378* 379* In order to return control to the user program, return_to_user$special_return is 380* called. This routine: 381* 382* - copies fortran_io_'s stack_frame.next_sp into the user's stack_frame.next_sp (this 383* makes fortran_io_'s stack frame part of the user's frame) 384* - sets pr6 to the user's frame 385* - does a short_return 386* 387* Fortran_io_'s stack frame is now part of the user's stack frame and remains so until 388* the next I/O operation. Each user stack frame has its own fortran_io_ stack frame. 389* 390* 391* Notes 392* 393* The procedure fortran_io_ must never execute a return_mac, i.e., a return from the 394* external procedure fortran_io_, or fortran_io_'s stack frame goes away while the flag in 395* the user's stack frame proclaims its existence. 396* 397* The procedure return_to_user.alm was initially added to bound_fortran_io_ in order to 398* provide a faster non-local return for the FORTRAN err= and end= exits. It now performs 399* that function, following the guidelines outlined here, as well as the "normal" return 400* mentioned above. 401* 402* The following include files and source segments are used to implement these changes: 403* 404* fortran_io_.pl1 405* fortran_ps.incl.alm 406* fortran_ps.incl.pl1 407* pl1_operators_.alm 408* return_to_user.alm 409* stack_frame.incl.alm 410* stack_frame.incl.pl1 411**/ 412 413 414 /* The following structure is declared to insure that all double word variables 415* are close packed. Using a structure prevents storage allocation dependencies. */ 416 417 dcl 1 dummy_for_double_word_alignment 418 aligned structure, 419 2 PS_ptr ptr, 420 2 block_pt ptr, 421 2 buffer_seg_pointer ptr, 422 2 buffer_pointer ptr, 423 2 constant_ptr ptr, 424 2 count_pt ptr, 425 2 end_pt ptr, 426 2 fcb_ptr ptr, 427 2 fmt_ptr ptr, 428 2 format_p ptr, 429 2 iocb_ptr ptr, 430 2 link_pt ptr, 431 2 name_pt ptr, 432 2 namelist_name_ptr ptr, 433 2 ok_pt ptr, 434 2 subs_pt ptr, 435 2 symbol_pt ptr, 436 2 table_pt ptr, 437 2 text_pt ptr, 438 2 user_sp ptr; 439 440 441 dcl 1 file_desc like fortran_buffer_.table aligned based (fcb_ptr); 442 443 dcl CPDW fixed bin (8) init (8) int static options (constant); 444 dcl CPW fixed bin (8) init (4) int static options (constant); 445 dcl EOF1 char (1) aligned int static options (constant) init (""); 446 /* \034 */ 447 dcl EOF2 char (2) aligned int static options (constant) init ("\f"); 448 /* \134 \146 */ 449 dcl EOF3 char (2) aligned int static options (constant) init ("\F"); 450 /* \134 \106 */ 451 declare FALSE bit (1) int static options (constant) init ("0"b); 452 declare TRUE bit (1) int static options (constant) init ("1"b); 453 454 dcl fio_data_type_index (0:63) static options (constant) 455 initial (0, 6, 5, 5, 4, 4, 4, 4, 3, 3, 3, 3, 3, 3, 3, 3, 2, 2, 2, 2, 2, 2, 2, 2, 456 2, 2, 2, 2, 2, 2, 2, 2, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 457 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1); 458 459 declare abs builtin; 460 declare add_char_offset_ entry (ptr, fixed bin (21)) returns (ptr) reducible; 461 dcl addr builtin; 462 dcl addrel builtin; 463 dcl area_size fixed bin int static options (constant) init (2048); 464 dcl assign_round_ entry (ptr, fixed bin, fixed bin (35), ptr, fixed bin, fixed bin (35)); 465 dcl attach_desc_len fixed bin; 466 dcl b_var_str char (256) varying based; 467 dcl base fixed bin (3); 468 dcl baseno builtin; 469 dcl baseptr builtin; 470 dcl begin_index fixed bin (21); 471 dcl binary builtin; 472 dcl binary_type (4) fixed bin init (6, 9, 94, 97) internal static options (constant); 473 dcl binary_prec (4) fixed bin (35) init (27, 63, 27, 63) internal static options (constant); 474 dcl bin_type fixed bin; 475 dcl bit builtin; 476 dcl buffer_index fixed bin (21); 477 dcl buffer_length fixed bin (21); 478 dcl buffer_max_len fixed bin (21); 479 dcl call_sw fixed bin (1); /* <0 first; =0 all others; >0 last */ 480 dcl capital_letters char (26) int static options (constant) init ("ABCDEFGHIJKLMNOPQRSTUVWXYZ"); 481 dcl ch char (1) aligned; 482 dcl char_len fixed bin (21); 483 declare char_offset fixed binary (21); 484 dcl character_type fixed bin static options (constant) init (6); 485 dcl chars_left fixed bin (21); 486 dcl chars_per_item fixed binary (21); 487 dcl chars char (4096) based; 488 declare code fixed binary (35); 489 dcl column_one fixed bin; 490 dcl com_err_ entry options (variable); 491 dcl convert builtin; 492 dcl copy builtin; 493 dcl count fixed bin; 494 dcl create_if_not_found bit (1) aligned int static options (constant) init ("1"b); 495 dcl cu_$cl entry (bit (1) aligned); 496 dcl cu_$stack_frame_ptr entry () returns (ptr); 497 dcl current fixed bin (4); 498 dcl dec_flt float decimal (59) aligned based (addr (work)); 499 dcl dec_int fixed decimal (11) aligned based (addr (work)); 500 dcl default_error_handler_$add_finish_handler 501 entry (entry, fixed bin (35)); 502 dcl delete_$path entry (char (*), char (*), bit (6), char (*), fixed bin (35)); 503 dcl dexp fixed decimal (3); 504 declare dirname character (168); 505 dcl divide builtin; 506 dcl dp_flt_pic picture "-9.v(17)9es99" aligned based (addr (work)); 507 dcl dp_fxd_pic picture "(18)-9.v(21)9" aligned based (addr (work)); 508 dcl data_type_of_prev_item fixed bin; 509 dcl e fixed bin; 510 dcl element_count fixed bin (24); 511 dcl entry_point fixed bin; 512 declare entryname character (32); 513 dcl error_table_$asynch_deletion 514 fixed bin (35) ext static; 515 dcl error_table_$end_of_info 516 fixed bin (35) ext static; 517 dcl error_table_$moderr fixed bin (35) ext static; 518 dcl error_table_$no_file fixed bin (35) ext static; 519 dcl error_table_$no_operation 520 fixed bin (35) ext static; 521 dcl error_table_$no_record fixed bin (35) ext static; 522 dcl error_table_$noentry fixed bin (35) ext static; 523 dcl error_table_$pathlong fixed bin (35) ext static; 524 dcl error_table_$short_record 525 fixed bin (35) ext static; 526 dcl exists bit (1) aligned; 527 dcl exists_file_code fixed bin; 528 dcl expand_pathname_ entry (char (*), char (*), char (*), fixed bin (35)); 529 dcl exps char (4) aligned int static options (constant) init ("edED"); 530 dcl ext_float_decimal fixed bin internal static options (constant) init (162); 531 dcl fast_related_data_$fortran_buffer_p 532 ptr ext static; 533 dcl fast_related_data_$fortran_io_initiated 534 bit (1) aligned ext static; 535 dcl fast_related_data_$in_dfast 536 bit (1) aligned ext static; 537 dcl fast_related_data_$in_fast_or_dfast 538 bit (1) aligned ext static; 539 dcl fast_related_data_$terminate_run 540 ext static entry variable; 541 dcl fixed builtin; 542 dcl fixedoverflow condition; 543 dcl flt_pic picture "-9.v(7)9es99" aligned based (addr (work)); 544 dcl format_type (0:3) char (13) int static options (constant) 545 init ("List-directed", "Unformatted", "Formatted", "Namelist"); 546 dcl fortran_buffer_$ ext static; 547 dcl fortran_io_error_$access_field_error 548 fixed bin (35) ext static; 549 dcl fortran_io_error_$already_connected 550 fixed bin (35) ext static; 551 dcl fortran_io_error_$already_opened 552 fixed bin (35) ext static; 553 dcl fortran_io_error_$attach_desc_field_error 554 fixed bin (35) ext static; 555 dcl fortran_io_error_$bad_char 556 fixed bin (35) ext static; 557 declare fortran_io_error_$blank_field_error 558 fixed bin (35) ext static; 559 dcl fortran_io_error_$cannot_position 560 fixed bin (35) ext static; 561 dcl fortran_io_error_$cannot_read 562 fixed bin (35) ext static; 563 dcl fortran_io_error_$cannot_reopen 564 fixed bin (35) ext static; 565 dcl fortran_io_error_$cannot_truncate 566 fixed bin (35) ext static; 567 dcl fortran_io_error_$cannot_write 568 fixed bin (35) ext static; 569 dcl fortran_io_error_$conversion_error 570 fixed bin (35) ext static; 571 declare fortran_io_error_$close_attr_error 572 fixed binary (35) external static; 573 dcl fortran_io_error_$dnumeric_file 574 fixed bin (35) ext static; 575 dcl fortran_io_error_$filename_field_error 576 fixed bin (35) ext static; 577 dcl fortran_io_error_$fio_sys_error 578 fixed bin (35) ext static; 579 dcl fortran_io_error_$form_field_error 580 fixed bin (35) ext static; 581 dcl fortran_io_error_$format_error 582 fixed bin (35) ext static; 583 dcl fortran_io_error_$format_is_infinite 584 fixed bin (35) ext static; 585 dcl fortran_io_error_$formatted_file 586 fixed bin (35) ext static; 587 dcl fortran_io_error_$incompatible_opening 588 fixed bin (35) ext static; 589 declare fortran_io_error_$internal_file_oflow 590 fixed bin (35) ext static; 591 dcl fortran_io_error_$invalid_file0_attr 592 fixed bin (35) ext static; 593 dcl fortran_io_error_$invalid_file0_type 594 fixed bin (35) ext static; 595 dcl fortran_io_error_$invalid_for_file0 596 fixed bin (35) ext static; 597 dcl fortran_io_error_$io_switch_field_error 598 fixed bin (35) ext static; 599 dcl fortran_io_error_$long_record 600 fixed bin (35) ext static; 601 dcl fortran_io_error_$missing_header 602 fixed bin (35) ext static; 603 dcl fortran_io_error_$mode_field_error 604 fixed bin (35) ext static; 605 dcl fortran_io_error_$must_be_empty 606 fixed bin (35) ext static; 607 dcl fortran_io_error_$namelist_error 608 fixed bin (35) ext static; 609 dcl fortran_io_error_$not_blocked 610 fixed bin (35) ext static; 611 dcl fortran_io_error_$not_direct 612 fixed bin (35) ext static; 613 dcl fortran_io_error_$not_open 614 fixed bin (35) ext static; 615 dcl fortran_io_error_$not_scratch_file 616 fixed bin (35) ext static; 617 dcl fortran_io_error_$not_sequential 618 fixed bin (35) ext static; 619 dcl fortran_io_error_$open_attr_conflict 620 fixed bin (35) ext static; 621 declare fortran_io_error_$open_attr_incomplete 622 fixed bin (35) ext static; 623 dcl fortran_io_error_$parens_too_deep 624 fixed bin (35) ext static; 625 dcl fortran_io_error_$read_after_eof 626 fixed bin (35) ext static; 627 dcl fortran_io_error_$short_record 628 fixed bin (35) ext static; 629 dcl fortran_io_error_$status_field_error 630 fixed bin (35) ext static; 631 dcl fortran_io_error_$syntax_error 632 fixed bin (35) ext static; 633 dcl fortran_io_error_$unformatted_file 634 fixed bin (35) ext static; 635 dcl fortran_io_error_$unknown_filetype 636 fixed bin (35) ext static; 637 dcl fortran_io_error_$write_after_eof 638 fixed bin (35) ext static; 639 dcl fortran_io_error_$wrong_mode 640 fixed bin (35) ext static; 641 dcl fxd_pic picture "(8)-9.v(11)9" aligned based (addr (work)); 642 dcl general_format_parse_$runtime 643 entry (char (1024) aligned, char (4096) aligned, bit (1) aligned, fixed bin (35)) 644 ; 645 declare get_pdir_ entry () returns (char (168)); 646 dcl have_runtime_format bit (1) aligned; 647 dcl hbound builtin; 648 declare hcs_$status_long entry (char (*), char (*), fixed bin (1), ptr, ptr, fixed bin (35)); 649 declare hcs_$status_minf entry (char (*), char (*), fixed bin (1), fixed bin (2), fixed bin (24), 650 fixed bin (35)); 651 dcl i fixed bin (18); 652 dcl illegal_return condition; 653 dcl in fixed bin; 654 dcl index builtin; 655 dcl integer_dtype fixed bin init (2) internal static options (constant); 656 dcl integer_prec fixed bin (35) init (35) internal static options (constant); 657 dcl interactive bit (1); 658 declare internal_file_count fixed binary (17); 659 dcl int_pic picture "(15)-9" aligned based (addr (work)); 660 dcl io_buf char (buffer_length) based (buffer_pointer); 661 dcl ioa_$ioa_switch entry options (variable); 662 dcl iox_$attach_iocb entry (ptr, char (*), fixed (35)); 663 dcl iox_$close entry (ptr, fixed bin (35)); 664 dcl iox_$control entry (ptr, char (*), ptr, fixed bin (35)); 665 dcl iox_$detach_iocb entry (ptr, fixed bin (35)); 666 dcl iox_$error_output ptr ext static; 667 dcl iox_$get_chars entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); 668 dcl iox_$get_line entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); 669 dcl iox_$find_iocb entry (char (*) aligned, ptr, fixed bin (35)); 670 dcl iox_$open entry (ptr, fixed bin, bit (1) aligned, fixed bin (35)); 671 dcl iox_$position entry (ptr, fixed bin, fixed bin (21), fixed bin (35)); 672 dcl iox_$put_chars entry (ptr, ptr, fixed bin (21), fixed bin (35)); 673 dcl iox_$read_record entry (ptr, ptr, fixed bin (21), fixed bin (21), fixed bin (35)); 674 dcl iox_$rewrite_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); 675 dcl iox_$seek_key entry (ptr, char (256) var, fixed bin (21), fixed bin (35)); 676 dcl iox_$write_record entry (ptr, ptr, fixed bin (21), fixed bin (35)); 677 dcl iox_$user_input ptr ext static; 678 dcl iox_$user_io ptr ext static; 679 dcl iox_$user_output ptr ext static; 680 dcl j fixed bin (18); 681 dcl k fixed bin (18); 682 dcl l fixed bin (18); 683 dcl last fixed bin (21); 684 declare lbound builtin; 685 dcl length builtin; 686 dcl lower_letters char (26) int static options (constant) init ("abcdefghijklmnopqrstuvwxyz"); 687 dcl ltrim builtin; 688 dcl max_fixed fixed bin int static options (constant) init (11); 689 dcl max_float fixed bin int static options (constant) init (59); 690 dcl me char (12) init ("fortran_io_") int static options (constant); 691 dcl min builtin; 692 dcl mod builtin; 693 declare must_produce_plus bit (1) aligned; 694 dcl my_code fixed bin (35); 695 dcl new_buffer_length fixed bin (21); 696 declare no_uid bit (36) aligned internal static options (constant) initial (""b); 697 dcl null builtin; 698 dcl operation_name (0:14) char (12) int static options (constant) 699 init ("ZERO-ERROR", " write", "Old endfile", " read", "Rewind", "Unused 5", 700 "Closefile", "Close", "Backspace", "Inquire", "Openfile", "Open", "Margin", 701 "Unused 13", "Endfile"); 702 dcl overflow condition; 703 dcl overflow_label label; 704 dcl pl1_operators_$VLA_words_per_seg_ 705 fixed bin (19) ext; 706 dcl prec fixed bin; 707 dcl process_type fixed bin; 708 dcl prompt_char char (4) aligned int static init ("? ") options (constant); 709 dcl psp ptr; 710 dcl ptr builtin; 711 dcl rel builtin; 712 dcl return_if_not_found bit (1) aligned int static options (constant) init ("0"b); 713 dcl return_to_user entry (ptr, ptr); 714 dcl return_to_user$special_return 715 entry; 716 dcl round builtin; 717 dcl rtrim builtin; 718 dcl search builtin; 719 dcl sent fixed bin (21); 720 dcl size condition; 721 dcl skip_line_numbers bit (1); 722 dcl stop_run external entry; 723 dcl str_len fixed bin; 724 dcl string builtin; 725 dcl substr builtin; 726 dcl suppress_final_newline bit (1) aligned; 727 dcl sys_info$max_seg_size fixed bin (18) ext static; 728 dcl terminal_file bit (1) aligned; 729 dcl translate builtin; 730 dcl underflow condition; 731 declare unique_chars_ entry (bit (*)) returns (char (15)); 732 dcl unspec builtin; 733 dcl user_info_$process_type 734 entry (fixed bin); 735 dcl verify builtin; 736 declare vfile_status_ entry (char (*), char (*), ptr, fixed bin (35)); 737 dcl white_space char (2) aligned int static options (constant) init (" "); 738 /* SP TAB */ 739 dcl word_len fixed bin (19); 740 dcl words (2) fixed bin (35) aligned based; 741 dcl zero_label label; 742 dcl zerodivide condition; 743 744 745 /* WARNING !!! these structures proport to know the internal representation of extended float decimal data */ 746 747 dcl 1 number aligned structure based (addr (work)), 748 2 sign char (1) unaligned, 749 2 digit char (prec) unaligned, 750 2 exp fixed bin (8) unaligned, 751 1 flt_dec aligned structure based (addr (work)), 752 2 pad1 char (60) unaligned, 753 2 exp fixed bin (8) unaligned; 754 755 dcl 1 word_align_1 aligned based, 756 2 based_bits bit (72) unaligned; 757 758 dcl 1 word_align_2 aligned based, 759 2 based_dp float bin (63) unaligned; 760 761 dcl 1 word_align_3 aligned based, 762 2 double_word fixed bin (71) unaligned; 763 764 765 /* I/O module information. */ 766 767 dcl 1 open_mode (13) aligned structure int static options (constant), 768 2 io_type bit (3) unal init ((3) (1)"001"b, (10) (1)"010"b), 769 2 direction unaligned structure, 770 3 in bit (1) 771 init ("1"b, "0"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "0"b, 772 "1"b), 773 3 out bit (1) 774 init ("0"b, "1"b, "1"b, "0"b, "1"b, "1"b, "1"b, "0"b, "1"b, "1"b, "0"b, "1"b, 775 "1"b), 776 2 for_input fixed bin (4) unal init (0, 1, 0, 0, 4, 0, 0, 0, 8, 0, 0, 11, 0), 777 2 for_output fixed bin (4) unal init (3, 0, 2, 6, 0, 7, 5, 10, 0, 9, 13, 0, 12); 778 779 780 781 /* Structures for formatted input/output processing. These overlay the buffer. */ 782 783 /* Used to clear first record of internal file write. */ 784 785 dcl buffer char (buffer_max_len) based (buffer_pointer); 786 787 788 dcl 1 record_structure aligned structure based (buffer_pointer), 789 2 pad char (buffer_index) unaligned, 790 /* these are already processed */ 791 2 rest_of_record char (buffer_length - buffer_index) unaligned; 792 /* What's left of the record */ 793 794 dcl 1 field_structure aligned structure based (buffer_pointer), 795 2 pad char (buffer_index) unaligned, 796 /* these are already processed */ 797 2 rest_of_field char (last - buffer_index) unaligned; 798 /* What's left of the field */ 799 800 dcl 1 output_structure aligned structure based (buffer_pointer), 801 2 pad char (buffer_length) unaligned, 802 /* these are already processed */ 803 2 rest_of_output char (1024) unaligned; 804 /* What's added to the output record */ 805 806 /* valid values for fields in open and close statements */ 807 808 declare open_status_values (5) char (12) varying internal static options (constant) 809 init ("unknown", "new", "old", "scratch", "append"); 810 811 declare open_mode_values (3) char (12) varying internal static options (constant) 812 init ("in", "out", "inout"); 813 814 declare open_access_values (2) char (12) varying internal static options (constant) 815 init ("sequential", "direct"); 816 817 declare open_form_values (2) char (12) varying internal static options (constant) 818 init ("formatted", "unformatted"); 819 820 declare open_blank_values (2) char (12) varying internal static options (constant) init ("null", "zero"); 821 822 declare close_status_values (2) char (12) varying internal static options (constant) init ("keep", "delete"); 823 824 /* various named constants */ 825 826 declare new_file fixed bin int static options (constant) init (1); 827 declare old_file fixed bin int static options (constant) init (2); 828 declare scratch_file fixed bin int static options (constant) init (3); 829 declare append_file fixed bin int static options (constant) init (4); 830 declare unknown_file fixed bin int static options (constant) init (0); 831 832 declare COMMA char (1) int static options (constant) init (","); 833 dcl two_NLs char (2) aligned int static options (constant) init (" 834 835 "); 836 dcl ( 837 SP init (" "), 838 NL init (" 839 "), 840 CR init (" "), 841 FF init (" ") 842 ) char (1) aligned internal static options (constant); 843 844 845 dcl 1 stack_f aligned based, 846 2 pad (2) bit (72) aligned, 847 2 sp_up_4 bit (72) aligned, 848 2 pad2 bit (72) aligned, 849 2 xr (0:7) fixed bin (17) unal; 850 851 /* The following data structure overlays the PS data structure. */ 852 853 854 dcl 1 dfast_communications_area 855 aligned based (addr (PS.data_word (1))), 856 2 max_recl fixed bin, 857 2 pad fixed bin, 858 2 pathname_ptr pointer, 859 2 filetype_ptr pointer; 860 861 862 /* BUFFER SEGMENT STRUCTURE - These fields are stored in the buffer segment. */ 863 864 dcl 1 based_work_area aligned based (buffer_seg_pointer), 865 /* OFFSET (octal) LENGTH IN WORDS (octal) */ 866 2 version fixed bin, /* 0001 */ 867 /* These fields are used for conversions and should not be overlayed. */ 868 /* 1*/ 869 2 work char (64) aligned, /* 0020 */ 870 /* 21*/ 871 2 work_str char (4096) aligned, 872 /* 1000 */ 873 /* These fields are only used by open. */ 874 /* 1021*/ 875 2 attachment char (256) unaligned, 876 /* 0100 */ 877 /* 1121*/ 878 2 dir char (168) unaligned, 879 /* 0052 */ 880 /* 1173*/ 881 2 ent char (32) unaligned, 882 /* 0010 */ 883 /* 1203*/ 884 2 ioname char (32) aligned, /* 0010 */ 885 /* 1213*/ 886 2 info (20) fixed bin, /* 0024 */ 887 /* These fields allow us to save info from most recent error. */ 888 /* 1237*/ 889 2 actual_error fixed bin (35), /* 0001 */ 890 /* 1240*/ 891 2 ps_at_error ptr; /* 0002 */ 892 893 /* 1242 - next free offset */ 894 /* 4000 - last free offset */ 895 896 897 dcl NL_FF char (2) aligned int static options (constant) init (" 898 "); 1 1 /* BEGIN fortran_ps.incl.pl1 */ 1 2 1 3 /* Template for FORTRAN I/O storage block. It is similar to PL/I PS.*/ 1 4 1 5 /* Modified November 1976 by R.Schoeman */ 1 6 /* Modified 17 May 1977 by D.S. Levin */ 1 7 /* Modified 6 Dec 1977 by DSL - clean up dcl for element_desc */ 1 8 /* Modified 19 Dec 1977 by DSL - add declaration for fio_ps. */ 1 9 /* Modified 29 Nov 82, HH - VLA's: Add 'VLA' to 'element_desc'. */ 1 10 1 11 declare 1 12 1 PS aligned structure based(PS_ptr), 1 13 1 14 /* OFFSET (octal) */ 1 15 1 16 /* 00 */ 2 stack_frame_p ptr, /* pointer to user's stack frame */ 1 17 /* 02 */ 2 symbol_table_top_p ptr, /* pointer to top of symtab, ONLY IF IT EXISTS */ 1 18 /* 04 */ 2 symbol_table_block_p ptr, /* pointer to cur block of symtab, ONLY IF IT EXISTS */ 1 19 /* 06 */ 2 user_format_p ptr, /* format as specified by user */ 1 20 /* 10 */ 2 file_number fixed bin(17), /* file reference number */ 1 21 /* 11 */ 2 record_number fixed bin(17), /* record no. if direct access */ 1 22 /* 12 */ 2 error_p ptr, /* full pointer to label if err= supplied */ 1 23 /* 14 */ 2 end_p ptr, /* full pointer to label if end= supplied */ 1 24 /* 16 */ 2 work_format_p ptr, /* format used at runtime. (can be the same as user_format_p) */ 1 25 /* 20 */ 2 buffer_p ptr, /* ptr to I/O buf or ptr to string source/target */ 1 26 /* 22 */ 2 namelist_p ptr, /* pointer to OK list */ 1 27 1 28 /* 24 */ 2 1 /* BEGIN INCLUDE FILE fortran_job_bits.incl.pl1 */ 2 2 2 3 /****^ *********************************************************** 2 4* * * 2 5* * Copyright, (C) Honeywell Information Systems Inc., 1987 * 2 6* * * 2 7* *********************************************************** */ 2 8 2 9 2 10 /****^ HISTORY COMMENTS: 2 11* 1) change(86-07-14,BWong), approve(86-07-14,MCR7286), audit(86-07-17,Ginter), 2 12* install(86-07-28,MR12.0-1105): 2 13* Fix fortran bug 454. 2 14* 2) change(87-06-23,RWaters), approve(87-06-23,MCR7703), audit(87-07-10,Huen), 2 15* install(87-08-06,MR12.1-1069): 2 16* Implemented SCP 6315: fortran error-handling argument. 2 17* END HISTORY COMMENTS */ 2 18 2 19 2 20 /* Modified: 2 21* May 15 1987 by R. Waters - SCP 6315 added debug_io bit. 2 22* May 23 1985 by B.Wong - 454: document internal file mode. 2 23* March 28 1984 by M. Mabey to install HFP support. 2 24* May 11 1980 by Marshall Presser to add ansi_77 bit 2 25* July 13 1979 by C R Davis to add fold bit. 2 26* May 17 1977 by David Levin to extend control_type field and add iostat_var 2 27**/ 2 28 2 29 2 job_bits unaligned structure, 2 30 3 error_label bit(1), /* if err= supplied in statement. */ 2 31 3 end_label bit(1), /* if end= supplied in statement. */ 2 32 3 read bit(1), /* if not control stmnt then read if true, write if false. */ 2 33 3 format bit(2), /* list directed-"00"b, unfmt-"01"b, fmt-"10"b, namelist-"11"b */ 2 34 3 mode bit(2), /* seq-"00"b, direct access-"01"b, string io-"10"b, internal file-"11"b */ 2 35 3 list bit(1), /* if I/O transmission includes a list. */ 2 36 3 control_type bit(4), /* see fortran_io_consts.incl.pl1 for meanings */ 2 37 3 mbz bit(1), /* to allow expansion of control_type. MUST BE ZERO */ 2 38 3 iostat_var bit(1), /* if iostat= supplied in statement */ 2 39 3 debug_io bit(1), /* if user wants cu_$cl called after an io error */ 2 40 3 reserved bit(3), /* used to be bit (4) but I stole one for debug_io. Hope they're not important :-) */ 2 41 2 42 /* the following two fields are generated at runtime */ 2 43 2 44 3 have_input bit(1), /* if buffer contains a printable input record. */ 2 45 3 end_of_input bit(1), /* if user has terminated list-dir input */ 2 46 2 47 3 fold bit (1), /* if symbol names have been folded to lower case */ 2 48 3 ansi_77 bit(1), /* if source has been compiled in ansii77 mode */ 2 49 3 hfp bit(1), /* if hex floating point math is to be used */ 2 50 3 pad bit(13), 2 51 2 52 /* END fortran_job_bits.incl.pl1 */ 2 53 1 29 1 30 1 31 /* 25 */ 2 max_buffer fixed bin(17), 1 32 1 33 /* 26 */ 2 element_desc unaligned structure, 1 34 3 data_type, 1 35 4 (integer, real, double, complex, logical, char, array_ref, VLA) bit(1), 1 36 3 length fixed bin(23), 1 37 3 pad bit(4), 1 38 1 39 /* 27 */ 2 element_count fixed bin(24), 1 40 /* 30 */ 2 element_p ptr, 1 41 /* 32 */ 2 start_field fixed bin, 1 42 /* 33 */ 2 buffer_size fixed bin, 1 43 /* 34 */ 2 data_word(18) fixed bin, 1 44 /* 56 */ 2 iostat_p ptr; /* ptr to location for iostat var */ 1 45 1 46 1 47 dcl 1 fio_ps aligned, /* ps in fortran I/O's stack frame. */ 1 48 /* Octal offsets */ 1 49 /* 00 */ 2 label_for_transfer label, /* Two ptrs, one to label var ref, one to fio frame. */ 1 50 /* 04 */ 2 address_of_index ptr, /* Pointer to storage for label var index. */ 1 51 1 52 /* 06 */ 2 job_bits unaligned structure like PS.job_bits, 1 53 /* 07 */ 2 file_number fixed bin, 1 54 1 55 /* 10 */ 2 element_desc unaligned structure like PS.element_desc, 1 56 /* 11 */ 2 element_count fixed bin, 1 57 /* 12 */ 2 element_p ptr; 1 58 1 59 3 1 /* BEGIN fortran_io_consts.incl.pl1 - various constants for fortran I/O */ 3 2 3 3 /* Modified: 3 4* 24 Oct 81, MEP added inquire_opr, deleted unused_9 (op_9) 3 5* 1 Oct 1981 - MEP internal file 3 6* 17 June 1981 - MEP for ansi77 i/o enhancements 3 7**/ 3 8 declare 3 9 (list_directed initial("00"b), 3 10 unformatted initial("01"b), 3 11 formatted initial("10"b), 3 12 namelist initial("11"b), 3 13 3 14 sequential_access initial("00"b), 3 15 direct_access initial("01"b), 3 16 string_io initial("10"b), 3 17 internal_file initial("11"b) )bit(2) aligned internal static options(constant); 3 18 3 19 dcl (write_opr initial(1), 3 20 old_endfile_opr initial(2), 3 21 read_opr initial(3), 3 22 rewind_opr initial(4), 3 23 op_5 initial(5), 3 24 closefile_opr initial(6), 3 25 close_opr initial(7), 3 26 backspace_opr initial(8), 3 27 inquire_opr initial(9), 3 28 openfile_opr initial(10), 3 29 open_opr initial(11), 3 30 margin_opr initial(12), 3 31 op_13 initial(13), 3 32 endfile_opr initial(14)) fixed bin(4) int static options(constant); 3 33 3 34 dcl (stream_file init("001"b), 3 35 record_file init("010"b), 3 36 blocked_file init("011"b), 3 37 binary_file init("100"b) ) bit(3) aligned int static options(constant); 3 38 3 39 dcl (undefined init(-1), 3 40 nonexistent init(0), 3 41 unstructured init(1), 3 42 sequential init(2), 3 43 blocked init(3), 3 44 indexed init(4), 3 45 binary_stream init(5) ) fixed bin int static options(constant); 3 46 3 47 /* This is the list of fields of the fields_specified word. It is used to check for duplication in the parse, and 3 48* is positionally importan for the code generator, fortran_io, and pl1_operators. */ 3 49 3 50 dcl (status_field init(1), 3 51 io_switch_field init(2), 3 52 attach_desc_field init(3), 3 53 filename_field init(4), 3 54 mode_field init(5), 3 55 access_field init(6), 3 56 form_field init(7), 3 57 recl_field init (8), 3 58 binarystream_field init (9), 3 59 prompt_field init (10), 3 60 carriage_field init (11), 3 61 defer_field init (12), 3 62 blank_field init (13), 3 63 units_field init (14), 3 64 fmt_field init (15), 3 65 rec_field init (16), 3 66 exist_field init (17), 3 67 opened_field init (18), 3 68 number_field init (19), 3 69 named_field init (20), 3 70 name_field init (21), 3 71 sequential_field init (22), 3 72 formatted_field init (23), 3 73 unformatted_field init (24), 3 74 nextrec_field init (25), 3 75 direct_field init (26) ) fixed bin int static options(constant); 3 76 3 77 /* The following masks indicate the valid keywords and fields known to the i/o routines: 3 78* read: unit, fmt, iostat, err, end, rec. 3 79* write: unit, fmt, iostat, err, end. 3 80* open: unit, iostat, err, file, status, access, form, recl, blank, status, ioswitch, 3 81* attach, mode, binarystream, prompt, carriage, defer. 3 82* close: unit, iostat, err, status. 3 83* inquire: unit _x_o_r file, iostat, err, exist, opened, number, named, name, access, sequential, direct, 3 84* form, formatted, unformatted, recl, nextrec, blank. 3 85* */ 3 86 declare (open_keyword_mask init ("111111111111100000000000000000000000"b), 3 87 valid_open_keyword init ("111111111111110000000000000000000000"b), 3 88 valid_read_keyword init ("000000000000011100000000000000000000"b), 3 89 valid_write_keyword init ("000000000000011000000000000000000000"b), 3 90 valid_close_keyword init ("100000000000010000000000000000000000"b), 3 91 valid_inquire_keyword init("000100000000010011111111110000000000"b)) 3 92 bit (36) aligned internal static options (constant); 3 93 /* END fortran_io_consts.incl.pl1 */ 1 60 1 61 1 62 /* END fortran_ps.incl.pl1 */ 899 4 1 /* BEGIN fortran_buffer.incl.pl1 The external data base for fortran I/O. */ 4 2 4 3 /* Modified November 1976 by R.Schoeman. */ 4 4 /* Modified: 4 5* 25 Aug 83, MM - added the bit "using_tape_nstd" 4 6* 23 Apr 82, HH - absorbed 'more_bits' into 'per_connection'. 4 7* 14 Apr 82, HH - added 'switch_ready', 'eofs_are_records' & 'unwritten_eofs' for ENDFILE statement. 4 8* 2 Nov 81, MEP - added last_rec field for inquire statement. 4 9* 2 Sept 81, MEP - unlike Christ, I could not make 36 bits feed the multitudes. Added more_bits. 4 10* 7 August 81, MEP - add blank 4 11* 12 May 1978, DSL - Add rewind_on_open. 4 12* 7 Sep 1977 by DSL - change terminal_file to allow_delete 4 13* 2 Aug 1977 by David Levin - add terminal_file and allow_reopen */ 4 14 4 15 dcl fortran_buffer_ptr ptr; 4 16 dcl ptr_array (1) ptr; /* needed for call to get_temp_segments */ 4 17 4 18 declare 1 fortran_buffer_ based (fortran_buffer_ptr), 4 19 2 table (0:99) aligned structure, 4 20 /* each entry is THREE words */ 4 21 3 bits unaligned structure, 4 22 /* FIRST WORD: */ 4 23 4 installation_defined, 4 24 5 default_input bit (1), 4 25 5 default_output bit (1), 4 26 5 printer_file bit (1), 4 27 4 per_process, 4 28 5 prompt bit (1), 4 29 5 defer_newline bit (1), 4 30 4 per_connection, 4 31 5 connected bit (1), 4 32 5 fortran_attached bit (1), 4 33 5 fortran_opened bit (1), 4 34 5 formatted_records bit (1), 4 35 5 direction, 4 36 6 in bit (1), 4 37 6 out bit (1), 4 38 5 allow, 4 39 6 direct_access bit (1), 4 40 6 seq_access bit (1), 4 41 6 positioning bit (1), 4 42 5 carriage_controllable bit (1), 4 43 5 newline_needed bit (1), 4 44 5 double_word_file bit (1), 4 45 5 allow_reopen bit (1), 4 46 5 allow_delete bit (1), 4 47 5 rewind_on_open bit (1), 4 48 5 blank_null bit (1), 4 49 5 type_of_io bit (3), 4 50 5 open_code fixed bin (5), 4 51 5 previous fixed bin (5), 4 52 /* SECOND WORD: */ 4 53 5 file_status fixed binary (2) unsigned, 4 54 5 has_been_deleted bit (1), 4 55 5 last_rec fixed binary (21), 4 56 5 using_vfile bit (1), 4 57 5 using_tape_nstd bit(1), 4 58 5 switch_ready bit (1), /* switch attached & opened */ 4 59 5 eofs_are_records bit (1), 4 60 5 unwritten_eofs fixed bin (3) unsigned, 4 61 5 pad bit (4), 4 62 /* THIRD WORD: */ 4 63 3 switch_p ptr unaligned, 4 64 4 65 /* word of control bits */ 4 66 4 67 2 all_files_closed bit (1) unal, 4 68 2 allocated_by_fortran 4 69 bit (1) unal, 4 70 2 terminal_needs_newline 4 71 bit (1), 4 72 2 fill bit (33) unal, 4 73 4 74 /* another control word; note strange alignment */ 4 75 4 76 2 maximum_buffer fixed bin (26) unaligned, 4 77 /* Use three bytes (chars). */ 4 78 2 extra_char char (1) unaligned, /* "buf" must be on a word boundary */ 4 79 2 buf fixed bin; 4 80 4 81 dcl Max_unwritten_eofs fixed bin static options (constant) init (7); 4 82 4 83 /* END fortran_buffer.incl.pl1 */ 900 5 1 /* BEGIN fortran_open_data.incl.pl1 5 2* 5 3* Created: 16 May 1977 by David Levin. 5 4* 5 5* Modified: 5 6* 04 Feb 86, SH & AG - 490: changed file_status field to 5 7* fixed bin (3) to accomodate the addition of 5 8* a new value "append". 5 9* 12 Oct 81, MEP - changed blank field (level 2) to correct declaration 5 10* 2 Sept 81, MEP - added file_status field 5 11* 7 August 81, MEP - added blank_null field 5 12* 5 July 1977, DSL - add status field as first field. 5 13**/ 5 14 5 15 5 16 /****^ HISTORY COMMENTS: 5 17* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter), 5 18* install(86-07-28,MR12.0-1105): 5 19* Fix fortran bug 490 (SCP6284). 5 20* END HISTORY COMMENTS */ 5 21 5 22 5 23 dcl 1 fortran_open_data aligned based(addr(fortran_buffer_.buf)) structure, 5 24 5 25 2 specified unaligned structure, 5 26 3 status bit(1), 5 27 3 io_switch bit(1), 5 28 3 attach_desc bit(1), 5 29 3 filename bit(1), 5 30 3 mode bit(1), 5 31 3 access bit(1), 5 32 3 form bit(1), 5 33 3 recl bit(1), 5 34 3 binary bit(1), 5 35 3 prompt bit(1), 5 36 3 carriage bit(1), 5 37 3 defer bit(1), 5 38 3 blank bit(1), 5 39 5 40 3 converted_values, 5 41 4 direction, 5 42 5 in bit(1), 5 43 5 out bit(1), 5 44 4 direct_access bit(1), 5 45 4 formatted_records bit(1), 5 46 4 blank_null bit (1), 5 47 5 48 3 dfast_openfile bit(1), 5 49 3 file_status fixed binary (3) unsigned, 5 50 3 pad bit(14), 5 51 5 52 2 status aligned structure, 5 53 3 offset fixed bin(17) unaligned, 5 54 3 length fixed bin(17) unaligned, 5 55 5 56 2 io_switch aligned structure, 5 57 3 offset fixed bin(17) unaligned, 5 58 3 length fixed bin(17) unaligned, 5 59 5 60 2 attach_desc aligned structure, 5 61 3 offset fixed bin(17) unaligned, 5 62 3 length fixed bin(17) unaligned, 5 63 5 64 2 filename aligned structure, 5 65 3 offset fixed bin(17) unaligned, 5 66 3 length fixed bin(17) unaligned, 5 67 5 68 2 mode aligned structure, 5 69 3 offset fixed bin(17) unaligned, 5 70 3 length fixed bin(17) unaligned, 5 71 5 72 2 access aligned structure, 5 73 3 offset fixed bin(17) unaligned, 5 74 3 length fixed bin(17) unaligned, 5 75 5 76 2 form aligned structure, 5 77 3 offset fixed bin(17) unaligned, 5 78 3 length fixed bin(17) unaligned, 5 79 5 80 2 max_rec_len fixed bin, 5 81 5 82 2 binary bit(1), 5 83 2 prompt bit(1), 5 84 2 carriage bit(1), 5 85 2 defer bit(1), 5 86 2 blank aligned structure, 5 87 3 offset fixed bin(17) unaligned, 5 88 3 length fixed bin(17) unaligned, 5 89 5 90 2 char_str char(1024) varying; 5 91 5 92 /* END fortran_open_data.incl.pl1 */ 901 6 1 /* BEGIN INCLUDE FILE fortran_inquire_data.incl.pl1 */ 6 2 6 3 /* This include file describes the information passed between a fortran program 6 4* and fortran_io_. The specified, file, and unit fields are passed from the 6 5* fortran program to fortran_io_; all other fields are passed from fortran_io_ 6 6* to the fortran program. See also fortran_inquire_data.incl.alm, which 6 7* describes the same structure for use by pl1_operators_. 6 8* 6 9* Written 22 October 1981 by C R Davis. */ 6 10 6 11 declare 6 12 6 13 1 fortran_inquire_data aligned structure based (addr (fortran_buffer_.buf)), 6 14 6 15 2 specified unaligned structure, /* WORD 0 */ 6 16 3 pad1 bit (3), 6 17 3 filename bit (1), /* 4 */ 6 18 3 pad2 bit (1), 6 19 3 access bit (1), /* 6 */ 6 20 3 form bit (1), /* 7 */ 6 21 3 recl bit (1), /* 8 */ 6 22 3 pad3 bit (4), 6 23 3 blank bit (1), /* 13 */ 6 24 3 unit bit (1), /* 14 */ 6 25 3 pad4 bit (2), 6 26 3 exist bit (1), /* 17 */ 6 27 3 opened bit (1), /* 18 */ 6 28 3 number bit (1), /* 19 */ 6 29 3 named bit (1), /* 20 */ 6 30 3 name bit (1), /* 21 */ 6 31 3 sequential bit (1), /* 22 */ 6 32 3 formatted bit (1), /* 23 */ 6 33 3 unformatted bit (1), /* 24 */ 6 34 3 nextrec bit (1), /* 25 */ 6 35 3 direct bit (1), /* 26 */ 6 36 3 pad5 bit (10), 6 37 6 38 2 unit fixed binary (18), /* WORD 1 */ 6 39 6 40 2 filename character (168) unaligned, /* WORDS 2-43 */ 6 41 6 42 2 access aligned structure, /* WORDS 44-45 */ 6 43 3 pointer pointer unaligned, 6 44 3 length fixed binary (18), 6 45 6 46 2 form aligned structure, /* WORDS 46-47 */ 6 47 3 pointer pointer unaligned, 6 48 3 length fixed binary (18), 6 49 6 50 2 recl pointer unaligned, /* WORD 48 */ 6 51 6 52 2 blank aligned structure, /* WORDS 49-50 */ 6 53 3 pointer pointer unaligned, 6 54 3 length fixed binary (18), 6 55 6 56 2 exist pointer unaligned, /* WORD 51 */ 6 57 6 58 2 opened pointer unaligned, /* WORD 52 */ 6 59 6 60 2 number pointer unaligned, /* WORD 53 */ 6 61 6 62 2 named pointer unaligned, /* WORD 54 */ 6 63 6 64 2 name aligned structure, /* WORDS 55-56 */ 6 65 3 pointer pointer unaligned, 6 66 3 length fixed binary (18), 6 67 6 68 2 sequential aligned structure, /* WORDS 57-58 */ 6 69 3 pointer pointer unaligned, 6 70 3 length fixed binary (18), 6 71 6 72 2 formatted aligned structure, /* WORDS 59-60 */ 6 73 3 pointer pointer unaligned, 6 74 3 length fixed binary (18), 6 75 6 76 2 unformatted aligned structure, /* WORDS 61-62 */ 6 77 3 pointer pointer unaligned, 6 78 3 length fixed binary (18), 6 79 6 80 2 nextrec pointer unaligned, /* WORD 63 */ 6 81 6 82 2 direct aligned structure, /* WORDS 64-65 */ 6 83 3 pointer pointer unaligned, 6 84 3 length fixed binary (18); 6 85 6 86 /* END INCLUDE FILE fortran_inquire_data.incl.pl1 */ 902 7 1 /* BEGIN INCLUDE FILE ... stack_frame.incl.pl1 ... */ 7 2 7 3 /* format: off */ 7 4 7 5 /* Modified: 16 Dec 1977, D. Levin - to add fio_ps_ptr and pl1_ps_ptr */ 7 6 /* Modified: 3 Feb 1978, P. Krupp - to add run_unit_manager bit & main_proc bit */ 7 7 /* Modified: 21 March 1978, D. Levin - change fio_ps_ptr to support_ptr */ 7 8 /* Modified: 03/01/84, S. Herbst - Added RETURN_PTR_MASK */ 7 9 7 10 7 11 /****^ HISTORY COMMENTS: 7 12* 1) change(86-09-15,Kissel), approve(86-09-15,MCR7473), 7 13* audit(86-10-01,Fawcett), install(86-11-03,MR12.0-1206): 7 14* Modified to add constants for the translator_id field in the stack_frame 7 15* structure. 7 16* END HISTORY COMMENTS */ 7 17 7 18 7 19 dcl RETURN_PTR_MASK bit (72) int static options (constant) /* mask to be AND'd with stack_frame.return_ptr */ 7 20 init ("777777777777777777000000"b3); /* when copying, to ignore bits that a call fills */ 7 21 /* with indicators (nonzero for Fortran hexfp caller) */ 7 22 /* say: unspec(ptr) = unspec(stack_frame.return_ptr) & RETURN_PTR_MASK; */ 7 23 7 24 dcl TRANSLATOR_ID_PL1V2 bit (18) internal static options (constant) init ("000000"b3); 7 25 dcl TRANSLATOR_ID_ALM bit (18) internal static options (constant) init ("000001"b3); 7 26 dcl TRANSLATOR_ID_PL1V1 bit (18) internal static options (constant) init ("000002"b3); 7 27 dcl TRANSLATOR_ID_SIGNAL_CALLER bit (18) internal static options (constant) init ("000003"b3); 7 28 dcl TRANSLATOR_ID_SIGNALLER bit (18) internal static options (constant) init ("000004"b3); 7 29 7 30 7 31 dcl sp pointer; /* pointer to beginning of stack frame */ 7 32 7 33 dcl stack_frame_min_length fixed bin static init(48); 7 34 7 35 7 36 dcl 1 stack_frame based(sp) aligned, 7 37 2 pointer_registers(0 : 7) ptr, 7 38 2 prev_sp pointer, 7 39 2 next_sp pointer, 7 40 2 return_ptr pointer, 7 41 2 entry_ptr pointer, 7 42 2 operator_and_lp_ptr ptr, /* serves as both */ 7 43 2 arg_ptr pointer, 7 44 2 static_ptr ptr unaligned, 7 45 2 support_ptr ptr unal, /* only used by fortran I/O */ 7 46 2 on_unit_relp1 bit(18) unaligned, 7 47 2 on_unit_relp2 bit(18) unaligned, 7 48 2 translator_id bit(18) unaligned, /* Translator ID (see constants above) 7 49* 0 => PL/I version II 7 50* 1 => ALM 7 51* 2 => PL/I version I 7 52* 3 => signal caller frame 7 53* 4 => signaller frame */ 7 54 2 operator_return_offset bit(18) unaligned, 7 55 2 x(0: 7) bit(18) unaligned, /* index registers */ 7 56 2 a bit(36), /* accumulator */ 7 57 2 q bit(36), /* q-register */ 7 58 2 e bit(36), /* exponent */ 7 59 2 timer bit(27) unaligned, /* timer */ 7 60 2 pad bit(6) unaligned, 7 61 2 ring_alarm_reg bit(3) unaligned; 7 62 7 63 7 64 dcl 1 stack_frame_flags based(sp) aligned, 7 65 2 pad(0 : 7) bit(72), /* skip over prs */ 7 66 2 xx0 bit(22) unal, 7 67 2 main_proc bit(1) unal, /* on if frame belongs to a main procedure */ 7 68 2 run_unit_manager bit(1) unal, /* on if frame belongs to run unit manager */ 7 69 2 signal bit(1) unal, /* on if frame belongs to logical signal_ */ 7 70 2 crawl_out bit(1) unal, /* on if this is a signal caller frame */ 7 71 2 signaller bit(1) unal, /* on if next frame is signaller's */ 7 72 2 link_trap bit(1) unal, /* on if this frame was made by the linker */ 7 73 2 support bit(1) unal, /* on if frame belongs to a support proc */ 7 74 2 condition bit(1) unal, /* on if condition established in this frame */ 7 75 2 xx0a bit(6) unal, 7 76 2 xx1 fixed bin, 7 77 2 xx2 fixed bin, 7 78 2 xx3 bit(25) unal, 7 79 2 old_crawl_out bit (1) unal, /* on if this is a signal caller frame */ 7 80 2 old_signaller bit(1) unal, /* on if next frame is signaller's */ 7 81 2 xx3a bit(9) unaligned, 7 82 2 xx4(9) bit(72) aligned, 7 83 2 v2_pl1_op_ret_base ptr, /* When a V2 PL/I program calls an operator the 7 84* * operator puts a pointer to the base of 7 85* * the calling procedure here. (text base ptr) */ 7 86 2 xx5 bit(72) aligned, 7 87 2 pl1_ps_ptr ptr; /* ptr to ps for this frame; also used by fio. */ 7 88 7 89 /* format: on */ 7 90 7 91 /* END INCLUDE FILE ... stack_frame.incl.pl1 */ 903 8 1 /* include file for info structure used with record_status control order 8 2* created by M. Asherman 1/6/76 */ 8 3 /* modified 6/15/77 to support stationary type records */ 8 4 8 5 dcl rs_info_ptr ptr; 8 6 dcl 1 rs_info based (rs_info_ptr) aligned, 8 7 2 version fixed, /* must be set to 1 or 2 (Input) */ 8 8 2 flags aligned, 8 9 3 lock_sw bit (1) unal, /* Input -- if ="1"b try to lock record */ 8 10 3 unlock_sw bit (1) unal, /* Input -- if ="1"b try to unlock record */ 8 11 3 create_sw bit (1) unal, /* Input--if set creat new record */ 8 12 3 locate_sw bit (1) unal, /* Input--if set causes current rec to be 8 13* located outside the index by descrip, or created without key */ 8 14 3 inc_ref_count bit (1) unal, /* Input--bump reference count of record, if stationary */ 8 15 3 dec_ref_count bit (1) unal, /* Input--decrement ref count if this flag set and record stationary */ 8 16 3 locate_pos_sw bit (1) unal, /* Input--if set the record_length is taken 8 17* as an input argument specifying the absolute logical record positioni to which both the current and next positions will be set */ 8 18 3 mbz1 bit (29) unal, /* must be set to "0"b, reserved for future use */ 8 19 2 record_length fixed (21), /* length in bytes, Input if create_sw set */ 8 20 2 max_rec_len fixed (21), /* max length of contained record 8 21* Input if create_sw is set--overrides min_block_size in effect */ 8 22 2 record_ptr ptr, /* points to first byte of record--will be word aligned */ 8 23 2 descriptor fixed (35), /* Input if locate_sw set and create_sw="0"b */ 8 24 2 ref_count fixed (34), /* Output--should match number of keys on this record-- = -1 if non-stationary record */ 8 25 2 time_last_modified fixed (71), /* Output */ 8 26 2 modifier fixed (35), /* Output--also Input when locking */ 8 27 2 block_ptr ptr unal, /* Output */ 8 28 2 last_image_modifier 8 29 fixed (35), 8 30 2 mbz2 fixed; 8 31 8 32 dcl 1 rs_desc based (addr (rs_info.descriptor)), 8 33 /* record block descriptor structure */ 8 34 2 comp_num fixed (17) unal, /* msf component number */ 8 35 2 offset bit (18) unal; /* word offset of record block */ 8 36 8 37 dcl 1 seq_desc based (addr (rs_info.descriptor)), 8 38 /* for sequential files */ 8 39 2 bitno bit (6) unal, 8 40 2 comp_num fixed (11) unal, /* msf component number */ 8 41 2 wordno bit (18) unal; /* word offset */ 8 42 8 43 dcl rs_info_version_1 static internal fixed init (1); 8 44 dcl rs_info_version_2 static internal fixed init (2); 8 45 904 9 1 /* BEGIN INCLUDE FILE ..... iocb.incl.pl1 ..... 13 Feb 1975, M. Asherman */ 9 2 /* Modified 11/29/82 by S. Krupp to add new entries and to change 9 3* version number to IOX2. */ 9 4 /* format: style2 */ 9 5 9 6 dcl 1 iocb aligned based, /* I/O control block. */ 9 7 2 version character (4) aligned, /* IOX2 */ 9 8 2 name char (32), /* I/O name of this block. */ 9 9 2 actual_iocb_ptr ptr, /* IOCB ultimately SYNed to. */ 9 10 2 attach_descrip_ptr ptr, /* Ptr to printable attach description. */ 9 11 2 attach_data_ptr ptr, /* Ptr to attach data structure. */ 9 12 2 open_descrip_ptr ptr, /* Ptr to printable open description. */ 9 13 2 open_data_ptr ptr, /* Ptr to open data structure (old SDB). */ 9 14 2 reserved bit (72), /* Reserved for future use. */ 9 15 2 detach_iocb entry (ptr, fixed (35)),/* detach_iocb(p,s) */ 9 16 2 open entry (ptr, fixed, bit (1) aligned, fixed (35)), 9 17 /* open(p,mode,not_used,s) */ 9 18 2 close entry (ptr, fixed (35)),/* close(p,s) */ 9 19 2 get_line entry (ptr, ptr, fixed (21), fixed (21), fixed (35)), 9 20 /* get_line(p,bufptr,buflen,actlen,s) */ 9 21 2 get_chars entry (ptr, ptr, fixed (21), fixed (21), fixed (35)), 9 22 /* get_chars(p,bufptr,buflen,actlen,s) */ 9 23 2 put_chars entry (ptr, ptr, fixed (21), fixed (35)), 9 24 /* put_chars(p,bufptr,buflen,s) */ 9 25 2 modes entry (ptr, char (*), char (*), fixed (35)), 9 26 /* modes(p,newmode,oldmode,s) */ 9 27 2 position entry (ptr, fixed, fixed (21), fixed (35)), 9 28 /* position(p,u1,u2,s) */ 9 29 2 control entry (ptr, char (*), ptr, fixed (35)), 9 30 /* control(p,order,infptr,s) */ 9 31 2 read_record entry (ptr, ptr, fixed (21), fixed (21), fixed (35)), 9 32 /* read_record(p,bufptr,buflen,actlen,s) */ 9 33 2 write_record entry (ptr, ptr, fixed (21), fixed (35)), 9 34 /* write_record(p,bufptr,buflen,s) */ 9 35 2 rewrite_record entry (ptr, ptr, fixed (21), fixed (35)), 9 36 /* rewrite_record(p,bufptr,buflen,s) */ 9 37 2 delete_record entry (ptr, fixed (35)),/* delete_record(p,s) */ 9 38 2 seek_key entry (ptr, char (256) varying, fixed (21), fixed (35)), 9 39 /* seek_key(p,key,len,s) */ 9 40 2 read_key entry (ptr, char (256) varying, fixed (21), fixed (35)), 9 41 /* read_key(p,key,len,s) */ 9 42 2 read_length entry (ptr, fixed (21), fixed (35)), 9 43 /* read_length(p,len,s) */ 9 44 2 open_file entry (ptr, fixed bin, char (*), bit (1) aligned, fixed bin (35)), 9 45 /* open_file(p,mode,desc,not_used,s) */ 9 46 2 close_file entry (ptr, char (*), fixed bin (35)), 9 47 /* close_file(p,desc,s) */ 9 48 2 detach entry (ptr, char (*), fixed bin (35)); 9 49 /* detach(p,desc,s) */ 9 50 9 51 declare iox_$iocb_version_sentinel 9 52 character (4) aligned external static; 9 53 9 54 /* END INCLUDE FILE ..... iocb.incl.pl1 ..... */ 905 10 1 /* BEGIN format_tables.incl.pl1 */ 10 2 10 3 /****^ HISTORY COMMENTS: 10 4* 1) change(86-07-14,BWong), approve(86-07-14,MCR7382), audit(86-07-17,Ginter): 10 5* Fix fortran bug 122. 10 6* END HISTORY COMMENTS */ 10 7 10 8 /* format: style2 */ 10 9 /* 10 10* Modified: 10 11* 27 Nov 85, RW 122 - Changed fmt_len from fixed bin (11) to 10 12* fixed bin (12) unsigned. 10 13* 19 Oct 82, TO - Added 'd_format'. 10 14* 27-31 July 1981, MEP - Changed names of format_desc_bit fields, and added names of new formats. 10 15* 23 May 1978, DSL - Change precision of scalars to fixed bin(8). 10 16* Modified: March 1978, DSL - to implement new runtime format 10 17* modified: June 1976, by D Levin 10 18* 10 19* This include file defines the internal representation of format specifications for fortran. */ 10 20 10 21 10 22 /* number of array elements required to represent a format specification */ 10 23 10 24 /* format: off */ 10 25 dcl increment_table (0:29) fixed bin internal static options (constant) 10 26 init (3, 4, 4, 3, 4, 3, 4, 0, 0, 3, 3, 3, 2, 3, 2, 2, 1, 1, 1, 3, 1, 3, 0, 0, 0, 1, 1, 1, 1, 1); 10 27 /* i f e l d o g r a h x t p ( ) / : " E tr bz bn s sp ss */ 10 28 10 29 /* format: on */ 10 30 /* actual representation of a format statement */ 10 31 10 32 dcl 1 runtime_format based aligned structure, 10 33 2 header_word unaligned structure, 10 34 3 version bit (6), /* current version is fmt_parse_ver1 */ 10 35 3 last_left_paren fixed bin (11), /* position at which to repeat the spec */ 10 36 3 format_desc_bits structure, 10 37 4 anyitems bit (1), /* ON if format contains a field descriptor */ 10 38 4 list_directed bit (1), /* ON if format specifies list directed format */ 10 39 4 skip_line_numbers 10 40 bit (1), /* ON if format specifies skiping line numbers */ 10 41 4 contains_hollerith 10 42 bit (1), /* ON if format contains hollerith fields */ 10 43 4 suppress_newline 10 44 bit (1), /* ON if final new_line not wanted */ 10 45 4 pad bit (1), 10 46 3 fmt_len fixed bin (12) unsigned,/* length of format, in chars */ 10 47 2 fmt (1023) bit (36); /* encoded format specs */ 10 48 10 49 dcl 1 old_format aligned based structure, 10 50 2 header_word like runtime_format.header_word unaligned structure, 10 51 2 fmt (1022) fixed bin (17) unaligned; 10 52 10 53 dcl 1 format aligned based, 10 54 2 long_format bit (1) unaligned, 10 55 2 spec fixed bin (7) unaligned, 10 56 2 rep_factor fixed bin (8) unaligned, 10 57 2 width fixed bin (8) unaligned, 10 58 2 precision fixed bin (8) unaligned; 10 59 10 60 dcl 1 long_format aligned based, 10 61 2 long_format bit (1) unaligned, 10 62 2 spec fixed bin (7) unaligned, 10 63 2 exponent fixed bin (9) unsigned unaligned, 10 64 2 rep_factor fixed bin (17) unaligned, 10 65 2 width fixed bin (17) unaligned, 10 66 2 precision fixed bin (17) unaligned; 10 67 10 68 10 69 /* error message overlay */ 10 70 10 71 dcl 1 format_error aligned based structure, 10 72 2 input_length fixed bin, 10 73 2 error_message char (128); 10 74 10 75 10 76 /* named constants for format specifications */ 10 77 10 78 dcl ( 10 79 a_format init (10), 10 80 bn_format init (25), 10 81 bz_format init (26), 10 82 d_format init (4), 10 83 e_format init (2), 10 84 extended_i_format init (22), 10 85 g_format init (6), 10 86 i_format init (0), 10 87 s_format init (27), 10 88 sp_format init (28), 10 89 ss_format init (29), 10 90 t_format init (13), 10 91 tr_format init (21), 10 92 end_of_format init (20), 10 93 hollerith_field init (11), 10 94 quoted_string init (19) 10 95 ) fixed bin int static options (constant); 10 96 10 97 dcl fmt_parse_ver1 bit (6) aligned int static options (constant) init ("110000"b); 10 98 dcl max_value fixed bin (8) int static options (constant) init (255); 10 99 dcl chars_per_word fixed bin (8) int static options (constant) init (4); 10 100 dcl chars_per_halfword fixed bin (8) int static options (constant) init (2); 10 101 10 102 /* END format_tables.incl.pl1 */ 906 11 1 dcl 1 uns_info based (addr (info)), /* info structure for unstructured files */ 11 2 2 info_version fixed, /* (Input) must =1--only one version 11 3* currently supported */ 11 4 2 type fixed, /* =1 */ 11 5 2 end_pos fixed (34), /* length (bytes) not including header */ 11 6 2 flags aligned, 11 7 3 pad1 bit (2) unal, /* used for lock_status in other files */ 11 8 3 header_present bit (1) unal, /* on if file code is set */ 11 9 3 pad2 bit (33) unal, 11 10 2 header_id fixed (35); /* meaning is user defined */ 11 11 dcl 1 seq_info based (addr (info)), /* info structure for sequential files */ 11 12 2 info_version fixed, 11 13 2 type fixed, /* =2 */ 11 14 2 end_pos fixed (34), /* record count */ 11 15 2 flags aligned, 11 16 3 lock_status bit (2) unal, /* 0,1,2, or 3 to indicate not locked, 11 17* locked by (other,this,dead) process */ 11 18 3 pad bit (34) unal, 11 19 2 version fixed, /* end_pos valid only in latest version */ 11 20 2 action fixed; /* indicates if adjustment or rollback is needed */ 11 21 dcl 1 blk_info based (addr (info)), /* info structure for blocked files */ 11 22 2 info_version fixed, 11 23 2 type fixed, /* =3 */ 11 24 2 end_pos fixed (34), /* record count */ 11 25 2 flags aligned, 11 26 3 lock_status bit (2) unal, /* same as seq_info.= */ 11 27 3 pad bit (34) unal, 11 28 2 version fixed, /* only one currently supported */ 11 29 2 action fixed, /* non-zero if truncation in progress, else =0 */ 11 30 2 max_rec_len fixed (21), /* bytes--determines characteristiWc block size */ 11 31 2 pad fixed, /* not used at this time */ 11 32 2 time_last_modified fixed (71); /* time stamp for synchronization */ 11 33 dcl 1 indx_info based (addr (info)), /* info structure for indexed files */ 11 34 2 info_version fixed, 11 35 2 type fixed, /* =4 */ 11 36 2 records fixed (34), /* record count */ 11 37 2 flags aligned, 11 38 3 lock_status bit (2) unal, /* same as seq_info.= */ 11 39 3 pad bit (34) unal, 11 40 2 version_info aligned, 11 41 3 file_version fixed (17) unal, /* headers differ */ 11 42 3 program_version fixed (17) unal, /* may indicate bugs */ 11 43 2 action fixed, /* non-zero code indicates update in progress */ 11 44 2 non_null_recs fixed (34), /* count of allocated recs */ 11 45 2 record_bytes fixed (34), /* total record length */ 11 46 2 free_blocks fixed, /* available record blocks */ 11 47 2 index_height fixed, /* height of index tree (0 if empty) */ 11 48 2 nodes fixed, /* nodes being used in the index */ 11 49 2 key_bytes fixed (34), /* total length of keys */ 11 50 2 change_count fixed (35), /* bumped on each file modification */ 11 51 2 num_keys fixed (34), /* number of index entries */ 11 52 2 dup_keys fixed (34), /* 0 if all keys are distinct, else 1 for each dup */ 11 53 2 dup_key_bytes fixed (34), /* total bytes of duplicate keys */ 11 54 2 word (1) fixed; /* reserved for future use */ 11 55 dcl 1 vbl_info based (addr (info)), /* info structure for variable files */ 11 56 2 info_version fixed, 11 57 2 type fixed, /* =5 */ 11 58 2 end_pos fixed (34), /* logical end of file--not necessarily allocation count */ 11 59 2 flags aligned, 11 60 3 lock_status bit (2) unal, /* same as seq_info.= */ 11 61 3 pad bit (34) unal, 11 62 2 version fixed, /* only one currently supported */ 11 63 2 action fixed, /* same as in indexed files */ 11 64 2 first_nz fixed (34), /* position (numeric key) for first allocated record */ 11 65 2 last_nz fixed (34), /* last allocated record position */ 11 66 2 change_count fixed (35); /* used for synchronization */ 11 67 dcl vfs_version_1 static internal fixed init (1); 11 68 /* should be used in 11 69* assignments to info_version */ 907 12 1 /* Begin include file ..... iox_modes.incl.pl1 */ 12 2 12 3 /* Written by C. D. Tavares, 03/17/75 */ 12 4 /* Updated 10/31/77 by CDT to include short iox mode strings */ 12 5 12 6 dcl iox_modes (13) char (24) int static options (constant) aligned initial 12 7 ("stream_input", "stream_output", "stream_input_output", 12 8 "sequential_input", "sequential_output", "sequential_input_output", "sequential_update", 12 9 "keyed_sequential_input", "keyed_sequential_output", "keyed_sequential_update", 12 10 "direct_input", "direct_output", "direct_update"); 12 11 12 12 dcl short_iox_modes (13) char (4) int static options (constant) aligned initial 12 13 ("si", "so", "sio", "sqi", "sqo", "sqio", "squ", "ksqi", "ksqo", "ksqu", "di", "do", "du"); 12 14 12 15 dcl (Stream_input initial (1), 12 16 Stream_output initial (2), 12 17 Stream_input_output initial (3), 12 18 Sequential_input initial (4), 12 19 Sequential_output initial (5), 12 20 Sequential_input_output initial (6), 12 21 Sequential_update initial (7), 12 22 Keyed_sequential_input initial (8), 12 23 Keyed_sequential_output initial (9), 12 24 Keyed_sequential_update initial (10), 12 25 Direct_input initial (11), 12 26 Direct_output initial (12), 12 27 Direct_update initial (13)) fixed bin int static options (constant); 12 28 12 29 /* End include file ..... iox_modes.incl.pl1 */ 908 909 910 /* IMPLEMENTS THE STATIC STACK FRAME TRANSFER VECTOR */ 911 912 label_for_entry (0): 913 goto label_for_entry (entry_point); 914 915 916 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 917 /* ENTRY TO INITIATE READ OR WRITE */ 918 919 read_or_write: 920 entry (psp); 921 922 PS_ptr = psp; 923 924 call make_static_frame; 925 926 /* The following enables all handlers used during fortran I/O. */ 927 928 overflow_label = no_handler; 929 zero_label = no_handler; 930 on fixedoverflow, overflow, underflow, size goto overflow_label; 931 on zerodivide goto zero_label; 932 933 label_for_entry (12): /* read_or_write */ 934 /* Prepare for I/O operation. If the operation is not a string operation 935* then call initialize_fortran_io to validate the request and initialize the buffer. 936* For string I/O requests (encode and decode)and ansi77 internal files set up the various buffer pointers to look right. 937* For internal files, calculate the number of records of the internal file. 938* if PS.buffer_length = 0, then it is not an array and there is 1 record 939* else PS.buffer_length gives the number of words for the array (ansi66) 940* or the number of characters for the array (ansi77). See the comment in 941* set_size_and_count for a more graphic explanation. 942**/ 943 call_sw = -1; /* first call */ 944 if fio_ps.mode = string_io | fio_ps.mode = internal_file 945 then do; 946 buffer_max_len = PS.max_buffer; 947 buffer_pointer = PS.buffer_p; 948 if fio_ps.ansi_77 949 then char_offset = buffer_max_len; 950 else char_offset = divide (buffer_max_len + CPW - 1, CPW, 17, 0) * CPW; 951 952 if fio_ps.read 953 then buffer_length = buffer_max_len; 954 else buffer_length = 0; 955 if fio_ps.mode = internal_file 956 then do; 957 if ^fio_ps.read & ^fio_ps.list/* clear record */ 958 then buffer = ""; 959 960 if PS.buffer_size = 0 /* internal_file isn't an array */ 961 then internal_file_count = 1; 962 else if fio_ps.ansi_77 963 then internal_file_count = divide (PS.buffer_size, buffer_max_len, 17, 0); 964 else internal_file_count = divide (PS.buffer_size * CPW, char_offset, 17, 0); 965 end /* internal_file */; 966 end /* string_io and internal_file */; 967 968 if fio_ps.read /* Determine the I/O operation to be performed. */ 969 then current = read_opr; 970 else current = write_opr; 971 972 call initialize_fortran_io; 973 have_runtime_format = "0"b; 974 suppress_final_newline = "0"b; 975 go to initiate_routine (fixed (fio_ps.format, 2)); 976 977 initiate_routine (0): /* Free format I/O(list-directed) */ 978 overflow_label = conversion_error_handler; 979 zero_label = no_handler; 980 981 if fio_ps.read & fio_ps.format = list_directed 982 then buffer_index = 0; 983 984 fio_ps.format = list_directed; 985 986 /* the parse prevents list_directed I/O on internal files */ 987 988 if ^fio_ps.read & fio_ps.mode ^= string_io 989 then if (file_desc.printer_file & file_desc.carriage_controllable) | fio_ps.ansi_77 990 then do; 991 if buffer_length = buffer_max_len 992 then call too_much_output; 993 substr (rest_of_output, 1, 1) = SP;/* append NL to existing contents */ 994 buffer_length = buffer_length + 1; 995 end; 996 if fio_ps.read 997 then call initialize_list_input (); 998 else data_type_of_prev_item = character_type; /* Suppress separator before 1st item. */ 999 go to initiate_common; 1000 1001 initiate_routine (1): /* Unformatted I/O. */ 1002 buffer_index = 0; /* number of words read from buffer so far */ 1003 go to initiate_common; 1004 1005 initiate_routine (2): /* Formatted I/O. */ 1006 call initialize_formatted_io; 1007 1008 initiate_common: 1009 if ^fio_ps.list 1010 then goto terminate_no_list; 1011 call return_to_user$special_return; 1012 1013 initiate_routine (3): /* Namelist */ 1014 overflow_label = conversion_error_handler; 1015 zero_label = no_handler; 1016 1017 call namelist_io; 1018 goto terminate_no_list; 1019 1020 1021 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1022 /* ERROR - ATTEMPT TO ENTER fortran_io_ VIA STANDARD CALL. */ 1023 1024 element: 1025 terminate: 1026 entry (psp); 1027 1028 PS_ptr = psp; 1029 fio_ps.file_number = PS.file_number; 1030 string (fio_ps.job_bits) = string (PS.job_bits); 1031 fio_ps.error_label, fio_ps.iostat_var, fio_ps.have_input = "0"b; 1032 fortran_buffer_ptr = fast_related_data_$fortran_buffer_p; 1033 1034 call print_error (fortran_io_error_$fio_sys_error, me, "Wrong version of pl1_operators_."); 1035 1036 1037 1038 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1039 /* ELEMENT CALL - TRANSMIT ONE SCALAR OR ONE ARRAY */ 1040 1041 label_for_entry (15): 1042 call_sw = 0; /* all others */ 1043 go to element_routine (fixed (fio_ps.format, 2)); 1044 1045 element_routine (0): 1046 if ^fio_ps.end_of_input /* user can signal end of input; rest of list not set */ 1047 then call list_io; 1048 1049 element_list_abort: 1050 call return_to_user$special_return; 1051 1052 element_routine (1): 1053 call unformatted_io; 1054 call return_to_user$special_return; 1055 1056 element_routine (2): 1057 call formatted_io; 1058 1059 call return_to_user$special_return; 1060 1061 1062 1063 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1064 /* TERMINATE CALL - FINISH UP I/O REQUEST */ 1065 1066 label_for_entry (14): 1067 terminate_no_list: 1068 call_sw = 1; /* last call */ 1069 if ^fio_ps.read 1070 then call write_a_record; 1071 return_error_code: 1072 call return_to_user$special_return; 1073 1074 1075 1076 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1077 /* FILE CONTROL CALL - PERFORM FILE CONTROL */ 1078 1079 file_control: 1080 entry (psp); 1081 1082 PS_ptr = psp; 1083 1084 call make_static_frame; 1085 1086 /* The following enables all handlers used during fortran I/O. */ 1087 1088 overflow_label = no_handler; 1089 zero_label = no_handler; 1090 on fixedoverflow, overflow, underflow, size goto overflow_label; 1091 on zerodivide goto zero_label; 1092 1093 label_for_entry (13): 1094 call_sw = 0; /* all others */ 1095 current = binary (fio_ps.control_type, 4, 0); /* determine the io operation */ 1096 call initialize_fortran_io; 1097 1098 call return_to_user$special_return; 1099 1100 1101 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1102 /* GET AREA PTR CALL - RETURN PTR TO WORK AREA */ 1103 1104 get_io_area_ptr: 1105 entry (psp); /* Returns a pointer to a work area for open and close statements. */ 1106 1107 PS_ptr = psp; 1108 1109 call make_static_frame; 1110 1111 /* The following enables all handlers used during fortran I/O. */ 1112 1113 overflow_label = no_handler; 1114 zero_label = no_handler; 1115 on fixedoverflow, overflow, underflow, size goto overflow_label; 1116 on zerodivide goto zero_label; 1117 1118 label_for_entry (22): 1119 call_sw = 0; /* all others */ 1120 PS.buffer_p = addr (fortran_buffer_.buf); 1121 fortran_open_data.char_str = ""; 1122 call return_to_user$special_return; 1123 1124 /* ENTRY POINTS TO IMPLEMENT I/O RELATED FEATURES */ 1125 1126 stop: 1127 entry; 1128 1129 /* Implements file system part of FORTRAN stop statement. As this is called with fortran_stop_ on the stack, 1130* we CANNOT rely on any automatic variables in fortran_io_ having thier values saved, as we can in other entries. 1131**/ 1132 1133 if fast_related_data_$in_fast_or_dfast 1134 then call close_all_files ("1"b); /* dont ask, just close them */ 1135 else call close_for_stop; 1136 1137 return; 1138 1139 1140 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1141 1142 finish_handler: 1143 entry; /* This entry point is the finish handler for FORTRAN I/O. */ 1144 1145 call close_all_files ("0"b); 1146 call release_buffer_ptr; 1147 return; 1148 1149 1150 1151 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1152 /* Entry to implement the close_file command. */ 1153 1154 close_file: 1155 entry (close_unit, close_code); 1156 dcl close_unit fixed bin, 1157 close_code fixed bin (35); 1158 1159 call get_buffer_ptr (return_if_not_found, exists);/* do not force creation of buffer segment */ 1160 1161 if ^exists /* no buffer segment, therefore nothing is open */ 1162 then do; 1163 close_code = 0; 1164 return; 1165 end; 1166 1167 1168 if close_unit < 0 1169 then do; /* Request to close all files. */ 1170 call close_all_files ("0"b); 1171 close_code = 0; 1172 return; 1173 end; 1174 1175 if close_unit >= 1 & close_unit <= 99 1176 then do; /* request to close particular file. */ 1177 fio_ps.file_number = close_unit; 1178 fcb_ptr = addr (fortran_buffer_.table (fio_ps.file_number)); 1179 iocb_ptr = file_desc.switch_p; 1180 1181 call close_fortran_file; 1182 1183 close_code = 0; 1184 return; 1185 end; 1186 1187 else if close_unit = 0 1188 then do; 1189 close_code = fortran_io_error_$invalid_for_file0; 1190 return; 1191 end; 1192 1193 close_code = error_table_$no_file; 1194 1195 return; 1196 1197 1198 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1199 /* Entry to implement the set_cc command. */ 1200 1201 set_cc: 1202 entry (cc_unit, status_bit, error_code); 1203 dcl cc_unit fixed bin, 1204 status_bit bit (1) aligned, 1205 error_code fixed bin (35); 1206 1207 call get_buffer_ptr (create_if_not_found, exists);/* output value ignored */ 1208 1209 if cc_unit < 0 | cc_unit > 99 1210 then error_code = error_table_$no_file; 1211 else do; 1212 fortran_buffer_.table (cc_unit).printer_file = status_bit; 1213 error_code = 0; 1214 1215 end; 1216 return; 1217 1218 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1219 /* New entry to allow the set_cc command to set defer on. */ 1220 1221 set_cc_defer: 1222 entry (file_unit, cc_bit, defer_bit, defer_specified, err_code); 1223 dcl file_unit fixed bin, 1224 cc_bit bit (1) aligned, 1225 defer_bit bit (1) aligned, 1226 defer_specified bit (1) aligned, 1227 err_code fixed bin (35); 1228 1229 call get_buffer_ptr (create_if_not_found, exists);/* output value ignored */ 1230 1231 if file_unit < 0 | file_unit > 99 1232 then error_code = error_table_$no_file; 1233 else do; 1234 fortran_buffer_.table (file_unit).printer_file = cc_bit; 1235 if defer_specified 1236 then fortran_buffer_.table (file_unit).defer_newline = defer_bit; 1237 error_code = 0; 1238 1239 end; 1240 return; 1241 1242 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1243 /* Entry to print the version of the compiler at the last modification to 'fortran_io_'. */ 1244 1245 version: 1246 entry; 1247 dcl fort_version_info$greeting 1248 char (16) aligned ext static; 1249 dcl fort_version_info$version_number 1250 char (16) aligned ext static; 1251 dcl ioa_ entry options (variable); 1252 1253 call ioa_ (rtrim (fort_version_info$greeting) || substr (fort_version_info$version_number, 10)); 1254 return; 1255 1256 1257 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1258 1259 conversion_error_handler: 1260 buffer_index = begin_index; /* Point to beginning of constant for error. */ 1261 call print_error (fortran_io_error_$conversion_error); 1262 1263 no_handler: 1264 call print_error (fortran_io_error_$fio_sys_error, me, "Condition for which there is no handler."); 1265 1266 get_buffer_ptr: 1267 proc (a_create_sw, seg_exists); 1268 1269 dcl a_create_sw bit (1) aligned; /* "1"b create if not found; "0"b do not create if not found */ 1270 dcl seg_exists bit (1) aligned; /* "1"b buffer seg already exists; "0"b does not exist */ 1271 1272 dcl create_sw bit (1) aligned; 1273 dcl get_segment bit (1) aligned; 1274 dcl get_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); 1275 dcl release_temp_segments_ entry (char (*), (*) ptr, fixed bin (35)); 1276 dcl size builtin; 1277 1278 1279 create_sw = a_create_sw; 1280 seg_exists = fast_related_data_$fortran_io_initiated; 1281 1282 /* If buffer seg is already initiated, just set up the global pointers. */ 1283 1284 if fast_related_data_$fortran_io_initiated 1285 then do; 1286 fortran_buffer_ptr = fast_related_data_$fortran_buffer_p; 1287 1288 /* If rel(fortran_buffer_ptr) < area_size we must increase its value in order to 1289* prevent an invalid value for buffer_seg_pointer. This code is only needed as 1290* long as old style fortran_io_'s exist in the system. */ 1291 1292 if fixed (rel (fortran_buffer_ptr), 18) < area_size 1293 then do; 1294 unspec (addrel (fortran_buffer_ptr, area_size) -> fortran_buffer_) = 1295 unspec (fortran_buffer_ptr -> fortran_buffer_); 1296 1297 fortran_buffer_ptr = addrel (fortran_buffer_ptr, area_size); 1298 fast_related_data_$fortran_buffer_p = fortran_buffer_ptr; 1299 /* so we only do it once a process */ 1300 1301 fortran_buffer_.maximum_buffer = 1302 (sys_info$max_seg_size - (binary (rel (addr (fortran_buffer_.buf)), 18) - 1)) * CPW; 1303 end; 1304 1305 buffer_seg_pointer = addrel (fortran_buffer_ptr, -area_size); 1306 return; 1307 end; 1308 1309 else if ^create_sw 1310 then return; /* not there yet, return if we shouldn't create it */ 1311 1312 /* Segment is not initiated. (Create and) Inititate it. */ 1313 1314 fortran_buffer_ptr = fast_related_data_$fortran_buffer_p; 1315 /* Get buffer pointer */ 1316 1317 /* First see if we must allocate our own segment. */ 1318 1319 if fortran_buffer_ptr ^= null 1320 then do; 1321 get_segment = "0"b; /* Segment, or part thereof, already allocated */ 1322 1323 buffer_seg_pointer = fortran_buffer_ptr; 1324 fortran_buffer_ptr, fast_related_data_$fortran_buffer_p = addrel (buffer_seg_pointer, area_size); 1325 end; 1326 1327 else do; 1328 1329 if ^create_sw /* not there yet, return if we shouldn't create it */ 1330 then do; 1331 seg_exists = "0"b; 1332 return; 1333 end; 1334 1335 get_segment = "1"b; /* Must free it when we are done */ 1336 1337 call get_temp_segments_ (me, ptr_array, (0)); 1338 /* will never be non-zero */ 1339 1340 buffer_seg_pointer = ptr_array (1); 1341 1342 fortran_buffer_ptr, fast_related_data_$fortran_buffer_p = ptr (buffer_seg_pointer, area_size); 1343 1344 /* also must establish a finish handler. */ 1345 1346 call default_error_handler_$add_finish_handler (finish_handler, my_code); 1347 if my_code ^= 0 1348 then call print_error (my_code, me, "Cannot establish finish handler for FORTRAN I/O."); 1349 end; 1350 1351 /* Now initialize. First assignment to buffer segment is to prevent hardware bug from screwing 1352* actual assignment. If hardware bug occurs, first assignment will fail. */ 1353 1354 fortran_buffer_ptr -> words (1) = 0; /* Insures that initialization is not the first */ 1355 /* reference to the segment. */ 1356 unspec (fortran_buffer_) = unspec (addr (fortran_buffer_$) -> fortran_buffer_); 1357 1358 fortran_buffer_.maximum_buffer = 1359 (sys_info$max_seg_size - (binary (rel (addr (fortran_buffer_.buf)), 18) - 1)) * CPW; 1360 1361 if get_segment 1362 then fortran_buffer_.allocated_by_fortran = "1"b; 1363 1364 if fast_related_data_$in_dfast /* insure file table entry is right for file 0 */ 1365 then do; 1366 fortran_buffer_.table (0).prompt = "1"b; 1367 fortran_buffer_.table (0).defer_newline = "0"b; 1368 fortran_buffer_.table (0).printer_file = "0"b; 1369 end; 1370 1371 fast_related_data_$fortran_io_initiated = "1"b; 1372 return; 1373 1374 1375 release_buffer_ptr: 1376 entry (); /* Releases buffer seg and resets all external fields. */ 1377 1378 if ^fast_related_data_$fortran_io_initiated /* i.e., never referenced */ 1379 then return; 1380 1381 ptr_array (1) = fast_related_data_$fortran_buffer_p; 1382 /* Get buffer pointer. */ 1383 1384 if ptr_array (1) -> fortran_buffer_.allocated_by_fortran 1385 /* Release seg only if we allocated it. */ 1386 then do; 1387 ptr_array (1) = ptr (ptr_array (1), 0); 1388 call release_temp_segments_ (me, ptr_array, my_code); 1389 fast_related_data_$fortran_buffer_p = null; 1390 /* Prevent use of invalid seg no. */ 1391 end; 1392 else fast_related_data_$fortran_buffer_p = addrel (ptr_array (1), -area_size); 1393 1394 fast_related_data_$fortran_io_initiated = "0"b; /* Segment must be initiated before next use. */ 1395 end get_buffer_ptr; 1396 1397 1398 1399 make_static_frame: 1400 proc; 1401 1402 /* This procedure is responsible for setting up the "static" frame and setting all fields in the 1403* user's stack frame and fortran_io_'s stack frame that are constant. */ 1404 1405 sp = cu_$stack_frame_ptr (); /* Pointer to our stack frame. */ 1406 user_sp = sp -> stack_frame.prev_sp; /* Pointer to user's stack frame. */ 1407 1408 /* Set fields in fio_ps. */ 1409 1410 fio_ps.file_number = PS.file_number; /* Copy values from user ps to ours. */ 1411 string (fio_ps.job_bits) = string (PS.job_bits); 1412 fio_ps.element_p = null; 1413 1414 /* Store a pointer to the label array goto used to enter this procedure and at the 1415* same time store a pointer to our stack frame. */ 1416 1417 entry_point = 0; /* To initialize and insure correct address in next stmnt. */ 1418 /* By using a variable index, the optimizer treats all members */ 1419 /* of the label array as having been referenced here. */ 1420 fio_ps.label_for_transfer = label_for_entry (entry_point); 1421 1422 fio_ps.address_of_index = addr (entry_point); /* So code in pl1_operators_ can find it. */ 1423 1424 /* Update user's stack frame. */ 1425 1426 user_sp -> sp_up_4 = sp -> sp_up_4; /* So user stack extension works around us. */ 1427 1428 user_sp -> stack_frame.support_ptr = addr (fio_ps); 1429 /* store in stack frame at reserved location. */ 1430 substr (addr (user_sp -> stack_frame_flags.pl1_ps_ptr) -> based_bits, 1, 1) = "1"b; 1431 /* tell ops we're initialized. */ 1432 1433 /* Initialize constant parts of our stack frame. */ 1434 1435 column_one = 0; 1436 1437 /* Set up the buffer segment. */ 1438 1439 call get_buffer_ptr (create_if_not_found, exists);/* output value ignored */ 1440 1441 ps_at_error = null; 1442 actual_error = 0; 1443 1444 /* set the "interactive" bit */ 1445 1446 call user_info_$process_type (process_type); 1447 if process_type = 1 1448 then interactive = "1"b; 1449 else interactive = "0"b; 1450 1451 end make_static_frame; 1452 1453 1454 initialize_fortran_io: 1455 procedure; 1456 1457 1458 /* the following table controls the operation performed in response to any given FORTRAN I/O 1459* statement. It embodies the logic to maintain the file table entry for each file reference number. */ 1460 1461 /* format: off */ 1462 dcl control_matrix(0:14, 0:14) fixed bin int static options(constant) /* bounds depend on the domain of io_op */ 1463 initial ( 1464 1465 /* Current P R E V I O U S O P E R A T I O N */ 1466 1467 /* Z w o r r u c c b i o o m u e */ 1468 /* E r l e e n l l a n p p a n n */ 1469 /* R i d a w u o o c q e e r u d */ 1470 /* O t d i s s s k u n n g s f */ 1471 /* e e n e e e s i f i e i */ 1472 /* n d d f p r i n d l */ 1473 /* d _ i a e l _ e */ 1474 /* f 5 l c e 1 */ 1475 /* e e 3 */ 1476 1477 /* ZERO */ 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 1478 1479 /* write */ 4, 3, 19, 3, 3, 19, 19, 19, 3, 19, 3, 3, 19, 19, 3, 1480 1481 /* old endf */ 6, 6, 19, 6, 6, 19, 19, 19, 6, 19, 6, 6, 19, 19, 6, 1482 1483 /* read */ 2, 5, 19, 1, 1, 19, 19, 19, 1, 19, 1, 1, 19, 19, 1, 1484 1485 /* rewind */ 9, 9, 19, 9, 0, 19, 19, 19, 9, 19, 0, 9, 19, 19, 9, 1486 1487 /* unused_5 */ 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 1488 1489 /* closefile */ 10, 10, 19, 10, 10, 19, 19, 19, 10, 19, 10, 10, 19, 19, 10, 1490 1491 /* close */ 11, 11, 19, 11, 11, 19, 19, 19, 11, 19, 11, 11, 19, 19, 11, 1492 1493 /* backspace */ 8, 8, 19, 8, 0, 19, 19, 19, 8, 19, 0, 8, 19, 19, 8, 1494 1495 /* inquire */ 12, 12, 12, 12, 12, 19, 12, 12, 12, 12, 12, 12, 12, 19, 12, 1496 1497 /* openfile */ 15, 15, 19, 15, 15, 19, 19, 19, 15, 19, 15, 15, 19, 19, 15, 1498 1499 /* open */ 16, 16, 19, 16, 16, 19, 19, 19, 16, 19, 16, 16, 19, 19, 16, 1500 1501 /* margin */ 17, 17, 19, 17, 17, 19, 19, 19, 17, 19, 17, 17, 19, 19, 17, 1502 1503 /* unused_13 */ 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 19, 1504 1505 /* endfile */ 7, 7, 19, 7, 7, 19, 19, 19, 7, 19, 7, 7, 19, 19, 7); 1506 1507 /* format: on */ 1508 1509 /* If this is not an inquire statement, get the unit reference number. */ 1510 1511 if current ^= inquire_opr /* we may not know the unit number */ 1512 then do; 1513 if fio_ps.file_number >= 1 & fio_ps.file_number <= 99 1514 then do; 1515 fcb_ptr = addr (fortran_buffer_.table (fio_ps.file_number)); 1516 iocb_ptr = file_desc.switch_p; 1517 1518 if ^file_desc.connected /* in dfast, the file must be opened before it is used */ 1519 then if fast_related_data_$in_dfast 1520 then if current ^= open_opr & current ^= openfile_opr 1521 then do; 1522 k = file_desc.open_code; 1523 /* get the code that tells why the open failed */ 1524 file_desc.open_code = 0; 1525 /* next time just say it is closed */ 1526 1527 if k = 0 1528 then call print_error (fortran_io_error_$not_open); 1529 else call print_error (binary (unspec (file_desc.switch_p), 35), me, 1530 "Openfile failed."); 1531 1532 end; 1533 end /* 1 <= file >= 99 */; 1534 1535 else if fio_ps.file_number = 0 /* terminal I/O, encode/decode or internal-file */ 1536 then do; 1537 fcb_ptr = addr (fortran_buffer_.table (0)); 1538 file_desc.blank_null = fio_ps.ansi_77; 1539 1540 if fio_ps.mode = string_io | fio_ps.mode = internal_file 1541 then return; 1542 1543 file_desc.previous = open_opr;/* operations are never dependent on previous operation */ 1544 if current = read_opr 1545 then do; 1546 iocb_ptr, file_desc.switch_p = iox_$user_input; 1547 1548 /* If user_input and user_output reference the same target, a read effectively 1549* outputs a newline character. Remember this fact. */ 1550 1551 if iox_$user_input -> iocb.actual_iocb_ptr 1552 = iox_$user_output -> iocb.actual_iocb_ptr 1553 then fortran_buffer_.terminal_needs_newline = "0"b; 1554 end; 1555 1556 else if current = write_opr 1557 then iocb_ptr, file_desc.switch_p = iox_$user_output; 1558 1559 else if current ^= openfile_opr & current ^= open_opr 1560 then call print_error (fortran_io_error_$invalid_for_file0); 1561 end /* file = 0 */; 1562 1563 else call print_error (error_table_$no_file); 1564 end /* not inquire */; 1565 1566 /* file table entry is ready;perform appropriate actions */ 1567 1568 if fio_ps.iostat_var 1569 then PS.iostat_p -> words (1) = 0; /* value if operation is successful */ 1570 1571 /* for inquire operation, we may not know yet which file, and previous doesn't matter anyway */ 1572 1573 if current = inquire_opr 1574 then goto action (12); 1575 else goto action (control_matrix (current, file_desc.previous)); 1576 1577 /* The logic required to execute any user request is presented here. If the operation is a file positioning 1578* request, the code below should completely perform the request. For input and output transfers of data, 1579* various housekeeping steps are taken, and in the case of a user request for input, the first record is read. */ 1580 1581 action (0): /* Rewind or backspace after rewind. */ 1582 /* Endfile on non-connected file */ 1583 return; /* The last operation was more final. Forget I ever called. */ 1584 1585 action (2): /* Read, the first time the file is referenced. */ 1586 dcl unwritten_eofs fixed bin (3) unsigned; 1587 1588 unwritten_eofs = file_desc.unwritten_eofs; 1589 call implicit_open; /* Open the file. */ 1590 file_desc.unwritten_eofs = unwritten_eofs; /* Implicit opening clears this field. */ 1591 1592 action (1): /* Read a record from the designated file. */ 1593 buffer_pointer = addr (fortran_buffer_.buf); 1594 buffer_max_len = fortran_buffer_.maximum_buffer; 1595 1596 call validate_mode_and_access; 1597 1598 file_desc.previous = current; 1599 1600 /* If this is the first call for a direct access read on a binary stream file, 1601* do nothing. The records will be read by the element transfer calls. */ 1602 1603 if file_desc.type_of_io = binary_file & call_sw < 0 & fio_ps.list 1604 then return; 1605 1606 /* A goto is used here instead of a call so that referencing read_a_record is not needed. 1607* Of course, I could have made read_a_record a separate procedure... */ 1608 1609 goto read_a_record_label; 1610 1611 action (4): /* Write, the first time the file is referenced. */ 1612 unwritten_eofs = file_desc.unwritten_eofs; 1613 call implicit_open; /* Open the file. */ 1614 file_desc.unwritten_eofs = unwritten_eofs; /* Implicit opening clears this field. */ 1615 1616 action (3): /* An output transfer. Prepare the buffer for output. */ 1617 call validate_mode_and_access; 1618 1619 buffer_pointer = addr (fortran_buffer_.buf); 1620 buffer_max_len = fortran_buffer_.maximum_buffer; 1621 1622 /* If this is a deferred newline file without carriage control, output the first newline now. 1623* Moving the code here removes it from "write_a_record" which is an inner loop of fortran_io_. */ 1624 1625 if file_desc.newline_needed & ^(file_desc.printer_file & file_desc.carriage_controllable) 1626 then do; 1627 column_one, buffer_length = 1; 1628 substr (io_buf, 1, 1) = NL; 1629 end; 1630 else buffer_length = 0; 1631 1632 goto store_op_and_return; 1633 1634 action (5): /* Read after write. */ 1635 call finish_line; /* Make sure the last line is completely written. */ 1636 if my_code ^= 0 1637 then call print_error (my_code); 1638 go to action (1); 1639 1640 action (19): /* impossible (current, previous) combination */ 1641 call print_error (fortran_io_error_$fio_sys_error, me, "File table entry is wrong."); 1642 1643 action (10): /* closefile */ 1644 if ^fast_related_data_$in_dfast 1645 then goto not_supported; 1646 1647 action (6): /* Close the file. (closefile, old endfile) */ 1648 call close_fortran_file; 1649 return; 1650 1651 action (11): /* Close the file. (close) */ 1652 call close_statement; 1653 return; 1654 1655 action (12): /* INQUIRE */ 1656 call inquire_statement; 1657 return; /* does no action, dont set op */ 1658 1659 action (8): /* BACKSPACE. */ 1660 if file_desc.unwritten_eofs > 0 1661 then file_desc.unwritten_eofs = file_desc.unwritten_eofs - 1; 1662 else if file_desc.switch_ready 1663 then do; 1664 if file_desc.connected 1665 then do; 1666 if ^file_desc.allow.positioning | iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io 1667 then call print_error (fortran_io_error_$cannot_position); 1668 1669 call finish_line; 1670 if my_code ^= 0 1671 then call print_error (my_code); 1672 end; 1673 call iox_$position (iocb_ptr, 0, -1, my_code); 1674 if my_code = error_table_$end_of_info 1675 then my_code = 0; /* We were at BOI. */ 1676 else if my_code ^= 0 1677 then call iox_$control (iocb_ptr, "backspace_record", null, my_code); 1678 /* Try something else. */ 1679 if my_code ^= 0 1680 then call print_error (fortran_io_error_$cannot_position); 1681 end; 1682 1683 goto set_BOR_store_op_and_return; 1684 1685 action (9): /* REWIND */ 1686 file_desc.unwritten_eofs = 0; /* Forget about any unwritten EOF records. */ 1687 if file_desc.switch_ready 1688 then do; 1689 if file_desc.connected 1690 then do; 1691 if ^file_desc.allow.positioning | iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io 1692 then call print_error (fortran_io_error_$cannot_position); 1693 1694 call finish_line; 1695 if my_code ^= 0 1696 then call print_error (my_code); 1697 end; 1698 1699 call iox_$position (iocb_ptr, -1, 0, my_code); 1700 if my_code = error_table_$end_of_info 1701 then my_code = 0; /* File is empty. */ 1702 else if my_code ^= 0 1703 then do; /* probably failed because not 'vfile_' */ 1704 call iox_$control (iocb_ptr, "rewind", null, my_code); 1705 if my_code ^= 0 /* probably failed because not 'tape_nstd_' */ 1706 then if file_desc.fortran_opened 1707 then do; 1708 call iox_$close (iocb_ptr, my_code); 1709 if my_code ^= 0 1710 then call print_error (fortran_io_error_$cannot_position); 1711 1712 file_desc.switch_ready = FALSE; 1713 file_desc.newline_needed = "0"b; 1714 file_desc.previous = 0; 1715 /* forces reopen on next data transfer */ 1716 return; /* must not execute usual exit code */ 1717 end; 1718 end; 1719 1720 if my_code ^= 0 1721 then call print_error (fortran_io_error_$cannot_position); 1722 end; 1723 1724 set_BOR_store_op_and_return: /* current operation positions to Beginning Of a Record */ 1725 file_desc.newline_needed = "0"b; 1726 1727 store_op_and_return: /* All logic, except closing a file, terminates here. */ 1728 if file_desc.connected 1729 then file_desc.previous = current; /* The operation type is stored for further use. */ 1730 else file_desc.previous = 0; /* Force subsequent READ or WRITE to open first. */ 1731 return; 1732 1733 /* The implementation of ENDFILE is tricky for several reasons: */ 1734 /* */ 1735 /* (1) It can be applied to a file which is not connected, in which case we */ 1736 /* must perform an implicit association. We cannot perform an implicit */ 1737 /* connection via the 'implicit_open' routine, since we have no way to */ 1738 /* discover the form of the file. Moreover, we may not even be able to */ 1739 /* associate the file correctly, if the I/O module allows both stream */ 1740 /* and sequential openings. */ 1741 /* */ 1742 /* (2) The Standard says that ENDFILE must appear to produce a record as */ 1743 /* far as BACKSPACE is concerned. Thus we must keep a count of the */ 1744 /* "unwritten" EOF records for I/O modules that do not support EOF */ 1745 /* records (i.e. all standard I/O modules other than 'tape_nstd_'). */ 1746 /* */ 1747 /* (3) The Standard says that ENDFILE must alter the file so that only the */ 1748 /* records preceeding the ENDFILE are retained. This means that we */ 1749 /* must disallow ENDFILE if the I/O module does not support truncation, */ 1750 /* as is the case with 'tape_mult_' and 'tty_'. */ 1751 1752 action (7): /* ENDFILE */ 1753 dcl switch_for_endfile char (6) aligned, 1754 unit_for_endfile pic "99"; 1755 1756 if file_desc.unwritten_eofs > 0 1757 then if file_desc.unwritten_eofs < Max_unwritten_eofs 1758 then file_desc.unwritten_eofs = file_desc.unwritten_eofs + 1; 1759 else call print_error (fortran_io_error_$cannot_truncate, me, "More than ^i successive ENDFILEs.", 1760 Max_unwritten_eofs); 1761 else do; /* Try to write or simulate an EOF record. */ 1762 if file_desc.connected 1763 then do; /* Check that ENDFILE is allowed. */ 1764 if ^file_desc.allow.positioning 1765 then call print_error (fortran_io_error_$cannot_truncate); 1766 if file_desc.out 1767 then do; 1768 call finish_line; 1769 if my_code ^= 0 1770 then call print_error (my_code); 1771 end; 1772 else if file_desc.allow_reopen 1773 then call reopen_for_output; 1774 else call print_error (fortran_io_error_$cannot_truncate); 1775 end; 1776 else file_desc.out = TRUE; /* Ensure subsequent connection allows output. */ 1777 if ^file_desc.switch_ready 1778 then do; /* Implicitly associate the unit. */ 1779 unit_for_endfile = fio_ps.file_number; 1780 switch_for_endfile = "file" || unit_for_endfile; 1781 call iox_$find_iocb (switch_for_endfile, iocb_ptr, my_code); 1782 if my_code ^= 0 1783 then call print_error (my_code, me, "Cannot get iocb for ^a.", switch_for_endfile); 1784 if iocb_ptr -> iocb.attach_descrip_ptr = null 1785 then do; /* Attach unit to disk file of same name as switch. */ 1786 call iox_$attach_iocb (iocb_ptr, "vfile_ " || switch_for_endfile, my_code); 1787 if my_code ^= 0 1788 then call print_error (my_code, me, switch_for_endfile); 1789 file_desc.fortran_attached = TRUE; 1790 end; 1791 else if before (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, " ") = "tape_nstd_" 1792 then do; /* 'tape_nstd_' is special: it really has EOF records. */ 1793 file_desc.switch_ready = TRUE; 1794 /* Must maintain the association till connection. */ 1795 file_desc.eofs_are_records = TRUE; 1796 file_desc.switch_p = iocb_ptr; 1797 end; 1798 if iocb_ptr -> iocb.open_descrip_ptr = null 1799 then do; /* Open the unit for stream or sequential output. */ 1800 call iox_$open (iocb_ptr, 2, ""b, my_code); 1801 /* Try stream output. */ 1802 if my_code ^= 0 1803 then call iox_$open (iocb_ptr, 5, ""b, my_code); 1804 /* Try sequential output. */ 1805 if my_code ^= 0 1806 then call print_error (my_code, me, switch_for_endfile); 1807 file_desc.fortran_opened = TRUE; 1808 end; 1809 end; 1810 1811 call iox_$control (iocb_ptr, "write_eof", null, my_code); 1812 if my_code ^= 0 1813 then do; /* EOF records not supported -- try to simulate. */ 1814 if file_desc.previous ^= 1 1815 then do; /* Truncate if last op not WRITE. */ 1816 call iox_$control (iocb_ptr, "truncate", null, my_code); 1817 if my_code ^= 0 1818 then call print_error (fortran_io_error_$cannot_truncate); 1819 end; 1820 if fio_ps.ansi_77 1821 then file_desc.unwritten_eofs = 1; 1822 end; 1823 1824 if file_desc.fortran_opened & ^file_desc.switch_ready 1825 then do; /* Close the file in case we opened in wrong mode. */ 1826 call iox_$close (iocb_ptr, my_code); 1827 file_desc.fortran_opened = FALSE; 1828 end; 1829 end; 1830 goto set_BOR_store_op_and_return; 1831 1832 action (15): /* openfile */ 1833 if ^fast_related_data_$in_dfast 1834 then goto not_supported; 1835 call dfast_openfile; 1836 goto store_op_and_return; 1837 1838 action (16): /* open */ 1839 call open_statement; 1840 goto store_op_and_return; 1841 1842 action (17): /* margin */ 1843 if ^fast_related_data_$in_dfast 1844 then goto not_supported; 1845 1846 call set_max_recl (max_recl); 1847 return; /* use of margin is not recorded as previous operation */ 1848 1849 not_supported: 1850 call ioa_$ioa_switch (iox_$error_output, "Warning: ^a (on file ^d) is not supported in Multics or FAST. 1851 The statement is ignored.", operation_name (current), fio_ps.file_number); 1852 return; 1853 1854 1855 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 1856 1857 /* These two entries are called by the various I/O processing entries to perform additional data transfers as 1858* required. read_a_record is called only if the input transfer requires more than one record. 1859* write_a_record must be called each time a record is to be output. */ 1860 1861 1862 1863 read_a_record: 1864 entry; 1865 1866 if fio_ps.mode = string_io | fio_ps.mode = internal_file 1867 then do; 1868 buffer_pointer = add_char_offset_ (buffer_pointer, char_offset); 1869 if fio_ps.mode = internal_file 1870 then do; /* Check for EOF. */ 1871 internal_file_count = internal_file_count - 1; 1872 if internal_file_count <= 0 1873 then goto end_of_file; 1874 end; 1875 return; 1876 end; 1877 1878 read_a_record_label: 1879 buffer_length = buffer_max_len; /* get maximum buffer length */ 1880 fio_ps.have_input = "0"b; /* record is undefined till after the read */ 1881 1882 /* Position to record if required */ 1883 1884 if fio_ps.mode = direct_access 1885 then call get_record (exists); /* output value is ignored */ 1886 1887 /* Now, read */ 1888 1889 if file_desc.type_of_io = stream_file 1890 then do; 1891 1892 /* special processing for terminals */ 1893 1894 if iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io 1895 then do; 1896 if interactive 1897 then fortran_buffer_.terminal_needs_newline = "0"b; 1898 1899 /* output prompt_character if required */ 1900 1901 if file_desc.prompt 1902 then do; 1903 call iox_$put_chars (iox_$user_io, addr (prompt_char), 2, my_code); 1904 if my_code ^= 0 1905 then call print_error (my_code); 1906 end; 1907 end; 1908 1909 call iox_$get_line (iocb_ptr, buffer_pointer, buffer_length, sent, my_code); 1910 1911 /* remove newline from record if present */ 1912 1913 if my_code = 0 1914 then sent = sent - 1; 1915 1916 else if my_code = error_table_$short_record 1917 /* record does not end with newline */ 1918 then my_code = 0; 1919 1920 /* special end-of-file for formatted sequential stream files */ 1921 1922 if file_desc.carriage_controllable 1923 then do; 1924 if sent = length (EOF1) 1925 then if substr (io_buf, 1, length (EOF1)) = EOF1 1926 then goto end_of_file; 1927 else ; 1928 else if sent = length (EOF2) 1929 then if substr (io_buf, 1, length (EOF2)) = EOF2 1930 then goto end_of_file; 1931 else if substr (io_buf, 1, length (EOF3)) = EOF3 1932 then do; 1933 end_of_file: /* If user provided iostat var, set it; and if end= is not supplied then return. */ 1934 if fio_ps.ansi_77 1935 then if my_code = error_table_$end_of_info & ^file_desc.eofs_are_records 1936 then if file_desc.unwritten_eofs = 0 1937 then file_desc.unwritten_eofs = 1; 1938 /* Remember we hit EOI. */ 1939 else call print_error (fortran_io_error_$read_after_eof); 1940 if fio_ps.iostat_var 1941 then do; 1942 PS.iostat_p -> words (1) = -error_table_$end_of_info; 1943 /* Standard requires negative code for EOF. */ 1944 if ^fio_ps.end_label 1945 then goto return_error_code; 1946 end; 1947 1948 if fio_ps.end_label 1949 /* return to user if end= specified */ 1950 then call return_to_user (PS.end_p, PS.stack_frame_p); 1951 1952 /* Prevent err= transfer for EOF unless direct_access. */ 1953 1954 if fio_ps.mode ^= direct_access 1955 then fio_ps.error_label = "0"b; 1956 1957 fio_ps.have_input = "0"b; 1958 /* if EOF then nothing to print */ 1959 if fio_ps.mode = internal_file 1960 then call internal_file_overflow; 1961 else call print_error (error_table_$end_of_info); 1962 end; 1963 end; /* formatted end of file */ 1964 1965 file_desc.newline_needed = "0"b; /* in case write follows */ 1966 end; 1967 1968 else if file_desc.type_of_io = record_file | file_desc.type_of_io = blocked_file 1969 then do; 1970 call iox_$read_record (iocb_ptr, buffer_pointer, buffer_length, sent, my_code); 1971 end; 1972 1973 else if file_desc.type_of_io = binary_file 1974 then do; 1975 1976 /* If there is an I/O list, data is read directly from the device into each item on demand. 1977* If there is no list, one "record" (single word or double word) is read and discarded. */ 1978 1979 if ^fio_ps.list 1980 then do; 1981 fio_ps.element_p = buffer_pointer; 1982 /* need a place to put data; it will be discarded */ 1983 1984 if file_desc.double_word_file /* get default length */ 1985 then buffer_length = CPDW; 1986 else buffer_length = CPW; 1987 end; 1988 1989 else if call_sw < 0 /* do nothing on first call if there is a list */ 1990 then do; 1991 buffer_length = 0; /* Nothing read. */ 1992 my_code = 0; /* No errors occurred. */ 1993 return; 1994 end; 1995 1996 else do; /* get char len of item */ 1997 buffer_length = fio_ps.element_count; 1998 end; 1999 2000 if ^fio_ps.element_desc.VLA 2001 then call iox_$get_chars (iocb_ptr, fio_ps.element_p, buffer_length, sent, my_code); 2002 else do; 2003 chars_left = 4 * pl1_operators_$VLA_words_per_seg_ - char_pos (fio_ps.element_p) + 1; 2004 if buffer_length <= chars_left 2005 then call iox_$get_chars (iocb_ptr, fio_ps.element_p, buffer_length, sent, my_code); 2006 else do; /* Target crosses into next VLA component. */ 2007 call iox_$get_chars (iocb_ptr, fio_ps.element_p, chars_left, sent, my_code); 2008 if my_code = 0 2009 then do; 2010 call iox_$get_chars (iocb_ptr, 2011 baseptr (fixed (baseno (fio_ps.element_p)) + 1), 2012 buffer_length - chars_left, sent, my_code); 2013 sent = sent + chars_left; 2014 end; 2015 end; 2016 end; 2017 2018 if my_code ^= 0 2019 then if my_code = error_table_$short_record 2020 /* i.e., less data returned than requested. */ 2021 then goto end_of_file; /* Some data was not returned. */ 2022 end; 2023 2024 if my_code ^= 0 2025 then if my_code = error_table_$end_of_info 2026 then go to end_of_file; 2027 else call print_error (my_code); 2028 2029 2030 buffer_length = sent; 2031 fio_ps.have_input = fio_ps.format ^= unformatted; /* i.e., fmt, namelist, or list-dir */ 2032 return; 2033 2034 2035 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 2036 2037 /* called to output a record to the I/O module. */ 2038 2039 write_a_record: 2040 entry; 2041 2042 /* NOTE - Some code directly relating to output has been moved to action(3) in the in the main body of this 2043* internal procedure. The code was moved so as to remove a test from the write loop. 2044* For internal_files, blank out remainder of record if the format is insufficiently long (buffer_length < buffer_max_len) 2045* and on terminate call (call_sw = 1), pad with blanks if there is any unflushed buffer. 2046* Decrement the internal_file_count each time, when it hits zero, set buffer_max_len to zero, so expand_buffer will prevent 2047* the writing of the next record, as it is impossible to know if the next reocrd is going to be written. 2048* We can detect an error if there has been an attemp to write a zero_length record, as internal_file_count will go negative. 2049* Do not make this check on terminate call. 2050**/ 2051 2052 if fio_ps.mode = string_io | fio_ps.mode = internal_file 2053 then do; 2054 if fio_ps.mode = internal_file 2055 then do; 2056 if buffer_max_len > buffer_length 2057 then if call_sw < 1 | buffer_length > 0 2058 then substr (buffer_pointer -> chars, buffer_length + 1, 2059 buffer_max_len - buffer_length) = SP; 2060 internal_file_count = internal_file_count - 1; 2061 if internal_file_count = 0 2062 then buffer_max_len = -1; 2063 else if internal_file_count < 0 & call_sw <= 0 2064 then call internal_file_overflow; 2065 end /* internal_file only */; 2066 2067 buffer_length = 0; 2068 buffer_pointer = add_char_offset_ (buffer_pointer, char_offset); 2069 return; 2070 end; 2071 2072 /* Check for WRITE after EOF record. */ 2073 2074 if file_desc.unwritten_eofs > 0 2075 then if ^file_desc.carriage_controllable 2076 then call print_error (fortran_io_error_$write_after_eof); 2077 else do; /* Write appropriate number of EOF records. */ 2078 call finish_line; 2079 if my_code ^= 0 2080 then call print_error (my_code); 2081 do while (file_desc.unwritten_eofs > 0); 2082 call iox_$put_chars (iocb_ptr, addr (EOF1), length (EOF1), my_code); 2083 if my_code = 0 2084 then call iox_$put_chars (iocb_ptr, addr (NL), length (NL), my_code); 2085 if my_code ^= 0 2086 then call print_error (my_code); 2087 file_desc.unwritten_eofs = file_desc.unwritten_eofs - 1; 2088 end; 2089 end; 2090 2091 /* Special processing for formatted records */ 2092 2093 if file_desc.formatted_records 2094 then do; 2095 2096 /* state of the terminal is maintained elsewhere; copy it. */ 2097 2098 terminal_file = iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io; 2099 2100 if terminal_file 2101 then do; 2102 file_desc.newline_needed = fortran_buffer_.terminal_needs_newline; 2103 fortran_buffer_.terminal_needs_newline = file_desc.defer_newline; 2104 end; 2105 2106 /* IF REQUIRED, CONVERT CARRIAGE CONTROL CHAR TO SLEW CHAR OR ADD NEWLINE CHAR */ 2107 2108 if file_desc.carriage_controllable /* ="1"b if file contain newline chars */ 2109 then if file_desc.printer_file /* File requires CC char conversion. */ 2110 then if column_one = buffer_length 2111 then do; /* a blank line */ 2112 if column_one = 0 & ^file_desc.newline_needed 2113 then if terminal_file 2114 then fortran_buffer_.terminal_needs_newline = "1"b; 2115 else file_desc.newline_needed = "1"b; 2116 else do; 2117 buffer_length = buffer_length + 1; 2118 substr (io_buf, buffer_length, 1) = NL; 2119 end; 2120 end; 2121 2122 else if substr (io_buf, column_one + 1, 1) = SP 2123 /* Most common CC char. */ 2124 then goto single_space; 2125 2126 else if substr (io_buf, column_one + 1, 1) = "0" 2127 then do; /* Double space. */ 2128 if column_one = 0 2129 then if file_desc.newline_needed 2130 then do; /* first record, no need to move text. */ 2131 buffer_pointer = addr (fortran_buffer_.extra_char); 2132 buffer_length = buffer_length + 1; 2133 substr (io_buf, 1, 2) = two_NLs; 2134 end; 2135 else substr (io_buf, 1, 1) = NL; 2136 else do; 2137 if buffer_length - column_one - 1 > 0 2138 /* i.e., text follows CC char */ 2139 then substr (io_buf, column_one + 3, buffer_length - column_one - 1) = 2140 copy ( 2141 substr (io_buf, column_one + 2, 2142 buffer_length - column_one - 1), 1); 2143 substr (io_buf, column_one + 1, 2) = two_NLs; 2144 buffer_length = buffer_length + 1; 2145 end; 2146 end; /* double space */ 2147 2148 else if substr (io_buf, column_one + 1, 1) = "1" 2149 then do; /* Slew to top of next page. */ 2150 if column_one = 0 2151 then if file_desc.newline_needed 2152 then do; /* first record, no need to move text. */ 2153 buffer_pointer = addr (fortran_buffer_.extra_char); 2154 buffer_length = buffer_length + 1; 2155 substr (io_buf, 1, 2) = NL_FF; 2156 end; 2157 else substr (io_buf, 1, 1) = FF; 2158 else do; 2159 if buffer_length - column_one - 1 > 0 2160 /* i.e., text follows CC char */ 2161 then substr (io_buf, column_one + 3, buffer_length - column_one - 1) = 2162 copy ( 2163 substr (io_buf, column_one + 2, 2164 buffer_length - column_one - 1), 1); 2165 substr (io_buf, column_one + 1, 2) = NL_FF; 2166 buffer_length = buffer_length + 1; 2167 end; 2168 end; /* top of page */ 2169 2170 else if substr (io_buf, column_one + 1, 1) = "+" 2171 then do; /* Overprint on previous record. */ 2172 if column_one = 0 & ^file_desc.newline_needed 2173 then do; /* too late, newline already printed */ 2174 buffer_length = buffer_length - 1; 2175 buffer_pointer = addr (substr (io_buf, 2, 1)); 2176 end; 2177 else substr (io_buf, column_one + 1, 1) = CR; 2178 end; /* overprint */ 2179 2180 else do; /* Single space. */ 2181 single_space: 2182 if column_one = 0 & ^file_desc.newline_needed 2183 then do; 2184 buffer_length = buffer_length - 1; 2185 buffer_pointer = addr (substr (io_buf, 2, 1)); 2186 end; 2187 else substr (io_buf, column_one + 1, 1) = NL; 2188 end; /* single space */ 2189 2190 /* Add newline for files without carriage control */ 2191 2192 else do; 2193 if column_one = 0 & file_desc.newline_needed 2194 then do; 2195 buffer_length = buffer_length + 1; 2196 buffer_pointer = addr (fortran_buffer_.extra_char); 2197 fortran_buffer_.extra_char = NL; 2198 end; 2199 2200 if call_sw <= 0 2201 then do; 2202 substr (io_buf, buffer_length + 1, 1) = NL; 2203 buffer_length = buffer_length + 1; 2204 end; 2205 end; 2206 end; /* code for formatted records */ 2207 2208 2209 /* perform record positioning if required */ 2210 2211 if fio_ps.mode = direct_access 2212 then do; 2213 call get_record (exists); 2214 end; 2215 else exists = "0"b; 2216 2217 /* write the record */ 2218 2219 if file_desc.type_of_io = stream_file 2220 then goto write_stream; 2221 2222 else if file_desc.type_of_io = record_file 2223 then do; 2224 if file_desc.using_tape_nstd & (mod (buffer_length, 4) ^= 0) 2225 then do; 2226 new_buffer_length = buffer_length + 4 - mod (buffer_length, 4); 2227 2228 /* pad with spaces for formatted records; pad with null bytes otherwise. */ 2229 2230 if file_desc.formatted_records 2231 then substr (buffer, buffer_length + 1, new_buffer_length - buffer_length) = " "; 2232 else substr (buffer, buffer_length + 1, new_buffer_length - buffer_length) = low (1); 2233 buffer_length = new_buffer_length; 2234 end; 2235 if ^exists 2236 then call iox_$write_record (iocb_ptr, buffer_pointer, buffer_length, my_code); 2237 else call iox_$rewrite_record (iocb_ptr, buffer_pointer, buffer_length, my_code); 2238 buffer_length = 0; 2239 end; 2240 2241 else if file_desc.type_of_io = blocked_file 2242 then do; 2243 if my_code = error_table_$end_of_info 2244 then call print_error (my_code); /* file probably attached without -no_end option */ 2245 call iox_$write_record (iocb_ptr, buffer_pointer, buffer_length, my_code); 2246 buffer_length = 0; 2247 if my_code = 0 & fio_ps.mode = sequential_access & file_desc.open_code = Sequential_update 2248 then call iox_$control (iocb_ptr, "truncate", null, my_code); 2249 end; 2250 2251 else do; 2252 write_stream: 2253 if call_sw > 0 /* i.e., last call */ 2254 then do; 2255 2256 /* If file contains newline chars, one more may be needed. */ 2257 2258 if file_desc.carriage_controllable 2259 /* i.e., does file have newline chars? */ 2260 then if ^file_desc.defer_newline 2261 /* yes, and they are not deferred */ 2262 then if suppress_final_newline 2263 then ; 2264 else do; 2265 substr (io_buf, buffer_length + 1, 1) = NL; 2266 /* so put final newline char in */ 2267 buffer_length = buffer_length + 1; 2268 if terminal_file 2269 /* reset need for initial newline char */ 2270 then fortran_buffer_.terminal_needs_newline = "0"b; 2271 else file_desc.newline_needed = "0"b; 2272 end; 2273 else if ^file_desc.newline_needed 2274 then file_desc.newline_needed = "1"b; 2275 2276 call iox_$put_chars (iocb_ptr, buffer_pointer, buffer_length, my_code); 2277 column_one = 0; 2278 end; 2279 2280 else do; /* Write text later; just update virtual origin */ 2281 column_one = buffer_length; 2282 my_code = 0; /* "write call" was successful */ 2283 end; 2284 end; 2285 2286 if my_code ^= 0 2287 then call print_error (my_code); 2288 2289 return; 2290 2291 validate_mode_and_access: 2292 proc; /* compare mode and access of request to that of the file */ 2293 2294 /* CHECK MODE - input or output */ 2295 2296 if fio_ps.read 2297 then if ^file_desc.in 2298 then if ^file_desc.allow_reopen 2299 then call print_error (fortran_io_error_$cannot_read); 2300 else call reopen_for_input; 2301 else ; /* file is already open for input */ 2302 2303 else if ^file_desc.out 2304 then if ^file_desc.allow_reopen 2305 then call print_error (fortran_io_error_$cannot_write); 2306 else call reopen_for_output; 2307 2308 2309 /* CHECK ACCESS - sequential or direct */ 2310 2311 if fio_ps.mode = direct_access 2312 then if ^file_desc.allow.direct_access 2313 then call print_error (fortran_io_error_$not_direct); 2314 else ; /* file does support it */ 2315 else if ^file_desc.allow.seq_access 2316 then call print_error (fortran_io_error_$not_sequential); 2317 2318 2319 /* CHECK FORM - formatted or unformatted */ 2320 2321 if fio_ps.format = unformatted 2322 then if file_desc.formatted_records 2323 then call print_error (fortran_io_error_$formatted_file); 2324 else ; /* they match */ 2325 else if ^file_desc.formatted_records 2326 then call print_error (fortran_io_error_$unformatted_file); 2327 end validate_mode_and_access; 2328 2329 2330 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 2331 2332 get_record: 2333 proc (record_found); 2334 2335 dcl record_found bit (1) aligned; 2336 dcl record_key picture "99999999"; 2337 dcl record_length fixed bin (21); 2338 2339 /* is record number in range ? */ 2340 2341 if PS.record_number < 0 | PS.record_number > 99999999 2342 then call print_error (error_table_$no_record); 2343 2344 file_desc.last_rec = PS.record_number; 2345 record_found = "1"b; /* Reset only if I/O module cannot find the record. */ 2346 2347 /* position the file. */ 2348 2349 if file_desc.type_of_io = record_file 2350 then do; 2351 record_key = PS.record_number; /* convert number to character string */ 2352 2353 call iox_$seek_key (iocb_ptr, (record_key), record_length, my_code); 2354 if my_code ^= 0 2355 then if my_code = error_table_$no_record 2356 then record_found = "0"b; 2357 end; 2358 2359 else if file_desc.type_of_io = blocked_file 2360 then do; 2361 2362 /* vfile_ really should support a seek_key operation for 2363* blocked files. Since it doesn't, we must use 2364* record_status to locate a record for read (in order to 2365* tell us if a record has been deleted) and iox_$position for 2366* write (because record_status has a bug talking about records 2367* located by seek_key having been deleted by another opening). */ 2368 2369 if fio_ps.read 2370 then do; 2371 rs_info_ptr = addr (info); 2372 unspec (rs_info) = "0"b; 2373 rs_info.version = rs_info_version_2; 2374 rs_info.flags.locate_pos_sw = "1"b; 2375 rs_info.record_length = PS.record_number; 2376 call iox_$control (iocb_ptr, "record_status", rs_info_ptr, my_code); 2377 if my_code ^= 0 2378 then if my_code = error_table_$no_record | my_code = error_table_$asynch_deletion 2379 then record_found = "0"b; 2380 end; 2381 2382 else do; 2383 call iox_$position (iocb_ptr, 2, (PS.record_number), my_code); 2384 if my_code ^= 0 2385 then record_found = "0"b; 2386 end; 2387 end; 2388 2389 else if file_desc.type_of_io = binary_file 2390 then do; 2391 call iox_$position (iocb_ptr, 2, PS.record_number * CPW, my_code); 2392 end; 2393 2394 else do; /* double binary */ 2395 call iox_$position (iocb_ptr, 2, PS.record_number * CPDW, my_code); 2396 end; 2397 2398 PS.record_number = PS.record_number + 1; 2399 2400 if my_code ^= 0 2401 then if fio_ps.read | record_found 2402 then do; /* Convert error code if it may not be helpful. */ 2403 2404 if my_code = error_table_$no_record/* Record not found. */ 2405 then ; 2406 else if my_code = error_table_$end_of_info 2407 /* Record number is too large. */ 2408 then ; 2409 else if my_code = error_table_$asynch_deletion 2410 then my_code = error_table_$no_record; 2411 else my_code = fortran_io_error_$not_direct; 2412 /* Assume I/O module complained about order call. */ 2413 2414 call print_error (my_code); 2415 end; 2416 2417 end get_record; 2418 2419 end initialize_fortran_io; 2420 2421 set_max_recl: 2422 proc (maxl); 2423 2424 dcl maxl fixed bin; 2425 2426 info (1) = -1; /* vfile_ returns old value here */ 2427 info (2) = maxl; 2428 call iox_$control (iocb_ptr, "max_rec_len", addr (info), my_code); 2429 2430 if my_code ^= 0 2431 then if my_code ^= error_table_$no_operation 2432 then call print_error (fortran_io_error_$not_blocked); 2433 2434 else if info (1) < 0 /* file does not have max rec len */ 2435 then call print_error (fortran_io_error_$not_blocked); 2436 2437 else if info (1) ^= info (2) /* file is not empty or not open for output */ 2438 then if open_mode (file_desc.open_code).out 2439 then call print_error (fortran_io_error_$must_be_empty); 2440 else call print_error (fortran_io_error_$cannot_write, me, 2441 "A file must be opened for output in order to change its maximum record length."); 2442 2443 else ; /* old recl is the same; therefore no operation */ 2444 2445 end set_max_recl; 2446 2447 2448 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 2449 2450 strip_line_no: 2451 proc; /* Removes line no, a field of digits, from the beginning of a record */ 2452 2453 dcl ln fixed bin; 2454 2455 if length (rest_of_record) = 0 2456 then 2457 ln_error: 2458 call print_error (fortran_io_error_$syntax_error, me, "No line number on this line."); 2459 2460 ln = verify (rest_of_record, "0123456789") - 1; 2461 2462 if ln < 0 /* all digits */ 2463 then do; 2464 buffer_index = buffer_index + length (rest_of_record); 2465 last = buffer_index; 2466 return; 2467 end; 2468 2469 else if ln = 0 /* no digits */ 2470 then goto ln_error; 2471 2472 buffer_index = buffer_index + (ln + 1); /* skip digits plus one character */ 2473 last = buffer_index; 2474 end strip_line_no; 2475 2476 dfast_openfile: 2477 proc (); 2478 2479 dcl filetypes char (36) int static options (constant) 2480 init ("ter pri str bin rec raw num dnu key "); 2481 2482 in = divide (index (filetypes, translate (substr (filetype_ptr -> chars, 1, 3), lower_letters, capital_letters)) 2483 + 3, 4, 17, 0); 2484 2485 if in = 0 2486 then call print_error (fortran_io_error_$unknown_filetype, me, """^a""", substr (filetype_ptr -> chars, 1, 3)); 2487 2488 if fio_ps.file_number = 0 2489 then do; 2490 if in = 1 /* terminal */ 2491 then file_desc.printer_file = "0"b; 2492 2493 else if in = 2 /* print */ 2494 then file_desc.printer_file = "1"b; 2495 2496 else call print_error (fortran_io_error_$invalid_file0_type); 2497 return; 2498 end; 2499 2500 if file_desc.connected 2501 then call close_fortran_file; 2502 2503 unspec (fortran_open_data.specified) = "0"b; 2504 2505 fortran_open_data.specified.attach_desc = "1"b; 2506 fortran_open_data.specified.form = "1"b; 2507 fortran_open_data.specified.mode = "1"b; 2508 fortran_open_data.specified.access = "1"b; 2509 fortran_open_data.specified.prompt = "1"b; 2510 fortran_open_data.specified.carriage = "1"b; 2511 fortran_open_data.specified.defer = "1"b; 2512 2513 string (fortran_open_data.specified.direction) = "11"b; 2514 fortran_open_data.specified.dfast_openfile = "1"b; 2515 2516 fortran_open_data.prompt = "0"b; 2517 fortran_open_data.carriage = "0"b; 2518 fortran_open_data.defer = "0"b; 2519 2520 fortran_open_data.attach_desc.offset = 0; 2521 2522 /* Build an attach description to support the desired file type. */ 2523 2524 fortran_open_data.char_str = "vfile_ "; 2525 2526 fortran_open_data.char_str = 2527 fortran_open_data.char_str || rtrim (substr (pathname_ptr -> chars, 1, PS.max_buffer)); 2528 2529 goto convert_dfast_file (in); 2530 2531 2532 convert_dfast_file (1): /* terminal */ 2533 fortran_open_data.formatted_records = "1"b; 2534 2535 fortran_open_data.char_str = fortran_open_data.char_str || " -append"; 2536 in = unstructured; 2537 goto finish_dfast_open; 2538 2539 2540 convert_dfast_file (2): /* print */ 2541 fortran_open_data.carriage = "1"b; 2542 fortran_open_data.formatted_records = "1"b; 2543 2544 fortran_open_data.char_str = fortran_open_data.char_str || " -append"; 2545 in = unstructured; 2546 goto finish_dfast_open; 2547 2548 2549 convert_dfast_file (3): /* string */ 2550 fortran_open_data.direct_access = "1"b; 2551 fortran_open_data.formatted_records = "1"b; 2552 2553 fortran_open_data.char_str = fortran_open_data.char_str || " -blocked 12"; 2554 in = blocked; 2555 goto finish_dfast_open; 2556 2557 2558 convert_dfast_file (4): /* binary */ 2559 fortran_open_data.direct_access = "1"b; 2560 2561 fortran_open_data.char_str = fortran_open_data.char_str || " -blocked 12"; 2562 in = blocked; 2563 goto finish_dfast_open; 2564 2565 2566 convert_dfast_file (5): /* record */ 2567 fortran_open_data.char_str = fortran_open_data.char_str || " -append"; 2568 in = sequential; 2569 goto finish_dfast_open; 2570 2571 2572 convert_dfast_file (6): /* raw */ 2573 fortran_open_data.direct_access = "1"b; 2574 2575 fortran_open_data.char_str = fortran_open_data.char_str || " -no_trunc"; 2576 in = binary_stream; 2577 goto finish_dfast_open; 2578 2579 2580 convert_dfast_file (7): /* numeric */ 2581 fortran_open_data.direct_access = "1"b; 2582 2583 fortran_open_data.char_str = fortran_open_data.char_str || " -header 1"; 2584 in = binary_stream; 2585 goto finish_dfast_open; 2586 2587 2588 convert_dfast_file (8): /* dnumeric */ 2589 fortran_open_data.direct_access = "1"b; 2590 2591 fortran_open_data.char_str = fortran_open_data.char_str || " -header 2"; 2592 in = binary_stream; 2593 goto finish_dfast_open; 2594 2595 2596 convert_dfast_file (9): /* keyed */ 2597 fortran_open_data.formatted_records = "1"b; 2598 2599 in = indexed; 2600 2601 2602 finish_dfast_open: 2603 fortran_open_data.char_str = fortran_open_data.char_str || " -ssf"; 2604 2605 fortran_open_data.attach_desc.length = length (fortran_open_data.char_str); 2606 2607 call open_fortran_file (in); 2608 end dfast_openfile; 2609 2610 open_statement: 2611 proc; /* code for open and close statements */ 2612 2613 dcl allow_default bit (1) aligned; 2614 dcl desired_file_type fixed bin; 2615 dcl desired_type fixed bin; 2616 dcl erasable_file bit (1) aligned; 2617 dcl file picture "99"; 2618 dcl file_is_empty bit (1) aligned; 2619 dcl file_name (-1:6) char (12) int static options (constant) 2620 init ("undefined", "nonexistent", "unstructured", "sequential", "blocked", 2621 "indexed", "binary", "non vfile_"); 2622 dcl keep_status fixed bin; 2623 dcl fio_vfile_attach bit (1) aligned; 2624 dcl i fixed bin; 2625 dcl implicit_opening bit (1) aligned; 2626 dcl job_index fixed bin; 2627 dcl len fixed bin; 2628 dcl nstd_opening (13) fixed bin int static options (constant) 2629 init (1, 4, 8, 11, 6, 7, 5, 3, 2, 10, 9, 13, 12); 2630 dcl off fixed bin; 2631 dcl offset_for_direct_access 2632 fixed bin int static options (constant) init (2); 2633 dcl offset_for_out_mode fixed bin int static options (constant) init (4); 2634 dcl open_index fixed bin; 2635 dcl using_vfile bit (1) aligned; 2636 2637 2638 dcl 1 nstd aligned structure int static options (constant), 2639 2 first (8) fixed bin (17) init (1, 2, 3, 3, 5, 5, 10, 10), 2640 2 last (8) fixed bin (17) init (2, 2, 4, 4, 9, 7, 13, 13); 2641 2642 /* format: off */ 2643 dcl file_type_matrix (-1:5, -1:5) fixed bin int static options (constant) 2644 2645 init (/* desired actual */ 2646 2647 /* und ^ex uns seq blo ind bin */ 2648 /* und */ 0, 0, 1, 2, 3, 4, 5, 2649 /* ^ex */ 0, 0, 1, 2, 3, 4, 5, 2650 /* uns */ 1, 1, 1, 2, 3, 4, 5, 2651 /* seq */ 2, 2, 2, 2, -1, -1, -1, 2652 /* blo */ 3, 3, -1, -1, 3, -1, -1, 2653 /* ind */ 4, 4, -1, -1, -1, 4, -1, 2654 /* bin */ 5, 5, 5, -1, -1, -1, 5); 2655 2656 dcl opening (8, 0:5) fixed bin int static 2657 options (constant) 2658 /* bounds depend on job_index and file_type */ 2659 2660 init (/* n u s b i b */ 2661 /* o n e l n i */ 2662 /* n s q o d n */ 2663 /* e t u c e a */ 2664 /* x r e k x r */ 2665 /* i u n e e y */ 2666 /* s c t d d */ 2667 2668 /* in seq fmt */ 1, 1, 4, 4, 4, 0, 2669 /* in seq unf */ 4, 0, 4, 4, 4, 1, 2670 /* in D/A fmt */ 8, 0, 0, 4, 8, 0, 2671 /* in D/A unf */ 8, 0, 0, 4, 8, 1, 2672 /* out seq fmt */ 3, 3, 6, 7, 0, 0, 2673 /* out seq unf */ 6, 0, 6, 7, 0, 3, 2674 /* out D/A fmt */ 10, 0, 0, 7, 10, 0, 2675 /* out D/A unf */ 10, 0, 0, 7, 10, 3); 2676 2677 /* format: on */ 2678 2679 /* procedure to open a fortran file regardless how the open is requested. Currently, there 2680* are three methods, implicitly by a read or write statement, explicitly by the open 2681* statement, and explicitly by the dfast openfile statement. */ 2682 2683 /* open statement */ 2684 2685 2686 /* PROCESS FIELDS SUPPLIED BY THE USER */ 2687 2688 if fortran_open_data.specified.status 2689 then do; 2690 call convert_from_character (status_field, open_status_values, i); 2691 fortran_open_data.file_status = i - 1; 2692 end; 2693 else fortran_open_data.file_status = unknown_file;/* default value */ 2694 2695 if fortran_open_data.specified.mode 2696 then do; 2697 call convert_from_character (mode_field, open_mode_values, i); 2698 2699 if i = 1 /* value is "in" */ 2700 then string (fortran_open_data.direction) = "10"b; 2701 else if i = 2 /* value is out */ 2702 then string (fortran_open_data.direction) = "01"b; 2703 else string (fortran_open_data.direction) = "11"b; 2704 /* inout */ 2705 end; 2706 else string (fortran_open_data.direction) = "11"b;/* default is "inout" */ 2707 2708 if fortran_open_data.specified.access 2709 then do; 2710 call convert_from_character (access_field, open_access_values, i); 2711 if i = 2 /* 1 is sequential, 2 direct */ 2712 then fortran_open_data.direct_access = "1"b; 2713 end; 2714 2715 if fortran_open_data.specified.form 2716 then do; 2717 call convert_from_character (form_field, open_form_values, i); 2718 2719 if i = 1 /* 1 is formatted, 2 unformatted */ 2720 then fortran_open_data.formatted_records = "1"b; 2721 end; 2722 2723 if fortran_open_data.specified.blank 2724 then do; 2725 call convert_from_character (blank_field, open_blank_values, i); 2726 fortran_open_data.blank_null = (i = 1); /* 1 is null , 2 zero */ 2727 end; 2728 else fortran_open_data.blank_null = fio_ps.ansi_77; 2729 /* default to zero iff ansi66 */ 2730 2731 /* CHECK open statement conflicts */ 2732 2733 if fortran_open_data.specified.recl & fortran_open_data.specified.binary & fortran_open_data.binary 2734 then call print_error (fortran_io_error_$open_attr_conflict, me, "Binary stream and recl."); 2735 2736 if fortran_open_data.specified.filename 2737 then do; 2738 2739 if fortran_open_data.specified.attach_desc 2740 then call print_error (fortran_io_error_$open_attr_conflict, me, "Attach and file."); 2741 2742 call exists_file (exists_file_code); 2743 if exists_file_code = 1 2744 then call print_error (error_table_$pathlong, me, "A filename may not be longer than 168 characters.") 2745 ; 2746 else if exists_file_code = 2 2747 then call print_error (fortran_io_error_$open_attr_incomplete, me, 2748 "A non-blank filename is required."); 2749 2750 end; 2751 2752 /* The STATUS= specifier is ignored in ansi66 program units. */ 2753 2754 if fio_ps.ansi_77 2755 then do; 2756 2757 /* If status = "scratch", 2758* no "file=" specifier can be used. */ 2759 2760 if fortran_open_data.specified.filename & fortran_open_data.file_status = scratch_file 2761 then call print_error (fortran_io_error_$open_attr_conflict, me, "File and status = ""scratch""."); 2762 2763 /* If status = "old", 2764* a "file=" specifier must be present in the open statement and 2765* the named file must exist. */ 2766 2767 if fortran_open_data.file_status = old_file 2768 then do; 2769 if ^fortran_open_data.specified.filename 2770 then call print_error (fortran_io_error_$open_attr_incomplete, me, 2771 "A filename is required for status = ""old""."); 2772 else if exists_file_code = 3 2773 then call print_error (error_table_$noentry, me, "The file must exist if status = ""old"".") 2774 ; 2775 end; 2776 2777 /* If status = "new", 2778* a "file=" specifier must be present in the open statment, but 2779* the named file cannot exist already. */ 2780 2781 else if fortran_open_data.file_status = new_file 2782 then do; 2783 if ^fortran_open_data.specified.filename 2784 then call print_error (fortran_io_error_$open_attr_incomplete, me, 2785 "A filename is required for status = ""new""."); 2786 else if exists_file_code = 0 2787 then call print_error (fortran_io_error_$status_field_error, me, 2788 "The file must not exist if status = ""new""."); 2789 end; 2790 2791 /* If status = "append", 2792* the access control must be "sequential", 2793* no attach description may be present, 2794* no io_switch name may be present. */ 2795 2796 else if fortran_open_data.file_status = append_file 2797 then do; 2798 2799 if fortran_open_data.direct_access 2800 then call print_error (fortran_io_error_$open_attr_conflict, me, 2801 "Access = ""direct"" and status = ""append""."); 2802 2803 if fortran_open_data.specified.binary & fortran_open_data.binary 2804 then call print_error (fortran_io_error_$open_attr_conflict, me, 2805 "Binary stream and status = ""append""."); 2806 2807 if fortran_open_data.specified.attach_desc 2808 then call print_error (fortran_io_error_$open_attr_conflict, me, 2809 "Attach and status = ""append""."); 2810 2811 if fortran_open_data.specified.io_switch 2812 then call print_error (fortran_io_error_$open_attr_conflict, me, 2813 "Ioswitch and status = ""append""."); 2814 2815 end; 2816 2817 end; 2818 2819 desired_file_type = undefined; 2820 implicit_opening = "0"b; 2821 goto open_common; 2822 2823 2824 implicit_open: 2825 entry; 2826 2827 unspec (fortran_open_data.specified) = "0"b; 2828 2829 fortran_open_data.specified.form = "1"b; 2830 fortran_open_data.specified.mode = "1"b; 2831 fortran_open_data.specified.access = "1"b; 2832 2833 fortran_open_data.direction.out = file_desc.direction.out; 2834 /* Sets 'out' if an ENDFILE has occurred. */ 2835 if fio_ps.read 2836 then fortran_open_data.direction.in = "1"b; 2837 else fortran_open_data.direction.out = "1"b; 2838 2839 if fio_ps.mode = direct_access 2840 then fortran_open_data.direct_access = "1"b; 2841 2842 if fio_ps.format ^= unformatted 2843 then fortran_open_data.formatted_records = "1"b; 2844 2845 desired_file_type = undefined; 2846 implicit_opening = "1"b; 2847 goto open_common; 2848 2849 2850 open_fortran_file: 2851 entry (desired_type); 2852 2853 desired_file_type = desired_type; /* caller supplies desired type */ 2854 implicit_opening = "0"b; 2855 2856 open_common: 2857 if implicit_opening /* already done for open statement */ 2858 then fortran_open_data.blank_null = fio_ps.ansi_77; 2859 2860 if fio_ps.file_number = 0 /* Process file 0 separately. */ 2861 then do; 2862 if fortran_open_data.specified.status | fortran_open_data.specified.io_switch 2863 | fortran_open_data.specified.attach_desc | fortran_open_data.specified.filename 2864 | fortran_open_data.specified.mode | fortran_open_data.specified.access 2865 | fortran_open_data.specified.form | fortran_open_data.specified.recl 2866 | fortran_open_data.specified.binary 2867 then do; 2868 call print_error (fortran_io_error_$invalid_file0_attr); 2869 return; 2870 end; 2871 2872 if fortran_open_data.specified.prompt 2873 then file_desc.prompt = fortran_open_data.prompt; 2874 2875 if fortran_open_data.specified.carriage 2876 then file_desc.printer_file = fortran_open_data.carriage; 2877 2878 if fortran_open_data.specified.defer 2879 then file_desc.defer_newline = fortran_open_data.defer; 2880 2881 file_desc.blank_null = fortran_open_data.blank_null; 2882 return; 2883 end; /* file 0 */ 2884 2885 2886 /* begin open code */ 2887 2888 file = fio_ps.file_number; /* convert file number to character in case is needed */ 2889 uns_info.type = undefined; /* to prevent erroneous use of the structure */ 2890 2891 erasable_file, /* accumulates the condition: attached and opened by FIO */ 2892 file_is_empty, /* Assume a non-empty file. */ 2893 using_vfile, /* Assume I/O switch is not vfile_. */ 2894 fio_vfile_attach = "0"b; /* ="1"b if fio creates a vfile_ attach desc */ 2895 fortran_buffer_.all_files_closed = "0"b; /* file table is modified */ 2896 2897 2898 /* SET FILE TYPE ATTRIBUTES AS REQUIRED */ 2899 2900 if fortran_open_data.specified.recl 2901 then desired_file_type = blocked; 2902 2903 if fortran_open_data.specified.binary & fortran_open_data.binary 2904 then desired_file_type = binary_stream; 2905 2906 2907 /* FILE IS NOT CONNECTED; CONNECT IT */ 2908 2909 if ^file_desc.connected 2910 then do; /* file is not connected yet */ 2911 2912 /* File may be partially connected if last connection failed; it must be disconnected. */ 2913 2914 call close_fortran_file; /* disconnects partially open file and zeros table entry */ 2915 2916 2917 /* GET IOCB NAME AND THEN IOCB PTR */ 2918 2919 if fortran_open_data.specified.io_switch 2920 then do; 2921 call get_open_field (io_switch_field, off, len); 2922 2923 if len > length (ioname) 2924 then call print_error (field_error (io_switch_field), me, 2925 "I/O switch name is longer than ^d characters.", length (ioname)); 2926 else if len < 1 2927 then call print_error (field_error (io_switch_field), me, 2928 "I/O switch name must be non-blank."); 2929 2930 ioname = substr (fortran_open_data.char_str, off + 1, len); 2931 end; 2932 2933 else do; /* use default I/O switch name */ 2934 ioname = "file"; 2935 substr (ioname, 5, 2) = file; 2936 end; 2937 2938 call iox_$find_iocb (ioname, iocb_ptr, my_code); 2939 /* get iocb pointer */ 2940 2941 if my_code ^= 0 2942 then do; 2943 call print_error (my_code, me, "Cannot get iocb for ^a.", ioname); 2944 return; 2945 end; 2946 2947 file_desc.switch_p = iocb_ptr; /* Save in table for future use */ 2948 2949 2950 /* FILE IS NOT ATTACHED; ATTACH IT */ 2951 2952 if iocb_ptr -> iocb.attach_descrip_ptr = null 2953 then do; 2954 2955 /* the following determines if default attachment is possible */ 2956 2957 allow_default = 2958 ^fortran_open_data.specified.io_switch /* attach and file also not allowed */ 2959 & ^fortran_open_data.direct_access & fortran_open_data.formatted_records 2960 & string (fortran_open_data.direction) ^= "11"b & (desired_file_type = undefined); 2961 2962 2963 /* CHOOSE AN ATTACH DESCRIPTION */ 2964 2965 if fortran_open_data.specified.attach_desc 2966 /* CASE: user supplies attach desc */ 2967 then do; 2968 call get_open_field (attach_desc_field, off, attach_desc_len); 2969 2970 if attach_desc_len > length (attachment) 2971 then call print_error (field_error (attach_desc_field), me, 2972 "Attach description is longer than ^d characters.", length (attachment)) 2973 ; 2974 else if attach_desc_len < 1 2975 then call print_error (field_error (attach_desc_field), me, 2976 "Attach description must be non-blank."); 2977 2978 attachment = substr (fortran_open_data.char_str, off + 1, attach_desc_len); 2979 end; 2980 2981 else if fortran_open_data.specified.filename 2982 /* CASE: user supplies filename */ 2983 then do; 2984 call get_open_field (filename_field, off, len); 2985 2986 if len > length (attachment) - 7 2987 then call print_error (field_error (filename_field), me, 2988 "File name is longer than ^d characters.", length (attachment) - 7); 2989 else if len < 1 2990 then call print_error (field_error (filename_field), me, 2991 "File name must be non-blank."); 2992 2993 substr (attachment, 1, 7) = "vfile_ "; 2994 substr (attachment, 8) = substr (fortran_open_data.char_str, off + 1, len); 2995 attach_desc_len = len + 7; 2996 2997 using_vfile = "1"b; /* I/O module is vfile_ */ 2998 end; 2999 3000 /* CASE: default input */ 3001 else if allow_default & file_desc.default_input & fortran_open_data.in 3002 then do; /* file is default input */ 3003 attachment = "syn_ user_input -inhibit put_chars"; 3004 attach_desc_len = 34; 3005 3006 uns_info.type = unstructured; 3007 implicit_opening = "0"b; 3008 /* KLUDGE - prevents mode from being input/output */ 3009 end; 3010 3011 /* CASE: default output */ 3012 else if allow_default & file_desc.default_output & fortran_open_data.out 3013 then do; /* file is default output */ 3014 attachment = "syn_ user_output -inhibit get_line get_chars"; 3015 attach_desc_len = 44; 3016 3017 uns_info.type = unstructured; 3018 implicit_opening = "0"b; 3019 /* KLUDGE - prevents mode from being input/output */ 3020 end; 3021 3022 /* CASE: status = "scratch" */ 3023 else if fortran_open_data.file_status = scratch_file 3024 then do; 3025 attachment = 3026 "vfile_ " || rtrim (get_pdir_ ()) || ">file" || file || "." 3027 || unique_chars_ (""b); 3028 3029 /* attach_desc_len is found after the SECOND blank, the first is after "vfile_" */ 3030 attach_desc_len = index (substr (attachment, 8), SP) - 1; 3031 attach_desc_len = 7 + attach_desc_len; 3032 using_vfile = TRUE; 3033 end; 3034 3035 /* CASE: FORTRAN I/O attachment */ 3036 else do; 3037 attachment = "vfile_ file"; 3038 substr (attachment, 12, 2) = file; 3039 attach_desc_len = 13; 3040 3041 using_vfile = "1"b; /* I/O module is vfile_ */ 3042 end; 3043 3044 3045 /* ADD NECESSARY ATTACH CONTROL ARGUMENTS TO FORTRAN I/O'S VFILE_ ATTACHMENT */ 3046 3047 if ^fortran_open_data.specified.attach_desc & using_vfile 3048 then do; 3049 3050 fio_vfile_attach = "1"b; 3051 /* this is a fio created vfile_ attach desc */ 3052 3053 /* Attach control arguments for vfile_ blocked files. */ 3054 3055 if fortran_open_data.specified.recl 3056 then do; 3057 3058 call add_attach_option ("-no_end"); 3059 /* Any record number is valid at any time. */ 3060 3061 /* add "-blocked n" to force the file type */ 3062 3063 call add_attach_option ("-blocked"); 3064 3065 int_pic = fortran_open_data.max_rec_len; 3066 /* convert binary to char */ 3067 call add_attach_option ((int_pic)); 3068 end; 3069 3070 /* Attach control arguments for vfile_ binary stream files. */ 3071 3072 if desired_file_type = binary_stream 3073 then do; 3074 call add_attach_option ("-no_trunc"); 3075 /* prevents write from truncating */ 3076 call add_attach_option ("-no_end"); 3077 /* Any record number is valid at any time. */ 3078 end; 3079 3080 /* If opening for output and file is not binary stream, add "-extend". */ 3081 3082 else if fortran_open_data.out 3083 then do; 3084 call add_attach_option ("-extend"); 3085 file_desc.rewind_on_open = "1"b; 3086 end; 3087 3088 end; /* code to add attach control arguments */ 3089 3090 3091 /* ATTACH THE FILE */ 3092 3093 call iox_$attach_iocb (iocb_ptr, attachment, my_code); 3094 3095 if my_code ^= 0 3096 then do; 3097 call print_error (my_code); 3098 return; 3099 end; 3100 3101 file_desc.fortran_attached = "1"b; 3102 3103 end; /* code to attach a file */ 3104 3105 3106 /* FILE TYPE IS UNKNOWN; CALCULATE IT */ 3107 3108 if uns_info.type = undefined 3109 then if substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 7) = "vfile_ " 3110 then do; 3111 using_vfile, erasable_file = "1"b; 3112 /* I/O module is vfile_ */ 3113 3114 uns_info.info_version = vfs_version_1; 3115 call iox_$control (iocb_ptr, "file_status", addr (info), my_code); 3116 call process_vfile_status (/* file_type */); 3117 3118 /* If file is attached by fortran I/O using an attach description created 3119* by fortran I/O, check that the correct attach description was generated. 3120* Fix it if it isn't. Currently this code is only executed if the target 3121* file is blocked or binary stream and the user did not specify the 3122* appropriate attribute in the open statement. */ 3123 3124 if fio_vfile_attach 3125 then if uns_info.type = blocked & desired_file_type ^= blocked 3126 then do; 3127 call iox_$detach_iocb (iocb_ptr, my_code); 3128 call add_attach_option ("-no_end"); 3129 call iox_$attach_iocb (iocb_ptr, attachment, my_code); 3130 if my_code ^= 0 3131 then call print_error (my_code); 3132 end; 3133 3134 else if uns_info.type = binary_stream & desired_file_type ^= binary_stream 3135 then do; 3136 call iox_$detach_iocb (iocb_ptr, my_code); 3137 call add_attach_option ("-no_trunc"); 3138 call add_attach_option ("-no_end"); 3139 call iox_$attach_iocb (iocb_ptr, attachment, my_code); 3140 if my_code ^= 0 3141 then call print_error (my_code); 3142 end; 3143 end; 3144 3145 /* non vfile_ cases */ 3146 3147 else if iocb_ptr -> iocb.actual_iocb_ptr = iox_$user_io 3148 then uns_info.type = unstructured; 3149 3150 else if substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 11) = "tape_mult_ " 3151 then do; 3152 uns_info.type = binary_stream; 3153 uns_info.header_present = "0"b; 3154 end; 3155 else if substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 11) = "tape_nstd_ " 3156 then file_desc.using_tape_nstd = "1"b; 3157 3158 /* IS DESIRED FILE TYPE COMPATIBLE WITH ACTUAL FILE TYPE? */ 3159 3160 if ^fortran_open_data.dfast_openfile /* dfast ignores actual file type */ 3161 then do; 3162 if file_type_matrix (desired_file_type, uns_info.type) = undefined 3163 then do; 3164 call print_error (fortran_io_error_$incompatible_opening, me, 3165 "^/Existing file is a ^a file, but opening requires a ^a file.", 3166 file_name (uns_info.type), file_name (desired_file_type)); 3167 return; 3168 end; 3169 else desired_file_type = file_type_matrix (desired_file_type, uns_info.type); 3170 end; 3171 3172 3173 /* FILE IS NOT OPEN; OPEN IT */ 3174 3175 if iocb_ptr -> iocb.open_descrip_ptr = null 3176 /* file is closed, open it */ 3177 then do; 3178 3179 3180 /* DETERMINE REQUEST TYPE */ 3181 3182 /* formatted or unformatted */ 3183 if fortran_open_data.specified.form 3184 then if fortran_open_data.formatted_records 3185 then job_index = 1; 3186 else job_index = 2; 3187 else if fio_ps.ansi_77 & ^fortran_open_data.direct_access 3188 then job_index = 1; 3189 else job_index = 2; 3190 3191 if fortran_open_data.direct_access 3192 /* direct or sequential */ 3193 then job_index = job_index + offset_for_direct_access; 3194 3195 /* INPUT / OUTPUT -- in and inout are considered input, except for the case of 3196* inout and the file is empty or the file is not empty and fio created the attach 3197* desc, then inout is treated as output. This is done to protect vfiles from 3198* accidental truncation. If the attachment is not to a vfile and the mode is 3199* output, we treat this as output no matter what. */ 3200 3201 if fortran_open_data.out 3202 & (file_is_empty | fio_vfile_attach | (^using_vfile & ^fortran_open_data.in)) 3203 then job_index = job_index + offset_for_out_mode; 3204 3205 3206 /* VFILE_ OPENING */ 3207 3208 if using_vfile 3209 then do; 3210 open_index = opening (job_index, desired_file_type); 3211 if open_index = 0 3212 then if job_index > offset_for_out_mode /* an output opening */ 3213 & 3214 ^fortran_open_data.specified.mode /* but OUT not explicitly requested */ 3215 & opening (job_index - offset_for_out_mode, desired_file_type) ^= 0 3216 /* and IN is ok */ 3217 then do; 3218 job_index = job_index - offset_for_out_mode; 3219 /* change to input only opening */ 3220 open_index = opening (job_index, desired_file_type); 3221 end; 3222 3223 else do; 3224 3225 /* attributes conflict with existing file */ 3226 3227 call print_error (fortran_io_error_$incompatible_opening, me, 3228 "A ^a file.", file_name (desired_file_type)); 3229 return; 3230 end; 3231 3232 call iox_$open (iocb_ptr, open_index, "0"b, my_code); 3233 3234 if my_code ^= 0 3235 then do; 3236 3237 /* Opening can fail because of no write access. If so, try input only. */ 3238 3239 if my_code = error_table_$moderr 3240 /* insufficient access */ 3241 then if job_index > offset_for_out_mode 3242 /* and attempted output opening */ 3243 then if ^fortran_open_data.specified.mode 3244 /* and no explicit mode */ 3245 then if opening (job_index - offset_for_out_mode, 3246 desired_file_type) ^= 0 3247 /* and IN is ok */ 3248 then do; 3249 job_index = job_index - offset_for_out_mode; 3250 open_index = 3251 opening (job_index, desired_file_type); 3252 3253 call iox_$open (iocb_ptr, open_index, "0"b, 3254 my_code); 3255 end; 3256 3257 if my_code ^= 0 3258 then call print_error (my_code); 3259 end; 3260 3261 /* Some attach/open combinations position at the end of the file; 3262* if rewind_on_open is true, position at the beginning of the file. */ 3263 3264 if file_desc.rewind_on_open 3265 then do; 3266 call iox_$position (iocb_ptr, -1, 0, my_code); 3267 if my_code ^= 0 3268 then call print_error (my_code); 3269 end; 3270 3271 /* In ANSI 77 program units, if status = "append" in the open statement, 3272* position the file pointer to the end of the file. */ 3273 3274 if fio_ps.ansi_77 3275 then do; 3276 if fortran_open_data.file_status = append_file 3277 then do; 3278 call iox_$position (iocb_ptr, +1, 0, my_code); 3279 if my_code ^= 0 3280 then call print_error (my_code); 3281 end; 3282 end; 3283 3284 end; /* vfile opening */ 3285 3286 3287 /* NON VFILE_ BINARY FILE - tape_mult_ */ 3288 3289 else if desired_file_type = binary_stream 3290 then do; 3291 if fortran_open_data.out 3292 then open_index = 2;/* stream_output */ 3293 else open_index = 1;/* stream_input */ 3294 3295 call iox_$open (iocb_ptr, open_index, "0"b, my_code); 3296 if my_code ^= 0 3297 then call print_error (my_code); 3298 end; 3299 3300 3301 /* UNKNOWN FILE TYPE, OPENING WILL DEFINE TYPE OF I/O */ 3302 3303 else do; 3304 retry_non_vfile_opening: 3305 my_code = 1; 3306 do i = nstd (job_index).first to nstd (job_index).last while (my_code ^= 0); 3307 open_index = nstd_opening (i); 3308 call iox_$open (iocb_ptr, open_index, "0"b, my_code); 3309 3310 if my_code ^= 0 3311 then if my_code = error_table_$moderr 3312 /* error is insufficient access */ 3313 then if job_index > offset_for_out_mode 3314 /* and attempted output opening */ 3315 then if ^fortran_open_data.specified.mode 3316 /* and no explicit mode */ 3317 then do; 3318 /* so try an input opening; only possible once */ 3319 job_index = job_index - offset_for_out_mode; 3320 goto retry_non_vfile_opening; 3321 end; 3322 end; 3323 if my_code ^= 0 3324 then call print_error (my_code, me, "Cannot open."); 3325 end; /* non vfile_ opening */ 3326 3327 file_desc.fortran_opened = "1"b; 3328 end; /* code to open the file */ 3329 3330 3331 /* FILE IS OPEN; DETERMINE TYPE OF I/O IF UNKNOWN */ 3332 3333 else do; 3334 3335 /* determine opening mode used */ 3336 3337 text_pt = iocb_ptr -> iocb.open_descrip_ptr; 3338 /* point to open descrip */ 3339 i = length (before (text_pt -> b_var_str, " ")); 3340 /* get open mode length */ 3341 do open_index = 1 to hbound (iox_modes, 1) 3342 while (substr (text_pt -> b_var_str, 1, i) ^= iox_modes (open_index)); 3343 end; 3344 3345 /* If it is a non-standard open desc, see if we know about it. */ 3346 3347 if open_index > hbound (iox_modes, 1) 3348 then if substr (text_pt -> b_var_str, 1, 18) = "IOS compatability " 3349 then open_index = 3; /* stream_input_output */ 3350 3351 else do; 3352 call print_error (fortran_io_error_$fio_sys_error, me, 3353 "Unrecognized opening. ""^a""", text_pt -> b_var_str); 3354 return; 3355 end; 3356 end; /* not opened by fortran */ 3357 3358 file_desc.open_code = open_index; 3359 file_desc.switch_ready = TRUE; 3360 if before (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, " ") = "tape_nstd_" 3361 then file_desc.eofs_are_records = TRUE; /* An EOF is a physical record. */ 3362 3363 3364 /* STORE ATTRIBUTES INTO FILE TABLE ENTRY */ 3365 3366 /* type of I/O -- how to read, write, and position the file */ 3367 3368 if desired_file_type = binary_stream 3369 then do; 3370 file_desc.type_of_io = binary_file; 3371 3372 if uns_info.type = binary_stream & uns_info.header_present & uns_info.header_id = 2 3373 then file_desc.double_word_file = "1"b; 3374 end; 3375 3376 else if desired_file_type = blocked 3377 then file_desc.type_of_io = blocked_file; 3378 3379 else file_desc.type_of_io = open_mode (open_index).io_type; 3380 3381 /* Set allow_delete if and only if a) I/O switch is attached by FIO, b) I/O switch is opened by FIO, c) I/O switch is vfile_. */ 3382 3383 if erasable_file 3384 then if file_desc.fortran_attached & file_desc.fortran_opened 3385 then file_desc.allow_delete = "1"b; 3386 3387 call merge_attributes; /* must precede assignment to file_desc.connected */ 3388 3389 file_desc.connected = "1"b; 3390 end; /* code to connect a file */ 3391 3392 3393 /* FILE IS CONNECTED; UPDATE ITS FILE TABLE ENTRY */ 3394 3395 else do; 3396 3397 3398 /* If I/O switch is open, this is a normal open to a connected file. */ 3399 3400 if iocb_ptr -> iocb.open_descrip_ptr ^= null 3401 then do; 3402 using_vfile = substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 1, 7) = "vfile_ "; 3403 3404 call merge_attributes; 3405 end; 3406 3407 /* I/O switch is closed. this must be an implicit opening */ 3408 3409 else if ^implicit_opening /* i.e. - not caused by a data transfer */ 3410 then call print_error (fortran_io_error_$fio_sys_error); 3411 3412 /* Open file. Use new opening mode only if allowed by user and necessary. */ 3413 3414 else if 3415 ((string (open_mode (file_desc.open_code).direction) /* compare previous opening mode */ 3416 & string (fortran_open_data.direction)) ^= "0"b) /* to desired one; nonzero means compatible */ 3417 | ^file_desc.allow_reopen /* unchangable */ 3418 then do; /* Old one is unchangable or compatible; use it */ 3419 call iox_$open (iocb_ptr, (file_desc.open_code), "0"b, my_code); 3420 if my_code ^= 0 3421 then call print_error (my_code); 3422 end; 3423 3424 /* Must reopen the file. */ 3425 3426 else if fortran_open_data.in 3427 then call reopen_for_input; 3428 else call reopen_for_output; 3429 3430 end; /* code to process connected file */ 3431 3432 3433 /* Set previous as open in case I/O transmission fails. */ 3434 3435 file_desc.previous = open_opr; /* save trouble of reopening later */ 3436 return; /* code for open statement */ 3437 3438 3439 /* CODE FOR CLOSE STATEMENT */ 3440 3441 close_statement: 3442 entry; 3443 3444 /* If user gives status specifer, use it; otherwise the default is "keep". 3445* keep_status = 1 is "keep", 2 is "delete" */ 3446 3447 if fortran_open_data.specified.status 3448 then call convert_from_character (status_field, close_status_values, keep_status); 3449 else keep_status = 1; 3450 3451 erasable_file = file_desc.allow_delete; /* Copy values because close_fortran_file zeros them */ 3452 if (keep_status = 2 & erasable_file) | file_desc.file_status = scratch_file 3453 then call save_attach_desc (attachment); 3454 3455 call close_fortran_file; /* close the file first */ 3456 3457 /* If file is to be deleted, delete it now. */ 3458 3459 if file_desc.file_status = scratch_file 3460 then do; 3461 if fortran_open_data.specified.status & keep_status = 1 3462 /* user wants to keep */ 3463 then call print_error (fortran_io_error_$close_attr_error, me, 3464 "Cannot keep scratch file associated with unit number ^d.", fio_ps.file_number); 3465 else do; 3466 call delete_file (attachment, fio_ps.file_number); 3467 file_desc.has_been_deleted = TRUE; 3468 end; 3469 end; 3470 else if keep_status = 2 3471 then do; 3472 if ^erasable_file /* FIO does not have access to delete */ 3473 then call print_error (fortran_io_error_$not_scratch_file, me, 3474 "Cannot delete file associated with unit number ^d.", fio_ps.file_number); 3475 else do; 3476 call delete_file (attachment, fio_ps.file_number); 3477 file_desc.has_been_deleted = TRUE; 3478 end; 3479 end; 3480 return; 3481 3482 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 3483 3484 add_attach_option: 3485 proc (a_str); 3486 3487 dcl a_str char (256) varying; 3488 3489 if attach_desc_len + length (a_str) + 1 > length (attachment) 3490 then do; 3491 call print_error (fortran_io_error_$fio_sys_error, me, "Generated attach description is too long."); 3492 return; 3493 end; 3494 3495 substr (attachment, attach_desc_len + 2, length (a_str)) = a_str; 3496 attach_desc_len = attach_desc_len + length (a_str) + 1; 3497 end add_attach_option; 3498 3499 3500 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 3501 3502 process_vfile_status: 3503 procedure (/* file_type */); 3504 3505 if my_code = 0 3506 then if uns_info.info_version ^= vfs_version_1 3507 then do; 3508 call print_error (fortran_io_error_$fio_sys_error, me, "Wrong vfs version."); 3509 return; 3510 end; 3511 else do; 3512 if uns_info.end_pos = 0 3513 then file_is_empty = "1"b; 3514 3515 if uns_info.type = unstructured 3516 then do; 3517 if uns_info.header_present 3518 then uns_info.type = binary_stream; 3519 3520 else if iocb_ptr -> iocb.attach_descrip_ptr ^= null 3521 then call check_attach_options; 3522 /* attach options change file type */ 3523 3524 if uns_info.end_pos = 0 & uns_info.type = unstructured 3525 /* zero length segment */ 3526 then uns_info.type = nonexistent; 3527 end; 3528 end; /* vfile files */ 3529 3530 else if my_code = error_table_$noentry /* file does not exist, but may be attached */ 3531 then do; 3532 uns_info.type = nonexistent; 3533 file_is_empty = "1"b; /* File is obviously empty. */ 3534 3535 if iocb_ptr -> iocb.attach_descrip_ptr ^= null 3536 then call check_attach_options; /* attach options specify file type */ 3537 end; 3538 3539 else do; 3540 call print_error (my_code); /* error from vfile status */ 3541 return; 3542 end; 3543 3544 /* END OF process_vfile_status CODE */ 3545 3546 3547 check_attach_options: 3548 proc; /* converts attach options to file type */ 3549 3550 dcl adp ptr; /* attach description pointer */ 3551 3552 adp = iocb_ptr -> iocb.attach_descrip_ptr; 3553 3554 if index (adp -> b_var_str, "-blocked") ^= 0 3555 then uns_info.type = blocked; 3556 3557 end check_attach_options; 3558 end process_vfile_status; 3559 3560 3561 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 3562 3563 merge_attributes: 3564 proc; 3565 3566 dcl (actual_mode, desired_mode) 3567 bit (2) aligned; 3568 3569 if fortran_open_data.dfast_openfile 3570 then if file_desc.connected | ^file_desc.fortran_attached | ^file_desc.fortran_opened 3571 then do; 3572 call print_error (fortran_io_error_$fio_sys_error, me, "Connected attached, or opened in dfast.") 3573 ; 3574 return; 3575 end; 3576 3577 /* THE FOLLOWING ARE ERRORS IF FILE IS ALREADY CONNECTED */ 3578 3579 if file_desc.connected 3580 then if fortran_open_data.specified.status 3581 then call print_error (fortran_io_error_$already_connected, me, "File status."); 3582 3583 else if fortran_open_data.specified.io_switch 3584 then call print_error (fortran_io_error_$already_connected, me, "I/O switch name."); 3585 3586 else if fortran_open_data.specified.form 3587 then call print_error (fortran_io_error_$already_connected, me, "Format attribute (form)."); 3588 3589 else if fortran_open_data.specified.binary 3590 then call print_error (fortran_io_error_$already_connected, me, "Binary stream attribute."); 3591 3592 3593 /* ERRORS IF CONNECTED OR NOT ATTACHED BY FORTRAN */ 3594 3595 if file_desc.connected | ^file_desc.fortran_attached 3596 then do; 3597 3598 if fortran_open_data.specified.attach_desc 3599 then do; 3600 call print_error (fortran_io_error_$already_opened, me, "Attach description."); 3601 return; 3602 end; 3603 3604 if fortran_open_data.specified.filename 3605 then do; 3606 call print_error (fortran_io_error_$already_opened, me, "Filename."); 3607 return; 3608 end; 3609 end; 3610 3611 3612 /* MODE - in, out, inout. 3613* 3614* Set only if explicitly specified or if file is being connected. 3615* "file_desc.allow_reopen" is set at the same time and allows reopening 3616* the file if the file opening does not support a specific data transfer. 3617* This attribute is set if and only if the following conditions are met: 3618* 1) FIOS opens the I/O module during connection; 3619* 2) the most recent mode specified for the file is "inout", 3620* or the file was connected implicitly as a result of a read or write, 3621* or a mode has never been specified for this file. 3622* */ 3623 3624 3625 if ^file_desc.connected | fortran_open_data.specified.mode 3626 then do; 3627 actual_mode = string (open_mode (file_desc.open_code).direction); 3628 /* what file opening supports */ 3629 desired_mode = string (fortran_open_data.direction); 3630 /* what user wants */ 3631 3632 file_desc.allow_reopen = ((desired_mode = "11"b) | implicit_opening) & file_desc.fortran_opened; 3633 3634 if file_desc.allow_reopen /* no need to fix now, can do it any time */ 3635 then string (file_desc.direction) = actual_mode; 3636 3637 else if file_desc.fortran_opened /* reopen if necessary for new mode */ 3638 then do; 3639 3640 /* At this point it is known that "desired_mode" cannot be "11"b or "00"b. 3641* Therefore, the following tests for any incompatibility between the 3642* actual and desired opening */ 3643 3644 if (actual_mode & desired_mode) = "0"b 3645 /* nothing in common, so reopen */ 3646 then if fortran_open_data.direction.in 3647 then call reopen_for_input; 3648 else call reopen_for_output; 3649 3650 string (file_desc.direction) = desired_mode; 3651 /* limit mode to that requested by user */ 3652 end; 3653 3654 /* Cannot reopen at all; actual and desired modes must be compatible */ 3655 3656 else do; 3657 3658 /* test for incompatible (=0), or usemore than there is */ 3659 3660 if ((actual_mode & desired_mode) = "0"b) 3661 | (((actual_mode & desired_mode) ^= desired_mode) & fortran_open_data.specified.mode) 3662 then if ^fortran_open_data.direction.in 3663 /* tell him what he can't have */ 3664 then call print_error (fortran_io_error_$wrong_mode, me, 3665 "Requested mode is ""input""."); 3666 else call print_error (fortran_io_error_$wrong_mode, me, 3667 "Requested mode is ""output""."); 3668 3669 if implicit_opening | ^fortran_open_data.specified.mode 3670 then string (file_desc.direction) = actual_mode; 3671 else string (file_desc.direction) = desired_mode; 3672 end; 3673 end; /* code to set mode */ 3674 3675 open_index = file_desc.open_code; /* copy for use later on */ 3676 3677 3678 /* SET FORM - formatted or unformatted. Note that in '66 mode the default */ 3679 /* is always unformatted, while in '77 mode the default is formatted unless */ 3680 /* the access is direct. */ 3681 3682 if fortran_open_data.specified.form 3683 then file_desc.formatted_records = fortran_open_data.formatted_records; 3684 else if ^file_desc.connected 3685 then if fio_ps.ansi_77 3686 then if fortran_open_data.specified.access 3687 then file_desc.formatted_records = ^fortran_open_data.direct_access; 3688 else file_desc.formatted_records = TRUE; 3689 else file_desc.formatted_records = FALSE; 3690 3691 3692 /* SET ACCESS - allow/prohibit positioning, seq access, direct access */ 3693 3694 if ^file_desc.connected | fortran_open_data.specified.access 3695 then if fortran_open_data.direct_access 3696 then do; 3697 file_desc.allow.direct_access = "1"b; 3698 file_desc.allow.positioning, file_desc.allow.seq_access = 3699 file_desc.type_of_io = blocked_file | file_desc.type_of_io = binary_file; 3700 /* These file types allow both sequential and direct access. */ 3701 end; 3702 3703 else do; 3704 file_desc.allow.positioning = "1"b; 3705 file_desc.allow.direct_access = "0"b; 3706 file_desc.allow.seq_access = "1"b; 3707 end; 3708 3709 3710 3711 /* CHECK FILE TYPE AND FORM */ 3712 3713 if file_desc.formatted_records 3714 then if file_desc.type_of_io = binary_file 3715 then call print_error (fortran_io_error_$incompatible_opening, me, "Formatted opening for a binary file."); 3716 else ; 3717 else if file_desc.type_of_io = stream_file 3718 then call print_error (fortran_io_error_$incompatible_opening, me, "Unformatted opening for a stream file."); 3719 3720 3721 /* SET CARRIAGE - whether or not carriage control can be applied to the file */ 3722 3723 file_desc.carriage_controllable = 3724 ^file_desc.allow.direct_access /* seq access only */ & file_desc.formatted_records /* formatted file */ 3725 & file_desc.type_of_io = stream_file; /* terminal or unstructured */ 3726 3727 /* SET maximum record length and using_vfile */ 3728 3729 if fortran_open_data.specified.recl & using_vfile 3730 then call set_max_recl (fortran_open_data.max_rec_len); 3731 3732 file_desc.using_vfile = using_vfile; 3733 3734 /* SET and CHECK blank attribute and file_status */ 3735 3736 file_desc.blank_null = fortran_open_data.blank_null; 3737 if fortran_open_data.specified.blank & ^fortran_open_data.formatted_records 3738 then call print_error (fortran_io_error_$incompatible_opening, me, "Blank specified for an unformatted file."); 3739 3740 file_desc.file_status = fortran_open_data.file_status; 3741 if fortran_open_data.file_status = scratch_file & fortran_open_data.specified.attach_desc 3742 then call print_error (fortran_io_error_$open_attr_conflict, me, "Attach and status = ""scratch""."); 3743 3744 /* SET bit attributes */ 3745 3746 if fortran_open_data.specified.prompt 3747 then file_desc.prompt = fortran_open_data.prompt; 3748 3749 if fortran_open_data.specified.carriage 3750 then file_desc.printer_file = fortran_open_data.carriage; 3751 3752 if fortran_open_data.specified.defer 3753 then file_desc.defer_newline = fortran_open_data.defer; 3754 3755 end merge_attributes; 3756 3757 3758 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 3759 3760 convert_from_character: 3761 proc (fld_no, valid_values, which_one); 3762 3763 declare valid_values (*) char (12) varying; 3764 dcl (fld_no, i, num_valid_values, which_one) 3765 fixed bin; 3766 declare error_string char (64) varying; 3767 declare given char (12) varying; 3768 3769 call get_open_field (fld_no, off, len); 3770 3771 given = translate (substr (fortran_open_data.char_str, off + 1, len), lower_letters, capital_letters); 3772 3773 num_valid_values = hbound (valid_values, 1); 3774 3775 /* scan till a match in the list of valid values */ 3776 3777 do i = 1 to num_valid_values; 3778 if given = valid_values (i) 3779 then do; 3780 which_one = i; 3781 return; 3782 end; 3783 end; 3784 3785 /* user hasn't given a valid value, tell him which one are valid */ 3786 3787 error_string = ""; 3788 do i = 1 to num_valid_values - 2; 3789 error_string = error_string || valid_values (i) || COMMA; 3790 end; 3791 error_string = 3792 error_string || SP || valid_values (num_valid_values - 1) || " and " || valid_values (num_valid_values); 3793 3794 call print_error (field_error (fld_no), me, "Unrecognized value for field. ""^a"". 3795 ^3xValues allowed are: ^a ", substr (fortran_open_data.char_str, off + 1, len), error_string); 3796 end convert_from_character; 3797 3798 3799 end open_statement; 3800 3801 inquire_statement: 3802 procedure; 3803 3804 /* This implements the ansi77 INQUIRE statement. It first distinquishes between the two kinds of such statements, 3805* by_file or by_unit. It then checks each of the specified fields to determine which information is required and 3806* proceeds to capture that info and store it in the location specified 3807* in the remained of the structure fort_inquire_data. Full details in the 1978 version of the standard. 3808**/ 3809 3810 declare (by_file, in_range, file_connected, file_exists, need_name) 3811 bit (1) aligned; 3812 declare unit_number fixed binary (18); 3813 declare return_string character (168) varying; 3814 declare dir_name char (168); 3815 declare ent_name char (32); 3816 declare based_bit_1 bit (1) aligned based; 3817 3818 by_file = fortran_inquire_data.specified.filename; 3819 3820 if by_file 3821 then do; 3822 need_name = FALSE; 3823 3824 /* AT THIS POINT WE DEPEND THAT get_associated_unit WILL SET iocb_ptr */ 3825 3826 call get_associated_unit (ltrim (fortran_inquire_data.filename), unit_number, dir_name, ent_name, 3827 code); 3828 if code = 0 3829 then do; 3830 file_connected = TRUE; 3831 file_exists = TRUE; 3832 fio_ps.file_number = unit_number; 3833 /* if needed for error message */ 3834 fcb_ptr = addr (fortran_buffer_.table (unit_number)); 3835 end; 3836 else if code = error_table_$no_file 3837 then do; 3838 file_connected = FALSE; 3839 file_exists = FALSE; 3840 end; 3841 else do; /* file exists, but not connected */ 3842 file_connected = FALSE; 3843 file_exists = TRUE; 3844 end; 3845 end /* by_file */; 3846 else do; /* by unit */ 3847 fio_ps.file_number, unit_number = fortran_inquire_data.unit; 3848 need_name = TRUE; 3849 if unit_number >= lbound (fortran_buffer_.table, 1) & unit_number <= hbound (fortran_buffer_.table, 1) 3850 then do; 3851 in_range = TRUE; 3852 fcb_ptr = addr (fortran_buffer_.table (unit_number)); 3853 iocb_ptr = file_desc.switch_p; 3854 file_connected = fortran_buffer_.table (unit_number).connected; 3855 end /* unit in range */; 3856 3857 else do; 3858 file_connected = FALSE; 3859 in_range = FALSE; 3860 end /* file number out of range */; 3861 end; 3862 3863 /* The exist and opened fields are always defined */ 3864 3865 if fortran_inquire_data.specified.exist 3866 then do; 3867 if by_file 3868 then fortran_inquire_data.exist -> based_bit_1 = file_exists; 3869 else fortran_inquire_data.exist -> based_bit_1 = in_range; 3870 end /* EXIST */; 3871 3872 if fortran_inquire_data.specified.opened 3873 then fortran_inquire_data.opened -> based_bit_1 = file_connected; 3874 3875 /* If by unit and not connected, then no other fields are defined. 3876* If by file, then if not connected, the fields NAMED, NAME, SEQUENTIAL, DIRECT, FORMATTED and UNFORMATTED 3877* refer to the file, if it exists. NUMBER is defined iff OPENED is true. 3878* The remaining fields (ACCESS, FORM, RECl, NEXTREC, and BLANK) are only defined for connected files/units 3879**/ 3880 3881 if (by_file & ^file_exists) | (^by_file & ^file_connected) 3882 then return; 3883 3884 /* the file is named if it is connected, uses vfile_ and not a scratch file, 3885* or if not connected, and this is by_file 3886* this file must exists and have a name of some sort. 3887**/ 3888 3889 if fortran_inquire_data.specified.named 3890 then do; 3891 if ^file_connected 3892 then fortran_inquire_data.named -> based_bit_1 = TRUE; 3893 else if file_desc.using_vfile 3894 then fortran_inquire_data.named -> based_bit_1 = (file_desc.file_status ^= scratch_file); 3895 else fortran_inquire_data.named -> based_bit_1 = FALSE; 3896 end /* NAMED */; 3897 3898 if fortran_inquire_data.specified.name 3899 then do; 3900 if (file_connected & file_desc.using_vfile & file_desc.file_status ^= scratch_file) | ^file_connected 3901 then do; 3902 if need_name 3903 then call get_name_of_unit; 3904 return_string = rtrim (dir_name) || ">" || rtrim (ent_name); 3905 call set_return_value (fortran_inquire_data.name.pointer, fortran_inquire_data.name.length, 3906 return_string); 3907 end /* not a scratch file */; 3908 end /* NAME */; 3909 3910 if fortran_inquire_data.specified.formatted 3911 then do; 3912 if file_connected 3913 then do; 3914 if file_desc.formatted_records 3915 then return_string = "YES"; 3916 else return_string = "NO"; 3917 end; 3918 else return_string = "YES"; /* CAN be opened for formatted */ 3919 call set_return_value (fortran_inquire_data.formatted.pointer, fortran_inquire_data.formatted.length, 3920 return_string); 3921 end /* FORMATTED */; 3922 3923 if fortran_inquire_data.specified.unformatted 3924 then do; 3925 if file_connected 3926 then do; 3927 if file_desc.formatted_records 3928 then return_string = "NO"; 3929 else return_string = "YES"; 3930 end; 3931 else return_string = "YES"; /* CAN be opened unformatted */ 3932 call set_return_value (fortran_inquire_data.unformatted.pointer, 3933 fortran_inquire_data.unformatted.length, return_string); 3934 end /* UNFORMATTED */; 3935 3936 if fortran_inquire_data.specified.sequential 3937 then do; 3938 if file_connected 3939 then do; 3940 if file_desc.allow.seq_access 3941 then return_string = "YES"; 3942 else return_string = "NO"; 3943 end; 3944 else return_string = "YES"; /* all CAN be opened sequentially */ 3945 call set_return_value (fortran_inquire_data.sequential.pointer, 3946 fortran_inquire_data.sequential.length, return_string); 3947 end /* SEQUENTIAL */; 3948 3949 if fortran_inquire_data.specified.direct 3950 then do; 3951 if file_connected 3952 then do; 3953 if file_desc.allow.direct_access 3954 then return_string = "YES"; 3955 else return_string = "NO"; 3956 end; 3957 else do; /* by_file & no connected */ 3958 uns_info.info_version = 1; /* required for call to vfile_status_ */ 3959 call vfile_status_ (dir_name, ent_name, addr (info), code); 3960 if code ^= 0 3961 then return_string = "UNKNOWN"; 3962 else if uns_info.type = blocked | uns_info.type = indexed 3963 then return_string = "YES"; 3964 else return_string = "NO"; 3965 end /* not connected */; 3966 call set_return_value (fortran_inquire_data.direct.pointer, fortran_inquire_data.direct.length, 3967 return_string); 3968 end /* DIRECT */; 3969 3970 3971 /* The following attributes refer only to connected files/units */ 3972 3973 if ^file_connected 3974 then return; 3975 3976 if fortran_inquire_data.specified.blank 3977 then do; 3978 if file_desc.blank_null 3979 then return_string = "NULL"; 3980 else return_string = "ZERO"; 3981 call set_return_value (fortran_inquire_data.blank.pointer, fortran_inquire_data.blank.length, 3982 return_string); 3983 end /* BLANK */; 3984 3985 if fortran_inquire_data.specified.number 3986 then fortran_inquire_data.number -> words (1) = unit_number; 3987 3988 3989 if fortran_inquire_data.specified.access 3990 then do; 3991 if file_desc.allow.direct_access 3992 then return_string = "DIRECT"; 3993 else return_string = "SEQUENTIAL"; 3994 call set_return_value (fortran_inquire_data.access.pointer, fortran_inquire_data.access.length, 3995 return_string); 3996 end /* ACCESS */; 3997 3998 if fortran_inquire_data.specified.form 3999 then do; 4000 if file_desc.formatted_records 4001 then return_string = "FORMATTED"; 4002 else return_string = "UNFORMATTED"; 4003 call set_return_value (fortran_inquire_data.form.pointer, fortran_inquire_data.form.length, 4004 return_string); 4005 end /* FORM */; 4006 4007 /* RECL is defined only if connected for direct access and this is a blocked file */ 4008 4009 if fortran_inquire_data.specified.recl 4010 then do; 4011 if file_desc.allow.direct_access 4012 then do; 4013 if file_desc.type_of_io = blocked_file | file_desc.type_of_io = record_file 4014 then do; 4015 if need_name 4016 then call get_name_of_unit; 4017 uns_info.info_version = 1; 4018 /* must be set before call to vfile_status_ */ 4019 call vfile_status_ (dir_name, ent_name, addr (info), code); 4020 if code ^= 0 4021 then call print_error (code); 4022 else fortran_inquire_data.recl -> words (1) = blk_info.max_rec_len; 4023 end /* blocked */; 4024 else call print_error (fortran_io_error_$not_blocked); 4025 end /* direct access */; 4026 4027 end /* RECL */; 4028 4029 if fortran_inquire_data.specified.nextrec 4030 then do; 4031 if file_desc.allow.direct_access 4032 then fortran_inquire_data.nextrec -> words (1) = file_desc.last_rec + 1; 4033 end /* NEXTREC */; 4034 4035 return; 4036 4037 get_name_of_unit: 4038 procedure; 4039 call save_attach_desc (attachment); 4040 call expand_pathname_ (attachment, dir_name, ent_name, code); 4041 if code ^= 0 4042 then call print_error (code, me, "Can't find filename in an inquire statement."); 4043 need_name = FALSE; 4044 end get_name_of_unit; 4045 4046 get_associated_unit: 4047 procedure (filename, unit_number, dir_name, ent_name, code); 4048 4049 /* Algorithm: get the unique id of the filename in question. 4050* Then proceed through the array of files, stopping at the first with the same 4051* unique id. 4052* Note that the standard does not allow a file to be connected to more than one unit, so this is OKAY. 4053* The value of unit_number is undefined if there is no associated unit or no such file 4054* and a number in the range of permissable LUN's otherwise (presently 1 - 99, with 0 reserved for the terminal). 4055* code = error_table_$no_file if the file doesn't exist and fortran_io_error_$not_open if it 4056* exists and is not open, i.e. connected to a unit. 4057**/ 4058 declare filename char (*); /* INPUT */ 4059 declare dir_name char (*); /* OUTPUT */ 4060 declare ent_name char (*); /* OUTPUT */ 4061 declare unit_number fixed binary (18); /* OUTPUT */ 4062 declare code fixed binary (35); /* OUTPUT */ 4063 4064 declare (file_uid, uid) bit (36) aligned; 4065 declare dname char (168); 4066 declare ename char (32); 4067 4068 code = 0; 4069 call get_unique_id (filename, file_uid, dir_name, ent_name); 4070 if file_uid = no_uid 4071 then do; 4072 code = error_table_$no_file; 4073 return; 4074 end; 4075 4076 do i = 1 to hbound (fortran_buffer_.table, 1); 4077 fcb_ptr = addr (fortran_buffer_.table (i)); 4078 iocb_ptr = file_desc.switch_p; 4079 if file_desc.connected 4080 then do; 4081 if file_desc.switch_p ^= null 4082 then do; 4083 call save_attach_desc (attachment); 4084 call get_unique_id (attachment, uid, dname, ename); 4085 if uid = file_uid 4086 then do; 4087 unit_number = i; 4088 return; 4089 end; 4090 end; 4091 end /* connected unit */; 4092 end /* do loop */; 4093 4094 /* if we've got to here, there is no match */ 4095 4096 code = fortran_io_error_$not_open; 4097 4098 end get_associated_unit; 4099 4100 get_unique_id: 4101 procedure (filename, uid, dname, ename); 4102 4103 /* given a filename, return its unique id (uid), if it exists, otherwise no_uid */ 4104 13 1 declare /* Structure returned by hcs_$status_long */ 13 2 13 3 1 branch_status aligned, /* automatic: hcs_$status uses a pointer */ 13 4 13 5 2 type bit(2) unaligned, /* type of entry: link, segment, dir */ 13 6 2 number_names bit(16) unaligned, /* unused by directory_status_ */ 13 7 2 names_rel_pointer bit(18) unaligned, /* unused by directory_status_ */ 13 8 2 date_time_modified bit(36) unaligned, /* date time modified */ 13 9 2 date_time_used bit(36) unaligned, /* date time entry used */ 13 10 2 mode bit(5) unaligned, /* effective access of caller */ 13 11 2 raw_mode bit(5) unaligned, 13 12 2 pad1 bit(8) unaligned, 13 13 2 records bit(18) unaligned, /* number of records in use */ 13 14 2 date_time_dumped bit(36) unaligned, /* date time last dumped */ 13 15 2 date_time_entry_modified bit(36) unaligned, /* date time entry modified */ 13 16 2 lvid bit(36) unaligned, /* logical volume id */ 13 17 2 current_length bit(12) unaligned, /* number of blocks currently allocated */ 13 18 2 bit_count bit(24) unaligned, /* bit count of entry */ 13 19 2 pad3 bit(8) unaligned, 13 20 2 copy_switch bit(1) unaligned, /* the copy switch */ 13 21 2 tpd bit(1) unaligned, /* transparent to paging device */ 13 22 2 mdir bit(1) unaligned, /* master directory switch */ 13 23 2 damaged_switch bit (1) unaligned, /* true if contents damaged */ 13 24 2 synchronized_switch bit (1) unaligned, /* true if a DM synchronized file */ 13 25 2 pad4 bit(5) unaligned, 13 26 2 ring_brackets (0:2) bit(6) unaligned, /* branch ring brackets */ 13 27 2 unique_id bit(36) unaligned, /* entry unique id */ 13 28 13 29 13 30 /* The types of each class of branch */ 13 31 segment_type bit(2) aligned internal static initial ("01"b), 13 32 directory_type bit(2) aligned internal static initial ("10"b), 13 33 msf_type bit(2) aligned internal static initial ("10"b), /* will eventually be different */ 13 34 link_type bit(2) aligned internal static initial ("00"b); 13 35 13 36 4105 4106 declare filename character (*); /* INPUT */ 4107 declare (dname, ename) character (*); /* OUTPUT */ 4108 declare uid bit (36) aligned; /* OUTPUT */ 4109 declare 1 my_status like branch_status; 4110 declare status_ptr pointer; 4111 declare chase_sw fixed bin (1) internal static options (constant) initial (1); 4112 4113 call expand_pathname_ (filename, dname, ename, code); 4114 if code ^= 0 4115 then do; 4116 uid = no_uid; 4117 return; 4118 end; 4119 4120 status_ptr = addr (my_status); 4121 call hcs_$status_long (dname, ename, chase_sw, status_ptr, null, code); 4122 if code ^= 0 4123 then uid = no_uid; 4124 else uid = my_status.unique_id; 4125 4126 end get_unique_id; 4127 4128 set_return_value: 4129 procedure (char_ptr, char_len, char_value); 4130 4131 declare char_ptr unaligned pointer; /* INPUT: addr of fortran char variable */ 4132 declare char_len fixed binary (18); /* INPUT: length of fortran char variable */ 4133 declare char_value char (168) varying;/* INPUT: what to put there */ 4134 declare return_len fixed binary (18); 4135 declare based_chars char (char_len) based; 4136 4137 /* fill into the user's variable, the required value. Truncate the correct character string if user has not provided 4138* enough room, and pad with blanks if the user has provided too much room. 4139**/ 4140 return_len = min (char_len, length (char_value)); 4141 if return_len < 1 4142 then return; 4143 4144 substr (char_ptr -> based_chars, 1) = char_value; 4145 4146 end set_return_value; 4147 4148 end inquire_statement; 4149 4150 /* * * * * * * * * * */ 4151 4152 exists_file: 4153 proc (exists_file_code); 4154 4155 /* to determine if the file exists already if needed in OPEN statement. */ 4156 4157 declare exists_file_code fixed binary; 4158 declare my_code fixed binary (35); 4159 declare file_type fixed binary (2); 4160 declare bit_count fixed binary (24); 4161 declare pathname character (168); 4162 declare (off, len) fixed binary; 4163 4164 call get_open_field (filename_field, off, len); 4165 4166 exists_file_code = 0; 4167 4168 if len > length (pathname) 4169 then exists_file_code = 1; 4170 4171 else if len < 1 4172 then exists_file_code = 2; 4173 4174 else do; 4175 pathname = substr (fortran_open_data.char_str, off + 1, len); 4176 call expand_pathname_ (pathname, dirname, entryname, my_code); 4177 if my_code ^= 0 4178 then exists_file_code = 3; 4179 4180 /* chase links on call to status (3rd arg = 1) */ 4181 else do; 4182 call hcs_$status_minf (dirname, ltrim (entryname), 1, file_type, bit_count, my_code); 4183 if my_code ^= 0 4184 then exists_file_code = 3; 4185 end; 4186 end; 4187 4188 return; 4189 end exists_file; 4190 4191 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 4192 4193 get_open_field: 4194 proc (field_num, str_off, str_len); 4195 4196 dcl field_num fixed bin; 4197 dcl str_off fixed bin; 4198 dcl str_len fixed bin; 4199 4200 dcl 1 field (0:13) aligned based (addr (fortran_open_data)), 4201 2 off fixed bin (17) unaligned, 4202 2 len fixed bin (17) unaligned; 4203 4204 str_off = field (field_num).off; 4205 4206 str_len = length (rtrim (substr (fortran_open_data.char_str, str_off + 1, field (field_num).len))); 4207 4208 end get_open_field; 4209 4210 /* THIS PROCEDURE IS USED TO SNAP THE LINK FOR THE APPROPRIATE FIELD MESSAGE */ 4211 4212 field_error: 4213 proc (field_number) returns (fixed bin (35)); 4214 4215 dcl field_number fixed bin; 4216 4217 goto get_error_message (field_number); 4218 4219 get_error_message (1): 4220 return (fortran_io_error_$status_field_error); 4221 get_error_message (2): 4222 return (fortran_io_error_$io_switch_field_error); 4223 get_error_message (3): 4224 return (fortran_io_error_$attach_desc_field_error); 4225 get_error_message (4): 4226 return (fortran_io_error_$filename_field_error); 4227 get_error_message (5): 4228 return (fortran_io_error_$mode_field_error); 4229 get_error_message (6): 4230 return (fortran_io_error_$access_field_error); 4231 get_error_message (7): 4232 return (fortran_io_error_$form_field_error); 4233 get_error_message (13): 4234 return (fortran_io_error_$blank_field_error); 4235 end field_error; 4236 4237 reopen_for_input: 4238 proc; 4239 4240 dcl (new_opening, original_opening) 4241 fixed bin; 4242 dcl (code, tcode) fixed bin (35); 4243 4244 original_opening = file_desc.open_code; /* save in case cannot reopen */ 4245 4246 call iox_$close (iocb_ptr, tcode); /* error is irrelevant */ 4247 4248 tcode = 1; /* to get into the loop */ 4249 new_opening = open_mode (original_opening).for_input; 4250 4251 do while (new_opening ^= 0 & tcode ^= 0); 4252 call iox_$open (iocb_ptr, new_opening, "0"b, tcode); 4253 if tcode ^= 0 4254 then new_opening = open_mode (new_opening).for_input; 4255 end; 4256 4257 if tcode ^= 0 4258 then do; 4259 call iox_$open (iocb_ptr, original_opening, "0"b, tcode); 4260 call print_error (fortran_io_error_$cannot_reopen, me, "Cannot open for input."); 4261 return; 4262 end; 4263 4264 file_desc.open_code = new_opening; 4265 string (file_desc.direction) = string (open_mode (new_opening).direction); 4266 return; 4267 4268 4269 reopen_for_output: 4270 entry; 4271 4272 original_opening = file_desc.open_code; /* save in case cannot reopen */ 4273 code = 0; /* For error processing. */ 4274 4275 call iox_$close (iocb_ptr, tcode); /* error is irrelevant */ 4276 4277 tcode = 1; /* to get into the loop */ 4278 new_opening = open_mode (original_opening).for_output; 4279 4280 do while (new_opening ^= 0 & tcode ^= 0); 4281 if ^(new_opening = Sequential_input_output & file_desc.type_of_io = blocked_file) 4282 then call iox_$open (iocb_ptr, new_opening, "0"b, tcode); 4283 if tcode ^= 0 4284 then do; 4285 if tcode = error_table_$moderr 4286 then code = tcode; /* Tells why reopen failed. */ 4287 new_opening = open_mode (new_opening).for_output; 4288 end; 4289 end; 4290 4291 if tcode ^= 0 4292 then do; 4293 call iox_$open (iocb_ptr, original_opening, "0"b, tcode); 4294 if code = 0 4295 then code = fortran_io_error_$cannot_reopen; 4296 /* If no interesting msg, use canned one. */ 4297 call print_error (code, me, "Cannot open for output."); 4298 return; 4299 end; 4300 4301 if file_desc.rewind_on_open 4302 then do; 4303 call iox_$position (iocb_ptr, -1, 0, my_code); 4304 if my_code ^= 0 4305 then call print_error (my_code); 4306 end; 4307 4308 file_desc.open_code = new_opening; 4309 string (file_desc.direction) = string (open_mode (new_opening).direction); 4310 end reopen_for_input; 4311 4312 4313 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 4314 4315 close_fortran_file: 4316 proc; /* caller must set "fcb_ptr" & "iocb_ptr" */ 4317 4318 if iocb_ptr ^= null 4319 then do; 4320 4321 if iocb_ptr -> iocb.open_descrip_ptr ^= null 4322 then do; 4323 4324 /* If file is actually connected, flush its output buffer. */ 4325 4326 if file_desc.connected 4327 then call finish_line; 4328 4329 /* Close the I/O switch if fortran_io_ opened it. */ 4330 4331 if file_desc.fortran_opened 4332 then call iox_$close (iocb_ptr, my_code); 4333 else if file_desc.connected /* rewind only if actually connected */ 4334 then call iox_$position (iocb_ptr, -1, 0, my_code); 4335 end; 4336 4337 if file_desc.fortran_attached 4338 then call iox_$detach_iocb (iocb_ptr, my_code); 4339 end; 4340 4341 /* Forget everything we ever knew about the file. */ 4342 4343 unspec (file_desc.per_connection) = "0"b; 4344 4345 end close_fortran_file; 4346 4347 4348 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 4349 4350 /* Internal procedure to write the last newline character if necessary. */ 4351 finish_line: 4352 proc; 4353 4354 my_code = 0; 4355 4356 if file_desc.newline_needed 4357 then do; 4358 call iox_$put_chars (iocb_ptr, addr (NL), 1, my_code); 4359 file_desc.newline_needed = "0"b; 4360 end; 4361 end finish_line; 4362 4363 4364 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 4365 4366 close_for_stop: 4367 proc; /* if there are files open, this procedure closes them. */ 4368 4369 dcl buf_p ptr; 4370 dcl ix fixed bin; 4371 4372 if ^fast_related_data_$fortran_io_initiated /* not initiated, therefore not open */ 4373 then return; 4374 4375 buf_p = fast_related_data_$fortran_buffer_p; 4376 if buf_p = null 4377 then return; /* no segment, therefore not open */ 4378 4379 if buf_p -> fortran_buffer_.all_files_closed 4380 then return; /* nothing is open */ 4381 4382 /* Must always check in case fortran_buffer_.all_files_closed is wrong. */ 4383 4384 do ix = 1 to 99; 4385 4386 if buf_p -> fortran_buffer_.table (ix).fortran_opened 4387 | buf_p -> fortran_buffer_.table (ix).fortran_attached | buf_p -> fortran_buffer_.table (ix).connected 4388 then do; 4389 call close_all_files ("0"b); 4390 4391 buf_p -> fortran_buffer_.terminal_needs_newline = "0"b; 4392 /* true regardless of user answer */ 4393 return; 4394 end; 4395 end; 4396 4397 end close_for_stop; 4398 4399 4400 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 4401 4402 /* This procedure closes all open FORTRAN files. */ 4403 4404 close_all_files: 4405 proc (by_stop_statement); 4406 4407 dcl by_stop_statement bit (1) aligned; /* ="1"b if this proc should output newline chars */ 4408 4409 dcl frn fixed bin, 4410 fcode fixed bin (35); 4411 dcl p ptr; 4412 declare killing_file bit (1) aligned; 4413 declare attach_description char (256); 4414 4415 /* This procedure must be coded very carefully as it is called as a finish handler to close all files. */ 4416 4417 if ^fast_related_data_$fortran_io_initiated 4418 then return; /* never been used */ 4419 4420 p = fast_related_data_$fortran_buffer_p; /* get buf ptr */ 4421 if p = null 4422 then return; /* never allocated */ 4423 4424 /* output newline to terminal if needed */ 4425 4426 if p -> fortran_buffer_.terminal_needs_newline 4427 then do; 4428 if by_stop_statement 4429 then call iox_$put_chars (iox_$user_io, addr (NL), 1, fcode); 4430 p -> fortran_buffer_.terminal_needs_newline = "0"b; 4431 end; 4432 4433 /* output newline to file0 if not the terminal */ 4434 4435 if p -> fortran_buffer_.table (0).newline_needed 4436 then if iox_$user_output -> iocb.actual_iocb_ptr ^= iox_$user_io 4437 then call iox_$put_chars (iox_$user_output, addr (NL), 1, fcode); 4438 4439 p -> fortran_buffer_.table (0).newline_needed = "0"b; 4440 4441 /* Check entire file table for connected files (and partially connected files) and disconnect them. */ 4442 4443 do frn = 1 to 99; 4444 4445 iocb_ptr = p -> fortran_buffer_.table (frn).switch_p; 4446 if iocb_ptr ^= null 4447 then do; 4448 killing_file = 4449 p -> fortran_buffer_.table (frn).file_status = scratch_file 4450 & ^(p -> fortran_buffer_.table (frn).has_been_deleted); 4451 if killing_file 4452 then call save_attach_desc (attach_description); 4453 if iocb_ptr -> iocb.open_descrip_ptr ^= null 4454 then do; 4455 4456 /* Flush the file's output buffer only if the file is actually connected, 4457* needs a newline char, and isn't the terminal. */ 4458 4459 if p -> fortran_buffer_.table (frn).connected 4460 then if p -> fortran_buffer_.table (frn).newline_needed 4461 then if iocb_ptr -> iocb.actual_iocb_ptr ^= iox_$user_io 4462 then call iox_$put_chars (iocb_ptr, addr (NL), 1, fcode); 4463 4464 /* Close (if opened by fortran_io_) or rewind (if actually connected) */ 4465 4466 if p -> fortran_buffer_.table (frn).fortran_opened 4467 then call iox_$close (iocb_ptr, fcode); 4468 else if p -> fortran_buffer_.table (frn).connected 4469 then call iox_$position (iocb_ptr, -1, 0, fcode); 4470 end; /* processing for open I/O switch */ 4471 4472 if p -> fortran_buffer_.table (frn).fortran_attached 4473 then call iox_$detach_iocb (iocb_ptr, fcode); 4474 if killing_file 4475 then do; 4476 call delete_file (attach_description, frn); 4477 p -> fortran_buffer_.table (frn).has_been_deleted = TRUE; 4478 end; 4479 end; /* I/O switch exists */ 4480 unspec (p -> fortran_buffer_.table (frn).per_connection) = "0"b; 4481 end; /* loop to close all files */ 4482 4483 p -> fortran_buffer_.all_files_closed = "1"b; 4484 end close_all_files; 4485 4486 /* * * * * * * * * * */ 4487 4488 delete_file: 4489 procedure (saved_attach_desc, file_number); 4490 4491 /* deletes a file, either a scratch_file or if so indicated by the CLOSE statement 4492* user MUST set iocb_ptr */ 4493 4494 declare saved_attach_desc char (*); /* the pathname, saved from the attach desc */ 4495 declare file_number fixed binary; /* LUN associated with file */ 4496 4497 call expand_pathname_ (substr (saved_attach_desc, 1, attach_desc_len), dirname, entryname, my_code); 4498 if my_code ^= 0 4499 then do; 4500 call com_err_ (my_code, me, "Cannot delete file associated with unit number ^d.", fio_ps.file_number); 4501 return; 4502 end; 4503 4504 call delete_$path (dirname, entryname, "010111"b, me, my_code); 4505 if my_code ^= 0 4506 then do; 4507 call com_err_ (my_code, me, "Cannot delete file associated with unit number ^d.", fio_ps.file_number); 4508 return; 4509 end; 4510 end delete_file; 4511 4512 /* * * * * * * * * */ 4513 4514 save_attach_desc: 4515 procedure (attach_desc); 4516 declare attach_desc char (*); 4517 attach_desc_len = index (substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 8), " ") - 1; 4518 if attach_desc_len < 0 /* i.e., no blank follows pathname */ 4519 then attach_desc_len = length (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str) - 7; 4520 attach_desc = substr (iocb_ptr -> iocb.attach_descrip_ptr -> b_var_str, 8, attach_desc_len); 4521 end save_attach_desc; 4522 4523 error_handlers: 4524 procedure; 4525 4526 call print_error (fortran_io_error_$fio_sys_error, me, "Illegal entry point."); 4527 4528 too_much_input: 4529 entry; 4530 call print_error (fortran_io_error_$short_record); 4531 4532 too_much_output: 4533 entry; 4534 call print_error (fortran_io_error_$long_record, me, "^d", buffer_max_len); 4535 4536 internal_file_overflow: 4537 entry; 4538 call print_error (fortran_io_error_$internal_file_oflow); 4539 4540 conversion_error: 4541 entry; 4542 buffer_index = begin_index; /* Point to beginning of constant for error. */ 4543 call print_error (fortran_io_error_$conversion_error); 4544 4545 bad_char: 4546 entry; 4547 call print_error (fortran_io_error_$bad_char, me, """^a""", substr (rest_of_field, 1, 1)); 4548 4549 syntax_error: 4550 entry; 4551 call print_error (fortran_io_error_$syntax_error); 4552 4553 end error_handlers; 4554 4555 /* Procedure to abort the FORTRAN I/O system. */ 4556 print_error: 4557 proc options (variable); /* First argument must be valid error code. rest are optional */ 4558 4559 dcl comp_name char (32) aligned, 4560 dir_name char (168), 4561 ent_name char (256), 4562 seg_name char (32); 4563 4564 dcl std bit (1) aligned, 4565 op_name char (32) varying, 4566 (start, num, line_no, offset) 4567 fixed bin (18), 4568 cur_op fixed bin, 4569 bit_cnt fixed bin (24), 4570 (error_code, tcode) fixed bin (35); 4571 4572 dcl (ap, err_point, seg_base, sym_tab, p) 4573 ptr; 4574 4575 dcl length builtin; 4576 4577 declare component_info_$offset entry (ptr, fixed bin (18), ptr, fixed bin (35)), 4578 cu_$arg_count entry (fixed bin (18)), 4579 cu_$arg_list_ptr entry (ptr), 4580 cu_$arg_ptr entry (fixed bin, ptr, fixed bin, fixed bin (35)), 4581 cu_$gen_call entry (entry, ptr), 4582 get_entry_name_ entry (ptr, char (*), fixed bin (18), char (8) aligned, fixed bin (35)), 4583 hcs_$fs_get_path_name entry (ptr, char (*), fixed bin (18), char (*), fixed bin (35)), 4584 hcs_$status_mins entry (ptr, fixed bin (2), fixed bin (24), fixed bin (35)), 4585 object_info_$brief entry (ptr, fixed bin (24), ptr, fixed bin (35)), 4586 stack_frame_exit_ entry (ptr, ptr, ptr, bit (1), ptr, char (32), ptr), 4587 stu_$get_line_no entry (ptr, fixed bin (18), fixed bin (18), fixed bin (18)) 4588 returns (fixed bin (18)), 4589 stu_$get_runtime_line_no 4590 entry (ptr, fixed bin (18), fixed bin (18), fixed bin (18)) 4591 returns (fixed bin (18)); 4592 14 1 /* BEGIN INCLUDE SEGMENT ... component_info.incl.pl1 M. Weaver 4/26/72 */ 14 2 14 3 declare 1 ci aligned, 14 4 2 dcl_version fixed bin, /* version number of this structure */ 14 5 2 name char(32) aligned, /* objectname of component segment */ 14 6 2 text_start pointer, /* ptr to component's section of text */ 14 7 2 stat_start pointer, /* pointer to component's section of internal static */ 14 8 2 symb_start pointer, /* pointer to component's first symbol block */ 14 9 2 defblock_ptr pointer, /* ptr to component's definition block */ 14 10 2 text_lng fixed bin, /* length of text section */ 14 11 2 stat_lng fixed bin, /* length of internal static */ 14 12 2 symb_lng fixed bin, /* length of symbol section */ 14 13 2 n_blocks fixed bin, /* number of symbol blocks in component's symbol section */ 14 14 2 standard bit(1) aligned, /* indicates whether component is in standard (new) format */ 14 15 2 compiler char(8) aligned, /* name of component's compiler */ 14 16 2 compile_time fixed bin(71), /* time component was compiled */ 14 17 2 userid char(32) aligned, /* id of creator of component */ 14 18 2 cvers aligned, /* version of component's compiler in printable form */ 14 19 3 offset bit(18) unaligned, /* offset in words relative to symb_start */ 14 20 3 length bit(18) unaligned, /* length of name in characters */ 14 21 2 comment aligned, /* component's comment */ 14 22 3 offset bit(18) unaligned, /* offset in words relative to symb_start */ 14 23 3 length bit(18) unaligned, /* length of comment in characters */ 14 24 2 source_map fixed bin; /* offset, rel to beg of symbol block, of component's source map */ 14 25 14 26 /* END INCLUDE SEGMENT ... component_info.incl.pl1 */ 4593 15 1 /* BEGIN INCLUDE FILE ... object_info.incl.pl1 15 2*coded February 8, 1972 by Michael J. Spier */ 15 3 /* modified May 26, 1972 by M. Weaver */ 15 4 /* modified 15 April, 1975 by M. Weaver */ 15 5 15 6 declare 1 object_info aligned based, /* structure containing object info based, returned by object_info_ */ 15 7 2 version_number fixed bin, /* version number of current structure format (=2) */ 15 8 2 textp pointer, /* pointer to beginning of text section */ 15 9 2 defp pointer, /* pointer to beginning of definition section */ 15 10 2 linkp pointer, /* pointer to beginning of linkage section */ 15 11 2 statp pointer, /* pointer to beginning of static section */ 15 12 2 symbp pointer, /* pointer to beginning of symbol section */ 15 13 2 bmapp pointer, /* pointer to beginning of break map (may be null) */ 15 14 2 tlng fixed bin, /* length in words of text section */ 15 15 2 dlng fixed bin, /* length in words of definition section */ 15 16 2 llng fixed bin, /* length in words of linkage section */ 15 17 2 ilng fixed bin, /* length in words of static section */ 15 18 2 slng fixed bin, /* length in words of symbol section */ 15 19 2 blng fixed bin, /* length in words of break map */ 15 20 2 format, /* word containing bit flags about object type */ 15 21 3 old_format bit(1) unaligned, /* on if segment isn't in new format, i.e. has old style object map */ 15 22 3 bound bit(1) unaligned, /* on if segment is bound */ 15 23 3 relocatable bit(1) unaligned, /* on if seg has relocation info in its first symbol block */ 15 24 3 procedure bit(1) unaligned, /* on if segment is an executable object program */ 15 25 3 standard bit(1) unaligned, /* on if seg is in standard format (more than just standard map) */ 15 26 3 gate bit(1) unaligned, /* on if segment is a gate */ 15 27 3 separate_static bit(1) unaligned, /* on if static not in linkage */ 15 28 3 links_in_text bit(1) unaligned, /* on if there are threaded links in text */ 15 29 3 perprocess_static bit (1) unaligned, /* on if static is not to be per run unit */ 15 30 3 pad bit(27) unaligned, 15 31 2 entry_bound fixed bin, /* entry bound if segment is a gate */ 15 32 2 textlinkp pointer, /* ptr to first link in text */ 15 33 15 34 /* LIMIT OF BRIEF STRUCTURE */ 15 35 15 36 2 compiler char(8) aligned, /* name of processor which generated segment */ 15 37 2 compile_time fixed bin(71), /* clock reading of date/time object was generated */ 15 38 2 userid char(32) aligned, /* standard Multics id of creator of object segment */ 15 39 2 cvers aligned, /* generator version name in printable char string form */ 15 40 3 offset bit(18) unaligned, /* offset of name in words relative to base of symbol section */ 15 41 3 length bit(18) unaligned, /* length of name in characters */ 15 42 2 comment aligned, /* printable comment concerning generator or generation of segment */ 15 43 3 offset bit(18) unaligned, /* offset of comment in words relative to base of symbol section */ 15 44 3 length bit(18) unaligned, /* length of comment in characters */ 15 45 2 source_map fixed bin, /* offset, relative to base of symbol section, of source map structure */ 15 46 15 47 /* LIMIT OF DISPLAY STRUCTURE */ 15 48 15 49 2 rel_text pointer, /* pointer to text section relocation info */ 15 50 2 rel_def pointer, /* pointer to definition section relocation info */ 15 51 2 rel_link pointer, /* pointer to linkage section relocation info */ 15 52 2 rel_static pointer, /* pointer to static section relocation info */ 15 53 2 rel_symbol pointer, /* pointer to symbol section relocation info */ 15 54 2 text_boundary fixed bin, /* specifies mod of text section base boundary */ 15 55 2 static_boundary fixed bin, /* specifies mod of internal static base boundary */ 15 56 /* currently not used by system */ 15 57 2 default_truncate fixed bin, /* offset rel to symbp for binder to automatically trunc. symb sect. */ 15 58 2 optional_truncate fixed bin; /* offset rel to symbp for binder to optionally trunc. symb sect. */ 15 59 15 60 declare object_info_version_2 fixed bin int static init(2); 15 61 15 62 /* END INCLUDE FILE ... object_info.incl.pl1 */ 4594 16 1 dcl 1 symbol_header aligned based, 16 2 2 translator, /* dope for translator name */ 16 3 3 offset fixed bin(35), 16 4 3 code unal bit(9), 16 5 3 size unal bit(27), 16 6 2 version, /* dope for version name */ 16 7 3 offset fixed bin(35), 16 8 3 code unal bit(9), 16 9 3 size unal bit(27), 16 10 2 times, 16 11 3 creation fixed bin(71), 16 12 3 translation fixed bin(71), 16 13 2 root unal bit(18), 16 14 2 extension unal bit(18), 16 15 2 map unal bit(18), 16 16 2 n_files unal bit(18), 16 17 2 next_header unal bit(18), 16 18 2 bind_indicator unal bit(18), 16 19 2 text_size unal bit(18), 16 20 2 link_size unal bit(18), 16 21 2 program, /* dope for program name */ 16 22 3 offset fixed bin(35), 16 23 3 code unal bit(9), 16 24 3 size unal bit(27); 4595 4596 4597 dcl 1 oi aligned like object_info; 4598 4599 4600 /* GET ERROR CODE */ 4601 4602 call cu_$arg_ptr (1, p, 0, error_code); /* third arg is char len which is meaningless */ 4603 4604 if error_code = 0 4605 then error_code = p -> words (1); /* if call fails, FIOS error, so print why it failed */ 4606 4607 /* Save info about last error. */ 4608 4609 if my_code ^= 0 4610 then actual_error = my_code; 4611 else actual_error = error_code; 4612 4613 ps_at_error = PS_ptr; 4614 string (PS.job_bits) = string (fio_ps.job_bits); 4615 PS.element_p = fio_ps.element_p; 4616 PS.file_number = fio_ps.file_number; 4617 4618 /* IOSTAT FIELD - return the error code to the user instead of printing an error */ 4619 4620 if fio_ps.iostat_var 4621 then do; 4622 PS.iostat_p -> words (1) = error_code; /* copy into user's variable */ 4623 4624 if ^fio_ps.error_label /* If err= specified, it is handled below */ 4625 then goto return_error_code; 4626 end; 4627 4628 /* ERR FIELD - return to the user instead of printing an error */ 4629 4630 if fio_ps.error_label /* Return to user if err= specified. */ 4631 then call return_to_user (PS.error_p, PS.stack_frame_p); 4632 4633 /* OPENFILE ERRORS - print only if the file is subsequently referenced */ 4634 4635 if fio_ps.control_type = bit (openfile_opr, 4) 4636 then if fast_related_data_$in_dfast 4637 then if fio_ps.file_number >= 1 & fio_ps.file_number <= 99 4638 then do; 4639 num = fio_ps.file_number; 4640 4641 fortran_buffer_.table (num).previous = 0; 4642 /* indicates that file is not open */ 4643 fortran_buffer_.table (num).open_code = 1; 4644 /* how to decode the error message */ 4645 unspec (fortran_buffer_.table (num).switch_p) = unspec (error_code); 4646 /* a kludge but it works */ 4647 goto return_error_code; /* results in a return to the user */ 4648 end; 4649 4650 4651 /* PRINT AN ERROR MESSAGE */ 4652 4653 4654 /* End last output line BEFORE printing error message. */ 4655 4656 if fortran_buffer_.terminal_needs_newline 4657 then do; 4658 call iox_$put_chars (iox_$user_io, addr (NL), 1, tcode); 4659 fortran_buffer_.terminal_needs_newline = "0"b; 4660 end; 4661 4662 /* If caller provides extra info about the error, print caller's info first */ 4663 4664 call cu_$arg_count (num); 4665 4666 if num > 1 /* Will always have one argument. */ 4667 then do; 4668 call cu_$arg_list_ptr (ap); 4669 call cu_$gen_call (com_err_, ap); 4670 error_code = 0; 4671 end; 4672 4673 4674 /* PRINT LOCATION IN USER PROGRAM. */ 4675 4676 /* get return address in user's program */ 4677 4678 sp = PS.stack_frame_p; 4679 call stack_frame_exit_ (sp, null, null, "0"b, err_point, seg_name, addr (work)); 4680 /* Get return address. */ 4681 seg_base = ptr (err_point, 0); /* Base pointer. */ 4682 num, offset = binary (rel (err_point), 18); 4683 4684 /* get entry point name */ 4685 4686 call get_entry_name_ (sp -> stack_frame.entry_ptr, ent_name, 0, (8)" ", tcode); 4687 if tcode ^= 0 4688 then ent_name = " "; 4689 comp_name = substr (ent_name, 1, 32); /* In case not bound segment. */ 4690 4691 /* get status of object segment to see if it has a symbol table */ 4692 4693 call component_info_$offset (seg_base, offset, addr (ci), tcode); 4694 if tcode = 0 /* This is a bound segment. */ 4695 then do; 4696 sym_tab = ci.symb_start; 4697 std = ci.standard; 4698 offset = offset - binary (rel (ci.text_start), 18); 4699 comp_name = ci.name; 4700 end; 4701 else do; /* Not bound. */ 4702 call hcs_$status_mins (seg_base, 0, bit_cnt, tcode); 4703 /* Get bit count. */ 4704 if tcode ^= 0 4705 then go to no_line; /* No access. */ 4706 4707 oi.version_number = object_info_version_2; 4708 call object_info_$brief (seg_base, bit_cnt, addr (oi), tcode); 4709 if tcode ^= 0 4710 then go to no_line; 4711 4712 sym_tab = oi.symbp; 4713 std = oi.format.standard; 4714 end; 4715 4716 /* if object segment has symbol table, get line number */ 4717 4718 start = -1; 4719 if std 4720 then line_no = stu_$get_runtime_line_no (sym_tab, num, start, 0); 4721 else if sym_tab -> symbol_header.root ^= "0"b 4722 then line_no = stu_$get_line_no (addrel (sym_tab, sym_tab -> symbol_header.root), num, start, 0); 4723 4724 if start > 0 4725 then do; 4726 int_pic = line_no; 4727 substr (work, verify (work, SP) - 5, 4) = "Line"; 4728 end; 4729 else 4730 no_line: 4731 substr (work, 1, length (int_pic)) = SP; 4732 4733 /* get full pathname */ 4734 4735 call hcs_$fs_get_path_name (seg_base, dir_name, 0, seg_name, tcode); 4736 4737 /* PRINT THE ERROR MESSAGE */ 4738 4739 if fio_ps.mode = string_io | fio_ps.mode = internal_file 4740 then do; 4741 if fio_ps.mode = string_io 4742 then if fio_ps.read 4743 then op_name = "Decode"; 4744 else op_name = "Encode"; 4745 else if fio_ps.read 4746 then op_name = "Internal file read"; 4747 else op_name = "Internal file write"; 4748 4749 if (ent_name = seg_name) & (comp_name = seg_name) 4750 then call com_err_ (error_code, me, "^a statement error by ^a>^a|^o^a", op_name, dir_name, seg_name, 4751 offset, int_pic); 4752 else call com_err_ (error_code, me, "^a statement error by ^a>^a$^a at ^a|^o^a", op_name, dir_name, 4753 seg_name, ent_name, comp_name, offset, int_pic); 4754 end /* string_io */; 4755 4756 else do; 4757 4758 /* Convert request to char str. */ 4759 4760 if fio_ps.control_type ^= "0"b 4761 then do; 4762 cur_op = binary (fio_ps.control_type, 3, 0); 4763 op_name = ""; /* No qualifiers for control operations. */ 4764 end; 4765 else do; 4766 4767 if fio_ps.read 4768 then cur_op = read_opr; 4769 else cur_op = write_opr; 4770 4771 op_name = rtrim (format_type (binary (fio_ps.format, 2))); 4772 4773 if fio_ps.mode = direct_access 4774 then op_name = op_name || " direct access"; 4775 else op_name = op_name || " sequential"; 4776 end; 4777 4778 /* Print message. */ 4779 4780 if (ent_name = seg_name) & (comp_name = seg_name) 4781 then call com_err_ (error_code, me, "^a^a on file ^d.^/By ^a>^a|^o^a", op_name, 4782 operation_name (cur_op), fio_ps.file_number, 4783 /* info about request */ 4784 dir_name, seg_name, offset, int_pic); 4785 /* segment info */ 4786 else call com_err_ (error_code, me, "^a^a on file ^d.^/By ^a>^a$^a (^a|^o)^a", op_name, 4787 operation_name (cur_op), fio_ps.file_number, 4788 /* info about request */ 4789 dir_name, seg_name, ent_name, comp_name, offset, int_pic); 4790 /* segment info */ 4791 4792 if fio_ps.have_input & buffer_length > 0 4793 then do; 4794 call ioa_$ioa_switch (iox_$error_output, 4795 "Error occurred at character ^d of this record:^/""^a""", buffer_index + 1, io_buf); 4796 call ioa_$ioa_switch (iox_$error_output, "^vxI", buffer_index + 1); 4797 end; 4798 4799 if ^fast_related_data_$in_fast_or_dfast 4800 then call close_for_stop; 4801 end /* neither string_io nor internal_file */; 4802 4803 4804 /* TERMINATE THE RUN */ 4805 4806 /* SCP 6315 call another command level if the program was compiled 4807* with -debug_io otherwise just die gracefully 4808**/ 4809 if fio_ps.debug_io then call cu_$cl ("0"b); 4810 4811 if fast_related_data_$in_fast_or_dfast 4812 then call fast_related_data_$terminate_run; 4813 else call stop_run; 4814 4815 do while ("1"b); 4816 signal illegal_return; 4817 end; 4818 4819 end print_error; 4820 4821 /* Procedure for unformatted I/O. */ 4822 unformatted_io: 4823 proc; 4824 4825 /* get total size of element = element_size * element_count */ 4826 4827 call set_size_and_count (char_len, element_count, chars_per_item); 4828 char_len = chars_per_item * element_count; 4829 4830 /* Perform I/O. */ 4831 4832 if fio_ps.read 4833 then if file_desc.type_of_io ^= binary_file 4834 then do; /* Not binary file. Copy characters from buffer into variable. */ 4835 4836 if buffer_index + char_len > buffer_length 4837 then call too_much_input; 4838 4839 if ^fio_ps.element_desc.VLA 4840 then substr (fio_ps.element_p -> chars, 1, char_len) = substr (rest_of_record, 1, char_len); 4841 else do; 4842 chars_left = 4 * pl1_operators_$VLA_words_per_seg_ - char_pos (fio_ps.element_p) + 1; 4843 if char_len <= chars_left 4844 then substr (fio_ps.element_p -> chars, 1, char_len) = 4845 substr (rest_of_record, 1, char_len); 4846 else do; /* Target crosses into next VLA component. */ 4847 substr (fio_ps.element_p -> chars, 1, chars_left) = 4848 substr (rest_of_record, 1, chars_left); 4849 substr (baseptr (fixed (baseno (fio_ps.element_p)) + 1) -> chars, 1, 4850 char_len - chars_left) = 4851 substr (rest_of_record, chars_left + 1, char_len - chars_left); 4852 end; 4853 end; 4854 4855 buffer_index = buffer_index + char_len; 4856 /* Keep track of how many read */ 4857 end; /* code to read non binary file */ 4858 4859 else do; /* Binary file. Read data directly into the variable */ 4860 4861 if file_desc.double_word_file & ^fio_ps.double 4862 then call print_error (fortran_io_error_$dnumeric_file); 4863 4864 fio_ps.element_count = char_len; /* store length of item */ 4865 call read_a_record; /* read directly into the item */ 4866 end; /* code to read binary file */ 4867 4868 else do; /* Write logic. It is the same for all file types */ 4869 4870 if file_desc.double_word_file & ^fio_ps.double 4871 then call print_error (fortran_io_error_$dnumeric_file); 4872 4873 if buffer_length + char_len > buffer_max_len 4874 then call too_much_output; 4875 4876 if ^fio_ps.element_desc.VLA 4877 then substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len); 4878 else do; 4879 chars_left = 4 * pl1_operators_$VLA_words_per_seg_ - char_pos (fio_ps.element_p) + 1; 4880 if char_len <= chars_left 4881 then substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len); 4882 else do; /* Source crosses into next VLA component. */ 4883 substr (rest_of_output, 1, chars_left) = 4884 substr (fio_ps.element_p -> chars, 1, chars_left); 4885 substr (rest_of_output, chars_left + 1, char_len - chars_left) = 4886 substr (baseptr (fixed (baseno (fio_ps.element_p)) + 1) -> chars, 1, 4887 char_len - chars_left); 4888 end; 4889 end; 4890 4891 buffer_length = buffer_length + char_len; 4892 end; /* write logic */ 4893 4894 end unformatted_io; 4895 4896 /* Formatted I/O. */ 4897 formatted_io: 4898 proc; 4899 4900 4901 4902 /* Constants */ 4903 4904 dcl fixed_decimal fixed bin init (18) internal static options (constant); 4905 dcl ( 4906 READ_ init (30), 4907 WRITE_ init (0) 4908 ) fixed bin int static options (constant); 4909 declare MINUS_SIGN char (1) int static options (constant) init ("-"); 4910 declare PLUS_SIGN char (1) int static options (constant) init ("+"); 4911 4912 /* Automatic declarations. */ 4913 4914 dcl op_offset fixed bin; 4915 4916 dcl 1 field aligned, 4917 2 spec fixed bin, 4918 2 rep_factor fixed bin, 4919 2 width fixed bin, 4920 2 precision fixed bin, 4921 2 exponent fixed bin; 4922 4923 dcl 1 FORMAT aligned, 4924 2 indx fixed bin, 4925 2 scale fixed bin, 4926 2 paren_level fixed bin, 4927 2 restart (5) fixed bin, 4928 2 rep_factor (5) fixed bin; 4929 4930 declare blanks_as_null bit (1) aligned; 4931 declare leading_sign char (1); 4932 dcl infinite_format bit (1) aligned; 4933 dcl decimal_len fixed bin (35); 4934 dcl decimal_type fixed bin; 4935 dcl exponent fixed decimal (3); 4936 dcl (exp, negate) fixed bin; 4937 dcl add_zero bit (1) aligned; 4938 declare effective_digits fixed binary; 4939 declare digits_after_E fixed binary; 4940 declare x float binary; 4941 dcl lied_about_sign bit (1); 4942 4943 /* WARNING: This structure is based on the internal representation of extended float decimal data */ 4944 dcl 1 x_float aligned structure, 4945 2 char_pad char (11) unaligned, 4946 2 exp fixed bin (8) unaligned; 4947 4948 dcl x_flt float decimal (10) based (addr (x_float)); 4949 dcl scale fixed bin; 4950 dcl element_v float bin (63); 4951 dcl bin_int fixed bin (35); 4952 dcl min_field_width fixed bin; 4953 4954 /* Based variables. */ 4955 dcl ( 4956 float_bin float bin (27), 4957 logical bit (1) 4958 ) aligned based (fio_ps.element_p), 4959 in_fmt char (1024) aligned based (PS.user_format_p); 4960 dcl dec_int_picture char (12) based (addr (dec_int)); 4961 4962 /* constant */ 4963 4964 declare ten_to_the_power (-38:38) float bin (63) int static options (constant) 4965 init (1e-38, 1e-37, 1e-36, 1e-35, 1e-34, 1e-33, 1e-32, 1e-31, 1e-30, 1e-29, 4966 1e-28, 1e-27, 1e-26, 1e-25, 1e-24, 1e-23, 1e-22, 1e-21, 1e-20, 1e-19, 1e-18, 4967 1e-17, 1e-16, 1e-15, 1e-14, 1e-13, 1e-12, 1e-11, 1e-10, 1e-09, 1e-08, 1e-07, 4968 1e-06, 1e-05, 1e-04, 1e-03, 1e-02, 1e-01, 1e+00, 1e+01, 1e+02, 1e+03, 1e+04, 4969 1e+05, 1e+06, 1e+07, 1e+08, 1e+09, 1e+10, 1e+11, 1e+12, 1e+13, 1e+14, 1e+15, 4970 1e+16, 1e+17, 1e+18, 1e+19, 1e+20, 1e+21, 1e+22, 1e+23, 1e+24, 1e+25, 1e+26, 4971 1e+27, 1e+28, 1e+29, 1e+30, 1e+31, 1e+32, 1e+33, 1e+34, 1e+35, 1e+36, 1e+37, 4972 1e+38); 4973 4974 /* * * * * * * * * * * */ 4975 4976 call set_size_and_count (char_len, element_count, chars_per_item); 4977 4978 /* For complex data, we will treat the real and imaginary parts as separate elements. */ 4979 4980 if fio_ps.element_desc.complex 4981 then do; 4982 element_count = element_count * 2; 4983 char_len, chars_per_item = CPW; 4984 end; 4985 4986 goto format_routine (field.spec); 4987 4988 /* Unpack format as it is used in hopes of minimizing the cost of using it. */ 4989 4990 get_next_format: /* Come here to get next field if fmt is unpacked. */ 4991 fmt_ptr = addr (format_p -> runtime_format.fmt (FORMAT.indx)); 4992 FORMAT.indx = FORMAT.indx + 1; 4993 4994 field.spec = fmt_ptr -> format.spec + op_offset; 4995 goto unpack_format (field.spec); 4996 4997 4998 unpack_format (0): 4999 call unpack_two; 5000 goto i_format_common; 5001 unpack_format (22): /* output extended_i_format */ 5002 call unpack_three; 5003 i_format_common: 5004 infinite_format = "0"b; 5005 format_routine (22): 5006 format_routine (0): /* output i-format */ 5007 if element_count = 0 5008 then go to fmt_done; 5009 last = last + field.width; 5010 call expand_buffer; 5011 5012 /* Save the binary integer to be printed in 'bin_int', then convert it to */ 5013 /* decimal in 'dec_int'. Note that we refer to 'dec_int' through its alias */ 5014 /* 'dec_int_picture' because we know that the hardware representation is a */ 5015 /* character string consisting of a '+' or '-' followed by the ASCII form */ 5016 /* of the digits in the decimal value of the number. */ 5017 bin_int = fio_ps.element_p -> words (1); 5018 dec_int = bin_int; 5019 5020 /* Store the number of digits to be output in 'effective_digits'. */ 5021 if bin_int = 0 5022 then if field.spec = extended_i_format 5023 then effective_digits = field.precision; 5024 else effective_digits = 1; 5025 else do; 5026 effective_digits = length (dec_int_picture) - verify (dec_int_picture, "+-0") + 1; 5027 if field.spec = extended_i_format 5028 then if field.precision > effective_digits 5029 then effective_digits = field.precision; 5030 end; 5031 5032 /* Calculate the minimum field width needed to display the number and check */ 5033 /* that we actually have that much. */ 5034 min_field_width = effective_digits; 5035 if effective_digits > 0 /* i.e. if a sign is allowed */ 5036 then if bin_int < 0 | must_produce_plus 5037 then min_field_width = min_field_width + 1; 5038 if field.width - min_field_width < 0 5039 then goto print_stars; 5040 5041 /* If we have more field than needed, store enough spaces at the start of */ 5042 /* the field to take up the slack. */ 5043 if field.width - min_field_width > 0 5044 then do; 5045 substr (rest_of_field, 1, field.width - min_field_width) = ""; 5046 buffer_index = buffer_index + (field.width - min_field_width); 5047 end; 5048 5049 /* Store the sign if it's needed. */ 5050 if min_field_width > effective_digits 5051 then do; 5052 substr (rest_of_field, 1, 1) = substr (dec_int_picture, 1, 1); 5053 buffer_index = buffer_index + 1; 5054 end; 5055 5056 /* If more digits are required than we have in 'dec_int_picture', the extra */ 5057 /* digits must all be zeroes since 'dec_int' is big enough to hold any */ 5058 /* 'fixed bin (35)' value. */ 5059 do while (effective_digits >= length (dec_int_picture)); 5060 substr (rest_of_field, 1, 1) = "0"; 5061 buffer_index = buffer_index + 1; 5062 effective_digits = effective_digits - 1; 5063 end; 5064 5065 /* Store as many digits from the right end of 'dec_int_picture' as are */ 5066 /* needed to fill the field. */ 5067 substr (rest_of_field, 1, effective_digits) = 5068 substr (dec_int_picture, length (dec_int_picture) - effective_digits + 1, effective_digits); 5069 5070 goto countdown_element; 5071 5072 5073 unpack_format (1): 5074 call unpack_three; 5075 infinite_format = "0"b; 5076 5077 /* Assign_round_ is called to make a scaled fixed decimal according to the user's spec, if 5078*the number wont fit, fixedoverflow is signalled. If the relationship between the data 5079*precision and the size of the field causes a hardware fault this results in zerodivide 5080*being signalled. */ 5081 5082 format_routine (1): /* output f-format */ 5083 if element_count = 0 5084 then go to fmt_done; 5085 last = last + field.width; 5086 call expand_buffer; 5087 5088 if fio_ps.double 5089 then element_v = fio_ps.element_p -> based_dp; 5090 else element_v = fio_ps.element_p -> float_bin; 5091 5092 /* Set 'negate' equal to the sign bit of the element, except in '77 mode */ 5093 /* when the element is between -0.5 and 0, in which case we pretend the */ 5094 /* element is positive so that if it underflows the field we will not get */ 5095 /* minus zero as the result. */ 5096 5097 lied_about_sign = "0"b; 5098 if element_v >= 0 5099 then negate = 0; 5100 else if element_v > -0.5 & fio_ps.ansi_77 5101 then do; 5102 negate = 0; 5103 lied_about_sign = "1"b; 5104 end; 5105 else negate = 1; 5106 i = 1; 5107 call start_floating; 5108 scale = field.precision + FORMAT.scale; 5109 prec = field.width - negate - 1; 5110 decimal_len = prec + 262144 * scale; 5111 decimal_type = fixed_decimal; 5112 call create_decimal; /* Create fixed scaled decimal number. */ 5113 5114 if lied_about_sign /* If this point is reached and the flag is true, 5115* then an underflow did not occur in the create_decimal routine. */ 5116 then do; /* Drop the pretense that the element is positive. */ 5117 negate = 1; 5118 i = 1; 5119 call start_floating; 5120 if ^must_produce_plus 5121 then do; 5122 substr (number.digit, 1, prec - 1) = substr (number.digit, 2, prec - 1); 5123 /* Remove leftmost digit so the number corresponds to the proper precision. */ 5124 prec = prec - 1; /* Precision is one less since the element is negative. */ 5125 count = count - 1; 5126 end; 5127 end; 5128 if count >= prec - field.precision /* First non-zero digit is to right of decimal point. */ 5129 then if prec - field.precision = 0 5130 then count = 0; /* Print as .0... */ 5131 else count = (prec - field.precision) - 1; /* Print as 0.0... */ 5132 5133 i = field.width - count; 5134 call minus_sign; 5135 5136 i = prec - field.precision - count; 5137 if i > 0 5138 then do; 5139 substr (rest_of_record, 1, i) = substr (number.digit, count + 1, i); 5140 buffer_index = buffer_index + i; 5141 end; 5142 5143 substr (rest_of_record, 1, 1) = "."; 5144 5145 if field.precision > 0 5146 then substr (rest_of_record, 2, field.precision) = 5147 substr (number.digit, prec - field.precision + 1, field.precision); 5148 goto countdown_element; 5149 5150 5151 unpack_format (2): 5152 unpack_format (4): 5153 call unpack_four; 5154 infinite_format = "0"b; 5155 format_routine (2): /* output e-format */ 5156 format_routine (4): /* Output d-format */ 5157 /* e- and d-format should not raise any conditions. Conversion is done by assign_round_. */ 5158 if element_count = 0 5159 then go to fmt_done; 5160 last = last + field.width; 5161 call expand_buffer; 5162 5163 e_fmt: 5164 if fio_ps.element_p -> float_bin >= 0 5165 then negate = 0; 5166 else negate = 1; 5167 if field.exponent = 0 /* exponent not explict */ 5168 then do; 5169 digits_after_E = 2; /* ansi standard p 13-11 */ 5170 i = 5; /* reserved places, leading "." trailing "E+xx" */ 5171 end; 5172 else do; 5173 digits_after_E = field.exponent; 5174 i = field.exponent + 3; /* reserved for leading "." and exponent field */ 5175 end; 5176 call start_floating; 5177 5178 if FORMAT.scale <= 0 5179 then do; 5180 prec = field.precision + FORMAT.scale; 5181 if prec <= 0 5182 then goto print_stars; 5183 end; 5184 else do; 5185 prec = field.precision + 1; 5186 if prec < FORMAT.scale 5187 then goto print_stars; 5188 if ^add_zero 5189 then go to print_stars; 5190 end; 5191 5192 decimal_len = prec; 5193 decimal_type = ext_float_decimal; 5194 call create_decimal; 5195 5196 exponent = number.exp + prec - FORMAT.scale; 5197 if count > 0 5198 then do; 5199 number.digit = substr (number.digit, count + 1) || substr (number.digit, 1, count); 5200 exponent = exponent - count; 5201 end; 5202 if field.exponent = 0 & abs (exponent) > 99 5203 then digits_after_E = 3; 5204 5205 if abs (exponent) >= ten_to_the_power (digits_after_E) 5206 then goto print_stars; /* does exponent fit? */ 5207 call minus_sign; 5208 5209 if FORMAT.scale > 0 5210 then do; 5211 substr (rest_of_record, 1, FORMAT.scale) = substr (number.digit, 1, FORMAT.scale); 5212 count = FORMAT.scale; 5213 buffer_index = buffer_index + FORMAT.scale; 5214 end; 5215 else do; 5216 count = 0; 5217 if add_zero 5218 then do; 5219 substr (rest_of_record, 1, 1) = "0"; 5220 buffer_index = buffer_index + 1; 5221 end; 5222 end; 5223 5224 substr (rest_of_record, 1, 1) = "."; 5225 buffer_index = buffer_index + 1; 5226 5227 if FORMAT.scale < 0 5228 then do; 5229 substr (rest_of_field, 1, -FORMAT.scale) = copy ("0", -FORMAT.scale); 5230 buffer_index = buffer_index - FORMAT.scale; 5231 end; 5232 5233 if prec - count > 0 5234 then substr (rest_of_record, 1, prec - count) = substr (number.digit, count + 1, prec - count); 5235 buffer_index = buffer_index + prec - count; 5236 5237 /* include the E character if the exponent < 100 or the exponent length is specified */ 5238 if abs (exponent) < 100 | field.exponent > 0 5239 then do; 5240 if field.spec = d_format 5241 then substr (rest_of_record, 1, 1) = "D"; 5242 else substr (rest_of_record, 1, 1) = "E"; 5243 buffer_index = buffer_index + 1; 5244 end; 5245 5246 if exponent < 0 5247 then substr (rest_of_record, 1, 1) = MINUS_SIGN; 5248 else substr (rest_of_record, 1, 1) = PLUS_SIGN; 5249 buffer_index = buffer_index + 1; 5250 5251 /* in binary floating point, largest exponent (even with scale factor) is 2 5252* digits long so if exponent field is to be longer, we need to prefix zeros. 5253* Finally, put in the exponent as calculated at the end. In hex floating 5254* point, an exponent could be larger then 99. 5255**/ 5256 if abs (exponent) > 99 5257 then do; 5258 if digits_after_E > 3 5259 then do; 5260 substr (rest_of_record, 1, digits_after_E - 3) = copy ("0", digits_after_E - 3); 5261 buffer_index = buffer_index + digits_after_E - 3; 5262 end; 5263 substr (rest_of_record, 1, 3) = substr (addr (exponent) -> chars, 2, 3); 5264 end; 5265 else do; 5266 if digits_after_E > 2 5267 then do; 5268 substr (rest_of_record, 1, digits_after_E - 2) = copy ("0", digits_after_E - 2); 5269 buffer_index = buffer_index + digits_after_E - 2; 5270 end; 5271 effective_digits = min (digits_after_E, 2); 5272 substr (io_buf, last - effective_digits + 1, effective_digits) = 5273 substr (addr (exponent) -> chars, 5 - effective_digits, effective_digits); 5274 end; 5275 goto countdown_element; 5276 5277 5278 unpack_format (3): 5279 call unpack_two; 5280 infinite_format = "0"b; 5281 format_routine (3): /* output l-format */ 5282 if element_count = 0 5283 then go to fmt_done; 5284 last = last + field.width; 5285 call expand_buffer; 5286 if field.width - 1 > 0 5287 then substr (rest_of_record, 1, field.width - 1) = " "; 5288 5289 if logical 5290 then substr (io_buf, last, 1) = "T"; 5291 else substr (io_buf, last, 1) = "F"; 5292 goto countdown_element; 5293 5294 5295 unpack_format (5): 5296 call unpack_two; 5297 infinite_format = "0"b; 5298 format_routine (5): /* output o-format */ 5299 if element_count = 0 5300 then go to fmt_done; 5301 last = last + field.width; 5302 call expand_buffer; 5303 5304 count = chars_per_item * 3; 5305 if field.width > count 5306 then do; 5307 substr (rest_of_record, 1, field.width - count) = " "; 5308 buffer_index = buffer_index + (field.width - count); 5309 i = 0; 5310 end; 5311 else i = -3 * (field.width - count); 5312 5313 do i = i to count * 3 - 1 by 3; 5314 substr (rest_of_record, 1, 1) = 5315 substr ("01234567", binary (substr (fio_ps.element_p -> based_bits, i + 1, 3), 3) + 1, 1); 5316 buffer_index = buffer_index + 1; 5317 end; 5318 goto countdown_element; 5319 5320 5321 unpack_format (6): 5322 call unpack_four; 5323 infinite_format = "0"b; 5324 format_routine (6): /* output g-format */ 5325 if element_count = 0 5326 then go to fmt_done; 5327 last = last + field.width; 5328 call expand_buffer; 5329 5330 prec = field.precision; 5331 if prec = 0 | prec > max_float | prec > hbound (ten_to_the_power, 1) 5332 then go to e_fmt; 5333 else do; 5334 if fio_ps.job_bits.hfp 5335 then do; 5336 call assign_round_ (addr (x_float), ext_float_decimal, 10, fio_ps.element_p, 5337 binary_type (3), binary_prec (3)); 5338 if x_float.exp > (hbound (ten_to_the_power, 1) - 10) 5339 | x_float.exp < (-hbound (ten_to_the_power, 1) - 10) 5340 then goto e_fmt; 5341 x_float.exp = fixed (x_float.exp, 7); 5342 x = abs (x_flt); 5343 end; 5344 else x = abs (fio_ps.element_p -> float_bin); 5345 if x < 1.0e-1 | x >= ten_to_the_power (prec) 5346 then goto e_fmt; 5347 end; 5348 5349 if fio_ps.element_p -> float_bin >= 0 5350 then negate = 0; 5351 else negate = 1; 5352 if field.exponent = 0 5353 then do; /* not given, use defaults */ 5354 effective_digits = 4; 5355 i = 5; 5356 digits_after_E = 2; 5357 end; 5358 else do; /* set up user defined widths */ 5359 effective_digits = field.exponent + 2; 5360 i = field.exponent + 1; 5361 digits_after_E = field.exponent; 5362 end; 5363 call start_floating; 5364 5365 decimal_len = prec; 5366 decimal_type = ext_float_decimal; 5367 call create_decimal; 5368 5369 exp = prec - count + number.exp; 5370 if exp < 0 | exp > field.precision 5371 then go to e_fmt; 5372 5373 i = negate + 1 + field.precision - count + effective_digits; 5374 call minus_sign; 5375 5376 if exp > 0 5377 then do; 5378 substr (rest_of_record, 1, exp) = substr (number.digit, count + 1, exp); 5379 buffer_index = buffer_index + exp; 5380 count = count + exp; 5381 end; 5382 5383 substr (rest_of_record, 1, 1) = "."; 5384 buffer_index = buffer_index + 1; 5385 5386 if prec - count > 0 5387 then substr (rest_of_record, 1, prec - count) = substr (number.digit, count + 1, prec - count); 5388 5389 substr (io_buf, last - effective_digits + 1, effective_digits) = copy (SP, effective_digits); 5390 goto countdown_element; 5391 5392 5393 unpack_format (30): 5394 unpack_format (52): 5395 call unpack_two; 5396 infinite_format = "0"b; 5397 format_routine (30): /* input i-format */ 5398 format_routine (52): /* input extended i format */ 5399 if element_count = 0 5400 then go to fmt_done; 5401 last = last + field.width; 5402 call read_buffer; 5403 begin_index = buffer_index; /* For error message. */ 5404 i = verify (substr (rest_of_field, 1, field.width), " ") - 1; 5405 if i < 0 5406 then do; 5407 fixed_zero: 5408 fio_ps.element_p -> words (1) = 0; 5409 goto countdown_element; 5410 end; 5411 buffer_index = buffer_index + i; 5412 5413 dec_int = 0; 5414 if substr (rest_of_field, 1, 1) = "-" 5415 then do; 5416 substr (work, 1, 4) = "-000"; 5417 buffer_index = buffer_index + 1; 5418 if buffer_index >= last 5419 then goto fixed_zero; 5420 end; 5421 else if substr (rest_of_field, 1, 1) = "+" 5422 then do; 5423 buffer_index = buffer_index + 1; 5424 if buffer_index >= last 5425 then goto fixed_zero; 5426 end; 5427 5428 if verify (rest_of_field, " 0123456789") - 1 >= 0 5429 then do; 5430 buffer_index = buffer_index + (verify (rest_of_field, " 0123456789") - 1); 5431 call bad_char; 5432 end; 5433 5434 /* Leading spaces and zeroes are not significant: Skip them. */ 5435 i = verify (rest_of_field, " 0") - 1; 5436 if i < 0 5437 then goto fixed_zero; 5438 buffer_index = buffer_index + i; 5439 5440 call right_justify (addr (rest_of_field), length (rest_of_field), addr (number.digit), max_fixed, prec); 5441 /* Store significant digits in 'dec_int'. */ 5442 fio_ps.element_p -> words (1) = convert (my_code, dec_int); 5443 /* Convert decimal to binary. */ 5444 goto countdown_element; 5445 5446 5447 unpack_format (31): 5448 unpack_format (32): 5449 unpack_format (34): 5450 unpack_format (36): 5451 call unpack_three; 5452 infinite_format = "0"b; 5453 format_routine (31): /* input f-format */ 5454 format_routine (32): /* input e-format */ 5455 format_routine (34): /* input d-format */ 5456 format_routine (36): /* input g-format */ 5457 /* Convert external value to either single or double precision float binary. The 5458* precision of the float decimal source is derived from the external field, however a 5459* float dec(59) field is used for the conversion. There is no reason to translate blanks 5460* to zeros while creating the decimal value because the hardware treats blanks as zeros 5461* in decimal numbers. In ansi77, if we want blanks treated as null, we do it ourselves. */ 5462 if element_count = 0 5463 then go to fmt_done; 5464 last = last + field.width; 5465 call read_buffer; 5466 begin_index = buffer_index; /* For error message. */ 5467 i = verify (substr (rest_of_field, 1, field.width), " ") - 1; 5468 if i < 0 5469 then do; 5470 store_zero: 5471 if fio_ps.double 5472 then fio_ps.element_p -> based_dp = 0.0; 5473 else fio_ps.element_p -> float_bin = 0.0; 5474 goto countdown_element; 5475 end; 5476 buffer_index = buffer_index + i; 5477 5478 dec_flt = 0.0; 5479 if substr (rest_of_field, 1, 1) = "-" 5480 then do; 5481 substr (work, 1, 4) = "-000"; 5482 buffer_index = buffer_index + 1; 5483 if buffer_index >= last 5484 then goto store_zero; 5485 end; 5486 else if substr (rest_of_field, 1, 1) = "+" 5487 then do; 5488 buffer_index = buffer_index + 1; 5489 if buffer_index >= last 5490 then goto store_zero; 5491 end; 5492 5493 /* Leading spaces and zeroes are not significant: Skip them. */ 5494 i = verify (rest_of_field, " 0") - 1; 5495 if i < 0 5496 then goto store_zero; 5497 buffer_index = buffer_index + i; 5498 5499 /* "e" will be reset if there is a decimal point, otherwise, the value of d will be used. 5500* "exp" will be reset if there is an exponent, otherwise, the value of the scale will be used. */ 5501 e = field.precision; 5502 exp = -FORMAT.scale; 5503 5504 /* Get any digits which appear before the decimal point. */ 5505 l = verify (rest_of_field, " 0123456789") - 1; 5506 if l ^= 0 /* Found some digits. */ 5507 then do; 5508 if l < 0 5509 then l = length (rest_of_field); 5510 call left_justify (addr (rest_of_field), (l), addr (number.digit), max_float, prec); 5511 buffer_index = buffer_index + l; 5512 if last - buffer_index = 0 5513 then go to finish_float; 5514 end; 5515 else prec = 0; /* No digits yet. */ 5516 5517 /* Check for decimal point. If it exists, skip it and concatenate any digits which may follow it. */ 5518 ch = substr (rest_of_record, 1, 1); 5519 if ch = "." 5520 then do; 5521 buffer_index = buffer_index + 1; /* Skip over it. */ 5522 e = 0; /* The exponent if "." is last char in field. */ 5523 if last - buffer_index <= 0 5524 then go to finish_float; 5525 5526 /* Set 'l' to the size of the fraction part (i.e. the number of spaces and */ 5527 /* digits after the decimal point) and process it. */ 5528 l = verify (rest_of_field, " 0123456789") - 1; 5529 if l ^= 0 /* Digits after the decimal point. */ 5530 then do; 5531 if l < 0 5532 then l = last - buffer_index; 5533 5534 /* Trailing spaces and zeroes in the fraction part are not significant. If */ 5535 /* the fraction part is all zeroes and spaces, ignore it; otherwise set 'j' */ 5536 /* to the number of trailing zeroes and spaces and process it. */ 5537 j = verify (reverse (substr (rest_of_field, 1, l)), " 0") - 1; 5538 if j >= 0 5539 then do; /* There is at least 1 significant digit. */ 5540 5541 /* If there were any significant digits before the decimal point, then all */ 5542 /* but the last 'j' digits of the fraction part are significant. But if */ 5543 /* there were no significant digits before the decimal, leading spaces and */ 5544 /* zeroes in the fraction part are not significant. Set 'i' to the number */ 5545 /* of insignificant leading digits and spaces in the fraction part. Set */ 5546 /* 'e' to the number of decimal places before the first significant digit */ 5547 /* of the fraction part. */ 5548 if prec = 0 /* There were no digits before the decimal point. */ 5549 then do; 5550 i = verify (substr (rest_of_record, 1, l - j), " 0") - 1; 5551 if i < 0 5552 then i = l - j; 5553 e = i; 5554 if blanks_as_null 5555 then do k = 1 to i; 5556 if substr (rest_of_field, k, 1) = " " 5557 then e = e - 1; 5558 end; 5559 end; 5560 else i = 0; 5561 call left_justify (addr (substr (rest_of_field, i + 1)), l - i - j, 5562 addr (substr (number.digit, prec + 1)), max_float - prec, str_len); 5563 e = e + str_len; 5564 prec = prec + str_len; 5565 end; 5566 buffer_index = buffer_index + l; 5567 if last - buffer_index = 0 5568 then go to finish_float; 5569 end; 5570 ch = substr (rest_of_record, 1, 1); 5571 end; 5572 5573 /* Either we have an exponent field or a syntax error. */ 5574 exp = 0; /* Wipe out scale factor. */ 5575 dexp = 0; /* Zero this field for expon conversion. */ 5576 if index (exps, ch) ^= 0 5577 then do; 5578 buffer_index = buffer_index + 1; 5579 if last - buffer_index = 0 5580 then call syntax_error; /* "e" as last character in field */ 5581 i = verify (rest_of_field, " "); 5582 if i = 0 5583 then go to finish_float; 5584 buffer_index = buffer_index + i - 1; 5585 ch = substr (rest_of_record, 1, 1); 5586 end; 5587 if ch = "+" 5588 then do; 5589 buffer_index = buffer_index + 1; 5590 if buffer_index = last 5591 then call syntax_error; /* "+" as last character */ 5592 end; 5593 else if ch = "-" 5594 then do; 5595 substr (addr (dexp) -> chars, 1, 4) = "-000"; 5596 buffer_index = buffer_index + 1; 5597 if buffer_index = last 5598 then call syntax_error; /* "-" is the last char */ 5599 end; 5600 5601 /* At this point we had better have digits or else the end of the field. */ 5602 5603 if verify (rest_of_field, " 0123456789") - 1 >= 0 5604 then do; 5605 buffer_index = buffer_index + (verify (substr (rest_of_field, 1, prec), " 0123456789") - 1); 5606 call bad_char; 5607 end; 5608 5609 /* Leading spaces and zeroes are not significant: Skip them. */ 5610 i = verify (rest_of_field, " 0") - 1; 5611 if i < 0 5612 then goto finish_float; 5613 buffer_index = buffer_index + i; 5614 5615 /* Store the digits of the exponent in 'dexp', then assign it to 'exp'. */ 5616 call right_justify (addr (rest_of_field), length (rest_of_field), addr (substr (addr (dexp) -> chars, 2)), 3, 5617 str_len); 5618 exp = dexp; 5619 5620 finish_float: 5621 if prec = 0 5622 then go to store_zero; 5623 e = exp - e + prec - max_float; 5624 5625 if e >= 255 5626 then call conversion_error; 5627 else if e <= -256 5628 then call conversion_error; 5629 5630 flt_dec.exp = e; 5631 5632 if fio_ps.job_bits.hfp 5633 then bin_type = 3; 5634 else bin_type = 1; 5635 if fio_ps.double 5636 then bin_type = bin_type + 1; 5637 call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), addr (work), 5638 ext_float_decimal, (max_float)); 5639 goto countdown_element; 5640 5641 5642 unpack_format (33): 5643 call unpack_two; 5644 infinite_format = "0"b; 5645 format_routine (33): /* input l-format */ 5646 if element_count = 0 5647 then go to fmt_done; 5648 last = last + field.width; 5649 call read_buffer; 5650 5651 i = verify (substr (rest_of_field, 1, field.width), " "); 5652 5653 logical = "0"b; 5654 if i > 0 5655 then do; 5656 if substr (rest_of_field, i, 1) = "t" | substr (rest_of_field, i, 1) = "T" 5657 then logical = "1"b; 5658 else if substr (rest_of_field, i, min (field.width - i + 1, 2)) = ".t" 5659 | substr (rest_of_field, i, min (field.width - i + 1, 2)) = ".T" 5660 then logical = "1"b; 5661 end; 5662 goto countdown_element; 5663 5664 5665 unpack_format (35): 5666 call unpack_two; 5667 infinite_format = "0"b; 5668 format_routine (35): /* input o-format */ 5669 if element_count = 0 5670 then go to fmt_done; 5671 last = last + field.width; 5672 call read_buffer; 5673 5674 begin_index = buffer_index; /* For error message. */ 5675 i = verify (substr (rest_of_field, 1, field.width), " ") - 1; 5676 if i < 0 5677 then do; 5678 if fio_ps.double 5679 then fio_ps.element_p -> double_word = 0; 5680 else fio_ps.element_p -> words (1) = 0; 5681 goto countdown_element; 5682 end; 5683 buffer_index = buffer_index + i; 5684 5685 if substr (rest_of_field, 1, 1) = "-" 5686 then do; 5687 buffer_index = buffer_index + 1; 5688 negate = -1; 5689 end; 5690 else if substr (rest_of_field, 1, 1) = "+" 5691 then do; 5692 buffer_index = buffer_index + 1; 5693 negate = 0; 5694 end; 5695 else negate = 0; 5696 5697 addr (work) -> double_word = 0; 5698 in = (24 - (last - buffer_index)) * 3; 5699 5700 do buffer_index = buffer_index to last - 1; 5701 ch = substr (rest_of_record, 1, 1); 5702 if ch ^= " " 5703 then do; 5704 base = index ("01234567", ch) - 1; 5705 if base < 0 5706 then call bad_char; 5707 if in >= 0 5708 then substr (addr (work) -> based_bits, in + 1, 3) = bit (base, 3); 5709 end; 5710 in = in + 3; 5711 end; 5712 5713 if negate < 0 5714 then addr (work) -> double_word = -addr (work) -> double_word; 5715 if fio_ps.double 5716 then fio_ps.element_p -> double_word = addr (work) -> double_word; 5717 else fio_ps.element_p -> words (1) = addr (work) -> words (2); 5718 goto countdown_element; 5719 5720 5721 5722 unpack_format (7): 5723 unpack_format (8): 5724 unpack_format (37): 5725 unpack_format (38): 5726 format_routine (37): 5727 format_routine (38): /* Illegal types. */ 5728 format_routine (7): 5729 format_routine (8): 5730 call print_error (fortran_io_error_$fio_sys_error, me, "Invalid format."); 5731 5732 5733 unpack_format (39): 5734 call unpack_two; 5735 infinite_format = "0"b; 5736 format_routine (39): /* Input "r" format. */ 5737 if element_count = 0 5738 then go to fmt_done; 5739 last = last + field.width; 5740 call read_buffer; 5741 if field.width - char_len >= 0 5742 then do; 5743 buffer_index = buffer_index + (field.width - char_len); 5744 in = char_len; 5745 j = 0; 5746 end; 5747 else do; 5748 in = field.width; 5749 unspec (substr (fio_ps.element_p -> chars, 1, char_len)) = "0"b; 5750 j = char_len - field.width; 5751 end; 5752 substr (fio_ps.element_p -> chars, j + 1, in) = substr (rest_of_record, 1, in); 5753 go to countdown_element; 5754 5755 5756 unpack_format (9): 5757 call unpack_two; 5758 infinite_format = "0"b; 5759 format_routine (9): /* Output "r" format. */ 5760 if element_count = 0 5761 then go to fmt_done; 5762 last = last + field.width; 5763 call expand_buffer; 5764 if field.width - char_len > 0 5765 then do; 5766 substr (rest_of_record, 1, field.width - char_len) = " "; 5767 buffer_index = buffer_index + (field.width - char_len); 5768 j = 0; 5769 end; 5770 else j = char_len - field.width; 5771 substr (rest_of_record, 1, char_len - j) = substr (fio_ps.element_p -> chars, j + 1, char_len - j); 5772 go to countdown_element; 5773 5774 5775 unpack_format (10): 5776 call unpack_two; 5777 effective_digits = field.width; 5778 infinite_format = "0"b; 5779 format_routine (10): /* Output "a" format. */ 5780 if element_count = 0 5781 then go to fmt_done; 5782 5783 /* since width must ALWAYS be positive, a ZERO value means use unspecified a_format, 5784* i.e., let the width of the field be the number of characters in the data item */ 5785 if field.width = 0 5786 then effective_digits = char_len; 5787 last = last + effective_digits; 5788 call expand_buffer; 5789 5790 if effective_digits - char_len > 0 5791 then do; 5792 substr (rest_of_record, 1, effective_digits - char_len) = " "; 5793 buffer_index = buffer_index + (effective_digits - char_len); 5794 i = char_len; 5795 end; 5796 else i = effective_digits; 5797 substr (rest_of_record, 1, i) = substr (fio_ps.element_p -> chars, 1, i); 5798 go to countdown_element; 5799 5800 5801 unpack_format (40): 5802 call unpack_two; 5803 effective_digits = field.width; 5804 infinite_format = "0"b; 5805 format_routine (40): /* Input "a" format. */ 5806 if element_count = 0 5807 then go to fmt_done; 5808 if field.width = 0 /* see comment on output for signifigance */ 5809 then effective_digits = char_len; 5810 last = last + effective_digits; 5811 call read_buffer; 5812 5813 if effective_digits - char_len > 0 5814 then do; 5815 buffer_index = buffer_index + (effective_digits - char_len); 5816 in = char_len; 5817 end; 5818 else in = effective_digits; 5819 substr (fio_ps.element_p -> chars, 1, char_len) = substr (rest_of_record, 1, in); 5820 go to countdown_element; 5821 5822 5823 unpack_format (11): 5824 unpack_format (19): 5825 call unpack_two; 5826 format_routine (11): /* Output hollerith field. */ 5827 format_routine (19): 5828 last = last + field.rep_factor; 5829 call expand_buffer; 5830 substr (rest_of_record, 1, field.rep_factor) = substr (in_fmt, field.width, field.rep_factor); 5831 buffer_index = last; 5832 goto get_next_format; 5833 5834 5835 unpack_format (41): 5836 unpack_format (49): 5837 call unpack_two; 5838 format_routine (41): /* Input hollerith field. */ 5839 format_routine (49): 5840 last = last + field.rep_factor; 5841 call read_buffer; 5842 substr (in_fmt, field.width, field.rep_factor) = substr (rest_of_record, 1, field.rep_factor); 5843 buffer_index = last; 5844 goto get_next_format; 5845 5846 5847 unpack_format (42): 5848 unpack_format (12): 5849 call unpack_one; 5850 format_routine (42): /* Input X format. */ 5851 format_routine (12): /* Output X format. */ 5852 last = last + field.rep_factor; 5853 if op_offset = WRITE_ & ^fio_ps.ansi_77 5854 then do; /* Transmit specified number of spaces. */ 5855 call expand_buffer; 5856 substr (rest_of_record, 1, field.rep_factor) = ""; 5857 end; 5858 buffer_index = last; 5859 goto get_next_format; 5860 5861 5862 unpack_format (43): 5863 unpack_format (51): 5864 unpack_format (13): 5865 unpack_format (21): 5866 call unpack_two; 5867 format_routine (43): /* Input T format. */ 5868 format_routine (51): /* Input TL or TR formats. */ 5869 format_routine (13): /* Output T format. */ 5870 format_routine (21): /* Output TL or TR formats. */ 5871 if field.spec = t_format | field.spec = t_format + op_offset 5872 then last = field.width - 1 + column_one; 5873 else last = max (column_one, field.width + last); 5874 if op_offset = WRITE_ & ^fio_ps.ansi_77 5875 then call read_buffer; 5876 buffer_index = last; 5877 goto get_next_format; 5878 5879 5880 unpack_format (14): 5881 unpack_format (44): 5882 call unpack_one; 5883 format_routine (44): /* Process scale factor here. */ 5884 format_routine (14): 5885 FORMAT.scale = field.rep_factor; 5886 go to get_next_format; 5887 5888 5889 unpack_format (15): 5890 unpack_format (45): 5891 call unpack_one; 5892 format_routine (45): 5893 format_routine (15): /* "(" Check maximum level of parentheses. */ 5894 FORMAT.paren_level = FORMAT.paren_level + 1; 5895 if FORMAT.paren_level > hbound (FORMAT.restart, 1) 5896 then call print_error (fortran_io_error_$parens_too_deep, me, "Maximum is ^d.", hbound (FORMAT.restart, 1)); 5897 5898 FORMAT.rep_factor (FORMAT.paren_level) = field.rep_factor; 5899 FORMAT.restart (FORMAT.paren_level) = FORMAT.indx; 5900 go to get_next_format; 5901 5902 5903 unpack_format (16): 5904 unpack_format (46): 5905 format_routine (46): 5906 format_routine (16): /* ")" Bump counter and move on if done. */ 5907 if FORMAT.paren_level <= 0 5908 then goto get_next_format; 5909 FORMAT.rep_factor (FORMAT.paren_level) = FORMAT.rep_factor (FORMAT.paren_level) - 1; 5910 if FORMAT.rep_factor (FORMAT.paren_level) <= 0 5911 then FORMAT.paren_level = FORMAT.paren_level - 1; 5912 else FORMAT.indx = FORMAT.restart (FORMAT.paren_level); 5913 go to get_next_format; 5914 5915 countdown_element: 5916 element_count = element_count - 1; 5917 call advance_element_p; 5918 buffer_index = last; 5919 field.rep_factor = field.rep_factor - 1; 5920 if field.rep_factor <= 0 5921 then goto get_next_format; 5922 go to format_routine (field.spec); 5923 5924 5925 unpack_format (18): 5926 unpack_format (48): 5927 format_routine (48): /* :-format */ 5928 format_routine (18): 5929 if element_count = 0 5930 then go to fmt_done; 5931 go to get_next_format; 5932 5933 5934 unpack_format (50): 5935 format_routine (50): /* End of format statement for input. */ 5936 if element_count = 0 5937 then goto fmt_done; 5938 if infinite_format 5939 then call print_error (fortran_io_error_$format_is_infinite); 5940 infinite_format = "1"b; 5941 FORMAT.indx = format_p -> runtime_format.last_left_paren; 5942 FORMAT.paren_level = 0; 5943 5944 5945 unpack_format (47): 5946 format_routine (47): /* "/" Start a new input record. */ 5947 call read_a_record; 5948 buffer_index, last = 0; 5949 if skip_line_numbers 5950 then call strip_line_no (/* buffer_index, last */); 5951 goto get_next_format; 5952 5953 5954 unpack_format (20): 5955 format_routine (20): /* End of format statement for output. */ 5956 if element_count = 0 5957 then do; 5958 fmt_done: 5959 return; 5960 end; 5961 if infinite_format 5962 then call print_error (fortran_io_error_$format_is_infinite); 5963 infinite_format = "1"b; 5964 FORMAT.indx = format_p -> runtime_format.last_left_paren; 5965 FORMAT.paren_level = 0; 5966 if suppress_final_newline 5967 then go to get_next_format; 5968 5969 5970 unpack_format (17): 5971 format_routine (17): /* "/" Start a new output record. */ 5972 call write_a_record; 5973 buffer_index, last = buffer_length; 5974 goto get_next_format; 5975 5976 unpack_format (25): 5977 unpack_format (55): 5978 format_routine (25): 5979 format_routine (55): /* BN format - treat blanks as null */ 5980 blanks_as_null = "1"b; 5981 goto get_next_format; 5982 5983 unpack_format (26): 5984 unpack_format (56): 5985 format_routine (26): 5986 format_routine (56): /* BZ format - treat blanks as zero */ 5987 blanks_as_null = "0"b; 5988 goto get_next_format; 5989 5990 unpack_format (27): 5991 unpack_format (57): 5992 format_routine (27): /* S format (ansi77) */ 5993 format_routine (57): /* leading plus sign on output processor dependent */ 5994 must_produce_plus = "0"b; 5995 goto get_next_format; 5996 5997 unpack_format (28): 5998 unpack_format (58): 5999 format_routine (28): /* SP format (ansi77) */ 6000 format_routine (58): /* leading plus sign required on output */ 6001 must_produce_plus = "1"b; 6002 goto get_next_format; 6003 6004 unpack_format (29): 6005 unpack_format (59): 6006 format_routine (29): /* SS format (ansi77) */ 6007 format_routine (59): /* leading plus sign forbidden on output */ 6008 must_produce_plus = "0"b; 6009 goto get_next_format; 6010 6011 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6012 6013 print_zero: 6014 call minus_sign; /* all relevant values are already calculated */ 6015 6016 if add_zero /* also calculated */ 6017 then do; 6018 substr (rest_of_record, 1, 1) = "0"; 6019 buffer_index = buffer_index + 1; 6020 end; 6021 6022 substr (rest_of_record, 1, 1) = "."; 6023 6024 if field.precision > 0 6025 then substr (rest_of_record, 2, field.precision) = copy ("0", field.precision); 6026 6027 buffer_index = buffer_index + (field.precision + 1); 6028 if buffer_index = last 6029 then goto countdown_element; /* f-format exits here */ 6030 6031 if FORMAT.scale > 0 & field.precision ^= 0 6032 then substr (rest_of_field, 1, 1) = "0"; 6033 6034 if field.spec = d_format 6035 then substr (io_buf, last - digits_after_E - 1, 2) = "D+"; 6036 else substr (io_buf, last - digits_after_E - 1, 2) = "E+"; 6037 substr (io_buf, last - digits_after_E + 1, digits_after_E) = copy ("0", digits_after_E); 6038 goto countdown_element; 6039 6040 print_stars: 6041 substr (rest_of_field, 1, field.width) = copy ("*", field.width); 6042 go to countdown_element; 6043 6044 print_blanks: 6045 substr (rest_of_field, 1, field.width) = copy (SP, field.width); 6046 go to countdown_element; 6047 6048 /* Entry to initialize formatted I/O. */ 6049 6050 initialize_formatted_io: 6051 entry; 6052 6053 if fio_ps.read 6054 then buffer_index = 0; /* Must be set before call to print_error */ 6055 6056 if PS.user_format_p -> runtime_format.version = fmt_parse_ver1 6057 then format_p = PS.user_format_p; 6058 else do; 6059 call general_format_parse_$runtime (in_fmt, work_str, (fio_ps.ansi_77), my_code); 6060 6061 if my_code ^= 0 6062 then call print_error (fortran_io_error_$format_error, me, "^a^/""^a""", 6063 addr (work_str) -> error_message, substr (in_fmt, 1, addr (work_str) -> input_length)); 6064 else format_p = addr (work_str); 6065 end; 6066 6067 have_runtime_format = "1"b; 6068 6069 skip_line_numbers = format_p -> runtime_format.skip_line_numbers; 6070 6071 if format_p -> runtime_format.suppress_newline 6072 then suppress_final_newline = "1"b; 6073 6074 must_produce_plus = "0"b; 6075 blanks_as_null = file_desc.blank_null; 6076 6077 if format_p -> runtime_format.list_directed /* If v-format then this is list-directed I/O */ 6078 then do; 6079 if fio_ps.read 6080 then if skip_line_numbers 6081 then call strip_line_no (); 6082 6083 go to initiate_routine (0); 6084 end; 6085 6086 6087 if fio_ps.list & ^format_p -> runtime_format.anyitems 6088 /* format would loop forever */ 6089 then call print_error (fortran_io_error_$format_is_infinite); 6090 6091 6092 /* Initialize local variables. */ 6093 6094 buffer_index = 0; /* Must be set before call to strip_line_no */ 6095 last = 0; 6096 FORMAT.indx = 1; 6097 FORMAT.paren_level = 0; 6098 FORMAT.scale = 0; 6099 element_count = 0; 6100 infinite_format = "0"b; 6101 6102 if fio_ps.read 6103 then do; 6104 if skip_line_numbers 6105 then call strip_line_no (/* buffer_index, last */); 6106 op_offset = READ_; 6107 overflow_label = conversion_error_handler; 6108 zero_label = no_handler; 6109 end; 6110 else do; 6111 if skip_line_numbers 6112 then call print_error (fortran_io_error_$format_error, me, 6113 "Line number stripping only allowed during input."); 6114 op_offset = WRITE_; 6115 overflow_label = print_stars; 6116 zero_label = print_stars; 6117 end; 6118 goto get_next_format; 6119 6120 /* Internal procedures to unpack format specifiactions. */ 6121 6122 unpack_one: 6123 proc; 6124 if fmt_ptr -> format.long_format 6125 then field.rep_factor = fmt_ptr -> long_format.rep_factor; 6126 else field.rep_factor = fmt_ptr -> format.rep_factor; 6127 end unpack_one; 6128 6129 unpack_two: 6130 proc; 6131 if fmt_ptr -> format.long_format 6132 then do; 6133 FORMAT.indx = FORMAT.indx + 1; 6134 field.rep_factor = fmt_ptr -> long_format.rep_factor; 6135 field.width = fmt_ptr -> long_format.width; 6136 end; 6137 else do; 6138 field.rep_factor = fmt_ptr -> format.rep_factor; 6139 field.width = fmt_ptr -> format.width; 6140 end; 6141 end unpack_two; 6142 6143 unpack_three: 6144 proc; 6145 if fmt_ptr -> format.long_format 6146 then do; 6147 FORMAT.indx = FORMAT.indx + 1; 6148 field.rep_factor = fmt_ptr -> long_format.rep_factor; 6149 field.width = fmt_ptr -> long_format.width; 6150 field.precision = fmt_ptr -> long_format.precision; 6151 end; 6152 else do; 6153 field.rep_factor = fmt_ptr -> format.rep_factor; 6154 field.width = fmt_ptr -> format.width; 6155 field.precision = fmt_ptr -> format.precision; 6156 end; 6157 end unpack_three; 6158 6159 unpack_four: 6160 proc; 6161 if fmt_ptr -> format.long_format 6162 then do; 6163 FORMAT.indx = FORMAT.indx + 1; 6164 field.rep_factor = fmt_ptr -> long_format.rep_factor; 6165 field.width = fmt_ptr -> long_format.width; 6166 field.precision = fmt_ptr -> long_format.precision; 6167 field.exponent = fmt_ptr -> long_format.exponent; 6168 end; 6169 else do; 6170 field.rep_factor = fmt_ptr -> format.rep_factor; 6171 field.width = fmt_ptr -> format.width; 6172 field.precision = fmt_ptr -> format.precision; 6173 field.exponent = 0; 6174 end; 6175 end unpack_four; 6176 6177 6178 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6179 6180 /* Internal procedures to convert from binary to character under format control. */ 6181 6182 start_floating: 6183 proc; 6184 if negate ^= 0 6185 then leading_sign = MINUS_SIGN; 6186 else if must_produce_plus 6187 then do; 6188 negate = 1; 6189 leading_sign = PLUS_SIGN; 6190 end; 6191 6192 /* Check if there is room for a leading zero. */ 6193 i = field.precision + i + negate; 6194 if i > field.width 6195 then go to print_stars; 6196 if i < field.width 6197 then do; 6198 add_zero = "1"b; 6199 i = i + 1; 6200 end; 6201 else add_zero = "0"b; 6202 end start_floating; 6203 6204 6205 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6206 6207 create_decimal: 6208 proc; 6209 6210 if fio_ps.job_bits.hfp 6211 then bin_type = 3; 6212 else bin_type = 1; 6213 if fio_ps.double 6214 then bin_type = bin_type + 1; 6215 6216 if prec <= 0 | prec > max_float 6217 then go to print_stars; 6218 call assign_round_ (addr (work), decimal_type, decimal_len, fio_ps.element_p, binary_type (bin_type), 6219 binary_prec (bin_type)); 6220 count = verify (number.digit, "0") - 1; 6221 if count < 0 6222 then go to print_zero; 6223 end create_decimal; 6224 6225 6226 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6227 6228 minus_sign: 6229 proc; 6230 if field.width - i > 0 6231 then do; 6232 substr (rest_of_record, 1, field.width - i) = " "; 6233 buffer_index = buffer_index + (field.width - i); 6234 end; 6235 6236 /* Put out leading sign if it is required. */ 6237 6238 if negate ^= 0 6239 then do; 6240 substr (rest_of_record, 1, 1) = leading_sign; 6241 buffer_index = buffer_index + 1; 6242 end; 6243 end minus_sign; 6244 6245 6246 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6247 6248 /* Internal procedure to maintain output buffer size and incidentally detect some end of file conditions in internal_files */ 6249 6250 expand_buffer: 6251 proc; 6252 6253 if last > buffer_max_len 6254 then if fio_ps.mode = internal_file & internal_file_count <= 0 6255 then call internal_file_overflow; 6256 else call too_much_output; 6257 if last > buffer_length 6258 then do; 6259 if buffer_index > buffer_length 6260 then substr (io_buf, buffer_length + 1, buffer_index - buffer_length) = ""; 6261 buffer_length = last; 6262 end; 6263 end expand_buffer; 6264 6265 6266 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6267 6268 /* Internal procedure to grow a read buffer and blank the grown area. */ 6269 6270 read_buffer: 6271 proc; 6272 6273 if last > buffer_max_len 6274 then if op_offset = WRITE_ 6275 then call too_much_output; 6276 else call too_much_input; 6277 if last <= buffer_length 6278 then return; 6279 substr (io_buf, buffer_length + 1, last - buffer_length) = " "; 6280 buffer_length = last; 6281 6282 end read_buffer; 6283 6284 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6285 6286 /* Internal procedure to store a given character string left justified in */ 6287 /* another string, with spaces optionally deleted. */ 6288 6289 left_justify: 6290 proc (source_ptr, source_len, result_ptr, result_len, chars_stored); 6291 6292 dcl source_ptr ptr, /* Address of source string. */ 6293 source_len fixed bin, /* Length of source string. */ 6294 result_ptr ptr, /* Address of result string. */ 6295 result_len fixed bin, /* Length of result string. */ 6296 chars_stored fixed bin; /* Number of chars stored in result. */ 6297 6298 dcl piece_len fixed bin, 6299 source_idx fixed bin; 6300 6301 dcl result char (result_len) based (result_ptr), 6302 source char (source_len) based (source_ptr); 6303 6304 chars_stored = 0; 6305 if blanks_as_null 6306 then do source_idx = source_len + 1 - length (ltrim (source)) 6307 repeat source_len + 1 - length (ltrim (substr (source, source_idx + piece_len))) 6308 while (source_idx <= source_len); 6309 piece_len = length (before (substr (source, source_idx), " ")); 6310 if chars_stored + piece_len > result_len 6311 then call conversion_error; 6312 substr (result, chars_stored + 1, piece_len) = substr (source, source_idx, piece_len); 6313 chars_stored = chars_stored + piece_len; 6314 end; 6315 else do; 6316 if source_len > result_len 6317 then call conversion_error; 6318 substr (result, 1, source_len) = source; 6319 chars_stored = source_len; 6320 end; 6321 end left_justify; 6322 6323 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6324 6325 /* Internal procedure to store a given character string right justified in */ 6326 /* another string, optionally deleting spaces. */ 6327 6328 right_justify: 6329 proc (source_ptr, source_len, result_ptr, result_len, chars_stored); 6330 6331 dcl source_ptr ptr, /* Address of source string. */ 6332 source_len fixed bin, /* Length of source string. */ 6333 result_ptr ptr, /* Address of result string. */ 6334 result_len fixed bin, /* Length of result string. */ 6335 chars_stored fixed bin; /* Number of chars stored in result. */ 6336 6337 dcl piece_len fixed bin, 6338 source_limit fixed bin; 6339 6340 dcl result char (result_len) based (result_ptr), 6341 source char (source_len) based (source_ptr); 6342 6343 chars_stored = 0; 6344 if blanks_as_null 6345 then do source_limit = length (rtrim (source)) 6346 repeat length (rtrim (substr (source, 1, source_limit - piece_len))) while (source_limit > 0); 6347 piece_len = length (before (reverse (substr (source, 1, source_limit)), " ")); 6348 if chars_stored + piece_len > result_len 6349 then call conversion_error; 6350 chars_stored = chars_stored + piece_len; 6351 substr (result, result_len + 1 - chars_stored, piece_len) = 6352 substr (source, source_limit + 1 - piece_len, piece_len); 6353 end; 6354 else do; 6355 if chars_stored > result_len 6356 then call conversion_error; 6357 substr (result, result_len + 1 - source_len, source_len) = source; 6358 chars_stored = source_len; 6359 end; 6360 end right_justify; 6361 6362 end formatted_io; 6363 6364 /* Namelist and list-directed I/O */ 6365 namelist_io: 6366 proc; 6367 6368 dcl string builtin; /* To override some structure declarations. */ 6369 6370 dcl 1 ok_list aligned based (ok_pt), 6371 2 number fixed bin, 6372 2 list (100) fixed bin (17) unal, 6373 1 acc aligned based, 6374 2 name_size unal bit (9), 6375 2 name_string char (name_ln) unal, 6376 (headings, rep_factor, namelist, comma_encountered, comma_required, legal_end, null_value) 6377 bit (1) aligned, 6378 (name_ln, dims) fixed bin (18); 6379 dcl temp fixed bin (21); 6380 dcl c_temp (2) float bin (27); 6381 dcl factor fixed bin (18); 6382 dcl stu_$get_runtime_address 6383 ext entry (ptr, ptr, ptr, ptr, ptr, ptr, ptr) returns (ptr), 6384 stu_$find_runtime_symbol 6385 ext entry (ptr, char (*) aligned, ptr, fixed bin) returns (ptr), 6386 stu_$decode_runtime_value 6387 entry (fixed bin (35), ptr, ptr, ptr, ptr, ptr, fixed bin (35)) 6388 returns (fixed bin (35)); 6389 6390 dcl namelist_name_len fixed bin, 6391 namelist_name char (namelist_name_len) based (namelist_name_ptr); 6392 dcl integer fixed bin (35) aligned based, 6393 /* for integer variables */ 6394 logical bit (1) aligned based, 6395 /* for logical variables */ 6396 1 complex_value aligned based, 6397 2 real float bin (27), 6398 2 imag_part float bin (27); 6399 dcl (data_type, constant_type) 6400 fixed bin (6), 6401 ( 6402 integer_type fixed bin (6) init (1), 6403 real_type fixed bin (6) init (2), 6404 double_type fixed bin (6) init (3), 6405 complex_type fixed bin (6) init (4), 6406 logical_type fixed bin (6) init (5), 6407 character_type fixed bin (6) init (6), 6408 headers char (2) init ("$&"), 6409 delims char (5) init (" ,/;"), 6410 /* SP TAB , / ; */ 6411 alphameric char (64) 6412 init ("0123456789$_ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"), 6413 digits char (10) init ("0123456789"), 6414 numerics char (13) init ("+-0123456789."), 6415 log char (4) init ("tfTF") 6416 ) aligned int static options (constant), 6417 runtime_table (48) aligned fixed bin (6) internal static options (constant) 6418 init (1, 0, 2, 3, 0, 0, 4, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 5, 0, 6, 0, 0, 0, 0, 6419 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 2, 3); 6420 dcl (n, subscripts) fixed bin (18); 6421 dcl subscript_array (7) fixed bin (18); 6422 dcl repetition_count fixed bin (18); 6423 6424 17 1 /* BEGIN INCLUDE FILE ... runtime_symbol.incl.pl1 ... Modified 07/79 */ 17 2 17 3 dcl 1 runtime_symbol aligned based, 17 4 2 flag unal bit(1), /* always "1"b for Version II */ 17 5 2 use_digit unal bit(1), /* if "1"b and units are half words units are really digits */ 17 6 2 array_units unal bit(2), 17 7 2 units unal bit(2), /* addressing units */ 17 8 2 type unal bit(6), /* data type */ 17 9 2 level unal bit(6), /* structure level */ 17 10 2 ndims unal bit(6), /* number of dimensions */ 17 11 2 bits unal, 17 12 3 aligned bit(1), 17 13 3 packed bit(1), 17 14 3 simple bit(1), 17 15 2 skip unal bit(1), 17 16 2 scale unal bit(8), /* arithmetic scale factor */ 17 17 2 name unal bit(18), /* rel ptr to acc name */ 17 18 2 brother unal bit(18), /* rel ptr to brother entry */ 17 19 2 father unal bit(18), /* rel ptr to father entry */ 17 20 2 son unal bit(18), /* rel ptr to son entry */ 17 21 2 address unal, 17 22 3 location bit(18), /* location in storage class */ 17 23 3 class bit(4), /* storage class */ 17 24 3 next bit(14), /* rel ptr to next of same class */ 17 25 2 size fixed bin(35), /* encoded string|arith size */ 17 26 2 offset fixed bin(35), /* encoded offset from address */ 17 27 2 virtual_org fixed bin(35), 17 28 2 bounds(1), 17 29 3 lower fixed bin(35), /* encoded lower bound */ 17 30 3 upper fixed bin(35), /* encoded upper bound */ 17 31 3 multiplier fixed bin(35); /* encoded multiplier */ 17 32 17 33 dcl 1 runtime_bound based, 17 34 2 lower fixed bin(35), 17 35 2 upper fixed bin(35), 17 36 2 multiplier fixed bin(35); 17 37 17 38 dcl 1 runtime_block aligned based, 17 39 2 flag unal bit(1), /* always "1"b for Version II */ 17 40 2 quick unal bit(1), /* "1"b if quick block */ 17 41 2 fortran unal bit(1), /* "1"b if fortran program */ 17 42 2 standard unal bit(1), /* "1"b if program has std obj segment */ 17 43 2 owner_flag unal bit(1), /* "1"b if block has valid owner field */ 17 44 2 skip unal bit(1), 17 45 2 type unal bit(6), /* = 0 for a block node */ 17 46 2 number unal bit(6), /* begin block number */ 17 47 2 start unal bit(18), /* rel ptr to start of symbols */ 17 48 2 name unal bit(18), /* rel ptr to name of proc */ 17 49 2 brother unal bit(18), /* rel ptr to brother block */ 17 50 2 father unal bit(18), /* rel ptr to father block */ 17 51 2 son unal bit(18), /* rel ptr to son block */ 17 52 2 map unal, 17 53 3 first bit(18), /* rel ptr to first word of map */ 17 54 3 last bit(18), /* rel ptr to last word of map */ 17 55 2 entry_info unal bit(18), /* info about entry of quick block */ 17 56 2 header unal bit(18), /* rel ptr to symbol header */ 17 57 2 chain(4) unal bit(18), /* chain(i) is rel ptr to first symbol 17 58* on start list with length >= 2**i */ 17 59 2 token(0:5) unal bit(18), /* token(i) is rel ptr to first token 17 60* on list with length >= 2 ** i */ 17 61 2 owner unal bit(18); /* rel ptr to owner block */ 17 62 17 63 dcl 1 runtime_token aligned based, 17 64 2 next unal bit(18), /* rel ptr to next token */ 17 65 2 dcl unal bit(18), /* rel ptr to first dcl of this token */ 17 66 2 name, /* ACC */ 17 67 3 size unal unsigned fixed bin (9), /* number of chars in token */ 17 68 3 string unal char(n refer(runtime_token.size)); 17 69 17 70 dcl 1 encoded_value aligned based, 17 71 2 flag bit (2) unal, 17 72 2 code bit (4) unal, 17 73 2 n1 bit (6) unal, 17 74 2 n2 bit (6) unal, 17 75 2 n3 bit (18) unal; 17 76 17 77 /* END INCLUDE FILE ... runtime_symbol.incl.pl1 */ 6425 6426 6427 /* Put useful information into automatic storage. */ 6428 6429 ok_pt = PS.namelist_p; /* Pointer to namelist list of variables. */ 6430 sp = PS.stack_frame_p; /* Stack frame pointer. */ 6431 table_pt = PS.symbol_table_top_p; /* Symbol table pointer. */ 6432 text_pt, link_pt = null; 6433 buffer_index = 0; /* Index for substr. */ 6434 6435 namelist = "1"b; /* Tell the utilities who we are. */ 6436 6437 /* Pick up namelist name. */ 6438 6439 symbol_pt, block_pt = addrel (table_pt, ok_list.list (1)); 6440 6441 /* Pick up block pointer from namelist symbol. Otherwise block is possibly 6442* incorrect. bug 372. Scan entries until we get the right level. */ 6443 6444 if fixed (block_pt -> runtime_symbol.level, 6, 0) <= 1 6445 then block_pt = addrel (block_pt, block_pt -> runtime_symbol.father); 6446 else do while (fixed (block_pt -> runtime_symbol.level, 6, 0) > 1); 6447 block_pt = addrel (block_pt, block_pt -> runtime_symbol.father); 6448 end; 6449 6450 /* Decide on direction of transmission. */ 6451 if fio_ps.read 6452 then go to read; 6453 6454 /* Set format control switches for output. */ 6455 headings = ^(file_desc.printer_file & file_desc.carriage_controllable); 6456 6457 /* Create and output a header record if this is not a print file. */ 6458 if headings 6459 then do; 6460 6461 name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name); 6462 name_ln = fixed (name_pt -> acc.name_size, 9); 6463 6464 if buffer_length + (name_ln + 2) > buffer_max_len 6465 then call too_much_output; 6466 substr (rest_of_output, 1, name_ln + 2) = "$" || name_pt -> acc.name_string || SP; 6467 buffer_length = buffer_length + (name_ln + 2); 6468 end; 6469 else do; 6470 if buffer_length = buffer_max_len 6471 then call too_much_output; 6472 substr (rest_of_output, 1, 1) = SP; 6473 buffer_length = buffer_length + 1; 6474 end; 6475 6476 /* Go through and print everybody. */ 6477 do count = 2 to ok_pt -> ok_list.number; 6478 6479 /* Pick up variable name and print it. */ 6480 symbol_pt = addrel (table_pt, ok_list.list (count)); 6481 subs_pt = null; /* May have been set by last variable. */ 6482 call decode_runtime; 6483 6484 if buffer_length + (name_ln + 3) > buffer_max_len 6485 then call too_much_output; 6486 substr (rest_of_output, 1, name_ln + 3) = name_pt -> acc.name_string || " = "; 6487 buffer_length = buffer_length + (name_ln + 3); 6488 6489 6490 /* Print out all the elements. */ 6491 do n = 1 to element_count; 6492 if fio_ps.ansi_77 6493 then call ansi77_output; /* Use '77 style of output. */ 6494 else call ansi66_output; /* Use '66 style of output. */ 6495 6496 if count ^= ok_pt -> ok_list.number | n ^= element_count 6497 then do; 6498 if buffer_length >= buffer_max_len - 1 6499 then call too_much_output; 6500 if headings 6501 then substr (rest_of_output, 1, 2) = ","; 6502 else substr (rest_of_output, 1, 2) = " "; 6503 if fio_ps.ansi_77 6504 then buffer_length = buffer_length + 2; 6505 else buffer_length = buffer_length + 1; 6506 end; 6507 end; 6508 6509 end; /*Loop through namelist. */ 6510 6511 /* Output trailer if necessary. */ 6512 if headings 6513 then do; 6514 if buffer_length = buffer_max_len 6515 then call too_much_output; 6516 substr (rest_of_output, 1, 1) = "$"; 6517 buffer_length = buffer_length + 1; 6518 end; 6519 6520 return; 6521 6522 6523 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6524 6525 /* Namelist input. */ 6526 read: 6527 constant_ptr = addr (work_str); 6528 count_pt = null; 6529 6530 name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name); 6531 namelist_name_len = fixed (name_pt -> acc.name_size, 9); 6532 namelist_name_ptr = addr (name_pt -> acc.name_string); 6533 6534 /* Find header record. */ 6535 6536 find_header: 6537 call get_field; 6538 6539 if index (headers, substr (rest_of_record, 1, 1)) = 0 6540 then go to missing_header; 6541 else buffer_index = buffer_index + 1; 6542 6543 if buffer_length - buffer_index < namelist_name_len 6544 then do; 6545 missing_header: 6546 call print_error (fortran_io_error_$missing_header, me, """$^a""", namelist_name); 6547 call buffer_read; 6548 go to find_header; 6549 end; 6550 6551 if substr (rest_of_record, 1, namelist_name_len) ^= namelist_name 6552 then do; 6553 if ^fio_ps.fold 6554 then go to missing_header; /* Must match exactly */ 6555 if translate (substr (rest_of_record, 1, namelist_name_len), lower_letters, capital_letters) 6556 ^= namelist_name 6557 then go to missing_header; 6558 end; 6559 6560 buffer_index = buffer_index + namelist_name_len; 6561 6562 /* Insure we don't have a substr of something else. */ 6563 call check_end; 6564 if ^legal_end 6565 then go to missing_header; 6566 6567 /* Get the next variable or return. */ 6568 6569 get_name: 6570 call get_field; 6571 6572 /* check for end of namelist input. */ 6573 6574 if index (headers, substr (rest_of_record, 1, 1)) ^= 0 6575 then if count_pt = null 6576 then do; 6577 fio_ps.have_input = "0"b; /* no longer relevant */ 6578 return; 6579 end; 6580 else call print_error (fortran_io_error_$syntax_error, me, "No variable follows ""/""."); 6581 6582 i = verify (rest_of_record, alphameric) - 1; 6583 if i < 0 6584 then i = buffer_length - buffer_index; 6585 else if i = 0 6586 then call print_error (fortran_io_error_$syntax_error, me, "Variable name is missing."); 6587 6588 /* Look it up in the runtime symbol tables. */ 6589 symbol_pt = stu_$find_runtime_symbol (block_pt, substr (rest_of_record, 1, i), null, 0); 6590 if symbol_pt = null 6591 then do; 6592 if ^fio_ps.fold /* If symbols not folded */ 6593 then 6594 symbol_abort: 6595 call print_error (fortran_io_error_$namelist_error, me, "^a is not a member of $^a.", 6596 substr (rest_of_record, 1, i), namelist_name); 6597 symbol_pt = 6598 stu_$find_runtime_symbol (block_pt, 6599 translate (substr (rest_of_record, 1, i), lower_letters, capital_letters), null (), 0); 6600 if symbol_pt = null () 6601 then go to symbol_abort; /* Couldn't find it folded, either */ 6602 end; 6603 6604 do k = 2 to ok_pt -> ok_list.number; 6605 if addrel (table_pt, ok_list.list (k)) = symbol_pt 6606 then go to legal_symbol; 6607 end; 6608 go to symbol_abort; 6609 6610 legal_symbol: 6611 buffer_index = buffer_index + i; 6612 call get_field; 6613 6614 /* Process "count variable" and save for later. */ 6615 if count_pt = null 6616 then if ch = "/" 6617 then do; 6618 count_pt = symbol_pt; 6619 buffer_index = buffer_index + 1; 6620 call get_field; 6621 go to get_name; 6622 end; 6623 6624 /* Process subscripts. */ 6625 if ch = "(" 6626 then do; 6627 subs_pt = addr (subscript_array); 6628 buffer_index = buffer_index + 1; 6629 do subscripts = 1 to 7; 6630 call get_field; 6631 call input_float; 6632 if constant_type ^= integer_type 6633 then go to bad_subs; 6634 if constant_ptr -> integer = 0 6635 then go to bad_subs; 6636 subscript_array (subscripts) = constant_ptr -> integer; 6637 call check_end; 6638 if ^comma_encountered 6639 then goto check_paren; 6640 end; 6641 6642 check_paren: 6643 if substr (rest_of_record, 1, 1) ^= ")" 6644 then call print_error (fortran_io_error_$syntax_error, me, "Missing "")""."); 6645 buffer_index = buffer_index + 1; 6646 call get_field; 6647 end; 6648 else subscripts = 0; 6649 6650 /* Must have "=" here. */ 6651 if ch ^= "=" 6652 then call print_error (fortran_io_error_$syntax_error, me, "Missing ""=""."); 6653 6654 buffer_index = buffer_index + 1; 6655 6656 /* Validate subscripts. Also supply subscripts the user may have omitted. */ 6657 name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name); 6658 name_ln = fixed (name_pt -> acc.name_size, 9); 6659 i = fixed (symbol_pt -> runtime_symbol.ndims, 6); 6660 if subscripts > i 6661 then call print_error (fortran_io_error_$syntax_error, me, "More subscripts than dimensions for ^a.", 6662 name_pt -> acc.name_string); 6663 6664 if subscripts > 0 6665 then do; 6666 do k = subscripts + 1 to i; /* Fill in dimensions not specified. */ 6667 subscript_array (k) = 1; 6668 end; 6669 6670 do k = 1 to divide (i, 2, 17, 0); /* Reverse order for stu_. */ 6671 j = subscript_array (i - k + 1); 6672 subscript_array (i - k + 1) = subscript_array (k); 6673 subscript_array (k) = j; 6674 end; 6675 6676 do k = 1 to subscripts; 6677 l = stu_$decode_runtime_value (symbol_pt -> runtime_symbol.bounds (k).upper, block_pt, sp, 6678 link_pt, text_pt, null, my_code); 6679 if my_code ^= 0 6680 then 6681 bound_error: 6682 call print_error (fortran_io_error_$syntax_error, me, 6683 "Cannot get bounds information for ^a.", name_pt -> acc.name_string); 6684 if subscript_array (k) > l 6685 then 6686 bad_subs: 6687 call print_error (fortran_io_error_$syntax_error, me, 6688 "Subscript is out of range or invalid."); 6689 end; 6690 6691 end; 6692 else subs_pt = null; 6693 6694 /* Get symbol information. */ 6695 call decode_runtime; 6696 6697 /* Read in and store values. */ 6698 count = 0; 6699 6700 /* Input loop. */ 6701 do while (element_count > 0); 6702 factor = 1; 6703 rep_factor = "0"b; 6704 6705 get_value: 6706 call get_field; 6707 6708 if ch = "," 6709 then do n = 1 to factor; 6710 call store_null; 6711 end; 6712 else do; 6713 if index ("""'", ch) ^= 0 6714 then call input_charstr; 6715 else if ch = "(" 6716 then do; 6717 call input_complex; 6718 end; 6719 else if ch = "." 6720 then do; 6721 if buffer_index + 1 >= buffer_length 6722 then call syntax_error; 6723 if index (digits, substr (rest_of_record, 2, 1)) = 0 6724 then call input_logical; 6725 else call input_float; 6726 end; 6727 else if index (log, ch) ^= 0 6728 then do; 6729 temp = buffer_index; /* Check for end is just a heuristic... */ 6730 buffer_index = buffer_index + 1; 6731 /* must determine if "t" or "f" is value or variable */ 6732 call check_end; 6733 buffer_index = temp; /* restore to previous position */ 6734 6735 if ^legal_end 6736 then go to store_count; 6737 call input_logical; 6738 end; 6739 else if index (numerics, ch) ^= 0 6740 then do; 6741 call input_float; 6742 if constant_type = integer_type 6743 then if buffer_index < buffer_length 6744 then if substr (rest_of_record, 1, 1) = "*" 6745 then do; 6746 if rep_factor 6747 then call bad_char; 6748 rep_factor = "1"b; 6749 factor = constant_ptr -> integer; 6750 if factor <= 0 6751 then call print_error (fortran_io_error_$syntax_error, me, 6752 "Repetition count is less than one."); 6753 if factor > element_count 6754 then call print_error (fortran_io_error_$namelist_error, me, 6755 "Repetition factor is greater than remaining elements.(^d > ^d).", 6756 factor, element_count); 6757 buffer_index = buffer_index + 1; 6758 go to get_value; 6759 end; 6760 else if index ("hH", substr (rest_of_record, 1, 1)) ^= 0 6761 then do; 6762 i = constant_ptr -> integer; 6763 if i <= 0 6764 then call print_error (fortran_io_error_$syntax_error, me, 6765 "Hollerith constant length must be positive."); 6766 str_len = 0; 6767 buffer_index = buffer_index + 1; 6768 /* Skip "h". */ 6769 call build_string (i); 6770 end; 6771 end; 6772 else if rep_factor 6773 then call print_error (fortran_io_error_$syntax_error, me, 6774 "No value follows a repetition factor."); 6775 else go to store_count; 6776 6777 /* Store the constant. */ 6778 do n = 1 to factor; 6779 call store; 6780 end; 6781 end; /* Non-null constant. */ 6782 6783 /* Common for all constants. Update various counts. */ 6784 6785 call check_end; 6786 if ^legal_end 6787 then call bad_char; 6788 6789 element_count = element_count - factor; 6790 count = count + factor; 6791 end; /* Input loop. */ 6792 6793 store_count: 6794 if count_pt ^= null 6795 then do; 6796 subs_pt = null; 6797 symbol_pt = count_pt; 6798 call decode_runtime; 6799 constant_ptr -> integer = count; 6800 dec_int = count; 6801 constant_type = integer_type; 6802 call store; 6803 count_pt = null; 6804 end; 6805 go to get_name; 6806 6807 6808 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 6809 6810 /* List directed I/O entry points. */ 6811 6812 list_io: 6813 entry; 6814 6815 namelist = "0"b; /* Tell utilities who we're not.*/ 6816 6817 data_type = fio_data_type_index (fixed (substr (unspec (fio_ps.element_desc.data_type), 1, 6), 6, 0)); 6818 call set_size_and_count (char_len, element_count, chars_per_item); 6819 6820 if fio_ps.read 6821 then do; 6822 constant_ptr = addr (work_str); 6823 legal_end = "1"b; /* First field is always ok. */ 6824 do while (element_count > 0); 6825 6826 if repetition_count <= 0 6827 then do; 6828 call list_input (); /* Read a value */ 6829 end; 6830 6831 if null_value 6832 then call store_null (); 6833 else call store (); 6834 6835 element_count = element_count - 1; 6836 repetition_count = repetition_count - 1; 6837 end; 6838 6839 fio_ps.have_input = "0"b; 6840 6841 end; 6842 6843 /* List-directed output */ 6844 6845 else if fio_ps.ansi_77 6846 then do; /* Use '77 style of output. */ 6847 do n = 1 to element_count; 6848 if data_type_of_prev_item ^= character_type & data_type ^= character_type 6849 then do; /* Output a space for a separator. */ 6850 if buffer_length >= buffer_max_len 6851 then call too_much_output; 6852 substr (rest_of_output, 1, 1) = " "; 6853 buffer_length = buffer_length + 1; 6854 end; 6855 call ansi77_output; 6856 data_type_of_prev_item = data_type; 6857 end; 6858 end; 6859 6860 else do; /* Use '66 style of output. */ 6861 do n = 1 to element_count; 6862 call ansi66_output; 6863 end; 6864 end; 6865 6866 return; 6867 6868 6869 initialize_list_input: 6870 entry (); 6871 6872 repetition_count = 0; 6873 null_value = "0"b; 6874 comma_required = "0"b; 6875 6876 return; 6877 6878 /* Internal procedure to read list directed values. */ 6879 6880 list_input: 6881 procedure (); 6882 6883 list_input_retry: 6884 call get_field; 6885 6886 /* check of end of list-directed input. */ 6887 6888 if ch = ";" | ch = "/" 6889 then do; 6890 fio_ps.have_input = "0"b; /* no longer relevant */ 6891 if fio_ps.ansi_77 6892 then do; 6893 fio_ps.end_of_input = "1"b; 6894 goto element_list_abort; /* user has signalled end of input */ 6895 end; 6896 null_value = "1"b; /* ensure 0 or blanks are assigned to the list element in ansi 66 mode */ 6897 return; 6898 end; 6899 6900 if comma_required 6901 then if ch = "," 6902 then do; 6903 buffer_index = buffer_index + 1; 6904 comma_required = "0"b; 6905 go to list_input_retry; 6906 end; 6907 else call print_error (fortran_io_error_$syntax_error, me, 6908 "A non-blank delimiter is required after a repeated null value."); 6909 6910 if ch = "," 6911 then do; 6912 buffer_index = buffer_index + 1; /* Skip comma */ 6913 null_value = "1"b; 6914 return; 6915 end; 6916 6917 null_value = "0"b; 6918 call check_repetition (); /* Check for r*c or r* */ 6919 if null_value 6920 then return; /* r* form */ 6921 6922 go to free_input (data_type); 6923 6924 free_input (1): 6925 free_input (2): 6926 free_input (3): 6927 call input_float; 6928 goto free_delim; 6929 6930 free_input (4): /* complex */ 6931 if substr (rest_of_record, 1, 1) = "(" 6932 then do; /* complex constant */ 6933 call input_complex; 6934 end; 6935 6936 else do; /* or two integers or reals */ 6937 do i = 1 to 2; 6938 6939 if buffer_index >= buffer_length 6940 then call syntax_error; 6941 6942 if substr (rest_of_record, 1, 1) = "," 6943 then do; 6944 c_temp (i) = 0.0; /* user omitted value */ 6945 buffer_index = buffer_index + 1; 6946 /* skip comma */ 6947 call check_end; /* gets nexts no white */ 6948 if ^legal_end 6949 then call bad_char; 6950 end; 6951 6952 else call input_piece_of_complex (c_temp (i), "0"b); 6953 6954 if comma_encountered 6955 then buffer_index = buffer_index - 1; 6956 end; 6957 6958 unspec (constant_ptr -> complex_value) = unspec (c_temp); 6959 end; 6960 6961 constant_type = complex_type; 6962 goto free_delim; 6963 6964 free_input (5): 6965 call input_logical; 6966 go to free_delim; 6967 6968 free_input (6): 6969 ch = substr (rest_of_record, 1, 1); 6970 if index ("""'", ch) ^= 0 6971 then call input_charstr; 6972 else do; 6973 i = search (rest_of_record, delims) - 1; 6974 if i < 0 6975 then i = buffer_length - buffer_index; 6976 str_len = 0; 6977 call build_string (i); 6978 end; 6979 6980 free_delim: 6981 call check_end; 6982 if ^legal_end 6983 then call bad_char; /* Insure previous field ended ok. */ 6984 6985 return; 6986 6987 end list_input; 6988 6989 check_repetition: 6990 procedure (); 6991 6992 repetition_count = 1; 6993 6994 if index (digits, ch) = 0 6995 then return; 6996 6997 i = verify (rest_of_record, digits); 6998 if i = 0 6999 then return; 7000 7001 if substr (rest_of_record, i, 1) ^= "*" 7002 then return; 7003 7004 call input_float (); 7005 repetition_count = constant_ptr -> integer; 7006 if repetition_count <= 0 7007 then call print_error (fortran_io_error_$syntax_error, me, 7008 "A repetition count in a list-directed input field must be greater than zero."); 7009 7010 buffer_index = buffer_index + 1; /* Skip * */ 7011 7012 call check_end (); 7013 if legal_end 7014 then do; 7015 null_value = "1"b; /* r* form */ 7016 comma_required = ^comma_encountered; 7017 end; 7018 7019 end check_repetition; 7020 7021 /* Internal procedure to output values in 'ansi66' mode. */ 7022 7023 ansi66_output: 7024 proc; 7025 7026 /* ansi66 output is formatted as "bb-.v(18)9es99" for double precision and 7027* "bb-.v(8)9es99" for single precision numbers. */ 7028 dcl dp_pic_len fixed bin int static options (constant) init (26), 7029 flt_pic_len fixed bin int static options (constant) init (16); 7030 7031 dcl single_precision bit (1) int static options (constant) init ("1"b), 7032 double_precision bit (1) int static options (constant) init ("0"b); 7033 dcl number_string char (26); 7034 7035 go to output_format (data_type); 7036 7037 output_format (1): /* Integers. */ 7038 if buffer_length + length (int_pic) > buffer_max_len 7039 then call too_much_output; 7040 int_pic = fio_ps.element_p -> integer; 7041 substr (rest_of_output, 1, length (int_pic)) = int_pic; 7042 buffer_length = buffer_length + length (int_pic); 7043 go to output_return; 7044 7045 output_format (2): /* Single precision real. */ 7046 j = 3; 7047 if buffer_length + flt_pic_len > buffer_max_len 7048 then call too_much_output; 7049 7050 fake_complex: 7051 call ansi66_format (single_precision, fio_ps.element_p, number_string); 7052 substr (rest_of_output, 1, flt_pic_len) = substr (number_string, 1, flt_pic_len); 7053 buffer_length = buffer_length + flt_pic_len; 7054 go to real_part (j); 7055 7056 output_format (3): /* Double precision real. */ 7057 if buffer_length + dp_pic_len > buffer_max_len 7058 then call too_much_output; 7059 call ansi66_format (double_precision, fio_ps.element_p, number_string); 7060 substr (rest_of_output, 1, dp_pic_len) = number_string; 7061 buffer_length = buffer_length + dp_pic_len; 7062 go to output_return; 7063 7064 output_format (4): /* Complex. */ 7065 j = 1; 7066 if buffer_length + 2 * flt_pic_len + 5 > buffer_max_len 7067 then call too_much_output; 7068 7069 substr (rest_of_output, 1, 2) = " ("; 7070 buffer_length = buffer_length + 2; 7071 7072 go to fake_complex; 7073 7074 real_part (1): /* Append comma after real part for namelist. */ 7075 substr (rest_of_output, 1, 2) = ", "; 7076 buffer_length = buffer_length + 2; 7077 fio_ps.element_p = addrel (fio_ps.element_p, 1); /* Point to imaginary part.*/ 7078 j = j + 1; /*Next set of functions.*/ 7079 go to fake_complex; 7080 7081 real_part (2): /*Right paren for namelist.*/ 7082 substr (rest_of_output, 1, 1) = ")"; 7083 buffer_length = buffer_length + 1; 7084 fio_ps.element_p = addrel (fio_ps.element_p, -1); /* point to beginning of constant */ 7085 go to output_return; 7086 7087 output_format (5): /* Logical */ 7088 if buffer_length + 2 > buffer_max_len 7089 then call too_much_output; 7090 7091 if fio_ps.element_p -> logical 7092 then substr (rest_of_output, 1, 2) = " T"; 7093 else substr (rest_of_output, 1, 2) = " F"; 7094 buffer_length = buffer_length + 2; 7095 go to output_return; 7096 7097 output_format (6): /* Character */ 7098 if buffer_length + char_len > buffer_max_len 7099 then call too_much_output; 7100 7101 substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len); 7102 buffer_length = buffer_length + char_len; 7103 7104 real_part (3): /*Kludge for real and DP.*/ 7105 output_return: 7106 call advance_element_p; 7107 return; 7108 7109 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7110 7111 /* Internal procedure to format free format real and dp numbers in ansi66 mode. */ 7112 ansi66_format: 7113 proc (single_precision, binary_no_ptr, no_string); 7114 7115 dcl single_precision bit (1); 7116 dcl binary_no_ptr pointer; 7117 dcl no_string char (26); 7118 7119 dcl (first_digit, no_of_digits, trailing_zeros, precision) 7120 fixed bin; 7121 dcl exponent pic "s999"; 7122 dcl exp_char char (1); 7123 dcl dec_num float decimal (18); 7124 7125 /* WARNING the following structure is based upon the internal representation of ext float decimal data. */ 7126 dcl 1 decimal_number structure aligned based (addr (dec_num)), 7127 2 sign char (1) unaligned, 7128 2 digits char (precision) unaligned, 7129 2 exp fixed bin (8) unaligned; 7130 7131 if fio_ps.job_bits.hfp 7132 then bin_type = 3; 7133 else bin_type = 1; 7134 if single_precision 7135 then do; 7136 precision = 8; 7137 exp_char = "E"; 7138 end; 7139 else do; 7140 precision = 18; 7141 bin_type = bin_type + 1; 7142 exp_char = "D"; 7143 end; 7144 call assign_round_ (addr (dec_num), ext_float_decimal, (precision), binary_no_ptr, binary_type (bin_type), 7145 binary_prec (bin_type)); 7146 first_digit = verify (decimal_number.digits, "0"); 7147 if first_digit = 0 /* special case if number is zero */ 7148 then do; 7149 first_digit = precision; 7150 exponent = 0; 7151 end; 7152 else exponent = decimal_number.exp + (precision - (first_digit - 1)); 7153 no_of_digits = precision - first_digit + 1; 7154 trailing_zeros = precision - no_of_digits; 7155 if decimal_number.sign = "+" 7156 then decimal_number.sign = " "; /* suppress leading "+" sign. */ 7157 7158 substr (no_string, 1, 2) = " "; 7159 substr (no_string, 3, 2) = decimal_number.sign || "."; 7160 substr (no_string, 5, precision) = 7161 substr (decimal_number.digits, first_digit, no_of_digits) || copy ("0", trailing_zeros); 7162 if abs (exponent) > 99 /* drop the "E" */ 7163 then substr (no_string, precision + 5, 4) = exponent; 7164 else substr (no_string, precision + 5, 4) = exp_char || substr (exponent, 1, 1) || substr (exponent, 3, 2); 7165 end ansi66_format; 7166 end ansi66_output; 7167 7168 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7169 7170 /* Internal procedure to output values in 'ansi77' mode. */ 7171 7172 ansi77_output: 7173 proc; 7174 7175 dcl more_pieces bit, 7176 num_sig_chars fixed bin, 7177 piece_idx fixed bin, 7178 piece_len fixed bin, 7179 piece_max_len fixed bin; 7180 7181 dcl single_precision bit (1) int static options (constant) init ("1"b); 7182 dcl double_precision bit (1) int static options (constant) init ("0"b); 7183 dcl number_string char (30); 7184 dcl number_length fixed bin; 7185 7186 go to output_format (data_type); 7187 7188 output_format (1): /* Integers. */ 7189 int_pic = fio_ps.element_p -> integer; 7190 piece_idx = verify (int_pic, " "); /* Find first nonblank char. */ 7191 piece_len = length (int_pic) - piece_idx + 1; /* Find length of value. */ 7192 if buffer_length + piece_len > buffer_max_len 7193 then call too_much_output; 7194 substr (rest_of_output, 1, piece_len) = substr (int_pic, piece_idx, piece_len); 7195 buffer_length = buffer_length + piece_len; 7196 go to output_return; 7197 7198 output_format (2): /* Single precision real. */ 7199 j = 3; 7200 7201 convert_real_value: 7202 call ansi77_format (single_precision, fio_ps.element_p, number_string, number_length); 7203 if buffer_length + number_length > buffer_max_len 7204 then call too_much_output; 7205 substr (rest_of_output, 1, number_length) = substr (number_string, 1, number_length); 7206 buffer_length = buffer_length + number_length; 7207 go to real_part (j); 7208 7209 output_format (3): /* Double precision real. */ 7210 call ansi77_format (double_precision, fio_ps.element_p, number_string, number_length); 7211 if buffer_length + number_length > buffer_max_len 7212 then call too_much_output; 7213 substr (rest_of_output, 1, number_length) = substr (number_string, 1, number_length); 7214 buffer_length = buffer_length + number_length; 7215 go to output_return; 7216 7217 output_format (4): /* Complex. */ 7218 j = 1; 7219 if buffer_length >= buffer_max_len 7220 then call too_much_output; 7221 7222 substr (rest_of_output, 1, 1) = "("; 7223 buffer_length = buffer_length + 1; 7224 7225 go to convert_real_value; 7226 7227 real_part (1): /* Append comma after real part for namelist. */ 7228 if buffer_length >= buffer_max_len 7229 then call too_much_output; 7230 substr (rest_of_output, 1, 1) = ","; 7231 buffer_length = buffer_length + 1; 7232 fio_ps.element_p = addrel (fio_ps.element_p, 1); /* Point to imaginary part.*/ 7233 j = j + 1; /*Next set of functions.*/ 7234 go to convert_real_value; 7235 7236 real_part (2): /*Right paren for namelist.*/ 7237 if buffer_length >= buffer_max_len 7238 then call too_much_output; 7239 substr (rest_of_output, 1, 1) = ")"; 7240 buffer_length = buffer_length + 1; 7241 fio_ps.element_p = addrel (fio_ps.element_p, -1); /* point to beginning of constant */ 7242 go to output_return; 7243 7244 output_format (5): /* Logical */ 7245 if buffer_length >= buffer_max_len 7246 then call too_much_output; 7247 7248 if fio_ps.element_p -> logical 7249 then substr (rest_of_output, 1, 1) = "T"; 7250 else substr (rest_of_output, 1, 1) = "F"; 7251 buffer_length = buffer_length + 1; 7252 go to output_return; 7253 7254 output_format (6): /* Character */ 7255 if namelist 7256 then do; /* Store quoted character value in buffer. */ 7257 if buffer_length >= buffer_max_len 7258 then call too_much_output; 7259 substr (rest_of_output, 1, 1) = "'"; 7260 buffer_length = buffer_length + 1; 7261 num_sig_chars = length (rtrim (substr (fio_ps.element_p -> chars, 1, char_len))); 7262 piece_idx = 1; 7263 more_pieces = TRUE; 7264 do while (more_pieces); 7265 piece_max_len = num_sig_chars - piece_idx + 1; 7266 piece_len = index (substr (fio_ps.element_p -> chars, piece_idx, piece_max_len), "'"); 7267 if piece_len = 0 7268 then do; 7269 piece_len = piece_max_len; 7270 more_pieces = FALSE; 7271 end; 7272 if buffer_length + piece_len + 1 > buffer_max_len 7273 then call too_much_output; 7274 substr (rest_of_output, 1, piece_len) = substr (fio_ps.element_p -> chars, piece_idx, piece_len); 7275 substr (rest_of_output, piece_len + 1, 1) = "'"; 7276 buffer_length = buffer_length + piece_len + 1; 7277 piece_idx = piece_idx + piece_len; 7278 end; 7279 end; 7280 else do; /* Store raw character value in buffer. */ 7281 if buffer_length + char_len > buffer_max_len 7282 then call too_much_output; 7283 7284 substr (rest_of_output, 1, char_len) = substr (fio_ps.element_p -> chars, 1, char_len); 7285 buffer_length = buffer_length + char_len; 7286 end; 7287 7288 real_part (3): /*Kludge for real and DP.*/ 7289 output_return: 7290 call advance_element_p; 7291 7292 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7293 7294 /* Internal procedure to format free format real and dp numbers in ansi77 mode. */ 7295 ansi77_format: 7296 proc (single_precision, binary_no_ptr, no_string, no_length); 7297 7298 dcl single_precision bit (1); 7299 dcl binary_no_ptr ptr; 7300 dcl no_string char (30); 7301 dcl no_length fixed bin; 7302 7303 dcl 1 output_number aligned structure based (addr (no_string)), 7304 2 pad char (no_length) unaligned, 7305 2 rest_of_number char (30) unaligned; 7306 dcl (precision, first_digit, no_of_digits, no_of_zeros, dpt, chars_in_exp) 7307 fixed bin; 7308 dcl exponent pic "s999"; 7309 dcl dec_num float decimal (18); 7310 7311 /* WARNING the following structure is based upon the internal representation of ext float decimal data */ 7312 dcl 1 decimal_number structure aligned based (addr (dec_num)), 7313 2 sign char (1) unaligned, 7314 2 digits char (precision) unaligned, 7315 2 exp fixed bin (8) unaligned; 7316 7317 no_length = 0; 7318 if fio_ps.job_bits.hfp 7319 then bin_type = 3; 7320 else bin_type = 1; 7321 if ^single_precision 7322 then do; 7323 precision = 18; 7324 bin_type = bin_type + 1; 7325 end; 7326 else if fio_ps.job_bits.hfp 7327 then precision = 7; /* hex real numbers have only 7 dec digits */ 7328 else precision = 8; 7329 7330 call assign_round_ (addr (dec_num), ext_float_decimal, (precision), binary_no_ptr, binary_type (bin_type), 7331 binary_prec (bin_type)); 7332 first_digit = verify (decimal_number.digits, "0"); 7333 if first_digit = 0 /* special case if the number is zero */ 7334 then do; 7335 first_digit = precision; 7336 no_of_digits = 1; 7337 exponent = 0; 7338 end; 7339 else do; 7340 no_of_digits = length (rtrim (substr (decimal_number.digits, first_digit), "0")); 7341 exponent = decimal_number.exp + (precision - first_digit); 7342 if decimal_number.sign = "-" 7343 then do; 7344 substr (rest_of_number, 1, 1) = "-"; 7345 no_length = no_length + 1; 7346 end; 7347 end; 7348 if exponent < -4 | exponent >= precision 7349 then do; /* E format */ 7350 if abs (exponent) < 100 7351 then chars_in_exp = 4; 7352 else chars_in_exp = 5; 7353 if no_of_digits = 1 7354 then dpt = 2; /* if no digits after the decimal point, we need */ 7355 else dpt = 1; /* a trailing zero. */ 7356 substr (rest_of_number, 1, 2) = substr (decimal_number.digits, first_digit, 1) || "."; 7357 if dpt = 2 7358 then substr (rest_of_number, 3, 1) = "0"; 7359 else substr (rest_of_number, 3, no_of_digits - 1) = 7360 substr (decimal_number.digits, first_digit + 1, no_of_digits - 1); 7361 if chars_in_exp = 4 7362 then substr (rest_of_number, no_of_digits + dpt + 1, 4) = 7363 "E" || substr (exponent, 1, 1) || substr (exponent, 3, 2); 7364 else substr (rest_of_number, no_of_digits + dpt + 1, 5) = "E" || exponent; 7365 no_length = no_length + no_of_digits + dpt + chars_in_exp; 7366 end; 7367 else do; /* F format */ 7368 if exponent < 0 7369 then do; /* leading zeros needed */ 7370 no_of_zeros = abs (exponent) - 1; 7371 substr (rest_of_number, 1, no_of_zeros + 2) = "0." || copy ("0", no_of_zeros); 7372 substr (rest_of_number, no_of_zeros + 3, no_of_digits) = 7373 substr (decimal_number.digits, first_digit, no_of_digits); 7374 no_length = no_length + no_of_digits + no_of_zeros + 2; 7375 7376 end; 7377 else if exponent >= (no_of_digits - 1) 7378 then do; /* trailing zeros may be needed */ 7379 no_of_zeros = exponent - no_of_digits + 1; 7380 substr (rest_of_number, 1, no_of_digits) = 7381 substr (decimal_number.digits, first_digit, no_of_digits); 7382 substr (rest_of_number, no_of_digits + 1, no_of_zeros + 2) = 7383 copy ("0", no_of_zeros) || ".0"; 7384 no_length = no_length + no_of_zeros + no_of_digits + 2; 7385 end; 7386 else do; /* decimal inside digits */ 7387 dpt = exponent + 1; 7388 substr (rest_of_number, 1, dpt + 1) = 7389 substr (decimal_number.digits, first_digit, dpt) || "."; 7390 substr (rest_of_number, dpt + 2, no_of_digits - dpt) = 7391 substr (decimal_number.digits, first_digit + dpt, no_of_digits - dpt); 7392 no_length = no_length + no_of_digits + 1; 7393 end; 7394 end; 7395 end ansi77_format; 7396 end ansi77_output; 7397 7398 7399 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7400 7401 /* Internal procedure to input a line from the file system. */ 7402 7403 buffer_read: 7404 proc; 7405 7406 call read_a_record (); 7407 buffer_index = 0; 7408 if have_runtime_format 7409 then if skip_line_numbers 7410 then call strip_line_no (); 7411 7412 end buffer_read; 7413 7414 7415 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7416 7417 get_field: 7418 proc; /* Finds first non-blank of field or the comma */ 7419 7420 i = 0; /* get us into the loop */ 7421 do while (i = 0); 7422 7423 do while (buffer_index >= buffer_length); /* get non blank line */ 7424 call buffer_read; 7425 end; 7426 7427 i = verify (rest_of_record, white_space); 7428 7429 if i = 0 7430 then call buffer_read; /* rest of line is white; get another */ 7431 end; 7432 7433 buffer_index = buffer_index + i - 1; 7434 7435 ch = substr (rest_of_record, 1, 1); 7436 7437 end get_field; 7438 7439 7440 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7441 7442 check_end: 7443 proc; /* insure field ended neatly */ 7444 7445 dcl ii fixed bin; 7446 7447 legal_end = "1"b; 7448 comma_encountered = "0"b; 7449 7450 if buffer_index >= buffer_length 7451 then return; 7452 7453 ii = verify (rest_of_record, white_space) - 1; 7454 if ii < 0 /* rest of the line is white */ 7455 then do; 7456 buffer_index = buffer_length; 7457 return; 7458 end; 7459 buffer_index = buffer_index + ii; /* skip over white space */ 7460 7461 ch = substr (rest_of_record, 1, 1); 7462 7463 if ch = "," 7464 then do; 7465 comma_encountered = "1"b; 7466 buffer_index = buffer_index + 1; 7467 return; 7468 end; 7469 7470 if namelist 7471 then if index (headers, ch) ^= 0 7472 then return; 7473 else ; 7474 else if ch = ";" | ch = "/" 7475 then return; 7476 7477 if ii = 0 7478 then legal_end = "0"b; /* messy ending only if no white space */ 7479 7480 end check_end; 7481 7482 7483 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7484 7485 /* Internal procedure to handle runtime symbols. */ 7486 decode_runtime: 7487 proc; 7488 7489 dcl VLA_based bit (4) static options (constant) init ("1010"b); 7490 7491 /* Get symbol name. */ 7492 name_pt = addrel (symbol_pt, symbol_pt -> runtime_symbol.name); 7493 name_ln = fixed (name_pt -> acc.name_size, 9); 7494 7495 /* Get symbol location. Note, pointer may not be to first element because of subs_pt. */ 7496 fio_ps.element_p = stu_$get_runtime_address (block_pt, symbol_pt, sp, link_pt, text_pt, null, subs_pt); 7497 7498 /* Get number of dimensions and pointer to end of variable's storage. */ 7499 dims = fixed (symbol_pt -> runtime_symbol.ndims, 6); 7500 if dims > 0 7501 then do; 7502 do j = 1 to dims; 7503 subscript_array (j) = 7504 stu_$decode_runtime_value (symbol_pt -> runtime_symbol.bounds (j).upper, block_pt, sp, 7505 link_pt, text_pt, null, my_code); 7506 if my_code ^= 0 7507 then go to bound_error; 7508 end; 7509 7510 end_pt = 7511 stu_$get_runtime_address (block_pt, symbol_pt, sp, link_pt, text_pt, null, 7512 addr (subscript_array)); 7513 end; 7514 else end_pt = fio_ps.element_p; 7515 7516 /* Get data type. */ 7517 j = fixed (symbol_pt -> runtime_symbol.type, 6); 7518 if j <= 0 | j > hbound (runtime_table, 1) 7519 then go to unknown_type; 7520 data_type = runtime_table (j); 7521 if data_type = 0 7522 then 7523 unknown_type: 7524 call print_error (fortran_io_error_$namelist_error, me, "Invalid data type ^d for ^a.", j, 7525 name_pt -> acc.name_string); 7526 7527 /* Get character length, word length, and number of elements. */ 7528 if data_type = character_type 7529 then char_len = symbol_pt -> runtime_symbol.size; 7530 else if data_type = double_type | data_type = complex_type 7531 then char_len = CPDW; 7532 else char_len = CPW; 7533 7534 /* for ansi66 character arrays are padded out, round up to the nearest whole 7535* word, otherwise the chars_per_item is the char_len */ 7536 7537 if data_type = character_type & ^fio_ps.ansi_77 7538 then chars_per_item = char_len - mod (char_len, -CPW); 7539 else chars_per_item = char_len; 7540 7541 /* Check if the symbol is a VLA and calculate 'element_count' accordingly. */ 7542 if symbol_pt -> runtime_symbol.class = VLA_based 7543 then do; 7544 fio_ps.element_desc.VLA = TRUE; 7545 element_count = 7546 divide ((fixed (baseno (end_pt)) - fixed (baseno (fio_ps.element_p))) * 4 7547 * pl1_operators_$VLA_words_per_seg_ + char_pos (end_pt) - char_pos (fio_ps.element_p), 7548 chars_per_item, 24, 0) + 1; 7549 end; 7550 else do; 7551 fio_ps.element_desc.VLA = FALSE; 7552 element_count = divide (char_pos (end_pt) - char_pos (fio_ps.element_p), chars_per_item, 24, 0) + 1; 7553 end; 7554 end decode_runtime; 7555 7556 7557 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7558 7559 /* Procedure to store a null value. */ 7560 store_null: 7561 proc; 7562 7563 if fio_ps.ansi_77 7564 then go to null_bump; /* Do nothing */ 7565 7566 go to make_null (data_type); 7567 7568 make_null (1): 7569 fio_ps.element_p -> integer = 0; 7570 go to null_bump; 7571 7572 make_null (4): 7573 fio_ps.element_p -> complex_value.imag_part = 0.0; 7574 7575 make_null (2): 7576 fio_ps.element_p -> real = 0.0; 7577 go to null_bump; 7578 7579 make_null (3): 7580 fio_ps.element_p -> based_dp = 0.0; 7581 go to null_bump; 7582 7583 make_null (5): 7584 fio_ps.element_p -> logical = "0"b; 7585 go to null_bump; 7586 7587 make_null (6): 7588 substr (fio_ps.element_p -> chars, 1, char_len) = SP; 7589 7590 null_bump: 7591 call advance_element_p; 7592 end store_null; 7593 7594 7595 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7596 7597 /* Procedure to store constant into variable, depending on data types. */ 7598 store: 7599 proc; 7600 if fio_ps.job_bits.hfp 7601 then bin_type = 3; 7602 else bin_type = 1; 7603 go to validate_store (data_type * 6 + constant_type - 7); 7604 7605 validate_store (0): /* integer - integer */ 7606 validate_store (7): /* real - real */ 7607 validate_store (28): /* logical - logical */ 7608 fio_ps.element_p -> words (1) = constant_ptr -> words (1); 7609 /* copy without conversion */ 7610 goto store_bump; 7611 7612 validate_store (14): /* double precision - double precision */ 7613 validate_store (21): /* complex - complex */ 7614 fio_ps.element_p -> based_bits = constant_ptr -> based_bits; 7615 /* copy without conversion */ 7616 go to store_bump; 7617 7618 validate_store (1): /* integer - real */ 7619 call assign_round_ (fio_ps.element_p, integer_dtype, integer_prec, constant_ptr, binary_type (bin_type), 7620 binary_prec (bin_type)); 7621 go to store_bump; 7622 7623 validate_store (2): /* integer - double precision */ 7624 bin_type = bin_type + 1; /* double precision binary type */ 7625 call assign_round_ (fio_ps.element_p, integer_dtype, integer_prec, constant_ptr, binary_type (bin_type), 7626 binary_prec (bin_type)); 7627 go to store_bump; 7628 7629 validate_store (3): /* integer - complex */ 7630 validate_store (9): /* real - complex */ 7631 validate_store (15): /* double precision - complex */ 7632 call print_error (fortran_io_error_$syntax_error, me, 7633 "Complex constants can only be used as input for complex variables."); 7634 7635 validate_store (4): /* integer - logical */ 7636 validate_store (10): /* real - logical */ 7637 validate_store (16): /* double precision - logical */ 7638 validate_store (22): /* complex - logical */ 7639 call print_error (fortran_io_error_$syntax_error, me, "Numeric variables may not be assigned logical values."); 7640 7641 validate_store (5): /* integer - character */ 7642 validate_store (11): /* real - character */ 7643 validate_store (17): /* double precision - character */ 7644 validate_store (23): /* complex - character */ 7645 validate_store (35): /* character - character */ 7646 substr (fio_ps.element_p -> chars, 1, char_len) = substr (work_str, 1, str_len); 7647 go to store_bump; 7648 7649 validate_store (18): /* complex - integer */ 7650 fio_ps.element_p -> complex_value.imag_part = 0.0; 7651 7652 validate_store (6): /* real - integer */ 7653 call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), constant_ptr, 7654 integer_dtype, integer_prec); 7655 go to store_bump; 7656 7657 validate_store (20): /* complex - double precision */ 7658 fio_ps.element_p -> complex_value.imag_part = 0.0; 7659 7660 validate_store (8): /* real - double precision */ 7661 call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), constant_ptr, 7662 binary_type (bin_type + 1), binary_prec (bin_type + 1)); 7663 go to store_bump; 7664 7665 validate_store (19): /* complex - real */ 7666 fio_ps.element_p -> complex_value.imag_part = 0.0; 7667 fio_ps.element_p -> real = constant_ptr -> real; 7668 go to store_bump; 7669 7670 validate_store (12): /* double precision - integer */ 7671 bin_type = bin_type + 1; 7672 call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), constant_ptr, 7673 integer_dtype, integer_prec); 7674 go to store_bump; 7675 7676 validate_store (13): /* double precision - real */ 7677 bin_type = bin_type + 1; 7678 call assign_round_ (fio_ps.element_p, binary_type (bin_type), binary_prec (bin_type), addr (work), 7679 ext_float_decimal, (max_float)); 7680 go to store_bump; 7681 7682 validate_store (24): /* logical - integer */ 7683 validate_store (25): /* logical - real */ 7684 validate_store (26): /* logical - double precision */ 7685 validate_store (27): /* logical - complex */ 7686 validate_store (29): /* logical - character */ 7687 call print_error (fortran_io_error_$syntax_error, me, "Logical variables must be assigned logical values."); 7688 7689 validate_store (30): /* character - integer */ 7690 validate_store (31): /* character - real */ 7691 validate_store (32): /* character - double precision */ 7692 validate_store (33): /* character - complex */ 7693 validate_store (34): /* character - logical */ 7694 call print_error (fortran_io_error_$syntax_error, me, "Character variables must be assigned character values."); 7695 7696 store_bump: 7697 call advance_element_p; 7698 end store; 7699 7700 7701 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7702 7703 /* Procedure to input any type of number. */ 7704 input_float: 7705 proc; 7706 begin_index = buffer_index; 7707 legal_end = "0"b; 7708 constant_type = integer_type; 7709 dec_flt = 0.0; 7710 7711 if substr (rest_of_record, 1, 1) = "+" | substr (rest_of_record, 1, 1) = "-" 7712 then do; 7713 number.sign = substr (rest_of_record, 1, 1); 7714 buffer_index = buffer_index + 1; 7715 if buffer_index = buffer_length 7716 then call syntax_error; 7717 end; 7718 7719 i = verify (rest_of_record, "0") - 1; 7720 if i ^= 0 7721 then do; 7722 if i < 0 7723 then do; 7724 buffer_index = buffer_length; 7725 zero_field: 7726 constant_ptr -> integer = 0; 7727 constant_type = integer_type; 7728 return; 7729 end; 7730 buffer_index = buffer_index + i; 7731 legal_end = "1"b; 7732 end; 7733 7734 prec = verify (rest_of_record, digits) - 1; 7735 if prec ^= 0 7736 then do; 7737 if prec < 0 7738 then prec = buffer_length - buffer_index; 7739 if prec > max_float 7740 then call conversion_error; 7741 number.digit = substr (rest_of_record, 1, prec); 7742 buffer_index = buffer_index + prec; 7743 if buffer_index = buffer_length 7744 then go to build_integer; 7745 legal_end = "1"b; 7746 end; 7747 7748 e = 0; 7749 dexp = 0; 7750 7751 ch = substr (rest_of_record, 1, 1); 7752 if ch = "." 7753 then do; 7754 constant_type = real_type; 7755 buffer_index = buffer_index + 1; 7756 if buffer_index = buffer_length 7757 then if ^legal_end 7758 then call syntax_error; 7759 else go to build_binary; 7760 e = verify (rest_of_record, digits) - 1; 7761 if e ^= 0 7762 then do; 7763 if e < 0 7764 then e = buffer_length - buffer_index; 7765 if prec = 0 7766 then do; 7767 i = verify (substr (rest_of_record, 1, e), "0") - 1; 7768 if i < 0 7769 then i = e; 7770 end; 7771 else i = 0; 7772 7773 if prec + (e - i) > max_float 7774 then call conversion_error; 7775 if (e - i) > 0 7776 then substr (number.digit, prec + 1, e - i) = substr (rest_of_record, i + 1, e - i); 7777 prec = prec + (e - i); 7778 buffer_index = buffer_index + e; 7779 7780 if buffer_index = buffer_length 7781 then go to build_binary; 7782 legal_end = "1"b; 7783 end; 7784 ch = substr (rest_of_record, 1, 1); 7785 end; 7786 7787 if ^legal_end 7788 then call syntax_error; /* Must have some digits. */ 7789 7790 if index (exps, ch) ^= 0 7791 then do; 7792 legal_end = "0"b; /* Indicate need for exponent field. */ 7793 constant_type = real_type; 7794 if index ("eE", ch) = 0 7795 then constant_type = double_type; 7796 buffer_index = buffer_index + 1; 7797 if buffer_index = buffer_length 7798 then call syntax_error; 7799 7800 i = verify (rest_of_record, white_space); 7801 if i = 0 7802 then call syntax_error; 7803 buffer_index = buffer_index + i - 1; 7804 ch = substr (rest_of_record, 1, 1); 7805 end; 7806 7807 j = buffer_index; /* Lets us remember the sign. */ 7808 7809 if index ("+-", ch) ^= 0 7810 then do; 7811 legal_end = "0"b; /* Indicate need for exponent field. */ 7812 if constant_type = integer_type 7813 then constant_type = real_type; 7814 buffer_index = buffer_index + 1; 7815 if buffer_index = buffer_length 7816 then call syntax_error; 7817 end; 7818 7819 if constant_type = integer_type 7820 then do; 7821 build_integer: 7822 if prec = 0 7823 then go to zero_field; 7824 if prec > max_fixed 7825 then call conversion_error; 7826 substr (work_str, 1, prec + 1) = substr (work, 1, prec + 1); 7827 dec_int = 0; 7828 substr (work, 1, 1) = substr (work_str, 1, 1); 7829 substr (number.digit, max_fixed - prec + 1, prec) = substr (work_str, 2, prec); 7830 7831 constant_ptr -> integer = convert (integer, dec_int); 7832 return; 7833 end; 7834 7835 if ^legal_end /* Get an exponent field only if there was an "e" or sign. */ 7836 then do; 7837 i = verify (rest_of_record, digits) - 1; 7838 if i < 0 7839 then i = buffer_length - buffer_index; 7840 if i = 0 7841 then call syntax_error; /* Must have some digits. */ 7842 7843 dexp = convert (dexp, substr (io_buf, j + 1, i + buffer_index - j)); 7844 buffer_index = buffer_index + i; 7845 end; 7846 7847 build_binary: 7848 if prec = 0 7849 then go to zero_field; 7850 e = dexp - e + prec - max_float; 7851 if e > 255 | e < -256 7852 then call conversion_error; 7853 7854 flt_dec.exp = e; 7855 7856 if fio_ps.job_bits.hfp 7857 then bin_type = 3; 7858 else bin_type = 1; 7859 if constant_type = double_type 7860 then bin_type = bin_type + 1; 7861 call assign_round_ (constant_ptr, binary_type (bin_type), binary_prec (bin_type), addr (work), 7862 ext_float_decimal, (max_float)); 7863 7864 end input_float; 7865 7866 7867 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7868 7869 input_complex: 7870 proc; 7871 7872 buffer_index = buffer_index + 1; /* skip "(" */ 7873 7874 call get_field; 7875 7876 call input_piece_of_complex (c_temp (1), "0"b); 7877 7878 if ^comma_encountered 7879 then call syntax_error; /* comma must be used */ 7880 7881 call get_field; 7882 7883 call input_piece_of_complex (c_temp (2), "1"b); 7884 7885 if comma_encountered 7886 then call syntax_error; 7887 7888 if substr (rest_of_record, 1, 1) ^= ")" 7889 then call syntax_error; 7890 buffer_index = buffer_index + 1; /* Skip ")" */ 7891 7892 unspec (constant_ptr -> complex_value) = unspec (c_temp); 7893 7894 constant_type = complex_type; 7895 end input_complex; 7896 7897 7898 7899 input_piece_of_complex: 7900 proc (x, paren_ok); 7901 7902 dcl x float bin (27); 7903 dcl paren_ok bit (1) aligned; 7904 7905 call input_float; /* get integer or real */ 7906 7907 if constant_type = integer_type 7908 then do; 7909 if fio_ps.job_bits.hfp 7910 then bin_type = 3; 7911 else bin_type = 1; 7912 call assign_round_ (addr (x), binary_type (bin_type), binary_prec (bin_type), constant_ptr, 7913 integer_dtype, integer_prec); 7914 end; 7915 7916 else if constant_type = real_type 7917 then x = constant_ptr -> real; 7918 7919 else call print_error (fortran_io_error_$syntax_error, me, 7920 "Double precision constant cannot be used as input for complex variables."); 7921 7922 call check_end; 7923 if ^(legal_end | (paren_ok & ch = ")")) 7924 then call bad_char; 7925 end input_piece_of_complex; 7926 7927 7928 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7929 7930 /* Procedure to input a logical constant. */ 7931 input_logical: 7932 proc; 7933 7934 dcl delims char (4) static options (constant) initial (" ,/"); 7935 /* space tab , / */ 7936 7937 7938 constant_type = logical_type; 7939 if substr (rest_of_record, 1, 1) = "." 7940 then if length (rest_of_record) < 2 7941 then call syntax_error; /* Logical value must follow period. */ 7942 else ch = substr (rest_of_record, 2, 1); /* 2nd char determines logical value. */ 7943 else ch = substr (rest_of_record, 1, 1); /* 1st char determines logical value. */ 7944 if ch = "t" | ch = "T" 7945 then constant_ptr -> logical = TRUE; 7946 else if ch = "f" | ch = "F" 7947 then constant_ptr -> logical = FALSE; 7948 else call syntax_error; 7949 7950 j = search (rest_of_record, delims) - 1; 7951 if j < 0 7952 then j = length (rest_of_record); 7953 buffer_index = buffer_index + j; 7954 7955 end input_logical; 7956 7957 7958 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7959 7960 /* Procedure to input quoted character strings. */ 7961 input_charstr: 7962 proc; 7963 str_len = 0; 7964 buffer_index = buffer_index + 1; /* Skip initial delimiter */ 7965 7966 do while ("1"b); 7967 i = index (rest_of_record, ch) - 1; 7968 7969 /* If data is not all on this record, then do multiple buffer reads to find 7970* terminator. */ 7971 7972 if i < 0 7973 then do; 7974 call build_string (length (rest_of_record)); 7975 call buffer_read; 7976 end; 7977 else do; 7978 call build_string (i); 7979 buffer_index = buffer_index + 1; 7980 if buffer_index >= buffer_length 7981 then return; 7982 if substr (rest_of_record, 1, 1) ^= ch 7983 then return; 7984 call build_string (1); 7985 end; 7986 end; 7987 end input_charstr; 7988 7989 7990 /* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */ 7991 7992 build_string: 7993 proc (len1); 7994 dcl (len1, len2) fixed bin (18); 7995 7996 len2 = len1; 7997 if str_len + len1 > 256 7998 then do; 7999 call com_err_ (0, me, "Character string truncated to 256 characters."); 8000 len2 = 256 - str_len; 8001 end; 8002 if len2 > 0 8003 then substr (work_str, str_len + 1, len2) = 8004 substr (rest_of_record, 1, min (len2, buffer_length - buffer_index)); 8005 str_len = str_len + len2; 8006 buffer_index = buffer_index + len1; 8007 constant_type = character_type; 8008 8009 end build_string; 8010 8011 end namelist_io; 8012 8013 set_size_and_count: 8014 procedure (element_size, element_count, pointer_bump); 8015 8016 /* Returns size and count information about the data being transmitted. 8017* element_size is the number of interesting bytes in one element, 8018* element_count is the number of elements, and pointer_bump is the number 8019* of bytes of storage allocated to one element. */ 8020 8021 declare data_type fixed bin, 8022 element_count fixed bin (24); 8023 declare (element_size, pointer_bump) 8024 fixed binary (21); 8025 8026 8027 8028 data_type = fio_data_type_index (fixed (substr (unspec (fio_ps.element_desc.data_type), 1, 6), 6, 0)); 8029 goto set_size (data_type); 8030 8031 set_size (1): /* integer */ 8032 set_size (2): /* real */ 8033 set_size (5): /* logical */ 8034 pointer_bump, element_size = CPW; 8035 goto set_count; 8036 8037 set_size (3): /* double */ 8038 set_size (4): /* complex */ 8039 pointer_bump, element_size = CPDW; 8040 goto set_count; 8041 8042 set_size (6): /* character */ 8043 if fio_ps.ansi_77 8044 then pointer_bump, element_size = fio_ps.length; 8045 else do; 8046 element_size = fio_ps.length; 8047 pointer_bump = divide (fio_ps.length + CPW - 1, CPW, 17, 0) * CPW; 8048 end; 8049 go to set_count; 8050 8051 8052 /* fio_ps.element_count is the total number of WORDS in the array, except for 8053* character arrays in ansi_77 format, where it is the total number of BYTES 8054* in the array. We map this number into the actual number of ELEMENTS to be 8055* transmitted. */ 8056 8057 set_count: 8058 if fio_ps.array_ref & fio_ps.element_count > 0 8059 then do; 8060 if data_type = 6 /* character array */ 8061 then if fio_ps.ansi_77 8062 then element_count = divide (fio_ps.element_count, pointer_bump, 17, 0); 8063 else element_count = divide (fio_ps.element_count * CPW, pointer_bump, 17, 0); 8064 8065 else if fio_ps.double | fio_ps.complex 8066 then element_count = divide (fio_ps.element_count, 2, 17, 0); 8067 8068 else element_count = fio_ps.element_count; 8069 8070 8071 end; 8072 8073 else element_count = 1; 8074 8075 end set_size_and_count; 8076 8077 char_pos: 8078 procedure (P_character_ptr) returns (fixed binary (21)); 8079 /* Calculate the character position in a segment of a character pointer. 8080* Written 6-Nov-79 by M. N. Davidoff. 8081* Altered for use with fortran_io_ by MEP August 1980 */ 8082 8083 8084 declare P_character_ptr pointer; /* (Input) pointer to a character in a segment */ 8085 8086 /* automatic */ 8087 8088 declare source_position fixed binary (21); 8089 declare source_ptr pointer; 8090 8091 /* based */ 8092 8093 declare character_array (4 * sys_info$max_seg_size) char (1) based (source_ptr); 8094 8095 /* program */ 8096 8097 source_ptr = baseptr (baseno (P_character_ptr)); 8098 8099 /* Calculate the character position of the character pointer. */ 8100 8101 source_position = 4 * binary (rel (P_character_ptr), 18) + 1; 8102 do while (addr (character_array (source_position)) ^= P_character_ptr); 8103 source_position = source_position + 1; 8104 end; 8105 8106 return (source_position); 8107 end char_pos; 8108 8109 advance_element_p: 8110 proc; 8111 8112 /* Advance 'fio_ps.element_p' by 'chars_per_item' characters. */ 8113 8114 dcl error_table_$boundviol fixed bin (35) ext; 8115 8116 dcl 01 element_p aligned based (addr (fio_ps.element_p)) like its_unsigned; 8117 8118 dcl 01 segment aligned based (baseptr (element_p.segno)), 8119 02 pad bit (bits_before_element) unaligned, 8120 02 element bit (bits_in_element) unaligned; 8121 8122 dcl bits_before_element fixed bin (24), 8123 bits_in_element fixed bin (24); 8124 8125 bits_in_element = 9 * chars_per_item; 8126 bits_before_element = 36 * element_p.offset + element_p.bit_offset + bits_in_element; 8127 if fio_ps.element_desc.VLA 8128 then if bits_before_element >= 36 * pl1_operators_$VLA_words_per_seg_ 8129 then do; /* Cross over to next VLA component. */ 8130 bits_before_element = bits_before_element - 36 * pl1_operators_$VLA_words_per_seg_; 8131 if bits_before_element >= 36 * pl1_operators_$VLA_words_per_seg_ 8132 then call print_error (error_table_$boundviol); 8133 element_p.segno = element_p.segno + 1; 8134 end; 8135 fio_ps.element_p = addr (element); 8136 return; 18 1 /* BEGIN INCLUDE FILE its.incl.pl1 18 2* modified 27 July 79 by JRDavis to add its_unsigned 18 3* Internal format of ITS pointer, including ring-number field for follow-on processor */ 18 4 18 5 dcl 1 its based aligned, /* declaration for ITS type pointer */ 18 6 2 pad1 bit (3) unaligned, 18 7 2 segno bit (15) unaligned, /* segment number within the pointer */ 18 8 2 ringno bit (3) unaligned, /* ring number within the pointer */ 18 9 2 pad2 bit (9) unaligned, 18 10 2 its_mod bit (6) unaligned, /* should be 43(8) */ 18 11 18 12 2 offset bit (18) unaligned, /* word offset within the addressed segment */ 18 13 2 pad3 bit (3) unaligned, 18 14 2 bit_offset bit (6) unaligned, /* bit offset within the word */ 18 15 2 pad4 bit (3) unaligned, 18 16 2 mod bit (6) unaligned; /* further modification */ 18 17 18 18 dcl 1 itp based aligned, /* declaration for ITP type pointer */ 18 19 2 pr_no bit (3) unaligned, /* number of pointer register to use */ 18 20 2 pad1 bit (27) unaligned, 18 21 2 itp_mod bit (6) unaligned, /* should be 41(8) */ 18 22 18 23 2 offset bit (18) unaligned, /* word offset from pointer register word offset */ 18 24 2 pad2 bit (3) unaligned, 18 25 2 bit_offset bit (6) unaligned, /* bit offset relative to new word offset */ 18 26 2 pad3 bit (3) unaligned, 18 27 2 mod bit (6) unaligned; /* further modification */ 18 28 18 29 18 30 dcl 1 its_unsigned based aligned, /* just like its, but with unsigned binary */ 18 31 2 pad1 bit (3) unaligned, 18 32 2 segno fixed bin (15) unsigned unaligned, 18 33 2 ringno fixed bin (3) unsigned unaligned, 18 34 2 pad2 bit (9) unaligned, 18 35 2 its_mod bit (6) unaligned, 18 36 18 37 2 offset fixed bin (18) unsigned unaligned, 18 38 2 pad3 bit (3) unaligned, 18 39 2 bit_offset fixed bin (6) unsigned unaligned, 18 40 2 pad4 bit (3) unaligned, 18 41 2 mod bit (6) unaligned; 18 42 18 43 dcl 1 itp_unsigned based aligned, /* just like itp, but with unsigned binary where appropriate */ 18 44 2 pr_no fixed bin (3) unsigned unaligned, 18 45 2 pad1 bit (27) unaligned, 18 46 2 itp_mod bit (6) unaligned, 18 47 18 48 2 offset fixed bin (18) unsigned unaligned, 18 49 2 pad2 bit (3) unaligned, 18 50 2 bit_offset fixed bin (6) unsigned unaligned, 18 51 2 pad3 bit (3) unaligned, 18 52 2 mod bit (6) unaligned; 18 53 18 54 18 55 dcl ITS_MODIFIER bit (6) unaligned internal static options (constant) init ("43"b3); 18 56 dcl ITP_MODIFIER bit (6) unaligned internal static options (constant) init ("41"b3); 18 57 18 58 /* END INCLUDE FILE its.incl.pl1 */ 8137 8138 end advance_element_p; 8139 8140 end fortran_io_; SOURCE FILES USED IN THIS COMPILATION. LINE NUMBER DATE MODIFIED NAME PATHNAME 0 08/06/87 1045.1 fortran_io_.pl1 >spec>install>MR12.1-1069>fortran_io_.pl1 899 1 10/12/83 1515.6 fortran_ps.incl.pl1 >ldd>include>fortran_ps.incl.pl1 1-29 2 08/06/87 1045.5 fortran_job_bits.incl.pl1 >spec>install>MR12.1-1069>fortran_job_bits.incl.pl1 1-60 3 03/27/82 0424.8 fortran_io_consts.incl.pl1 >ldd>include>fortran_io_consts.incl.pl1 900 4 10/12/83 1519.1 fortran_buffer.incl.pl1 >ldd>include>fortran_buffer.incl.pl1 901 5 08/04/86 2015.0 fortran_open_data.incl.pl1 >ldd>include>fortran_open_data.incl.pl1 902 6 03/27/82 0424.8 fortran_inquire_data.incl.pl1 >ldd>include>fortran_inquire_data.incl.pl1 903 7 11/07/86 1550.3 stack_frame.incl.pl1 >ldd>include>stack_frame.incl.pl1 904 8 07/19/79 1547.0 rs_info.incl.pl1 >ldd>include>rs_info.incl.pl1 905 9 05/20/83 1846.4 iocb.incl.pl1 >ldd>include>iocb.incl.pl1 906 10 08/04/86 2015.0 format_tables.incl.pl1 >ldd>include>format_tables.incl.pl1 907 11 07/19/79 1547.0 vfs_info.incl.pl1 >ldd>include>vfs_info.incl.pl1 908 12 02/02/78 1229.7 iox_modes.incl.pl1 >ldd>include>iox_modes.incl.pl1 4105 13 11/22/82 0955.6 branch_status.incl.pl1 >ldd>include>branch_status.incl.pl1 4593 14 05/06/74 1741.0 component_info.incl.pl1 >ldd>include>component_info.incl.pl1 4594 15 08/05/77 1022.5 object_info.incl.pl1 >ldd>include>object_info.incl.pl1 4595 16 05/06/74 1752.6 symbol_header.incl.pl1 >ldd>include>symbol_header.incl.pl1 6425 17 11/26/79 1320.6 runtime_symbol.incl.pl1 >ldd>include>runtime_symbol.incl.pl1 8137 18 11/26/79 1320.6 its.incl.pl1 >ldd>include>its.incl.pl1 NAMES DECLARED IN THIS COMPILATION. IDENTIFIER OFFSET LOC STORAGE CLASS DATA TYPE ATTRIBUTES AND REFERENCES (* indicates a set context) NAMES DECLARED BY DECLARE STATEMENT. COMMA 046056 constant char(1) initial unaligned dcl 832 ref 3789 CPDW constant fixed bin(8,0) initial dcl 443 ref 1984 2395 7530 8037 CPW constant fixed bin(8,0) initial dcl 444 ref 950 950 950 964 1301 1358 1986 2391 4983 7532 7537 8031 8047 8047 8047 8063 CR constant char(1) initial dcl 836 ref 2177 EOF1 002240 constant char(1) initial dcl 445 set ref 1924 1924 1924 2082 2082 2082 2082 EOF2 046060 constant char(2) initial dcl 447 ref 1928 1928 1928 EOF3 046057 constant char(2) initial dcl 449 ref 1931 1931 FALSE constant bit(1) initial unaligned dcl 451 ref 1712 1827 3689 3822 3838 3839 3842 3858 3859 3895 4043 7270 7551 7946 FF constant char(1) initial dcl 836 ref 2157 FORMAT 001170 automatic structure level 1 dcl 4923 MINUS_SIGN constant char(1) initial unaligned dcl 4909 ref 5246 6184 Max_unwritten_eofs 001765 constant fixed bin(17,0) initial dcl 4-81 set ref 1756 1759* NL 001710 constant char(1) initial dcl 836 set ref 1628 2083 2083 2083 2083 2118 2135 2187 2197 2202 2265 4358 4358 4428 4428 4435 4435 4459 4459 4658 4658 NL_FF 046054 constant char(2) initial dcl 897 ref 2155 2165 PLUS_SIGN constant char(1) initial unaligned dcl 4910 ref 5248 6189 PS based structure level 1 dcl 1-11 PS_ptr 000100 automatic pointer level 2 dcl 417 set ref 922* 946 947 960 962 964 1028* 1029 1030 1082* 1107* 1120 1410 1411 1568 1846 1942 1948 1948 2341 2341 2344 2351 2375 2383 2391 2395 2398 2398 2482 2485 2485 2526 2526 4613 4614 4615 4616 4622 4630 4630 4678 5830 5842 6056 6056 6059 6061 6061 6429 6430 6431 P_character_ptr parameter pointer dcl 8084 ref 8077 8097 8101 8102 READ_ constant fixed bin(17,0) initial dcl 4905 ref 6106 SP 046055 constant char(1) initial dcl 836 ref 993 2056 2122 3030 3791 4727 4729 5389 6044 6466 6472 7587 Sequential_input_output constant fixed bin(17,0) initial dcl 12-15 ref 4281 Sequential_update constant fixed bin(17,0) initial dcl 12-15 ref 2247 TRUE constant bit(1) initial unaligned dcl 452 ref 1776 1789 1793 1795 1807 3032 3359 3360 3467 3477 3688 3830 3831 3843 3848 3851 3891 4477 7263 7544 7944 VLA 10(07) 000354 automatic bit(1) level 4 packed unaligned dcl 1-47 set ref 2000 4839 4876 7544* 7551* 8127 VLA_based constant bit(4) initial unaligned dcl 7489 ref 7542 WRITE_ constant fixed bin(17,0) initial dcl 4905 ref 5853 5874 6114 6273 a_create_sw parameter bit(1) dcl 1269 ref 1266 1279 a_str parameter varying char(256) dcl 3487 ref 3484 3489 3495 3495 3496 abs builtin function dcl 459 ref 5202 5205 5238 5256 5342 5344 7162 7350 7370 acc based structure level 1 dcl 6370 access 0(05) based bit(1) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2508* 2708 2831* 2862 3684 3694 access 54 based structure level 2 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" access 0(05) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3989 access_field constant fixed bin(17,0) initial dcl 3-50 set ref 2710* actual_error 2237 based fixed bin(35,0) level 2 dcl 864 set ref 1442* 4609* 4611* actual_iocb_ptr 12 based pointer level 2 dcl 9-6 ref 1551 1551 1666 1691 1894 2098 3147 4435 4459 actual_mode 000556 automatic bit(2) dcl 3566 set ref 3627* 3634 3644 3660 3660 3669 add_char_offset_ 000010 constant entry external dcl 460 ref 1868 2068 add_zero 001215 automatic bit(1) dcl 4937 set ref 5188 5217 6016 6198* 6201* addr builtin function dcl 461 ref 1120 1121 1178 1301 1356 1358 1422 1428 1430 1515 1537 1592 1619 1846 1903 1903 2082 2082 2083 2083 2131 2153 2175 2185 2196 2371 2428 2428 2482 2485 2485 2503 2505 2506 2507 2508 2509 2510 2511 2513 2514 2516 2517 2518 2520 2524 2526 2526 2526 2532 2535 2535 2540 2542 2544 2544 2549 2551 2553 2553 2558 2561 2561 2566 2566 2572 2575 2575 2580 2583 2583 2588 2591 2591 2596 2602 2602 2605 2605 2688 2691 2693 2695 2699 2701 2703 2706 2708 2711 2715 2719 2723 2726 2728 2733 2733 2733 2736 2739 2760 2760 2767 2769 2781 2783 2796 2799 2803 2803 2807 2811 2827 2829 2830 2831 2833 2835 2837 2839 2842 2856 2862 2862 2862 2862 2862 2862 2862 2862 2862 2872 2872 2875 2875 2878 2878 2881 2889 2900 2903 2903 2919 2930 2957 2957 2957 2957 2965 2978 2981 2994 3001 3006 3012 3017 3023 3047 3055 3065 3065 3067 3082 3108 3114 3115 3115 3124 3134 3147 3152 3153 3160 3162 3164 3169 3183 3183 3187 3191 3201 3201 3211 3239 3276 3291 3310 3372 3372 3372 3414 3426 3447 3461 3505 3512 3515 3517 3517 3524 3524 3524 3532 3554 3569 3579 3583 3586 3589 3598 3604 3625 3629 3644 3660 3660 3669 3682 3682 3684 3684 3694 3694 3729 3729 3736 3737 3737 3740 3741 3741 3746 3746 3749 3749 3752 3752 3771 3794 3794 3818 3826 3826 3834 3847 3852 3865 3867 3869 3872 3872 3889 3891 3893 3895 3898 3905 3905 3910 3919 3919 3923 3932 3932 3936 3945 3945 3949 3958 3959 3959 3962 3962 3966 3966 3976 3981 3981 3985 3985 3989 3994 3994 3998 4003 4003 4009 4017 4019 4019 4022 4022 4029 4031 4077 4120 4175 4204 4204 4206 4206 4206 4358 4358 4428 4428 4435 4435 4459 4459 4658 4658 4679 4679 4693 4693 4708 4708 4726 4729 4749 4752 4780 4786 4990 5018 5026 5026 5026 5026 5052 5052 5059 5059 5067 5067 5067 5067 5122 5122 5139 5145 5196 5199 5199 5199 5211 5233 5263 5272 5336 5336 5342 5369 5378 5386 5413 5440 5440 5440 5440 5440 5440 5442 5478 5510 5510 5510 5510 5510 5510 5561 5561 5561 5561 5561 5561 5595 5616 5616 5616 5616 5616 5616 5630 5637 5637 5697 5707 5713 5713 5715 5717 6061 6061 6061 6064 6218 6218 6220 6526 6532 6627 6800 6822 7037 7040 7041 7041 7042 7144 7144 7146 7152 7155 7155 7159 7160 7188 7190 7191 7194 7330 7330 7332 7340 7341 7342 7344 7356 7356 7357 7359 7359 7361 7364 7371 7372 7372 7380 7380 7382 7388 7388 7390 7390 7510 7510 7678 7678 7709 7713 7741 7775 7827 7829 7831 7854 7861 7861 7912 7912 8102 8126 8126 8133 8133 8135 8135 addrel builtin function dcl 462 ref 1294 1297 1305 1324 1392 4721 4721 6439 6444 6447 6461 6480 6530 6605 6657 7077 7084 7232 7241 7492 address 3 based structure level 2 packed unaligned dcl 17-3 address_of_index 4 000354 automatic pointer level 2 dcl 1-47 set ref 1422* adp 000546 automatic pointer dcl 3550 set ref 3552* 3554 all_files_closed 454 based bit(1) level 2 packed unaligned dcl 4-18 set ref 2895* 4379 4483* allocated_by_fortran 454(01) based bit(1) level 2 packed unaligned dcl 4-18 set ref 1361* 1384 allow 0(11) based structure level 4 packed unaligned dcl 441 allow_default 000504 automatic bit(1) dcl 2613 set ref 2957* 3001 3012 allow_delete 0(18) based bit(1) level 4 packed unaligned dcl 441 set ref 3383* 3451 allow_reopen 0(17) based bit(1) level 4 packed unaligned dcl 441 set ref 1772 2296 2303 3414 3632* 3634 alphameric 000535 constant char(64) initial dcl 6399 ref 6582 ansi_77 6(21) 000354 automatic bit(1) level 3 packed unaligned dcl 1-47 set ref 948 962 988 1538 1820 1933 2728 2754 2856 3187 3274 3684 5100 5853 5874 6059 6492 6503 6845 6891 7537 7563 8042 8060 anyitems 0(18) based bit(1) level 4 packed unaligned dcl 10-32 ref 6087 ap 000314 automatic pointer dcl 4572 set ref 4668* 4669* append_file constant fixed bin(17,0) initial dcl 829 ref 2796 3276 area_size constant fixed bin(17,0) initial dcl 463 ref 1292 1294 1297 1305 1324 1342 1392 array_ref 10(06) 000354 automatic bit(1) level 4 packed unaligned dcl 1-47 set ref 8057 assign_round_ 000012 constant entry external dcl 464 ref 5336 5637 6218 7144 7330 7618 7625 7652 7660 7672 7678 7861 7912 attach_desc 3 based structure level 2 in structure "fortran_open_data" dcl 5-23 in procedure "fortran_io_" attach_desc parameter char unaligned dcl 4516 in procedure "save_attach_desc" set ref 4514 4520* attach_desc 0(02) based bit(1) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2505* 2739 2807 2862 2965 3047 3598 3741 attach_desc_field constant fixed bin(17,0) initial dcl 3-50 set ref 2968* 2970* 2970* 2974* 2974* attach_desc_len 000150 automatic fixed bin(17,0) dcl 465 set ref 2968* 2970 2974 2978 2995* 3004* 3015* 3030* 3031* 3031 3039* 3489 3495 3496* 3496 4497 4497 4517* 4518 4518* 4520 attach_descrip_ptr 14 based pointer level 2 dcl 9-6 ref 1784 1791 2952 3108 3150 3155 3360 3402 3520 3535 3552 4517 4518 4520 attach_description 000105 automatic char(256) unaligned dcl 4413 set ref 4451* 4476* attachment 2021 based char(256) level 2 packed unaligned dcl 864 set ref 2970 2970 2970 2978* 2986 2986 2993* 2994* 3003* 3014* 3025* 3030 3037* 3038* 3093* 3129* 3139* 3452* 3466* 3476* 3489 3495* 4039* 4040* 4083* 4084* b_var_str based varying char(256) dcl 466 set ref 1791 3108 3150 3155 3339 3341 3347 3352* 3360 3402 3554 4517 4518 4520 base 000151 automatic fixed bin(3,0) dcl 467 set ref 5704* 5705 5707 based_bit_1 based bit(1) dcl 3816 set ref 3867* 3869* 3872* 3891* 3893* 3895* based_bits based bit(72) level 2 packed unaligned dcl 755 set ref 1430* 5314 5707* 7612* 7612 based_chars based char unaligned dcl 4135 set ref 4144* based_dp based float bin(63) level 2 packed unaligned dcl 758 set ref 5088 5470* 7579* based_work_area based structure level 1 dcl 864 baseno builtin function dcl 468 ref 2010 2010 4849 4885 7545 7545 8097 baseptr builtin function dcl 469 ref 2010 2010 4849 4885 8097 8135 begin_index 000152 automatic fixed bin(21,0) dcl 470 set ref 1259 4542 5403* 5466* 5674* 7706* bin_int 001230 automatic fixed bin(35,0) dcl 4951 set ref 5017* 5018 5021 5035 bin_type 000153 automatic fixed bin(17,0) dcl 474 set ref 5632* 5634* 5635* 5635 5637 5637 6210* 6212* 6213* 6213 6218 6218 7131* 7133* 7141* 7141 7144 7144 7318* 7320* 7324* 7324 7330 7330 7600* 7602* 7618 7618 7623* 7623 7625 7625 7652 7652 7660 7660 7660 7660 7670* 7670 7672 7672 7676* 7676 7678 7678 7856* 7858* 7859* 7859 7861 7861 7909* 7911* 7912 7912 binary builtin function dcl 471 in procedure "fortran_io_" ref 1095 1301 1358 1529 1529 4682 4698 4762 4771 5314 8101 binary 0(08) based bit(1) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2733 2803 2862 2903 3589 binary 11 based bit(1) level 2 in structure "fortran_open_data" dcl 5-23 in procedure "fortran_io_" set ref 2733 2803 2903 binary_file constant bit(3) initial dcl 3-34 ref 1603 1973 2389 3370 3698 3713 4832 binary_no_ptr parameter pointer dcl 7299 in procedure "ansi77_format" set ref 7295 7330* binary_no_ptr parameter pointer dcl 7116 in procedure "ansi66_format" set ref 7112 7144* binary_prec 002130 constant fixed bin(35,0) initial array dcl 473 set ref 5336* 5637* 6218* 7144* 7330* 7618* 7625* 7652* 7660* 7660* 7672* 7678* 7861* 7912* binary_stream constant fixed bin(17,0) initial dcl 3-39 ref 2576 2584 2592 2903 3072 3134 3134 3152 3289 3368 3372 3517 binary_type 002134 constant fixed bin(17,0) initial array dcl 472 set ref 5336* 5637* 6218* 7144* 7330* 7618* 7625* 7652* 7660* 7660* 7672* 7678* 7861* 7912* bit builtin function dcl 475 ref 4635 5707 bit_cnt 000311 automatic fixed bin(24,0) dcl 4564 set ref 4702* 4708* bit_count 001020 automatic fixed bin(24,0) dcl 4160 set ref 4182* bit_offset 1(21) based fixed bin(6,0) level 2 packed unsigned unaligned dcl 8116 ref 8126 bits based structure array level 3 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" bits based structure level 2 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" bits_before_element 001706 automatic fixed bin(24,0) dcl 8122 set ref 8126* 8127 8130* 8130 8131 8135 bits_in_element 001707 automatic fixed bin(24,0) dcl 8122 set ref 8125* 8126 8135 blank 61 based structure level 2 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" blank 0(12) based bit(1) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2723 3737 blank 0(12) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3976 blank_field constant fixed bin(17,0) initial dcl 3-50 set ref 2725* blank_null 0(17) based bit(1) level 4 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2726* 2728* 2856* 2881 3736 blank_null 0(20) based bit(1) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 1538* 2881* 3736* 3978 6075 blanks_as_null 001205 automatic bit(1) dcl 4930 set ref 5554 5976* 5983* 6075* 6305 6344 blk_info based structure level 1 unaligned dcl 11-21 block_pt 2 000100 automatic pointer level 2 dcl 417 set ref 6439* 6444 6444* 6444 6444 6446 6447* 6447 6447 6589* 6597* 6677* 7496* 7503* 7510* blocked constant fixed bin(17,0) initial dcl 3-39 ref 2554 2562 2900 3124 3124 3376 3554 3962 blocked_file constant bit(3) initial dcl 3-34 ref 1968 2241 2359 3376 3698 4013 4281 bounds 7 based structure array level 2 dcl 17-3 branch_status 000172 automatic structure level 1 dcl 13-1 buf 456 based fixed bin(17,0) level 2 dcl 4-18 set ref 1120 1121 1301 1358 1592 1619 2503 2505 2506 2507 2508 2509 2510 2511 2513 2514 2516 2517 2518 2520 2524 2526 2526 2532 2535 2535 2540 2542 2544 2544 2549 2551 2553 2553 2558 2561 2561 2566 2566 2572 2575 2575 2580 2583 2583 2588 2591 2591 2596 2602 2602 2605 2605 2688 2691 2693 2695 2699 2701 2703 2706 2708 2711 2715 2719 2723 2726 2728 2733 2733 2733 2736 2739 2760 2760 2767 2769 2781 2783 2796 2799 2803 2803 2807 2811 2827 2829 2830 2831 2833 2835 2837 2839 2842 2856 2862 2862 2862 2862 2862 2862 2862 2862 2862 2872 2872 2875 2875 2878 2878 2881 2900 2903 2903 2919 2930 2957 2957 2957 2957 2965 2978 2981 2994 3001 3012 3023 3047 3055 3065 3082 3160 3183 3183 3187 3191 3201 3201 3211 3239 3276 3291 3310 3414 3426 3447 3461 3569 3579 3583 3586 3589 3598 3604 3625 3629 3644 3660 3660 3669 3682 3682 3684 3684 3694 3694 3729 3729 3736 3737 3737 3740 3741 3741 3746 3746 3749 3749 3752 3752 3771 3794 3794 3818 3826 3826 3847 3865 3867 3869 3872 3872 3889 3891 3893 3895 3898 3905 3905 3910 3919 3919 3923 3932 3932 3936 3945 3945 3949 3966 3966 3976 3981 3981 3985 3985 3989 3994 3994 3998 4003 4003 4009 4022 4029 4031 4175 4204 4206 4206 buf_p 000100 automatic pointer dcl 4369 set ref 4375* 4376 4379 4386 4386 4386 4391 buffer based char unaligned dcl 785 set ref 957* 2230* 2232* buffer_index 000154 automatic fixed bin(21,0) dcl 476 set ref 981* 1001* 1259* 2455 2455 2460 2460 2464* 2464 2464 2464 2465 2472* 2472 2473 4542* 4547 4547 4547 4547 4794 4796 4836 4839 4839 4843 4843 4847 4847 4849 4849 4855* 4855 5045 5045 5046* 5046 5052 5052 5053* 5053 5060 5060 5061* 5061 5067 5067 5139 5139 5140* 5140 5143 5143 5145 5145 5211 5211 5213* 5213 5219 5219 5220* 5220 5224 5224 5225* 5225 5229 5229 5230* 5230 5233 5233 5235* 5235 5240 5240 5242 5242 5243* 5243 5246 5246 5248 5248 5249* 5249 5260 5260 5261* 5261 5263 5263 5268 5268 5269* 5269 5286 5286 5307 5307 5308* 5308 5314 5314 5316* 5316 5378 5378 5379* 5379 5383 5383 5384* 5384 5386 5386 5403 5404 5404 5411* 5411 5414 5414 5417* 5417 5418 5421 5421 5423* 5423 5424 5428 5428 5430* 5430 5430 5430 5435 5435 5438* 5438 5440 5440 5440 5440 5440 5440 5440 5440 5466 5467 5467 5476* 5476 5479 5479 5482* 5482 5483 5486 5486 5488* 5488 5489 5494 5494 5497* 5497 5505 5505 5508 5508 5510 5510 5510 5510 5511* 5511 5512 5518 5518 5521* 5521 5523 5528 5528 5531 5537 5537 5550 5550 5556 5556 5561 5561 5561 5561 5566* 5566 5567 5570 5570 5578* 5578 5579 5581 5581 5584* 5584 5585 5585 5589* 5589 5590 5596* 5596 5597 5603 5603 5605* 5605 5605 5605 5610 5610 5613* 5613 5616 5616 5616 5616 5616 5616 5616 5616 5651 5651 5656 5656 5656 5656 5658 5658 5658 5658 5674 5675 5675 5683* 5683 5685 5685 5687* 5687 5690 5690 5692* 5692 5698 5700* 5700* 5701 5701* 5743* 5743 5752 5752 5766 5766 5767* 5767 5771 5771 5792 5792 5793* 5793 5797 5797 5815* 5815 5819 5819 5830 5830 5831* 5842 5842 5843* 5856 5856 5858* 5876* 5918* 5948* 5973* 6018 6018 6019* 6019 6022 6022 6024 6024 6027* 6027 6028 6031 6031 6040 6040 6044 6044 6053* 6094* 6232 6232 6233* 6233 6240 6240 6241* 6241 6259 6259 6433* 6539 6539 6541* 6541 6543 6551 6551 6555 6555 6560* 6560 6574 6574 6582 6582 6583 6589 6589 6589 6589 6592 6592 6592 6592 6597 6597 6597 6597 6610* 6610 6619* 6619 6628* 6628 6642 6642 6645* 6645 6654* 6654 6721 6723 6723 6729 6730* 6730 6733* 6742 6742 6742 6757* 6757 6760 6760 6767* 6767 6903* 6903 6912* 6912 6930 6930 6939 6942 6942 6945* 6945 6954* 6954 6968 6968 6973 6973 6974 6997 6997 7001 7001 7010* 7010 7407* 7423 7427 7427 7433* 7433 7435 7435 7450 7453 7453 7456* 7459* 7459 7461 7461 7466* 7466 7706 7711 7711 7711 7711 7713 7713 7714* 7714 7715 7719 7719 7724* 7730* 7730 7734 7734 7737 7741 7741 7742* 7742 7743 7751 7751 7755* 7755 7756 7760 7760 7763 7767 7767 7775 7775 7778* 7778 7780 7784 7784 7796* 7796 7797 7800 7800 7803* 7803 7804 7804 7807 7814* 7814 7815 7837 7837 7838 7843 7844* 7844 7872* 7872 7888 7888 7890* 7890 7939 7939 7939 7939 7942 7942 7943 7943 7950 7950 7951 7951 7953* 7953 7964* 7964 7967 7967 7974 7974 7974 7974 7979* 7979 7980 7982 7982 8002 8002 8002 8006* 8006 buffer_length 000155 automatic fixed bin(21,0) dcl 477 set ref 952* 954* 991 993 994* 994 1627* 1628 1630* 1878* 1909* 1924 1928 1931 1970* 1984* 1986* 1991* 1997* 2000* 2004 2004* 2010 2030* 2056 2056 2056 2056 2067* 2108 2117* 2117 2118 2118 2122 2126 2132* 2132 2133 2135 2137 2137 2137 2137 2137 2143 2144* 2144 2148 2154* 2154 2155 2157 2159 2159 2159 2159 2159 2165 2166* 2166 2170 2174* 2174 2175 2177 2184* 2184 2185 2187 2195* 2195 2202 2202 2203* 2203 2224 2226 2226 2230 2230 2232 2232 2233* 2235* 2237* 2238* 2245* 2246* 2265 2265 2267* 2267 2276* 2281 2455 2460 2464 4792 4794 4794 4836 4839 4843 4847 4849 4873 4876 4880 4883 4885 4891* 4891 5139 5143 5145 5211 5219 5224 5233 5240 5242 5246 5248 5260 5263 5268 5272 5286 5289 5291 5307 5314 5378 5383 5386 5389 5518 5550 5570 5585 5701 5752 5766 5771 5792 5797 5819 5830 5842 5856 5973 6018 6022 6024 6034 6036 6037 6232 6240 6257 6259 6259 6259 6259 6261* 6277 6279 6279 6279 6280* 6464 6466 6467* 6467 6470 6472 6473* 6473 6484 6486 6487* 6487 6498 6500 6502 6503* 6503 6505* 6505 6514 6516 6517* 6517 6539 6543 6551 6555 6574 6582 6583 6589 6589 6592 6592 6597 6597 6642 6721 6723 6742 6742 6760 6850 6852 6853* 6853 6930 6939 6942 6968 6973 6974 6997 7001 7037 7041 7042* 7042 7047 7052 7053* 7053 7056 7060 7061* 7061 7066 7069 7070* 7070 7074 7076* 7076 7081 7083* 7083 7087 7091 7093 7094* 7094 7097 7101 7102* 7102 7192 7194 7195* 7195 7203 7205 7206* 7206 7211 7213 7214* 7214 7219 7222 7223* 7223 7227 7230 7231* 7231 7236 7239 7240* 7240 7244 7248 7250 7251* 7251 7257 7259 7260* 7260 7272 7274 7275 7276* 7276 7281 7284 7285* 7285 7423 7427 7435 7450 7453 7456 7461 7711 7711 7713 7715 7719 7724 7734 7737 7741 7743 7751 7756 7760 7763 7767 7775 7780 7784 7797 7800 7804 7815 7837 7838 7843 7888 7939 7939 7942 7943 7950 7951 7967 7974 7974 7980 7982 8002 8002 buffer_max_len 000156 automatic fixed bin(21,0) dcl 478 set ref 946* 948 950 952 957 962 991 1594* 1620* 1878 2056 2056 2061* 2230 2232 4534* 4873 6253 6273 6464 6470 6484 6498 6514 6850 7037 7047 7056 7066 7087 7097 7192 7203 7211 7219 7227 7236 7244 7257 7272 7281 buffer_p 20 based pointer level 2 dcl 1-11 set ref 947 1120* buffer_pointer 6 000100 automatic pointer level 2 dcl 417 set ref 947* 957 993 1592* 1619* 1628 1868* 1868* 1909* 1924 1928 1931 1970* 1981 2056 2068* 2068* 2118 2122 2126 2131* 2133 2135 2137 2137 2143 2148 2153* 2155 2157 2159 2159 2165 2170 2175* 2175 2177 2185* 2185 2187 2196* 2202 2230 2232 2235* 2237* 2245* 2265 2276* 2455 2460 2464 4547 4547 4794 4839 4843 4847 4849 4876 4880 4883 4885 5045 5052 5060 5067 5139 5143 5145 5211 5219 5224 5229 5233 5240 5242 5246 5248 5260 5263 5268 5272 5286 5289 5291 5307 5314 5378 5383 5386 5389 5404 5414 5421 5428 5430 5435 5440 5440 5440 5440 5467 5479 5486 5494 5505 5508 5510 5510 5518 5528 5537 5550 5556 5561 5561 5570 5581 5585 5603 5605 5610 5616 5616 5616 5616 5651 5656 5656 5658 5658 5675 5685 5690 5701 5752 5766 5771 5792 5797 5819 5830 5842 5856 6018 6022 6024 6031 6034 6036 6037 6040 6044 6232 6240 6259 6279 6466 6472 6486 6500 6502 6516 6539 6551 6555 6574 6582 6589 6589 6592 6592 6597 6597 6642 6723 6742 6760 6852 6930 6942 6968 6973 6997 7001 7041 7052 7060 7069 7074 7081 7091 7093 7101 7194 7205 7213 7222 7230 7239 7248 7250 7259 7274 7275 7284 7427 7435 7453 7461 7711 7711 7713 7719 7734 7741 7751 7760 7767 7775 7784 7800 7804 7837 7843 7888 7939 7939 7942 7943 7950 7951 7967 7974 7974 7982 8002 buffer_seg_pointer 4 000100 automatic pointer level 2 dcl 417 set ref 1305* 1323* 1324 1340* 1342 1441 1442 2371 2426 2427 2428 2428 2434 2437 2437 2889 2923 2923 2923 2930 2934 2935 2938 2943 2970 2970 2970 2978 2986 2986 2993 2994 3003 3006 3014 3017 3025 3030 3037 3038 3065 3067 3093 3108 3114 3115 3115 3124 3129 3134 3139 3147 3152 3153 3162 3164 3169 3372 3372 3372 3452 3466 3476 3489 3495 3505 3512 3515 3517 3517 3524 3524 3524 3532 3554 3958 3959 3959 3962 3962 4017 4019 4019 4022 4039 4040 4083 4084 4609 4611 4613 4679 4679 4726 4727 4727 4729 4729 4749 4752 4780 4786 5018 5026 5026 5052 5059 5067 5067 5122 5122 5139 5145 5196 5199 5199 5199 5211 5233 5369 5378 5386 5413 5416 5440 5440 5442 5478 5481 5510 5510 5561 5561 5630 5637 5637 5697 5707 5713 5713 5715 5717 6059 6061 6061 6061 6064 6218 6218 6220 6526 6800 6822 7037 7040 7041 7041 7042 7188 7190 7191 7194 7641 7678 7678 7709 7713 7741 7775 7826 7826 7827 7828 7828 7829 7829 7831 7854 7861 7861 8002 buffer_size 33 based fixed bin(17,0) level 2 dcl 1-11 ref 960 962 964 by_file 000626 automatic bit(1) dcl 3810 set ref 3818* 3820 3867 3881 3881 by_stop_statement parameter bit(1) dcl 4407 ref 4404 4428 c_temp 001364 automatic float bin(27) array dcl 6380 set ref 6944* 6952* 6958 7876* 7883* 7892 call_sw 000157 automatic fixed bin(1,0) dcl 479 set ref 933* 1041* 1066* 1093* 1118* 1603 1989 2056 2063 2200 2252 capital_letters 002121 constant char(26) initial unaligned dcl 480 ref 2482 3771 6555 6597 6597 carriage 0(10) based bit(1) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2510* 2875 3749 carriage 13 based bit(1) level 2 in structure "fortran_open_data" dcl 5-23 in procedure "fortran_io_" set ref 2517* 2540* 2875 3749 carriage_controllable 0(14) based bit(1) level 4 packed unaligned dcl 441 set ref 988 1625 1922 2074 2108 2258 3723* 6455 cc_bit parameter bit(1) dcl 1223 ref 1221 1234 cc_unit parameter fixed bin(17,0) dcl 1203 ref 1201 1209 1209 1212 ch 000160 automatic char(1) dcl 481 set ref 5518* 5519 5570* 5576 5585* 5587 5593 5701* 5702 5704 6615 6625 6651 6708 6713 6715 6719 6727 6739 6888 6888 6900 6910 6968* 6970 6994 7435* 7461* 7463 7470 7474 7474 7751* 7752 7784* 7790 7794 7804* 7809 7923 7942* 7943* 7944 7944 7946 7946 7967 7982 char_len 000161 automatic fixed bin(21,0) dcl 482 in procedure "fortran_io_" set ref 4827* 4828* 4836 4839 4839 4843 4843 4843 4849 4849 4855 4864 4873 4876 4876 4880 4880 4880 4885 4885 4891 4976* 4983* 5741 5743 5744 5749 5750 5764 5766 5767 5770 5771 5771 5785 5790 5792 5793 5794 5808 5813 5815 5816 5819 6818* 7097 7101 7101 7102 7261 7281 7284 7284 7285 7528* 7530* 7532* 7537 7537 7539 7587 7641 char_len parameter fixed bin(18,0) dcl 4132 in procedure "set_return_value" ref 4128 4140 4144 char_offset 000162 automatic fixed bin(21,0) dcl 483 set ref 948* 950* 964 1868* 2068* char_ptr parameter pointer unaligned dcl 4131 ref 4128 4144 char_str 16 based varying char(1024) level 2 dcl 5-23 set ref 1121* 2524* 2526* 2526 2535* 2535 2544* 2544 2553* 2553 2561* 2561 2566* 2566 2575* 2575 2583* 2583 2591* 2591 2602* 2602 2605 2930 2978 2994 3771 3794 3794 4175 4206 char_value parameter varying char(168) dcl 4133 ref 4128 4140 4144 character_array based char(1) array unaligned dcl 8093 set ref 8102 character_type constant fixed bin(6,0) initial dcl 6399 in procedure "namelist_io" ref 6848 6848 7528 7537 8007 character_type constant fixed bin(17,0) initial dcl 484 in procedure "fortran_io_" ref 998 chars based char(4096) unaligned dcl 487 set ref 2056* 2482 2485 2485 2526 4839* 4843* 4847* 4849* 4876 4880 4883 4885 5263 5272 5595* 5616 5616 5749* 5752* 5771 5797 5819* 7101 7261 7266 7274 7284 7587* 7641* chars_in_exp 001531 automatic fixed bin(17,0) dcl 7306 set ref 7350* 7352* 7361 7365 chars_left 000163 automatic fixed bin(21,0) dcl 485 set ref 2003* 2004 2007* 2010 2013 4842* 4843 4847 4847 4849 4849 4849 4879* 4880 4883 4883 4885 4885 4885 chars_per_item 000164 automatic fixed bin(21,0) dcl 486 set ref 4827* 4828 4976* 4983* 5304 6818* 7537* 7539* 7545 7552 8125 chars_stored parameter fixed bin(17,0) dcl 6292 in procedure "left_justify" set ref 6289 6304* 6310 6312 6313* 6313 6319* chars_stored parameter fixed bin(17,0) dcl 6331 in procedure "right_justify" set ref 6328 6343* 6348 6350* 6350 6351 6355 6358* chase_sw 001012 constant fixed bin(1,0) initial dcl 4111 set ref 4121* ci 000326 automatic structure level 1 dcl 14-3 set ref 4693 4693 class 3(18) based bit(4) level 3 packed unaligned dcl 17-3 ref 7542 close_code parameter fixed bin(35,0) dcl 1156 set ref 1154 1163* 1171* 1183* 1189* 1193* close_status_values 001711 constant varying char(12) initial array dcl 822 set ref 3447* close_unit parameter fixed bin(17,0) dcl 1156 ref 1154 1168 1175 1175 1177 1187 code 000165 automatic fixed bin(35,0) dcl 488 in procedure "fortran_io_" set ref 3826* 3828 3836 3959* 3960 4019* 4020 4020* 4040* 4041 4041* 4113* 4114 4121* 4122 code parameter fixed bin(35,0) dcl 4062 in procedure "get_associated_unit" set ref 4046 4068* 4072* 4096* code 001122 automatic fixed bin(35,0) dcl 4242 in procedure "reopen_for_input" set ref 4273* 4285* 4294 4294* 4297* column_one 000166 automatic fixed bin(17,0) dcl 489 set ref 1435* 1627* 2108 2112 2122 2126 2128 2137 2137 2137 2137 2137 2143 2148 2150 2159 2159 2159 2159 2159 2165 2170 2172 2177 2181 2187 2193 2277* 2281* 5867 5873 com_err_ 000014 constant entry external dcl 490 ref 4500 4507 4669 4669 4749 4752 4780 4786 7999 comma_encountered 001355 automatic bit(1) dcl 6370 set ref 6638 6954 7016 7448* 7465* 7878 7885 comma_required 001356 automatic bit(1) dcl 6370 set ref 6874* 6900 6904* 7016* comp_name 000100 automatic char(32) dcl 4559 set ref 4689* 4699* 4749 4752* 4780 4786* complex 10(03) 000354 automatic bit(1) level 4 packed unaligned dcl 1-47 set ref 4980 8065 complex_type constant fixed bin(6,0) initial dcl 6399 ref 6961 7530 7894 complex_value based structure level 1 dcl 6392 set ref 6958* 7892* component_info_$offset 000334 constant entry external dcl 4577 ref 4693 connected 0(05) based bit(1) array level 5 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 3854 4386 4459 4468 connected 0(05) based bit(1) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 1518 1664 1689 1727 1762 2500 2909 3389* 3569 3579 3595 3625 3684 3694 4079 4326 4333 constant_ptr 10 000100 automatic pointer level 2 dcl 417 set ref 6526* 6634 6636 6749 6762 6799 6822* 6958 7005 7605 7612 7618* 7625* 7652* 7660* 7667 7672* 7725 7831 7861* 7892 7912* 7916 7944 7946 constant_type 001371 automatic fixed bin(6,0) dcl 6399 set ref 6632 6742 6801* 6961* 7603 7708* 7727* 7754* 7793* 7794* 7812 7812* 7819 7859 7894* 7907 7916 7938* 8007* control_matrix 001231 constant fixed bin(17,0) initial array dcl 1462 ref 1575 control_type 6(08) 000354 automatic bit(4) level 3 packed unaligned dcl 1-47 set ref 1095 4635 4760 4762 convert builtin function dcl 491 ref 5442 7831 7843 converted_values 0(13) based structure level 3 packed unaligned dcl 5-23 copy builtin function dcl 492 ref 2137 2159 5229 5260 5268 5389 6024 6037 6040 6044 7160 7371 7382 count 000167 automatic fixed bin(17,0) dcl 493 set ref 5125* 5125 5128 5128* 5131* 5133 5136 5139 5197 5199 5199 5200 5212* 5216* 5233 5233 5233 5233 5235 5304* 5305 5307 5308 5311 5313 5369 5373 5378 5380* 5380 5386 5386 5386 5386 6220* 6221 6477* 6480 6496* 6698* 6790* 6790 6799 6800 count_pt 12 000100 automatic pointer level 2 dcl 417 set ref 6528* 6574 6615 6618* 6793 6797 6803* create_if_not_found constant bit(1) initial dcl 494 set ref 1207* 1229* 1439* create_sw 000406 automatic bit(1) dcl 1272 set ref 1279* 1309 1329 cu_$arg_count 000336 constant entry external dcl 4577 ref 4664 cu_$arg_list_ptr 000340 constant entry external dcl 4577 ref 4668 cu_$arg_ptr 000342 constant entry external dcl 4577 ref 4602 cu_$cl 000016 constant entry external dcl 495 ref 4809 cu_$gen_call 000344 constant entry external dcl 4577 ref 4669 cu_$stack_frame_ptr 000020 constant entry external dcl 496 ref 1405 cur_op 000310 automatic fixed bin(17,0) dcl 4564 set ref 4762* 4767* 4769* 4780 4786 current 000170 automatic fixed bin(4,0) dcl 497 set ref 968* 970* 1095* 1511 1518 1518 1544 1556 1559 1559 1573 1575 1598 1727 1849 d_format constant fixed bin(17,0) initial dcl 10-78 ref 5240 6034 data_type 10 000354 automatic structure level 3 in structure "fio_ps" packed unaligned dcl 1-47 in procedure "fortran_io_" set ref 6817 8028 data_type 001664 automatic fixed bin(17,0) dcl 8021 in procedure "set_size_and_count" set ref 8028* 8029 8060 data_type 001370 automatic fixed bin(6,0) dcl 6399 in procedure "namelist_io" set ref 6817* 6848 6856 6922 7035 7186 7520* 7521 7528 7530 7530 7537 7566 7603 data_type_of_prev_item 000244 automatic fixed bin(17,0) dcl 508 set ref 998* 6848 6856* data_word 34 based fixed bin(17,0) array level 2 dcl 1-11 set ref 1846 2482 2485 2485 2526 debug_io 6(14) 000354 automatic bit(1) level 3 packed unaligned dcl 1-47 set ref 4809 dec_flt based float dec(59) dcl 498 set ref 5478* 7709* dec_int based fixed dec(11,0) dcl 499 set ref 5018* 5026 5026 5052 5059 5067 5067 5413* 5442 6800* 7827* 7831 dec_int_picture based char(12) unaligned dcl 4960 ref 5026 5026 5052 5059 5067 5067 dec_num 001533 automatic float dec(18) dcl 7309 in procedure "ansi77_format" set ref 7330 7330 7332 7340 7341 7342 7356 7359 7372 7380 7388 7390 dec_num 001464 automatic float dec(18) dcl 7123 in procedure "ansi66_format" set ref 7144 7144 7146 7152 7155 7155 7159 7160 decimal_len 001210 automatic fixed bin(35,0) dcl 4933 set ref 5110* 5192* 5365* 6218* decimal_number based structure level 1 dcl 7126 in procedure "ansi66_format" decimal_number based structure level 1 dcl 7312 in procedure "ansi77_format" decimal_type 001211 automatic fixed bin(17,0) dcl 4934 set ref 5111* 5193* 5366* 6218* default_error_handler_$add_finish_handler 000022 constant entry external dcl 500 ref 1346 default_input based bit(1) level 4 packed unaligned dcl 441 ref 3001 default_output 0(01) based bit(1) level 4 packed unaligned dcl 441 ref 3012 defer 0(11) based bit(1) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2511* 2878 3752 defer 14 based bit(1) level 2 in structure "fortran_open_data" dcl 5-23 in procedure "fortran_io_" set ref 2518* 2878 3752 defer_bit parameter bit(1) dcl 1223 ref 1221 1235 defer_newline 0(04) based bit(1) array level 5 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 1235* 1367* defer_newline 0(04) based bit(1) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 2103 2258 2878* 3752* defer_specified parameter bit(1) dcl 1223 ref 1221 1235 delete_$path 000024 constant entry external dcl 502 ref 4504 delims 000556 constant char(5) initial dcl 6399 in procedure "namelist_io" ref 6973 delims constant char(4) initial unaligned dcl 7934 in procedure "input_logical" ref 7950 desired_file_type 000505 automatic fixed bin(17,0) dcl 2614 set ref 2819* 2845* 2853* 2900* 2903* 2957 3072 3124 3134 3162 3164 3169* 3169 3210 3211 3220 3227 3239 3250 3289 3368 3376 desired_mode 000557 automatic bit(2) dcl 3566 set ref 3629* 3632 3644 3650 3660 3660 3660 3671 desired_type parameter fixed bin(17,0) dcl 2615 ref 2850 2853 dexp 000171 automatic fixed dec(3,0) dcl 503 set ref 5575* 5595 5616 5616 5618 7749* 7843* 7843 7850 dfast_communications_area based structure level 1 dcl 854 dfast_openfile 0(18) based bit(1) level 3 packed unaligned dcl 5-23 set ref 2514* 3160 3569 digit 0(09) based char level 2 packed unaligned dcl 747 set ref 5122* 5122 5139 5145 5199* 5199 5199 5211 5233 5378 5386 5440 5440 5510 5510 5561 5561 6220 7741* 7775* 7829* digits 0(09) based char level 2 in structure "decimal_number" packed unaligned dcl 7126 in procedure "ansi66_format" ref 7146 7160 digits 0(09) based char level 2 in structure "decimal_number" packed unaligned dcl 7312 in procedure "ansi77_format" ref 7332 7340 7356 7359 7372 7380 7388 7390 digits 000532 constant char(10) initial dcl 6399 in procedure "namelist_io" ref 6723 6994 6997 7734 7760 7837 digits_after_E 001217 automatic fixed bin(17,0) dcl 4939 set ref 5169* 5173* 5202* 5205 5258 5260 5260 5261 5266 5268 5268 5269 5271 5356* 5361* 6034 6036 6037 6037 6037 dims 001362 automatic fixed bin(18,0) dcl 6370 set ref 7499* 7500 7502 dir_name 000110 automatic char(168) unaligned dcl 4559 in procedure "print_error" set ref 4735* 4749* 4752* 4780* 4786* dir_name 000707 automatic char(168) unaligned dcl 3814 in procedure "inquire_statement" set ref 3826* 3904 3959* 4019* 4040* dir_name parameter char unaligned dcl 4059 in procedure "get_associated_unit" set ref 4046 4069* direct 0(25) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3949 direct 100 based structure level 2 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" direct_access 0(11) based bit(1) level 5 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 2311 3697* 3705* 3723 3953 3991 4011 4031 direct_access 0(15) based bit(1) level 4 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2549* 2558* 2572* 2580* 2588* 2711* 2799 2839* 2957 3187 3191 3684 3694 direct_access constant bit(2) initial dcl 3-8 in procedure "fortran_io_" ref 1884 1954 2211 2311 2839 4773 direction 0(03) 000000 constant structure array level 2 in structure "open_mode" packed unaligned dcl 767 in procedure "fortran_io_" ref 3414 3627 4265 4309 direction 0(13) based structure level 4 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2513* 2699* 2701* 2703* 2706* 2957 3414 3629 direction 0(09) based structure level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 3634* 3650* 3669* 3671* 4265* 4309* dirname 000172 automatic char(168) unaligned dcl 504 set ref 4176* 4182* 4497* 4504* divide builtin function dcl 505 ref 950 962 964 2482 6670 7545 7552 8047 8060 8063 8065 dname parameter char unaligned dcl 4107 in procedure "get_unique_id" set ref 4100 4113* 4121* dname 000102 automatic char(168) unaligned dcl 4065 in procedure "get_associated_unit" set ref 4084* double 10(02) 000354 automatic bit(1) level 4 packed unaligned dcl 1-47 set ref 4861 4870 5088 5470 5635 5678 5715 6213 8065 double_precision constant bit(1) initial unaligned dcl 7031 in procedure "ansi66_output" set ref 7059* double_precision constant bit(1) initial unaligned dcl 7182 in procedure "ansi77_output" set ref 7209* double_type constant fixed bin(6,0) initial dcl 6399 ref 7530 7794 7859 double_word based fixed bin(71,0) level 2 packed unaligned dcl 761 set ref 5678* 5697* 5713* 5713 5715* 5715 double_word_file 0(16) based bit(1) level 4 packed unaligned dcl 441 set ref 1984 3372* 4861 4870 dp_pic_len constant fixed bin(17,0) initial dcl 7028 ref 7056 7060 7061 dpt 001530 automatic fixed bin(17,0) dcl 7306 set ref 7353* 7355* 7357 7361 7364 7365 7387* 7388 7388 7390 7390 7390 7390 dummy_for_double_word_alignment 000100 automatic structure level 1 dcl 417 e 000245 automatic fixed bin(17,0) dcl 509 set ref 5501* 5522* 5553* 5556* 5556 5563* 5563 5623* 5623 5625 5627 5630 7748* 7760* 7761 7763 7763* 7767 7768 7773 7775 7775 7775 7777 7778 7850* 7850 7851 7851 7854 effective_digits 001216 automatic fixed bin(17,0) dcl 4938 set ref 5021* 5024* 5026* 5027 5027* 5034 5035 5050 5059 5062* 5062 5067 5067 5067 5271* 5272 5272 5272 5272 5354* 5359* 5373 5389 5389 5389 5777* 5785* 5787 5790 5792 5793 5796 5803* 5808* 5810 5813 5815 5818 element based bit level 2 packed unaligned dcl 8118 set ref 8135 element_count 000246 automatic fixed bin(24,0) dcl 510 in procedure "fortran_io_" set ref 4827* 4828 4976* 4982* 4982 5005 5082 5155 5281 5298 5324 5397 5453 5645 5668 5736 5759 5779 5805 5915* 5915 5925 5934 5954 6099* 6491 6496 6701 6753 6753* 6789* 6789 6818* 6824 6835* 6835 6847 6861 7545* 7552* element_count 11 000354 automatic fixed bin(17,0) level 2 in structure "fio_ps" dcl 1-47 in procedure "fortran_io_" set ref 1997 4864* 8057 8060 8063 8065 8068 element_count parameter fixed bin(24,0) dcl 8021 in procedure "set_size_and_count" set ref 8013 8060* 8063* 8065* 8068* 8073* element_desc 10 000354 automatic structure level 2 in structure "fio_ps" packed unaligned dcl 1-47 in procedure "fortran_io_" element_desc 26 based structure level 2 in structure "PS" packed unaligned dcl 1-11 in procedure "fortran_io_" element_p based structure level 1 dcl 8116 in procedure "advance_element_p" element_p 30 based pointer level 2 in structure "PS" dcl 1-11 in procedure "fortran_io_" set ref 4615* element_p 12 000354 automatic pointer level 2 in structure "fio_ps" dcl 1-47 in procedure "fortran_io_" set ref 1412* 1981* 2000* 2003* 2004* 2007* 2010 2010 4615 4839 4842* 4843 4847 4849 4876 4879* 4880 4883 4885 5017 5088 5090 5163 5289 5314 5336* 5344 5349 5407 5442 5470 5473 5637* 5653 5656 5658 5678 5680 5715 5717 5749 5752 5771 5797 5819 6218* 7040 7050* 7059* 7077* 7077 7084* 7084 7091 7101 7188 7201* 7209* 7232* 7232 7241* 7241 7248 7261 7266 7274 7284 7496* 7514 7545 7545* 7552* 7568 7572 7575 7579 7583 7587 7605 7612 7618* 7625* 7641 7649 7652* 7657 7660* 7665 7667 7672* 7678* 8126 8126 8133 8133 8135* 8135 element_size parameter fixed bin(21,0) dcl 8023 set ref 8013 8031* 8037* 8042* 8046* element_v 001226 automatic float bin(63) dcl 4950 set ref 5088* 5090* 5098 5100 ename parameter char unaligned dcl 4107 in procedure "get_unique_id" set ref 4100 4113* 4121* ename 000154 automatic char(32) unaligned dcl 4066 in procedure "get_associated_unit" set ref 4084* end_label 6(01) 000354 automatic bit(1) level 3 packed unaligned dcl 1-47 set ref 1944 1948 end_of_input 6(19) 000354 automatic bit(1) level 3 packed unaligned dcl 1-47 set ref 1045 6893* end_p 14 based pointer level 2 dcl 1-11 set ref 1948* end_pos 2 based fixed bin(34,0) level 2 dcl 11-1 ref 3512 3524 end_pt 14 000100 automatic pointer level 2 dcl 417 set ref 7510* 7514* 7545 7545* 7552* ent_name parameter char unaligned dcl 4060 in procedure "get_associated_unit" set ref 4046 4069* ent_name 000761 automatic char(32) unaligned dcl 3815 in procedure "inquire_statement" set ref 3826* 3904 3959* 4019* 4040* ent_name 000162 automatic char(256) unaligned dcl 4559 in procedure "print_error" set ref 4686* 4687* 4689 4749 4752* 4780 4786* entry_point 000247 automatic fixed bin(17,0) dcl 511 set ref 912 1417* 1420 1422 entry_ptr 26 based pointer level 2 dcl 7-36 set ref 4686* entryname 000250 automatic char(32) unaligned dcl 512 set ref 4176* 4182 4182 4497* 4504* eofs_are_records 1(28) based bit(1) level 4 packed unaligned dcl 441 set ref 1795* 1933 3360* erasable_file 000506 automatic bit(1) dcl 2616 set ref 2891* 3111* 3383 3451* 3452 3472 err_code parameter fixed bin(35,0) dcl 1223 ref 1221 err_point 000316 automatic pointer dcl 4572 set ref 4679* 4681 4682 error_code parameter fixed bin(35,0) dcl 1203 in procedure "fortran_io_" set ref 1201 1209* 1213* 1231* 1237* error_code 000312 automatic fixed bin(35,0) dcl 4564 in procedure "print_error" set ref 4602* 4604 4604* 4611 4622 4645 4670* 4749* 4752* 4780* 4786* error_label 6 000354 automatic bit(1) level 3 packed unaligned dcl 1-47 set ref 1031* 1954* 4624 4630 error_message 1 based char(128) level 2 dcl 10-71 set ref 6061* error_p 12 based pointer level 2 dcl 1-11 set ref 4630* error_string 000570 automatic varying char(64) dcl 3766 set ref 3787* 3789* 3789 3791* 3791 3794* error_table_$asynch_deletion 000026 external static fixed bin(35,0) dcl 513 ref 2377 2409 error_table_$boundviol 000372 external static fixed bin(35,0) dcl 8114 set ref 8131* error_table_$end_of_info 000030 external static fixed bin(35,0) dcl 515 set ref 1674 1700 1933 1942 1961* 2024 2243 2406 error_table_$moderr 000032 external static fixed bin(35,0) dcl 517 ref 3239 3310 4285 error_table_$no_file 000034 external static fixed bin(35,0) dcl 518 set ref 1193 1209 1231 1563* 3836 4072 error_table_$no_operation 000036 external static fixed bin(35,0) dcl 519 ref 2430 error_table_$no_record 000040 external static fixed bin(35,0) dcl 521 set ref 2341* 2354 2377 2404 2409 error_table_$noentry 000042 external static fixed bin(35,0) dcl 522 set ref 2772* 3530 error_table_$pathlong 000044 external static fixed bin(35,0) dcl 523 set ref 2743* error_table_$short_record 000046 external static fixed bin(35,0) dcl 524 ref 1916 2018 exist 0(16) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3865 exist 63 based pointer level 2 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3867 3869 exists 000260 automatic bit(1) dcl 526 set ref 1159* 1161 1207* 1229* 1439* 1884* 2213* 2215* 2235 exists_file_code parameter fixed bin(17,0) dcl 4157 in procedure "exists_file" set ref 4152 4166* 4168* 4171* 4177* 4183* exists_file_code 000261 automatic fixed bin(17,0) dcl 527 in procedure "fortran_io_" set ref 2742* 2743 2746 2772 2786 exp based fixed bin(8,0) level 2 in structure "decimal_number" packed unaligned dcl 7126 in procedure "ansi66_format" ref 7152 exp based fixed bin(8,0) level 2 in structure "decimal_number" packed unaligned dcl 7312 in procedure "ansi77_format" ref 7341 exp 001213 automatic fixed bin(17,0) dcl 4936 in procedure "formatted_io" set ref 5369* 5370 5370 5376 5378 5378 5379 5380 5502* 5574* 5618* 5623 exp based fixed bin(8,0) level 2 in structure "number" packed unaligned dcl 747 in procedure "fortran_io_" ref 5196 5369 exp 17 based fixed bin(8,0) level 2 in structure "flt_dec" packed unaligned dcl 747 in procedure "fortran_io_" set ref 5630* 7854* exp 2(27) 001222 automatic fixed bin(8,0) level 2 in structure "x_float" packed unaligned dcl 4944 in procedure "formatted_io" set ref 5338 5338 5341* 5341 exp_char 001463 automatic char(1) unaligned dcl 7122 set ref 7137* 7142* 7164 expand_pathname_ 000050 constant entry external dcl 528 ref 4040 4113 4176 4497 exponent 0(09) based fixed bin(9,0) level 2 in structure "long_format" packed unsigned unaligned dcl 10-60 in procedure "fortran_io_" ref 6167 exponent 001462 automatic picture(4) unaligned dcl 7121 in procedure "ansi66_format" set ref 7150* 7152* 7162 7162 7164 7164 exponent 001532 automatic picture(4) unaligned dcl 7308 in procedure "ansi77_format" set ref 7337* 7341* 7348 7348 7350 7361 7361 7364 7368 7370 7377 7379 7387 exponent 001212 automatic fixed dec(3,0) dcl 4935 in procedure "formatted_io" set ref 5196* 5200* 5200 5202 5205 5238 5246 5256 5263 5272 exponent 4 001163 automatic fixed bin(17,0) level 2 in structure "field" dcl 4916 in procedure "formatted_io" set ref 5167 5173 5174 5202 5238 5352 5359 5360 5361 6167* 6173* exps 002120 constant char(4) initial dcl 529 ref 5576 7790 ext_float_decimal 002117 constant fixed bin(17,0) initial dcl 530 set ref 5193 5336* 5366 5637* 7144* 7330* 7678* 7861* extended_i_format constant fixed bin(17,0) initial dcl 10-78 ref 5021 5027 extra_char 455(27) based char(1) level 2 packed unaligned dcl 4-18 set ref 2131 2153 2196 2197* factor 001366 automatic fixed bin(18,0) dcl 6381 set ref 6702* 6708 6749* 6750 6753 6753* 6778 6789 6790 fast_related_data_$fortran_buffer_p 000052 external static pointer dcl 531 set ref 1032 1286 1298* 1314 1324* 1342* 1381 1389* 1392* 4375 4420 fast_related_data_$fortran_io_initiated 000054 external static bit(1) dcl 533 set ref 1280 1284 1371* 1378 1394* 4372 4417 fast_related_data_$in_dfast 000056 external static bit(1) dcl 535 ref 1364 1518 1643 1832 1842 4635 fast_related_data_$in_fast_or_dfast 000060 external static bit(1) dcl 537 ref 1133 4799 4811 fast_related_data_$terminate_run 000062 external static entry variable dcl 539 ref 4811 father 2 based bit(18) level 2 packed unaligned dcl 17-3 ref 6444 6447 fcb_ptr 16 000100 automatic pointer level 2 dcl 417 set ref 988 988 1178* 1179 1515* 1516 1518 1522 1524 1529 1529 1537* 1538 1543 1546 1556 1575 1588 1590 1598 1603 1611 1614 1625 1625 1625 1659 1659 1659 1662 1664 1666 1685 1687 1689 1691 1705 1712 1713 1714 1724 1727 1727 1730 1756 1756 1756 1756 1762 1764 1766 1772 1776 1777 1789 1793 1795 1796 1807 1814 1820 1824 1824 1827 1889 1901 1922 1933 1933 1933 1965 1968 1968 1973 1984 2074 2074 2081 2087 2087 2093 2102 2103 2108 2108 2112 2115 2128 2150 2172 2181 2193 2219 2222 2224 2230 2241 2247 2258 2258 2271 2273 2273 2296 2296 2303 2303 2311 2315 2321 2325 2344 2349 2359 2389 2437 2490 2493 2500 2833 2872 2875 2878 2881 2909 2947 3001 3012 3085 3101 3155 3264 3327 3358 3359 3360 3370 3372 3376 3379 3383 3383 3383 3389 3414 3414 3419 3435 3451 3452 3459 3467 3477 3569 3569 3569 3579 3595 3595 3625 3627 3632 3632 3634 3634 3637 3650 3669 3671 3675 3682 3684 3684 3688 3689 3694 3697 3698 3698 3698 3698 3704 3705 3706 3713 3713 3717 3723 3723 3723 3723 3732 3736 3740 3746 3749 3752 3834* 3852* 3853 3893 3893 3900 3900 3914 3927 3940 3953 3978 3991 4000 4011 4013 4013 4031 4031 4077* 4078 4079 4081 4244 4264 4265 4272 4281 4301 4308 4309 4326 4331 4333 4337 4343 4356 4359 4832 4861 4870 6075 6455 6455 fcode 000101 automatic fixed bin(35,0) dcl 4409 set ref 4428* 4435* 4459* 4466* 4468* 4472* field 001163 automatic structure level 1 dcl 4916 in procedure "formatted_io" field based structure array level 1 dcl 4200 in procedure "get_open_field" field_num parameter fixed bin(17,0) dcl 4196 ref 4193 4204 4206 field_number parameter fixed bin(17,0) dcl 4215 ref 4212 4217 field_structure based structure level 1 dcl 794 file 000507 automatic picture(2) unaligned dcl 2617 set ref 2888* 2935 3025 3038 file_connected 000630 automatic bit(1) dcl 3810 set ref 3830* 3838* 3842* 3854* 3858* 3872 3881 3891 3900 3900 3912 3925 3938 3951 3973 file_desc based structure level 1 dcl 441 file_exists 000631 automatic bit(1) dcl 3810 set ref 3831* 3839* 3843* 3867 3881 file_is_empty 000510 automatic bit(1) dcl 2618 set ref 2891* 3201 3512* 3533* file_name 001170 constant char(12) initial array unaligned dcl 2619 set ref 3164* 3164* 3227* file_number 7 000354 automatic fixed bin(17,0) level 2 in structure "fio_ps" dcl 1-47 in procedure "fortran_io_" set ref 1029* 1177* 1178 1410* 1513 1513 1515 1535 1779 1849* 2488 2860 2888 3461* 3466* 3472* 3476* 3832* 3847* 4500* 4507* 4616 4635 4635 4639 4780* 4786* file_number parameter fixed bin(17,0) dcl 4495 in procedure "delete_file" ref 4488 file_number 10 based fixed bin(17,0) level 2 in structure "PS" dcl 1-11 in procedure "fortran_io_" set ref 1029 1410 4616* file_status 1 based fixed bin(2,0) array level 5 in structure "fortran_buffer_" packed unsigned unaligned dcl 4-18 in procedure "fortran_io_" set ref 4448 file_status 1 based fixed bin(2,0) level 4 in structure "file_desc" packed unsigned unaligned dcl 441 in procedure "fortran_io_" set ref 3452 3459 3740* 3893 3900 file_status 0(19) based fixed bin(3,0) level 3 in structure "fortran_open_data" packed unsigned unaligned dcl 5-23 in procedure "fortran_io_" set ref 2691* 2693* 2760 2767 2781 2796 3023 3276 3740 3741 file_type 001017 automatic fixed bin(2,0) dcl 4159 set ref 4182* file_type_matrix 001072 constant fixed bin(17,0) initial array dcl 2643 ref 3162 3169 file_uid 000100 automatic bit(36) dcl 4064 set ref 4069* 4070 4085 file_unit parameter fixed bin(17,0) dcl 1223 ref 1221 1231 1231 1234 1235 filename 0(03) based bit(1) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2736 2760 2769 2783 2862 2981 3604 filename 2 based char(168) level 2 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3826 3826 filename parameter char unaligned dcl 4058 in procedure "get_associated_unit" set ref 4046 4069* filename parameter char unaligned dcl 4106 in procedure "get_unique_id" set ref 4100 4113* filename 0(03) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3818 filename_field constant fixed bin(17,0) initial dcl 3-50 set ref 2984* 2986* 2986* 2989* 2989* 4164* filetype_ptr 4 based pointer level 2 dcl 854 ref 2482 2485 2485 filetypes 001220 constant char(36) initial unaligned dcl 2479 ref 2482 fio_data_type_index 002140 constant fixed bin(17,0) initial array dcl 454 ref 6817 8028 fio_ps 000354 automatic structure level 1 dcl 1-47 set ref 1428 fio_vfile_attach 000512 automatic bit(1) dcl 2623 set ref 2891* 3050* 3124 3201 first 000110 constant fixed bin(17,0) initial array level 2 dcl 2638 ref 3306 first_digit 001525 automatic fixed bin(17,0) dcl 7306 in procedure "ansi77_format" set ref 7332* 7333 7335* 7340 7341 7356 7359 7372 7380 7388 7390 first_digit 001456 automatic fixed bin(17,0) dcl 7119 in procedure "ansi66_format" set ref 7146* 7147 7149* 7152 7153 7160 fixed builtin function dcl 541 ref 975 1043 1292 2010 2010 4849 4885 5341 6444 6446 6462 6531 6658 6659 6817 7493 7499 7517 7545 7545 8028 fixed_decimal constant fixed bin(17,0) initial dcl 4904 ref 5111 fixedoverflow 000262 stack reference condition dcl 542 ref 930 1090 1115 flags 3 based structure level 2 in structure "uns_info" dcl 11-1 in procedure "fortran_io_" flags 1 based structure level 2 in structure "rs_info" dcl 8-6 in procedure "fortran_io_" fld_no parameter fixed bin(17,0) dcl 3764 set ref 3760 3769* 3794* 3794* float_bin based float bin(27) dcl 4955 set ref 5090 5163 5344 5349 5473* flt_dec based structure level 1 dcl 747 flt_pic_len constant fixed bin(17,0) initial dcl 7028 ref 7047 7052 7052 7053 7066 fmt 1 based bit(36) array level 2 dcl 10-32 set ref 4990 fmt_parse_ver1 constant bit(6) initial dcl 10-97 ref 6056 fmt_ptr 20 000100 automatic pointer level 2 dcl 417 set ref 4990* 4994 6124 6124 6126 6131 6134 6135 6138 6139 6145 6148 6149 6150 6153 6154 6155 6161 6164 6165 6166 6167 6170 6171 6172 fold 6(20) 000354 automatic bit(1) level 3 packed unaligned dcl 1-47 set ref 6553 6592 for_input 0(05) 000000 constant fixed bin(4,0) initial array level 2 packed unaligned dcl 767 ref 4249 4253 for_output 0(10) 000000 constant fixed bin(4,0) initial array level 2 packed unaligned dcl 767 ref 4278 4287 form 0(06) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3998 form 0(06) based bit(1) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2506* 2715 2829* 2862 3183 3586 3682 form 56 based structure level 2 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" form_field constant fixed bin(17,0) initial dcl 3-50 set ref 2717* format 24 000376 automatic structure level 2 in structure "oi" dcl 4597 in procedure "print_error" format based structure level 1 dcl 10-53 in procedure "fortran_io_" format 6(03) 000354 automatic bit(2) level 3 in structure "fio_ps" packed unaligned dcl 1-47 in procedure "fortran_io_" set ref 975 981 984* 1043 2031 2321 2842 4771 format_desc_bits 0(18) based structure level 3 packed unaligned dcl 10-32 format_error based structure level 1 dcl 10-71 format_p 22 000100 automatic pointer level 2 dcl 417 set ref 4990 5941 5964 6056* 6064* 6069 6071 6077 6087 format_type 002102 constant char(13) initial array unaligned dcl 544 ref 4771 formatted 0(22) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3910 formatted 73 based structure level 2 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" formatted_records 0(08) based bit(1) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 2093 2230 2321 2325 3682* 3684* 3688* 3689* 3713 3723 3914 3927 4000 formatted_records 0(16) based bit(1) level 4 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2532* 2542* 2551* 2596* 2719* 2842* 2957 3183 3682 3737 fort_version_info$greeting 000322 external static char(16) dcl 1247 ref 1253 fort_version_info$version_number 000324 external static char(16) dcl 1249 ref 1253 fortran_attached 0(06) based bit(1) array level 5 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 4386 4472 fortran_attached 0(06) based bit(1) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 1789* 3101* 3383 3569 3595 4337 fortran_buffer_ based structure level 1 unaligned dcl 4-18 set ref 1294* 1294 1356* 1356 fortran_buffer_$ 000064 external static fixed bin(17,0) dcl 546 set ref 1356 fortran_buffer_ptr 000370 automatic pointer dcl 4-15 set ref 1032* 1120 1121 1178 1212 1234 1235 1286* 1292 1294 1294 1297* 1297 1298 1301 1301 1305 1314* 1319 1323 1324* 1342* 1354 1356 1358 1358 1361 1366 1367 1368 1515 1537 1551 1592 1594 1619 1620 1896 2102 2103 2112 2131 2153 2196 2197 2268 2503 2505 2506 2507 2508 2509 2510 2511 2513 2514 2516 2517 2518 2520 2524 2526 2526 2532 2535 2535 2540 2542 2544 2544 2549 2551 2553 2553 2558 2561 2561 2566 2566 2572 2575 2575 2580 2583 2583 2588 2591 2591 2596 2602 2602 2605 2605 2688 2691 2693 2695 2699 2701 2703 2706 2708 2711 2715 2719 2723 2726 2728 2733 2733 2733 2736 2739 2760 2760 2767 2769 2781 2783 2796 2799 2803 2803 2807 2811 2827 2829 2830 2831 2833 2835 2837 2839 2842 2856 2862 2862 2862 2862 2862 2862 2862 2862 2862 2872 2872 2875 2875 2878 2878 2881 2895 2900 2903 2903 2919 2930 2957 2957 2957 2957 2965 2978 2981 2994 3001 3012 3023 3047 3055 3065 3082 3160 3183 3183 3187 3191 3201 3201 3211 3239 3276 3291 3310 3414 3426 3447 3461 3569 3579 3583 3586 3589 3598 3604 3625 3629 3644 3660 3660 3669 3682 3682 3684 3684 3694 3694 3729 3729 3736 3737 3737 3740 3741 3741 3746 3746 3749 3749 3752 3752 3771 3794 3794 3818 3826 3826 3834 3847 3849 3849 3852 3854 3865 3867 3869 3872 3872 3889 3891 3893 3895 3898 3905 3905 3910 3919 3919 3923 3932 3932 3936 3945 3945 3949 3966 3966 3976 3981 3981 3985 3985 3989 3994 3994 3998 4003 4003 4009 4022 4029 4031 4076 4077 4175 4204 4206 4206 4641 4643 4645 4656 4659 fortran_inquire_data based structure level 1 dcl 6-11 fortran_io_error_$access_field_error 000066 external static fixed bin(35,0) dcl 547 ref 4229 fortran_io_error_$already_connected 000070 external static fixed bin(35,0) dcl 549 set ref 3579* 3583* 3586* 3589* fortran_io_error_$already_opened 000072 external static fixed bin(35,0) dcl 551 set ref 3600* 3606* fortran_io_error_$attach_desc_field_error 000074 external static fixed bin(35,0) dcl 553 ref 4223 fortran_io_error_$bad_char 000076 external static fixed bin(35,0) dcl 555 set ref 4547* fortran_io_error_$blank_field_error 000100 external static fixed bin(35,0) dcl 557 ref 4233 fortran_io_error_$cannot_position 000102 external static fixed bin(35,0) dcl 559 set ref 1666* 1679* 1691* 1709* 1720* fortran_io_error_$cannot_read 000104 external static fixed bin(35,0) dcl 561 set ref 2296* fortran_io_error_$cannot_reopen 000106 external static fixed bin(35,0) dcl 563 set ref 4260* 4294 fortran_io_error_$cannot_truncate 000110 external static fixed bin(35,0) dcl 565 set ref 1759* 1764* 1774* 1817* fortran_io_error_$cannot_write 000112 external static fixed bin(35,0) dcl 567 set ref 2303* 2440* fortran_io_error_$close_attr_error 000116 external static fixed bin(35,0) dcl 571 set ref 3461* fortran_io_error_$conversion_error 000114 external static fixed bin(35,0) dcl 569 set ref 1261* 4543* fortran_io_error_$dnumeric_file 000120 external static fixed bin(35,0) dcl 573 set ref 4861* 4870* fortran_io_error_$filename_field_error 000122 external static fixed bin(35,0) dcl 575 ref 4225 fortran_io_error_$fio_sys_error 000124 external static fixed bin(35,0) dcl 577 set ref 33* 1034* 1263* 1640* 3352* 3409* 3491* 3508* 3572* 4526* 5722* fortran_io_error_$form_field_error 000126 external static fixed bin(35,0) dcl 579 ref 4231 fortran_io_error_$format_error 000130 external static fixed bin(35,0) dcl 581 set ref 6061* 6111* fortran_io_error_$format_is_infinite 000132 external static fixed bin(35,0) dcl 583 set ref 5938* 5961* 6087* fortran_io_error_$formatted_file 000134 external static fixed bin(35,0) dcl 585 set ref 2321* fortran_io_error_$incompatible_opening 000136 external static fixed bin(35,0) dcl 587 set ref 3164* 3227* 3713* 3717* 3737* fortran_io_error_$internal_file_oflow 000140 external static fixed bin(35,0) dcl 589 set ref 4538* fortran_io_error_$invalid_file0_attr 000142 external static fixed bin(35,0) dcl 591 set ref 2868* fortran_io_error_$invalid_file0_type 000144 external static fixed bin(35,0) dcl 593 set ref 2496* fortran_io_error_$invalid_for_file0 000146 external static fixed bin(35,0) dcl 595 set ref 1189 1559* fortran_io_error_$io_switch_field_error 000150 external static fixed bin(35,0) dcl 597 ref 4221 fortran_io_error_$long_record 000152 external static fixed bin(35,0) dcl 599 set ref 4534* fortran_io_error_$missing_header 000154 external static fixed bin(35,0) dcl 601 set ref 6545* fortran_io_error_$mode_field_error 000156 external static fixed bin(35,0) dcl 603 ref 4227 fortran_io_error_$must_be_empty 000160 external static fixed bin(35,0) dcl 605 set ref 2437* fortran_io_error_$namelist_error 000162 external static fixed bin(35,0) dcl 607 set ref 6592* 6753* 7521* fortran_io_error_$not_blocked 000164 external static fixed bin(35,0) dcl 609 set ref 2430* 2434* 4024* fortran_io_error_$not_direct 000166 external static fixed bin(35,0) dcl 611 set ref 2311* 2411 fortran_io_error_$not_open 000170 external static fixed bin(35,0) dcl 613 set ref 1527* 4096 fortran_io_error_$not_scratch_file 000172 external static fixed bin(35,0) dcl 615 set ref 3472* fortran_io_error_$not_sequential 000174 external static fixed bin(35,0) dcl 617 set ref 2315* fortran_io_error_$open_attr_conflict 000176 external static fixed bin(35,0) dcl 619 set ref 2733* 2739* 2760* 2799* 2803* 2807* 2811* 3741* fortran_io_error_$open_attr_incomplete 000200 external static fixed bin(35,0) dcl 621 set ref 2746* 2769* 2783* fortran_io_error_$parens_too_deep 000202 external static fixed bin(35,0) dcl 623 set ref 5895* fortran_io_error_$read_after_eof 000204 external static fixed bin(35,0) dcl 625 set ref 1939* fortran_io_error_$short_record 000206 external static fixed bin(35,0) dcl 627 set ref 4530* fortran_io_error_$status_field_error 000210 external static fixed bin(35,0) dcl 629 set ref 2786* 4219 fortran_io_error_$syntax_error 000212 external static fixed bin(35,0) dcl 631 set ref 2455* 4551* 6580* 6585* 6642* 6651* 6660* 6679* 6684* 6750* 6763* 6772* 6907* 7006* 7629* 7635* 7682* 7689* 7919* fortran_io_error_$unformatted_file 000214 external static fixed bin(35,0) dcl 633 set ref 2325* fortran_io_error_$unknown_filetype 000216 external static fixed bin(35,0) dcl 635 set ref 2485* fortran_io_error_$write_after_eof 000220 external static fixed bin(35,0) dcl 637 set ref 2074* fortran_io_error_$wrong_mode 000222 external static fixed bin(35,0) dcl 639 set ref 3660* 3666* fortran_open_data based structure level 1 dcl 5-23 set ref 4204 4206 fortran_opened 0(07) based bit(1) array level 5 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 4386 4466 fortran_opened 0(07) based bit(1) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 1705 1807* 1824 1827* 3327* 3383 3569 3632 3637 4331 frn 000100 automatic fixed bin(17,0) dcl 4409 set ref 4443* 4445 4448 4448 4459 4459 4466 4468 4472 4476* 4477 4480* general_format_parse_$runtime 000224 constant entry external dcl 642 ref 6059 get_entry_name_ 000346 constant entry external dcl 4577 ref 4686 get_pdir_ 000226 constant entry external dcl 645 ref 3025 get_segment 000407 automatic bit(1) dcl 1273 set ref 1321* 1335* 1361 get_temp_segments_ 000330 constant entry external dcl 1274 ref 1337 given 000611 automatic varying char(12) dcl 3767 set ref 3771* 3778 has_been_deleted 1(02) based bit(1) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 3467* 3477* has_been_deleted 1(02) based bit(1) array level 5 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 4448 4477* have_input 6(18) 000354 automatic bit(1) level 3 packed unaligned dcl 1-47 set ref 1031* 1880* 1957* 2031* 4792 6577* 6839* 6890* have_runtime_format 000270 automatic bit(1) dcl 646 set ref 973* 6067* 7408 hbound builtin function dcl 647 ref 3341 3347 3773 3849 4076 5331 5338 5338 5895 5895 5895 7518 hcs_$fs_get_path_name 000350 constant entry external dcl 4577 ref 4735 hcs_$status_long 000230 constant entry external dcl 648 ref 4121 hcs_$status_minf 000232 constant entry external dcl 649 ref 4182 hcs_$status_mins 000352 constant entry external dcl 4577 ref 4702 header_id 4 based fixed bin(35,0) level 2 dcl 11-1 ref 3372 header_present 3(02) based bit(1) level 3 packed unaligned dcl 11-1 set ref 3153* 3372 3517 header_word based structure level 2 packed unaligned dcl 10-32 headers 046052 constant char(2) initial dcl 6399 ref 6539 6574 7470 headings 001352 automatic bit(1) dcl 6370 set ref 6455* 6458 6500 6512 hfp 6(22) 000354 automatic bit(1) level 3 packed unaligned dcl 1-47 set ref 5334 5632 6210 7131 7318 7326 7600 7856 7909 i 000566 automatic fixed bin(17,0) dcl 3764 in procedure "convert_from_character" set ref 3777* 3778 3780* 3788* 3789* i 000513 automatic fixed bin(17,0) dcl 2624 in procedure "open_statement" set ref 2690* 2691 2697* 2699 2701 2710* 2711 2717* 2719 2725* 2726 3306* 3307* 3339* 3341 i 000271 automatic fixed bin(18,0) dcl 651 in procedure "fortran_io_" set ref 4076* 4077 4087* 5106* 5118* 5133* 5136* 5137 5139 5139 5140 5170* 5174* 5309* 5311* 5313* 5313* 5314* 5355* 5360* 5373* 5404* 5405 5411 5435* 5436 5438 5467* 5468 5476 5494* 5495 5497 5550* 5551 5551* 5553 5554 5560* 5561 5561 5561 5581* 5582 5584 5610* 5611 5613 5651* 5654 5656 5656 5658 5658 5658 5658 5675* 5676 5683 5794* 5796* 5797 5797 6193* 6193 6194 6196 6199* 6199 6230 6232 6233 6582* 6583 6583* 6585 6589 6589 6592 6592 6597 6597 6610 6659* 6660 6666 6670 6671 6672 6762* 6763 6769* 6937* 6944 6952* 6973* 6974 6974* 6977* 6997* 6998 7001 7420* 7421 7427* 7429 7433 7719* 7720 7722 7730 7767* 7768 7768* 7771* 7773 7775 7775 7775 7775 7777 7800* 7801 7803 7837* 7838 7838* 7840 7843 7844 7967* 7972 7978* ii 001562 automatic fixed bin(17,0) dcl 7445 set ref 7453* 7454 7459 7477 illegal_return 000000 stack reference condition dcl 652 ref 4816 imag_part 1 based float bin(27) level 2 dcl 6392 set ref 7572* 7649* 7657* 7665* implicit_opening 000514 automatic bit(1) dcl 2625 set ref 2820* 2846* 2854* 2856 3007* 3018* 3409 3632 3669 in 000272 automatic fixed bin(17,0) dcl 653 in procedure "fortran_io_" set ref 2482* 2485 2490 2493 2529 2536* 2545* 2554* 2562* 2568* 2576* 2584* 2592* 2599* 2607* 5698* 5707 5707 5710* 5710 5744* 5748* 5752 5752 5816* 5818* 5819 in 0(09) based bit(1) level 5 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 2296 in 0(13) based bit(1) level 5 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2835* 3001 3201 3426 3644 3660 in_fmt based char(1024) dcl 4955 set ref 5830 5842* 6059* 6061 6061 in_range 000627 automatic bit(1) dcl 3810 set ref 3851* 3859* 3869 index builtin function dcl 654 ref 2482 3030 3554 4517 5576 5704 6539 6574 6713 6723 6727 6739 6760 6970 6994 7266 7470 7790 7794 7809 7967 indexed constant fixed bin(17,0) initial dcl 3-39 ref 2599 3962 indx 001170 automatic fixed bin(17,0) level 2 dcl 4923 set ref 4990 4992* 4992 5899 5912* 5941* 5964* 6096* 6133* 6133 6147* 6147 6163* 6163 infinite_format 001207 automatic bit(1) dcl 4932 set ref 5003* 5075* 5154* 5280* 5297* 5323* 5396* 5452* 5644* 5667* 5735* 5758* 5778* 5804* 5938 5940* 5961 5963* 6100* info 2213 based fixed bin(17,0) array level 2 dcl 864 set ref 2371 2426* 2427* 2428 2428 2434 2437 2437 2889 3006 3017 3108 3114 3115 3115 3124 3134 3147 3152 3153 3162 3164 3169 3372 3372 3372 3505 3512 3515 3517 3517 3524 3524 3524 3532 3554 3958 3959 3959 3962 3962 4017 4019 4019 4022 info_version based fixed bin(17,0) level 2 dcl 11-1 set ref 3114* 3505 3958* 4017* input_length based fixed bin(17,0) level 2 dcl 10-71 ref 6061 6061 inquire_opr constant fixed bin(4,0) initial dcl 3-19 ref 1511 1573 installation_defined based structure array level 4 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" installation_defined based structure level 3 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" int_pic based picture(16) dcl 659 set ref 3065* 3067 4726* 4729 4749* 4752* 4780* 4786* 7037 7040* 7041 7041 7042 7188* 7190 7191 7194 integer based fixed bin(35,0) dcl 6392 set ref 6634 6636 6749 6762 6799* 7005 7040 7188 7568* 7725* 7831* 7831 integer_dtype 002415 constant fixed bin(17,0) initial dcl 655 set ref 7618* 7625* 7652* 7672* 7912* integer_prec 002400 constant fixed bin(35,0) initial dcl 656 set ref 7618* 7625* 7652* 7672* 7912* integer_type constant fixed bin(6,0) initial dcl 6399 ref 6632 6742 6801 7708 7727 7812 7819 7907 interactive 000273 automatic bit(1) unaligned dcl 657 set ref 1447* 1449* 1896 internal_file constant bit(2) initial dcl 3-8 ref 944 955 1540 1866 1869 1959 2052 2054 4739 6253 internal_file_count 000274 automatic fixed bin(17,0) dcl 658 set ref 960* 962* 964* 1871* 1871 1872 2060* 2060 2061 2063 6253 io_buf based char unaligned dcl 660 set ref 1628* 1924 1928 1931 2118* 2122 2126 2133* 2135* 2137* 2137 2143* 2148 2155* 2157* 2159* 2159 2165* 2170 2175 2177* 2185 2187* 2202* 2265* 4794* 5272* 5289* 5291* 5389* 6034* 6036* 6037* 6259* 6279* 7843 io_switch 0(01) based bit(1) level 3 packed unaligned dcl 5-23 set ref 2811 2862 2919 2957 3583 io_switch_field constant fixed bin(17,0) initial dcl 3-50 set ref 2921* 2923* 2923* 2926* 2926* io_type 000000 constant bit(3) initial array level 2 packed unaligned dcl 767 ref 3379 ioa_ 000326 constant entry external dcl 1251 ref 1253 ioa_$ioa_switch 000234 constant entry external dcl 661 ref 1849 4794 4796 iocb based structure level 1 dcl 9-6 iocb_ptr 24 000100 automatic pointer level 2 dcl 417 set ref 1179* 1516* 1546* 1556* 1666 1673* 1676* 1691 1699* 1704* 1708* 1781* 1784 1786* 1791 1796 1798 1800* 1802* 1811* 1816* 1826* 1894 1909* 1970* 2000* 2004* 2007* 2010* 2082* 2083* 2098 2235* 2237* 2245* 2247* 2276* 2353* 2376* 2383* 2391* 2395* 2428* 2938* 2947 2952 3093* 3108 3115* 3127* 3129* 3136* 3139* 3147 3150 3155 3175 3232* 3253* 3266* 3278* 3295* 3308* 3337 3360 3400 3402 3419* 3520 3535 3552 3853* 4078* 4246* 4252* 4259* 4275* 4281* 4293* 4303* 4318 4321 4331* 4333* 4337* 4358* 4445* 4446 4453 4459 4459* 4466* 4468* 4472* 4517 4518 4520 ioname 2203 based char(32) level 2 dcl 864 set ref 2923 2923 2923 2930* 2934* 2935* 2938* 2943* iostat_p 56 based pointer level 2 dcl 1-11 ref 1568 1942 4622 iostat_var 6(13) 000354 automatic bit(1) level 3 packed unaligned dcl 1-47 set ref 1031* 1568 1940 4620 iox_$attach_iocb 000236 constant entry external dcl 662 ref 1786 3093 3129 3139 iox_$close 000240 constant entry external dcl 663 ref 1708 1826 4246 4275 4331 4466 iox_$control 000242 constant entry external dcl 664 ref 1676 1704 1811 1816 2247 2376 2428 3115 iox_$detach_iocb 000244 constant entry external dcl 665 ref 3127 3136 4337 4472 iox_$error_output 000246 external static pointer dcl 666 set ref 1849* 4794* 4796* iox_$find_iocb 000254 constant entry external dcl 669 ref 1781 2938 iox_$get_chars 000250 constant entry external dcl 667 ref 2000 2004 2007 2010 iox_$get_line 000252 constant entry external dcl 668 ref 1909 iox_$open 000256 constant entry external dcl 670 ref 1800 1802 3232 3253 3295 3308 3419 4252 4259 4281 4293 iox_$position 000260 constant entry external dcl 671 ref 1673 1699 2383 2391 2395 3266 3278 4303 4333 4468 iox_$put_chars 000262 constant entry external dcl 672 ref 1903 2082 2083 2276 4358 4428 4435 4459 4658 iox_$read_record 000264 constant entry external dcl 673 ref 1970 iox_$rewrite_record 000266 constant entry external dcl 674 ref 2237 iox_$seek_key 000270 constant entry external dcl 675 ref 2353 iox_$user_input 000274 external static pointer dcl 677 ref 1546 1551 iox_$user_io 000276 external static pointer dcl 678 set ref 1666 1691 1894 1903* 2098 3147 4428* 4435 4459 4658* iox_$user_output 000300 external static pointer dcl 679 set ref 1551 1556 4435 4435* iox_$write_record 000272 constant entry external dcl 676 ref 2235 2245 iox_modes 001572 constant char(24) initial array dcl 12-6 ref 3341 3341 3347 its_unsigned based structure level 1 dcl 18-30 ix 000102 automatic fixed bin(17,0) dcl 4370 set ref 4384* 4386 4386 4386* j 000275 automatic fixed bin(18,0) dcl 680 set ref 5537* 5538 5550 5551 5561 5745* 5750* 5752 5768* 5770* 5771 5771 5771 6671* 6673 7045* 7054 7064* 7078* 7078 7198* 7207 7217* 7233* 7233 7502* 7503 7503* 7517* 7518 7518 7520 7521* 7807* 7843 7843 7950* 7951 7951* 7953 job_bits 6 000354 automatic structure level 2 in structure "fio_ps" packed unaligned dcl 1-47 in procedure "fortran_io_" set ref 1030* 1411* 4614 job_bits 24 based structure level 2 in structure "PS" packed unaligned dcl 1-11 in procedure "fortran_io_" set ref 1030 1411 4614* job_index 000515 automatic fixed bin(17,0) dcl 2626 set ref 3183* 3186* 3187* 3189* 3191* 3191 3201* 3201 3210 3211 3211 3218* 3218 3220 3239 3239 3249* 3249 3250 3306 3306 3310 3319* 3319 k 000276 automatic fixed bin(18,0) dcl 681 set ref 1522* 1527 5554* 5556* 6604* 6605* 6666* 6667* 6670* 6671 6672 6672 6673* 6676* 6677 6684* keep_status 000511 automatic fixed bin(17,0) dcl 2622 set ref 3447* 3449* 3452 3461 3470 killing_file 000104 automatic bit(1) dcl 4412 set ref 4448* 4451 4474 l 000277 automatic fixed bin(18,0) dcl 682 set ref 5505* 5506 5508 5508* 5510 5511 5528* 5529 5531 5531* 5537 5550 5551 5561 5566 6677* 6684 label_for_transfer 000354 automatic label variable level 2 dcl 1-47 set ref 1420* last 10 000110 constant fixed bin(17,0) initial array level 2 in structure "nstd" dcl 2638 in procedure "open_statement" ref 3306 last 000300 automatic fixed bin(21,0) dcl 683 in procedure "fortran_io_" set ref 2465* 2473* 4547 4547 5009* 5009 5045 5052 5060 5067 5085* 5085 5160* 5160 5229 5272 5284* 5284 5289 5291 5301* 5301 5327* 5327 5389 5401* 5401 5404 5414 5418 5421 5424 5428 5430 5435 5440 5440 5440 5440 5464* 5464 5467 5479 5483 5486 5489 5494 5505 5508 5510 5510 5512 5523 5528 5531 5537 5556 5561 5561 5567 5579 5581 5590 5597 5603 5605 5610 5616 5616 5616 5616 5648* 5648 5651 5656 5656 5658 5658 5671* 5671 5675 5685 5690 5698 5700 5739* 5739 5762* 5762 5787* 5787 5810* 5810 5826* 5826 5831 5838* 5838 5843 5850* 5850 5858 5867* 5873* 5873 5876 5918 5948* 5973* 6028 6031 6034 6036 6037 6040 6044 6095* 6253 6257 6261 6273 6277 6279 6280 last_left_paren 0(06) based fixed bin(11,0) level 3 packed unaligned dcl 10-32 ref 5941 5964 last_rec 1(03) based fixed bin(21,0) level 4 packed unaligned dcl 441 set ref 2344* 4031 lbound builtin function dcl 684 ref 3849 leading_sign 001206 automatic char(1) unaligned dcl 4931 set ref 6184* 6189* 6240 legal_end 001357 automatic bit(1) dcl 6370 set ref 6564 6735 6786 6823* 6948 6982 7013 7447* 7477* 7707* 7731* 7745* 7756 7782* 7787 7792* 7811* 7835 7923 len 0(18) based fixed bin(17,0) array level 2 in structure "field" packed unaligned dcl 4200 in procedure "get_open_field" ref 4206 len 000516 automatic fixed bin(17,0) dcl 2627 in procedure "open_statement" set ref 2921* 2923 2926 2930 2984* 2986 2989 2994 2995 3769* 3771 3794 3794 len 001074 automatic fixed bin(17,0) dcl 4162 in procedure "exists_file" set ref 4164* 4168 4171 4175 len1 parameter fixed bin(18,0) dcl 7994 ref 7992 7996 7997 8006 len2 001654 automatic fixed bin(18,0) dcl 7994 set ref 7996* 8000* 8002 8002 8002 8005 length builtin function dcl 685 in procedure "fortran_io_" ref 1924 1924 1928 1928 1931 2082 2082 2083 2083 2455 2464 2605 2923 2923 2923 2970 2970 2970 2986 2986 3339 3489 3489 3495 3496 4140 4168 4206 4518 5026 5059 5067 5440 5440 5508 5616 5616 6305 6309 6314 6344 6347 6353 7037 7041 7042 7191 7261 7340 7939 7951 7974 7974 length 10(08) 000354 automatic fixed bin(23,0) level 3 in structure "fio_ps" packed unaligned dcl 1-47 in procedure "fortran_io_" set ref 8042 8046 8047 length 57 based fixed bin(18,0) level 3 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" set ref 4003* length builtin function dcl 4575 in procedure "print_error" ref 4729 length 76 based fixed bin(18,0) level 3 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" set ref 3932* length 3(18) based fixed bin(17,0) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2605* length 62 based fixed bin(18,0) level 3 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" set ref 3981* length 70 based fixed bin(18,0) level 3 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" set ref 3905* length 72 based fixed bin(18,0) level 3 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" set ref 3945* length 101 based fixed bin(18,0) level 3 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" set ref 3966* length 55 based fixed bin(18,0) level 3 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" set ref 3994* length 74 based fixed bin(18,0) level 3 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" set ref 3919* level 0(12) based bit(6) level 2 packed unaligned dcl 17-3 ref 6444 6446 lied_about_sign 001221 automatic bit(1) unaligned dcl 4941 set ref 5097* 5103* 5114 line_no 000306 automatic fixed bin(18,0) dcl 4564 set ref 4719* 4721* 4726 link_pt 26 000100 automatic pointer level 2 dcl 417 set ref 6432* 6677* 7496* 7503* 7510* list 6(07) 000354 automatic bit(1) level 3 in structure "fio_ps" packed unaligned dcl 1-47 in procedure "fortran_io_" set ref 957 1008 1603 1979 6087 list 1 based fixed bin(17,0) array level 2 in structure "ok_list" packed unaligned dcl 6370 in procedure "namelist_io" ref 6439 6480 6605 list_directed constant bit(2) initial dcl 3-8 in procedure "fortran_io_" ref 981 984 list_directed 0(19) based bit(1) level 4 in structure "runtime_format" packed unaligned dcl 10-32 in procedure "fortran_io_" ref 6077 ln 000466 automatic fixed bin(17,0) dcl 2453 set ref 2460* 2462 2469 2472 locate_pos_sw 1(06) based bit(1) level 3 packed unaligned dcl 8-6 set ref 2374* log 000525 constant char(4) initial dcl 6399 ref 6727 logical based bit(1) dcl 4955 in procedure "formatted_io" set ref 5289 5653* 5656* 5658* logical based bit(1) dcl 6392 in procedure "namelist_io" set ref 7091 7248 7583* 7944* 7946* logical_type constant fixed bin(6,0) initial dcl 6399 ref 7938 long_format based bit(1) level 2 in structure "format" packed unaligned dcl 10-53 in procedure "fortran_io_" ref 6124 6131 6145 6161 long_format based structure level 1 dcl 10-60 in procedure "fortran_io_" lower_letters 002073 constant char(26) initial unaligned dcl 686 ref 2482 3771 6555 6597 6597 ltrim builtin function dcl 687 ref 3826 3826 4182 4182 6305 6314 max_buffer 25 based fixed bin(17,0) level 2 dcl 1-11 ref 946 2526 max_fixed constant fixed bin(17,0) initial dcl 688 set ref 5440* 7824 7829 max_float 002072 constant fixed bin(17,0) initial dcl 689 set ref 5331 5510* 5561 5623 5637 6216 7678 7739 7773 7850 7861 max_rec_len 6 based fixed bin(21,0) level 2 in structure "blk_info" dcl 11-21 in procedure "fortran_io_" ref 4022 max_rec_len 10 based fixed bin(17,0) level 2 in structure "fortran_open_data" dcl 5-23 in procedure "fortran_io_" set ref 3065 3729* max_recl based fixed bin(17,0) level 2 dcl 854 set ref 1846* maximum_buffer 455 based fixed bin(26,0) level 2 packed unaligned dcl 4-18 set ref 1301* 1358* 1594 1620 maxl parameter fixed bin(17,0) dcl 2424 ref 2421 2427 me 002067 constant char(12) initial unaligned dcl 690 set ref 33* 1034* 1263* 1337* 1347* 1388* 1529* 1640* 1759* 1782* 1787* 1805* 2440* 2455* 2485* 2733* 2739* 2743* 2746* 2760* 2769* 2772* 2783* 2786* 2799* 2803* 2807* 2811* 2923* 2926* 2943* 2970* 2974* 2986* 2989* 3164* 3227* 3323* 3352* 3461* 3472* 3491* 3508* 3572* 3579* 3583* 3586* 3589* 3600* 3606* 3660* 3666* 3713* 3717* 3737* 3741* 3794* 4041* 4260* 4297* 4500* 4504* 4507* 4526* 4534* 4547* 4749* 4752* 4780* 4786* 5722* 5895* 6061* 6111* 6545* 6580* 6585* 6592* 6642* 6651* 6660* 6679* 6684* 6750* 6753* 6763* 6772* 6907* 7006* 7521* 7629* 7635* 7682* 7689* 7919* 7999* min builtin function dcl 691 ref 4140 5271 5658 5658 8002 min_field_width 001231 automatic fixed bin(17,0) dcl 4952 set ref 5034* 5035* 5035 5038 5043 5045 5046 5050 mod builtin function dcl 692 ref 2224 2226 7537 mode 6(05) 000354 automatic bit(2) level 3 in structure "fio_ps" packed unaligned dcl 1-47 in procedure "fortran_io_" set ref 944 944 955 988 1540 1540 1866 1866 1869 1884 1954 1959 2052 2052 2054 2211 2247 2311 2839 4739 4739 4741 4773 6253 mode 0(04) based bit(1) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2507* 2695 2830* 2862 3211 3239 3310 3625 3660 3669 mode_field constant fixed bin(17,0) initial dcl 3-50 set ref 2697* more_pieces 001500 automatic bit(1) unaligned dcl 7175 set ref 7263* 7264 7270* must_produce_plus 000301 automatic bit(1) dcl 693 set ref 5035 5120 5990* 5997* 6004* 6074* 6186 my_code 000302 automatic fixed bin(35,0) dcl 694 in procedure "fortran_io_" set ref 1346* 1347 1347* 1388* 1636 1636* 1670 1670* 1673* 1674 1674* 1676 1676* 1679 1695 1695* 1699* 1700 1700* 1702 1704* 1705 1708* 1709 1720 1769 1769* 1781* 1782 1782* 1786* 1787 1787* 1800* 1802 1802* 1805 1805* 1811* 1812 1816* 1817 1826* 1903* 1904 1904* 1909* 1913 1916 1916* 1933 1970* 1992* 2000* 2004* 2007* 2008 2010* 2018 2018 2024 2024 2027* 2079 2079* 2082* 2083 2083* 2085 2085* 2235* 2237* 2243 2243* 2245* 2247 2247* 2276* 2282* 2286 2286* 2353* 2354 2354 2376* 2377 2377 2377 2383* 2384 2391* 2395* 2400 2404 2406 2409 2409* 2411* 2414* 2428* 2430 2430 2938* 2941 2943* 3093* 3095 3097* 3115* 3127* 3129* 3130 3130* 3136* 3139* 3140 3140* 3232* 3234 3239 3253* 3257 3257* 3266* 3267 3267* 3278* 3279 3279* 3295* 3296 3296* 3304* 3306 3308* 3310 3310 3323 3323* 3419* 3420 3420* 3505 3530 3540* 4303* 4304 4304* 4331* 4333* 4337* 4354* 4358* 4497* 4498 4500* 4504* 4505 4507* 4609 4609 5442 6059* 6061 6677* 6679 7503* 7506 my_code 001016 automatic fixed bin(35,0) dcl 4158 in procedure "exists_file" set ref 4176* 4177 4182* 4183 my_status 000204 automatic structure level 1 packed unaligned dcl 4109 set ref 4120 n 001372 automatic fixed bin(18,0) dcl 6420 set ref 6491* 6496* 6708* 6778* 6847* 6861* name 67 based structure level 2 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" name 0(20) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3898 name 1 based bit(18) level 2 in structure "runtime_symbol" packed unaligned dcl 17-3 in procedure "namelist_io" ref 6461 6530 6657 7492 name 1 000326 automatic char(32) level 2 in structure "ci" dcl 14-3 in procedure "print_error" set ref 4699 name_ln 001361 automatic fixed bin(18,0) dcl 6370 set ref 6462* 6464 6466 6466 6467 6484 6486 6486 6487 6532 6658* 6660 6660 6679 6679 7493* 7521 7521 name_pt 30 000100 automatic pointer level 2 dcl 417 set ref 6461* 6462 6466 6486 6530* 6531 6532 6657* 6658 6660 6679 7492* 7493 7521 name_size based bit(9) level 2 packed unaligned dcl 6370 ref 6462 6531 6658 7493 name_string 0(09) based char level 2 packed unaligned dcl 6370 set ref 6466 6486 6532 6660* 6679* 7521* named 66 based pointer level 2 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3891 3893 3895 named 0(19) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3889 namelist 001354 automatic bit(1) dcl 6370 set ref 6435* 6815* 7254 7470 namelist_name based char unaligned dcl 6390 set ref 6545* 6551 6555 6592* namelist_name_len 001367 automatic fixed bin(17,0) dcl 6390 set ref 6531* 6543 6545 6545 6551 6551 6555 6555 6560 6592 6592 namelist_name_ptr 32 000100 automatic pointer level 2 dcl 417 set ref 6532* 6545 6551 6555 6592 namelist_p 22 based pointer level 2 dcl 1-11 ref 6429 ndims 0(18) based bit(6) level 2 packed unaligned dcl 17-3 ref 6659 7499 need_name 000632 automatic bit(1) dcl 3810 set ref 3822* 3848* 3902 4015 4043* negate 001214 automatic fixed bin(17,0) dcl 4936 set ref 5098* 5102* 5105* 5109 5117* 5163* 5166* 5349* 5351* 5373 5688* 5693* 5695* 5713 6184 6188* 6193 6238 new_buffer_length 000303 automatic fixed bin(21,0) dcl 695 set ref 2226* 2230 2232 2233 new_file constant fixed bin(17,0) initial dcl 826 ref 2781 new_opening 001120 automatic fixed bin(17,0) dcl 4240 set ref 4249* 4251 4252* 4253* 4253 4264 4265 4278* 4280 4281 4281* 4287* 4287 4308 4309 newline_needed 0(15) based bit(1) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 1625 1713* 1724* 1965* 2102* 2112 2115* 2128 2150 2172 2181 2193 2271* 2273 2273* 4356 4359* newline_needed 0(15) based bit(1) array level 5 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 4435 4439* 4459 nextrec 0(24) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 4029 nextrec 77 based pointer level 2 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 4031 no_length parameter fixed bin(17,0) dcl 7301 set ref 7295 7317* 7344 7345* 7345 7356 7357 7359 7361 7364 7365* 7365 7371 7372 7374* 7374 7380 7382 7384* 7384 7388 7390 7392* 7392 no_of_digits 001457 automatic fixed bin(17,0) dcl 7119 in procedure "ansi66_format" set ref 7153* 7154 7160 no_of_digits 001526 automatic fixed bin(17,0) dcl 7306 in procedure "ansi77_format" set ref 7336* 7340* 7353 7359 7359 7361 7364 7365 7372 7372 7374 7377 7379 7380 7380 7382 7384 7390 7390 7392 no_of_zeros 001527 automatic fixed bin(17,0) dcl 7306 set ref 7370* 7371 7371 7372 7374 7379* 7382 7382 7384 no_string parameter char(26) unaligned dcl 7117 in procedure "ansi66_format" set ref 7112 7158* 7159* 7160* 7162* 7164* no_string parameter char(30) unaligned dcl 7300 in procedure "ansi77_format" set ref 7295 7344 7356 7357 7359 7361 7364 7371 7372 7380 7382 7388 7390 no_uid constant bit(36) initial dcl 696 ref 4070 4116 4122 nonexistent constant fixed bin(17,0) initial dcl 3-39 ref 3524 3532 nstd 000110 constant structure level 1 dcl 2638 nstd_opening 001153 constant fixed bin(17,0) initial array dcl 2628 ref 3307 null builtin function dcl 697 ref 1319 1389 1412 1441 1676 1676 1704 1704 1784 1798 1811 1811 1816 1816 2247 2247 2952 3175 3400 3520 3535 4081 4121 4121 4318 4321 4376 4421 4446 4453 4679 4679 4679 4679 6432 6481 6528 6574 6589 6589 6590 6597 6597 6600 6615 6677 6677 6692 6793 6796 6803 7496 7496 7503 7503 7510 7510 null_value 001360 automatic bit(1) dcl 6370 set ref 6831 6873* 6896* 6913* 6917* 6919 7015* num 000305 automatic fixed bin(18,0) dcl 4564 set ref 4639* 4641 4643 4645 4664* 4666 4682* 4719* 4721* num_sig_chars 001501 automatic fixed bin(17,0) dcl 7175 set ref 7261* 7265 num_valid_values 000567 automatic fixed bin(17,0) dcl 3764 set ref 3773* 3777 3788 3791 3791 number based structure level 1 dcl 747 in procedure "fortran_io_" number 0(18) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3985 number 65 based pointer level 2 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3985 number based fixed bin(17,0) level 2 in structure "ok_list" dcl 6370 in procedure "namelist_io" ref 6477 6496 6604 number_length 001515 automatic fixed bin(17,0) dcl 7184 set ref 7201* 7203 7205 7205 7206 7209* 7211 7213 7213 7214 number_string 001505 automatic char(30) unaligned dcl 7183 in procedure "ansi77_output" set ref 7201* 7205 7209* 7213 number_string 001440 automatic char(26) unaligned dcl 7033 in procedure "ansi66_output" set ref 7050* 7052 7059* 7060 numerics 000526 constant char(13) initial dcl 6399 ref 6739 object_info based structure level 1 dcl 15-6 object_info_$brief 000354 constant entry external dcl 4577 ref 4708 object_info_version_2 constant fixed bin(17,0) initial dcl 15-60 ref 4707 off 000517 automatic fixed bin(17,0) dcl 2630 in procedure "open_statement" set ref 2921* 2930 2968* 2978 2984* 2994 3769* 3771 3794 3794 off 001073 automatic fixed bin(17,0) dcl 4162 in procedure "exists_file" set ref 4164* 4175 off based fixed bin(17,0) array level 2 in structure "field" packed unaligned dcl 4200 in procedure "get_open_field" ref 4204 offset 1 based fixed bin(18,0) level 2 in structure "element_p" packed unsigned unaligned dcl 8116 in procedure "advance_element_p" ref 8126 offset 3 based fixed bin(17,0) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2520* offset 000307 automatic fixed bin(18,0) dcl 4564 in procedure "print_error" set ref 4682* 4693* 4698* 4698 4749* 4752* 4780* 4786* offset_for_direct_access constant fixed bin(17,0) initial dcl 2631 ref 3191 offset_for_out_mode constant fixed bin(17,0) initial dcl 2633 ref 3201 3211 3211 3218 3239 3239 3249 3310 3319 oi 000376 automatic structure level 1 dcl 4597 set ref 4708 4708 ok_list based structure level 1 dcl 6370 ok_pt 34 000100 automatic pointer level 2 dcl 417 set ref 6429* 6439 6477 6480 6496 6604 6605 old_file constant fixed bin(17,0) initial dcl 827 ref 2767 op_name 000273 automatic varying char(32) dcl 4564 set ref 4741* 4744* 4745* 4747* 4749* 4752* 4763* 4771* 4773* 4773 4775* 4775 4780* 4786* op_offset 001162 automatic fixed bin(17,0) dcl 4914 set ref 4994 5853 5867 5874 6106* 6114* 6273 open_access_values 001741 constant varying char(12) initial array dcl 814 set ref 2710* open_blank_values 001721 constant varying char(12) initial array dcl 820 set ref 2725* open_code 0(24) based fixed bin(5,0) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 1522 1524* 2247 2437 3358* 3414 3419 3627 3675 4244 4264* 4272 4308* open_code 0(24) based fixed bin(5,0) array level 5 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 4643* open_descrip_ptr 20 based pointer level 2 dcl 9-6 ref 1798 3175 3337 3400 4321 4453 open_form_values 001731 constant varying char(12) initial array dcl 817 set ref 2717* open_index 000520 automatic fixed bin(17,0) dcl 2634 set ref 3210* 3211 3220* 3232* 3250* 3253* 3291* 3293* 3295* 3307* 3308* 3341* 3341* 3347 3347* 3358 3379 3675* open_mode 000000 constant structure array level 1 dcl 767 open_mode_values 001751 constant varying char(12) initial array dcl 811 set ref 2697* open_opr constant fixed bin(4,0) initial dcl 3-19 ref 1518 1543 1559 3435 open_status_values 001765 constant varying char(12) initial array dcl 808 set ref 2690* opened 0(17) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3872 opened 64 based pointer level 2 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3872 openfile_opr constant fixed bin(4,0) initial dcl 3-19 ref 1518 1559 4635 opening 001012 constant fixed bin(17,0) initial array dcl 2656 ref 3210 3211 3220 3239 3250 operation_name 002012 constant char(12) initial array unaligned dcl 698 set ref 1849* 4780* 4786* original_opening 001121 automatic fixed bin(17,0) dcl 4240 set ref 4244* 4249 4259* 4272* 4278 4293* out 0(10) based bit(1) level 5 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 1766 1776* 2303 2833 out 0(04) 000000 constant bit(1) initial array level 3 in structure "open_mode" packed unaligned dcl 767 in procedure "fortran_io_" ref 2437 out 0(14) based bit(1) level 5 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2833* 2837* 3012 3082 3201 3291 output_number based structure level 1 dcl 7303 output_structure based structure level 1 dcl 800 overflow 000304 stack reference condition dcl 702 ref 930 1090 1115 overflow_label 000312 automatic label variable dcl 703 set ref 928* 930 977* 1013* 1088* 1090 1113* 1115 6107* 6115* p 000324 automatic pointer dcl 4572 in procedure "print_error" set ref 4602* 4604 p 000102 automatic pointer dcl 4411 in procedure "close_all_files" set ref 4420* 4421 4426 4430 4435 4439 4445 4448 4448 4459 4459 4466 4468 4472 4477 4480 4483 paren_level 2 001170 automatic fixed bin(17,0) level 2 dcl 4923 set ref 5892* 5892 5895 5898 5899 5903 5909 5909 5910 5910* 5910 5912 5942* 5965* 6097* paren_ok parameter bit(1) dcl 7903 ref 7899 7923 pathname 001021 automatic char(168) unaligned dcl 4161 set ref 4168 4175* 4176* pathname_ptr 2 based pointer level 2 dcl 854 ref 2526 per_connection 0(05) based structure array level 4 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 4480* per_connection 0(05) based structure level 3 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 4343* per_process 0(03) based structure array level 4 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" per_process 0(03) based structure level 3 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" piece_idx 001502 automatic fixed bin(17,0) dcl 7175 set ref 7190* 7191 7194 7262* 7265 7266 7274 7277* 7277 piece_len 001503 automatic fixed bin(17,0) dcl 7175 in procedure "ansi77_output" set ref 7191* 7192 7194 7194 7195 7266* 7267 7269* 7272 7274 7274 7275 7276 7277 piece_len 001342 automatic fixed bin(17,0) dcl 6337 in procedure "right_justify" set ref 6347* 6348 6350 6351 6351 6351 6353 piece_len 001332 automatic fixed bin(17,0) dcl 6298 in procedure "left_justify" set ref 6309* 6310 6312 6312 6313 6314 piece_max_len 001504 automatic fixed bin(17,0) dcl 7175 set ref 7265* 7266 7269 pl1_operators_$VLA_words_per_seg_ 000302 external static fixed bin(19,0) dcl 704 ref 2003 4842 4879 7545 8127 8130 8131 pl1_ps_ptr 52 based pointer level 2 dcl 7-64 set ref 1430 pointer 71 based pointer level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" set ref 3945* pointer 67 based pointer level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" set ref 3905* pointer 73 based pointer level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" set ref 3919* pointer 75 based pointer level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" set ref 3932* pointer 100 based pointer level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" set ref 3966* pointer 54 based pointer level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" set ref 3994* pointer 61 based pointer level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" set ref 3981* pointer 56 based pointer level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" set ref 4003* pointer_bump parameter fixed bin(21,0) dcl 8023 set ref 8013 8031* 8037* 8042* 8047* 8060 8063 positioning 0(13) based bit(1) level 5 packed unaligned dcl 441 set ref 1666 1691 1764 3698* 3704* prec 000316 automatic fixed bin(17,0) dcl 706 set ref 5109* 5110 5122 5122 5122 5122 5124* 5124 5128 5128 5131 5136 5139 5145 5145 5180* 5181 5185* 5186 5192 5196 5196 5199 5199 5199 5211 5233 5233 5233 5233 5235 5330* 5331 5331 5331 5345 5365 5369 5369 5378 5386 5386 5386 5386 5440 5440 5440* 5510 5510 5510* 5515* 5548 5561 5561 5561 5561 5561 5564* 5564 5605 5620 5623 6216 6216 6220 7734* 7735 7737 7737* 7739 7741 7741 7742 7765 7773 7775 7775 7777* 7777 7821 7824 7826 7826 7829 7829 7829 7829 7847 7850 precision 0(27) based fixed bin(8,0) level 2 in structure "format" packed unaligned dcl 10-53 in procedure "fortran_io_" ref 6155 6172 precision 001524 automatic fixed bin(17,0) dcl 7306 in procedure "ansi77_format" set ref 7323* 7326* 7328* 7330 7332 7335 7340 7341 7341 7348 7356 7359 7372 7380 7388 7390 precision 1(18) based fixed bin(17,0) level 2 in structure "long_format" packed unaligned dcl 10-60 in procedure "fortran_io_" ref 6150 6166 precision 001461 automatic fixed bin(17,0) dcl 7119 in procedure "ansi66_format" set ref 7136* 7140* 7144 7146 7149 7152 7152 7153 7154 7160 7160 7162 7164 precision 3 001163 automatic fixed bin(17,0) level 2 in structure "field" dcl 4916 in procedure "formatted_io" set ref 5021 5027 5027 5108 5128 5128 5131 5136 5145 5145 5145 5145 5180 5185 5330 5370 5373 5501 6024 6024 6024 6027 6031 6150* 6155* 6166* 6172* 6193 prev_sp 20 based pointer level 2 dcl 7-36 ref 1406 previous 0(30) based fixed bin(5,0) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 1543* 1575 1598* 1714* 1727* 1730* 1814 3435* previous 0(30) based fixed bin(5,0) array level 5 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 4641* printer_file 0(02) based bit(1) array level 5 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 1212* 1234* 1368* printer_file 0(02) based bit(1) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 988 1625 2108 2490* 2493* 2875* 3749* 6455 process_type 000317 automatic fixed bin(17,0) dcl 707 set ref 1446* 1447 prompt 0(03) based bit(1) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 1901 2872* 3746* prompt 12 based bit(1) level 2 in structure "fortran_open_data" dcl 5-23 in procedure "fortran_io_" set ref 2516* 2872 3746 prompt 0(03) based bit(1) array level 5 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 1366* prompt 0(09) based bit(1) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2509* 2872 3746 prompt_char 002011 constant char(4) initial dcl 708 set ref 1903 1903 ps_at_error 2240 based pointer level 2 dcl 864 set ref 1441* 4613* psp parameter pointer dcl 709 ref 919 922 1024 1024 1028 1079 1082 1104 1107 ptr builtin function dcl 710 ref 1342 1387 4681 ptr_array 000372 automatic pointer array dcl 4-16 set ref 1337* 1340 1381* 1384 1387* 1387 1388* 1392 read 6(02) 000354 automatic bit(1) level 3 packed unaligned dcl 1-47 set ref 952 957 968 981 988 996 1069 2296 2369 2400 2835 4741 4745 4767 4832 6053 6079 6102 6451 6820 read_opr constant fixed bin(4,0) initial dcl 3-19 ref 968 1544 4767 real based float bin(27) level 2 dcl 6392 set ref 7575* 7667* 7667 7916 real_type constant fixed bin(6,0) initial dcl 6399 ref 7754 7793 7812 7916 recl 60 based pointer level 2 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 4022 recl 0(07) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 4009 recl 0(07) based bit(1) level 3 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2733 2862 2900 3055 3729 record_file constant bit(3) initial dcl 3-34 ref 1968 2222 2349 4013 record_found parameter bit(1) dcl 2335 set ref 2332 2345* 2354* 2377* 2384* 2400 record_key 000446 automatic picture(8) unaligned dcl 2336 set ref 2351* 2353 record_length 2 based fixed bin(21,0) level 2 in structure "rs_info" dcl 8-6 in procedure "fortran_io_" set ref 2375* record_length 000450 automatic fixed bin(21,0) dcl 2337 in procedure "get_record" set ref 2353* record_number 11 based fixed bin(17,0) level 2 dcl 1-11 set ref 2341 2341 2344 2351 2375 2383 2391 2395 2398* 2398 record_structure based structure level 1 dcl 788 rel builtin function dcl 711 ref 1292 1301 1358 4682 4698 8101 release_temp_segments_ 000332 constant entry external dcl 1275 ref 1388 rep_factor 0(09) based fixed bin(8,0) level 2 in structure "format" packed unaligned dcl 10-53 in procedure "fortran_io_" ref 6126 6138 6153 6170 rep_factor 0(18) based fixed bin(17,0) level 2 in structure "long_format" packed unaligned dcl 10-60 in procedure "fortran_io_" ref 6124 6134 6148 6164 rep_factor 1 001163 automatic fixed bin(17,0) level 2 in structure "field" dcl 4916 in procedure "formatted_io" set ref 5826 5830 5830 5838 5842 5842 5850 5856 5883 5898 5919* 5919 5920 6124* 6126* 6134* 6138* 6148* 6153* 6164* 6170* rep_factor 10 001170 automatic fixed bin(17,0) array level 2 in structure "FORMAT" dcl 4923 in procedure "formatted_io" set ref 5898* 5909* 5909 5910 rep_factor 001353 automatic bit(1) dcl 6370 in procedure "namelist_io" set ref 6703* 6746 6748* 6772 repetition_count 001403 automatic fixed bin(18,0) dcl 6422 set ref 6826 6836* 6836 6872* 6992* 7005* 7006 rest_of_field based char level 2 packed unaligned dcl 794 set ref 4547 4547 5045* 5052* 5060* 5067* 5229* 5404 5414 5421 5428 5430 5435 5440 5440 5440 5440 5467 5479 5486 5494 5505 5508 5510 5510 5528 5537 5556 5561 5561 5581 5603 5605 5610 5616 5616 5616 5616 5651 5656 5656 5658 5658 5675 5685 5690 6031* 6040* 6044* rest_of_number based char(30) level 2 packed unaligned dcl 7303 set ref 7344* 7356* 7357* 7359* 7361* 7364* 7371* 7372* 7380* 7382* 7388* 7390* rest_of_output based char(1024) level 2 packed unaligned dcl 800 set ref 993* 4876* 4880* 4883* 4885* 6466* 6472* 6486* 6500* 6502* 6516* 6852* 7041* 7052* 7060* 7069* 7074* 7081* 7091* 7093* 7101* 7194* 7205* 7213* 7222* 7230* 7239* 7248* 7250* 7259* 7274* 7275* 7284* rest_of_record based char level 2 packed unaligned dcl 788 set ref 2455 2460 2464 4839 4843 4847 4849 5139* 5143* 5145* 5211* 5219* 5224* 5233* 5240* 5242* 5246* 5248* 5260* 5263* 5268* 5286* 5307* 5314* 5378* 5383* 5386* 5518 5550 5570 5585 5701 5752 5766* 5771* 5792* 5797* 5819 5830* 5842 5856* 6018* 6022* 6024* 6232* 6240* 6539 6551 6555 6574 6582 6589 6589 6592 6592 6597 6597 6642 6723 6742 6760 6930 6942 6968 6973 6997 7001 7427 7435 7453 7461 7711 7711 7713 7719 7734 7741 7751 7760 7767 7775 7784 7800 7804 7837 7888 7939 7939 7942 7943 7950 7951 7967 7974 7974 7982 8002 restart 3 001170 automatic fixed bin(17,0) array level 2 dcl 4923 set ref 5895 5895 5895 5899* 5912 result based char unaligned dcl 6340 in procedure "right_justify" set ref 6351* 6357* result based char unaligned dcl 6301 in procedure "left_justify" set ref 6312* 6318* result_len parameter fixed bin(17,0) dcl 6292 in procedure "left_justify" ref 6289 6310 6312 6316 6318 result_len parameter fixed bin(17,0) dcl 6331 in procedure "right_justify" ref 6328 6348 6351 6351 6355 6357 6357 result_ptr parameter pointer dcl 6292 in procedure "left_justify" ref 6289 6312 6318 result_ptr parameter pointer dcl 6331 in procedure "right_justify" ref 6328 6351 6357 return_if_not_found constant bit(1) initial dcl 712 set ref 1159* return_len 001006 automatic fixed bin(18,0) dcl 4134 set ref 4140* 4141 return_string 000634 automatic varying char(168) dcl 3813 set ref 3904* 3905* 3914* 3916* 3918* 3919* 3927* 3929* 3931* 3932* 3940* 3942* 3944* 3945* 3953* 3955* 3960* 3962* 3964* 3966* 3978* 3980* 3981* 3991* 3993* 3994* 4000* 4002* 4003* return_to_user 000304 constant entry external dcl 713 ref 1948 4630 return_to_user$special_return 000306 constant entry external dcl 714 ref 1011 1049 1054 1059 1071 1098 1122 rewind_on_open 0(19) based bit(1) level 4 packed unaligned dcl 441 set ref 3085* 3264 4301 root 10 based bit(18) level 2 packed unaligned dcl 16-1 ref 4721 4721 4721 rs_info based structure level 1 dcl 8-6 set ref 2372* rs_info_ptr 000376 automatic pointer dcl 8-5 set ref 2371* 2372 2373 2374 2375 2376* rs_info_version_2 constant fixed bin(17,0) initial dcl 8-44 ref 2373 rtrim builtin function dcl 717 ref 1253 2526 3025 3904 3904 4206 4771 6344 6353 7261 7340 runtime_format based structure level 1 dcl 10-32 runtime_symbol based structure level 1 dcl 17-3 runtime_table 000445 constant fixed bin(6,0) initial array dcl 6399 ref 7518 7520 saved_attach_desc parameter char unaligned dcl 4494 ref 4488 4497 4497 scale 1 001170 automatic fixed bin(17,0) level 2 in structure "FORMAT" dcl 4923 in procedure "formatted_io" set ref 5108 5178 5180 5186 5196 5209 5211 5211 5212 5213 5227 5229 5229 5230 5502 5883* 6031 6098* scale 001225 automatic fixed bin(17,0) dcl 4949 in procedure "formatted_io" set ref 5108* 5110 scratch_file constant fixed bin(17,0) initial dcl 828 ref 2760 3023 3452 3459 3741 3893 3900 4448 search builtin function dcl 718 ref 6973 7950 seg_base 000320 automatic pointer dcl 4572 set ref 4681* 4693* 4702* 4708* 4735* seg_exists parameter bit(1) dcl 1270 set ref 1266 1280* 1331* seg_name 000262 automatic char(32) unaligned dcl 4559 set ref 4679* 4735* 4749 4749 4749* 4752* 4780 4780 4780* 4786* segment based structure level 1 dcl 8118 segno 0(03) based fixed bin(15,0) level 2 packed unsigned unaligned dcl 8116 set ref 8133* 8133 8135 sent 000320 automatic fixed bin(21,0) dcl 719 set ref 1909* 1913* 1913 1924 1928 1970* 2000* 2004* 2007* 2010* 2013* 2013 2030 seq_access 0(12) based bit(1) level 5 packed unaligned dcl 441 set ref 2315 3698* 3706* 3940 sequential constant fixed bin(17,0) initial dcl 3-39 in procedure "fortran_io_" ref 2568 sequential 0(21) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3936 sequential 71 based structure level 2 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" sequential_access constant bit(2) initial dcl 3-8 ref 2247 sign based char(1) level 2 in structure "decimal_number" packed unaligned dcl 7312 in procedure "ansi77_format" ref 7342 sign based char(1) level 2 in structure "number" packed unaligned dcl 747 in procedure "fortran_io_" set ref 7713* sign based char(1) level 2 in structure "decimal_number" packed unaligned dcl 7126 in procedure "ansi66_format" set ref 7155 7155* 7159 single_precision constant bit(1) initial unaligned dcl 7181 in procedure "ansi77_output" set ref 7201* single_precision constant bit(1) initial unaligned dcl 7031 in procedure "ansi66_output" set ref 7050* single_precision parameter bit(1) unaligned dcl 7115 in procedure "ansi66_format" ref 7112 7134 single_precision parameter bit(1) unaligned dcl 7298 in procedure "ansi77_format" ref 7295 7321 size 4 based fixed bin(35,0) level 2 in structure "runtime_symbol" dcl 17-3 in procedure "namelist_io" ref 7528 size 000322 stack reference condition dcl 720 in procedure "fortran_io_" ref 930 1090 1115 skip_line_numbers 0(20) based bit(1) level 4 in structure "runtime_format" packed unaligned dcl 10-32 in procedure "fortran_io_" ref 6069 skip_line_numbers 000330 automatic bit(1) unaligned dcl 721 in procedure "fortran_io_" set ref 5949 6069* 6079 6104 6111 7408 source based char unaligned dcl 6340 in procedure "right_justify" ref 6344 6347 6351 6353 6357 source based char unaligned dcl 6301 in procedure "left_justify" ref 6305 6309 6312 6314 6318 source_idx 001333 automatic fixed bin(17,0) dcl 6298 set ref 6305* 6305* 6309 6312* 6314 source_len parameter fixed bin(17,0) dcl 6331 in procedure "right_justify" ref 6328 6344 6347 6351 6353 6357 6357 6357 6358 source_len parameter fixed bin(17,0) dcl 6292 in procedure "left_justify" ref 6289 6305 6305 6305 6309 6312 6314 6314 6316 6318 6318 6319 source_limit 001343 automatic fixed bin(17,0) dcl 6337 set ref 6344* 6344* 6347 6351* 6353 source_position 001674 automatic fixed bin(21,0) dcl 8088 set ref 8101* 8102 8103* 8103 8106 source_ptr 001676 automatic pointer dcl 8089 in procedure "char_pos" set ref 8097* 8102 source_ptr parameter pointer dcl 6292 in procedure "left_justify" ref 6289 6305 6309 6312 6314 6318 source_ptr parameter pointer dcl 6331 in procedure "right_justify" ref 6328 6344 6347 6351 6353 6357 sp 000374 automatic pointer dcl 7-31 set ref 1405* 1406 1426 4678* 4679* 4686 6430* 6677* 7496* 7503* 7510* sp_up_4 4 based bit(72) level 2 dcl 845 set ref 1426* 1426 spec 001163 automatic fixed bin(17,0) level 2 in structure "field" dcl 4916 in procedure "formatted_io" set ref 4986 4994* 4995 5021 5027 5240 5867 5867 5922 6034 spec 0(01) based fixed bin(7,0) level 2 in structure "format" packed unaligned dcl 10-53 in procedure "fortran_io_" ref 4994 specified based structure level 2 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" specified based structure level 2 in structure "fortran_open_data" packed unaligned dcl 5-23 in procedure "fortran_io_" set ref 2503* 2827* stack_f based structure level 1 dcl 845 stack_frame based structure level 1 dcl 7-36 stack_frame_exit_ 000356 constant entry external dcl 4577 ref 4679 stack_frame_flags based structure level 1 dcl 7-64 stack_frame_p based pointer level 2 dcl 1-11 set ref 1948* 4630* 4678 6430 standard 26 000326 automatic bit(1) level 2 in structure "ci" dcl 14-3 in procedure "print_error" set ref 4697 standard 24(04) 000376 automatic bit(1) level 3 in structure "oi" packed unaligned dcl 4597 in procedure "print_error" set ref 4713 start 000304 automatic fixed bin(18,0) dcl 4564 set ref 4718* 4719* 4721* 4724 status based bit(1) level 3 packed unaligned dcl 5-23 set ref 2688 2862 3447 3461 3579 status_bit parameter bit(1) dcl 1203 ref 1201 1212 status_field constant fixed bin(17,0) initial dcl 3-50 set ref 2690* 3447* status_ptr 000216 automatic pointer dcl 4110 set ref 4120* 4121* std 000272 automatic bit(1) dcl 4564 set ref 4697* 4713* 4719 stop_run 000310 constant entry external dcl 722 ref 4813 str_len parameter fixed bin(17,0) dcl 4198 in procedure "get_open_field" set ref 4193 4206* str_len 000331 automatic fixed bin(17,0) dcl 723 in procedure "fortran_io_" set ref 5561* 5563 5564 5616* 6766* 6976* 7641 7963* 7997 8000 8002 8005* 8005 str_off parameter fixed bin(17,0) dcl 4197 set ref 4193 4204* 4206 stream_file constant bit(3) initial dcl 3-34 ref 1889 2219 3717 3723 string builtin function dcl 724 set ref 1030* 1030 1411* 1411 2513* 2699* 2701* 2703* 2706* 2957 3414 3414 3627 3629 3634* 3650* 3669* 3671* 4265* 4265 4309* 4309 4614* 4614 string_io constant bit(2) initial dcl 3-8 ref 944 988 1540 1866 2052 4739 4741 stu_$decode_runtime_value 000370 constant entry external dcl 6382 ref 6677 7503 stu_$find_runtime_symbol 000366 constant entry external dcl 6382 ref 6589 6597 stu_$get_line_no 000360 constant entry external dcl 4577 ref 4721 stu_$get_runtime_address 000364 constant entry external dcl 6382 ref 7496 7510 stu_$get_runtime_line_no 000362 constant entry external dcl 4577 ref 4719 subs_pt 36 000100 automatic pointer level 2 dcl 417 set ref 6481* 6627* 6692* 6796* 7496* subscript_array 001374 automatic fixed bin(18,0) array dcl 6421 set ref 6627 6636* 6667* 6671 6672* 6672 6673* 6684 7503* 7510 7510 subscripts 001373 automatic fixed bin(18,0) dcl 6420 set ref 6629* 6636* 6648* 6660 6664 6666 6676 substr builtin function dcl 725 set ref 993* 1253 1430* 1628* 1924 1928 1931 2056* 2118* 2122 2126 2133* 2135* 2137* 2137 2143* 2148 2155* 2157* 2159* 2159 2165* 2170 2175 2177* 2185 2187* 2202* 2230* 2232* 2265* 2482 2485 2485 2526 2930 2935* 2978 2993* 2994* 2994 3030 3038* 3108 3150 3155 3341 3347 3402 3495* 3771 3794 3794 4144* 4175 4206 4497 4497 4517 4520 4547 4547 4689 4727* 4729* 4839* 4839 4843* 4843 4847* 4847 4849* 4849 4876* 4876 4880* 4880 4883* 4883 4885* 4885 5045* 5052* 5052 5060* 5067* 5067 5122* 5122 5139* 5139 5143* 5145* 5145 5199 5199 5211* 5211 5219* 5224* 5229* 5233* 5233 5240* 5242* 5246* 5248* 5260* 5263* 5263 5268* 5272* 5272 5286* 5289* 5291* 5307* 5314* 5314 5314 5378* 5378 5383* 5386* 5386 5389* 5404 5414 5416* 5421 5467 5479 5481* 5486 5518 5537 5550 5556 5561 5561 5561 5561 5570 5585 5595* 5605 5616 5616 5651 5656 5656 5658 5658 5675 5685 5690 5701 5707* 5749 5752* 5752 5766* 5771* 5771 5792* 5797* 5797 5819* 5819 5830* 5830 5842* 5842 5856* 6018* 6022* 6024* 6031* 6034* 6036* 6037* 6040* 6044* 6061 6061 6232* 6240* 6259* 6279* 6309 6312* 6312 6314 6318* 6347 6351* 6351 6353 6357* 6466* 6472* 6486* 6500* 6502* 6516* 6539 6551 6555 6574 6589 6589 6592 6592 6597 6597 6642 6723 6742 6760 6817 6852* 6930 6942 6968 7001 7041* 7052* 7052 7060* 7069* 7074* 7081* 7091* 7093* 7101* 7101 7158* 7159* 7160* 7160 7162* 7164* 7164 7164 7194* 7194 7205* 7205 7213* 7213 7222* 7230* 7239* 7248* 7250* 7259* 7261 7266 7274* 7274 7275* 7284* 7284 7340 7344* 7356* 7356 7357* 7359* 7359 7361* 7361 7361 7364* 7371* 7372* 7372 7380* 7380 7382* 7388* 7388 7390* 7390 7435 7461 7587* 7641* 7641 7711 7711 7713 7741 7751 7767 7775* 7775 7784 7804 7826* 7826 7828* 7828 7829* 7829 7843 7888 7939 7942 7943 7982 8002* 8002 8028 support_ptr 35 based pointer level 2 packed unaligned dcl 7-36 set ref 1428* suppress_final_newline 000332 automatic bit(1) dcl 726 set ref 974* 2258 5966 6071* suppress_newline 0(22) based bit(1) level 4 packed unaligned dcl 10-32 ref 6071 switch_for_endfile 000426 automatic char(6) dcl 1752 set ref 1780* 1781* 1782* 1786 1787* 1805* switch_p 2 based pointer array level 3 in structure "fortran_buffer_" packed unaligned dcl 4-18 in procedure "fortran_io_" set ref 4445 4645* switch_p 2 based pointer level 2 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 1179 1516 1529 1529 1546* 1556* 1796* 2947* 3853 4078 4081 switch_ready 1(27) based bit(1) level 4 packed unaligned dcl 441 set ref 1662 1687 1712* 1777 1793* 1824 3359* sym_tab 000322 automatic pointer dcl 4572 set ref 4696* 4712* 4719* 4721 4721 4721 4721 4721 symb_start 16 000326 automatic pointer level 2 dcl 14-3 set ref 4696 symbol_header based structure level 1 dcl 16-1 symbol_pt 40 000100 automatic pointer level 2 dcl 417 set ref 6439* 6461 6461 6480* 6530 6530 6589* 6590 6597* 6600 6605 6618 6657 6657 6659 6677 6797* 7492 7492 7496* 7499 7503 7510* 7517 7528 7542 symbol_table_top_p 2 based pointer level 2 dcl 1-11 ref 6431 symbp 12 000376 automatic pointer level 2 dcl 4597 set ref 4712 sys_info$max_seg_size 000312 external static fixed bin(18,0) dcl 727 ref 1301 1358 t_format constant fixed bin(17,0) initial dcl 10-78 ref 5867 5867 table based structure array level 2 dcl 4-18 set ref 1178 1515 1537 3834 3849 3849 3852 4076 4077 table_pt 42 000100 automatic pointer level 2 dcl 417 set ref 6431* 6439 6480 6605 tcode 000313 automatic fixed bin(35,0) dcl 4564 in procedure "print_error" set ref 4658* 4686* 4687 4693* 4694 4702* 4704 4708* 4709 4735* tcode 001123 automatic fixed bin(35,0) dcl 4242 in procedure "reopen_for_input" set ref 4246* 4248* 4251 4252* 4253 4257 4259* 4275* 4277* 4280 4281* 4283 4285 4285 4291 4293* temp 001363 automatic fixed bin(21,0) dcl 6379 set ref 6729* 6733 ten_to_the_power 000560 constant float bin(63) initial array dcl 4964 ref 5205 5331 5338 5338 5345 terminal_file 000333 automatic bit(1) dcl 728 set ref 2098* 2100 2112 2268 terminal_needs_newline 454(02) based bit(1) level 2 packed unaligned dcl 4-18 set ref 1551* 1896* 2102 2103* 2112* 2268* 4391* 4426 4430* 4656 4659* text_pt 44 000100 automatic pointer level 2 dcl 417 set ref 3337* 3339 3341 3347 3352 6432* 6677* 7496* 7503* 7510* text_start 12 000326 automatic pointer level 2 dcl 14-3 set ref 4698 trailing_zeros 001460 automatic fixed bin(17,0) dcl 7119 set ref 7154* 7160 translate builtin function dcl 729 ref 2482 3771 6555 6597 6597 two_NLs constant char(2) initial dcl 833 ref 2133 2143 type 1 based fixed bin(17,0) level 2 in structure "uns_info" dcl 11-1 in procedure "fortran_io_" set ref 2889* 3006* 3017* 3108 3124 3134 3147* 3152* 3162 3164 3169 3372 3515 3517* 3524 3524* 3532* 3554* 3962 3962 type 0(06) based bit(6) level 2 in structure "runtime_symbol" packed unaligned dcl 17-3 in procedure "namelist_io" ref 7517 type_of_io 0(21) based bit(3) level 4 packed unaligned dcl 441 set ref 1603 1889 1968 1968 1973 2219 2222 2241 2349 2359 2389 3370* 3376* 3379* 3698 3698 3713 3717 3723 4013 4013 4281 4832 uid parameter bit(36) dcl 4108 in procedure "get_unique_id" set ref 4100 4116* 4122* 4124* uid 000101 automatic bit(36) dcl 4064 in procedure "get_associated_unit" set ref 4084* 4085 undefined 046053 constant fixed bin(17,0) initial dcl 3-39 ref 2819 2845 2889 2957 3108 3162 underflow 000334 stack reference condition dcl 730 ref 930 1090 1115 unformatted 75 based structure level 2 in structure "fortran_inquire_data" dcl 6-11 in procedure "fortran_io_" unformatted constant bit(2) initial dcl 3-8 in procedure "fortran_io_" ref 2031 2321 2842 unformatted 0(23) based bit(1) level 3 in structure "fortran_inquire_data" packed unaligned dcl 6-11 in procedure "fortran_io_" ref 3923 unique_chars_ 000314 constant entry external dcl 731 ref 3025 unique_id 11 000204 automatic bit(36) level 2 packed unaligned dcl 4109 set ref 4124 unit 1 based fixed bin(18,0) level 2 dcl 6-11 ref 3847 unit_for_endfile 000430 automatic picture(2) unaligned dcl 1752 set ref 1779* 1780 unit_number parameter fixed bin(18,0) dcl 4061 in procedure "get_associated_unit" set ref 4046 4087* unit_number 000633 automatic fixed bin(18,0) dcl 3812 in procedure "inquire_statement" set ref 3826* 3832 3834 3847* 3849 3849 3852 3854 3985 unknown_file constant fixed bin(17,0) initial dcl 830 ref 2693 uns_info based structure level 1 unaligned dcl 11-1 unspec builtin function dcl 732 set ref 1294* 1294 1356* 1356 1529 1529 2372* 2503* 2827* 4343* 4480* 4645* 4645 5749* 6817 6958* 6958 7892* 7892 8028 unstructured constant fixed bin(17,0) initial dcl 3-39 ref 2536 2545 3006 3017 3147 3515 3524 unwritten_eofs 000424 automatic fixed bin(3,0) unsigned dcl 1585 in procedure "initialize_fortran_io" set ref 1588* 1590 1611* 1614 unwritten_eofs 1(29) based fixed bin(3,0) level 4 in structure "file_desc" packed unsigned unaligned dcl 441 in procedure "fortran_io_" set ref 1588 1590* 1611 1614* 1659 1659* 1659 1685* 1756 1756 1756* 1756 1820* 1933 1933* 2074 2081 2087* 2087 upper 10 based fixed bin(35,0) array level 3 dcl 17-3 set ref 6677* 7503* user_format_p 6 based pointer level 2 dcl 1-11 ref 5830 5842 6056 6056 6059 6061 6061 user_info_$process_type 000316 constant entry external dcl 733 ref 1446 user_sp 46 000100 automatic pointer level 2 dcl 417 set ref 1406* 1426 1428 1430 using_tape_nstd 1(26) based bit(1) level 4 packed unaligned dcl 441 set ref 2224 3155* using_vfile 1(25) based bit(1) level 4 in structure "file_desc" packed unaligned dcl 441 in procedure "fortran_io_" set ref 3732* 3893 3900 using_vfile 000521 automatic bit(1) dcl 2635 in procedure "open_statement" set ref 2891* 2997* 3032* 3041* 3047 3111* 3201 3208 3402* 3729 3732 valid_values parameter varying char(12) array dcl 3763 ref 3760 3773 3778 3789 3791 3791 verify builtin function dcl 735 ref 2460 4727 5026 5404 5428 5430 5435 5467 5494 5505 5528 5537 5550 5581 5603 5605 5610 5651 5675 6220 6582 6997 7146 7190 7332 7427 7453 7719 7734 7760 7767 7800 7837 version based bit(6) level 3 in structure "runtime_format" packed unaligned dcl 10-32 in procedure "fortran_io_" ref 6056 version based fixed bin(17,0) level 2 in structure "rs_info" dcl 8-6 in procedure "fortran_io_" set ref 2373* version_number 000376 automatic fixed bin(17,0) level 2 dcl 4597 set ref 4707* vfile_status_ 000320 constant entry external dcl 736 ref 3959 4019 vfs_version_1 constant fixed bin(17,0) initial dcl 11-67 ref 3114 3505 which_one parameter fixed bin(17,0) dcl 3764 set ref 3760 3780* white_space constant char(2) initial dcl 737 ref 7427 7453 7800 width 0(18) based fixed bin(8,0) level 2 in structure "format" packed unaligned dcl 10-53 in procedure "fortran_io_" ref 6139 6154 6171 width 2 001163 automatic fixed bin(17,0) level 2 in structure "field" dcl 4916 in procedure "formatted_io" set ref 5009 5038 5043 5045 5046 5085 5109 5133 5160 5284 5286 5286 5301 5305 5307 5308 5311 5327 5401 5404 5464 5467 5648 5651 5658 5658 5671 5675 5739 5741 5743 5748 5750 5762 5764 5766 5767 5770 5777 5785 5803 5808 5830 5842 5867 5873 6040 6040 6044 6044 6135* 6139* 6149* 6154* 6165* 6171* 6194 6196 6230 6232 6233 width 1 based fixed bin(17,0) level 2 in structure "long_format" packed unaligned dcl 10-60 in procedure "fortran_io_" ref 6135 6149 6165 word_align_1 based structure level 1 dcl 755 word_align_2 based structure level 1 dcl 758 word_align_3 based structure level 1 dcl 761 words based fixed bin(35,0) array dcl 740 set ref 1354* 1568* 1942* 3985* 4022* 4031* 4604 4622* 5017 5407* 5442* 5680* 5717* 5717 7605* 7605 work 1 based char(64) level 2 dcl 864 set ref 3065 3067 4679 4679 4726 4727 4727* 4729 4729* 4749 4752 4780 4786 5018 5026 5026 5052 5059 5067 5067 5122 5122 5139 5145 5196 5199 5199 5199 5211 5233 5369 5378 5386 5413 5416* 5440 5440 5442 5478 5481* 5510 5510 5561 5561 5630 5637 5637 5697 5707 5713 5713 5715 5717 6218 6218 6220 6800 7037 7040 7041 7041 7042 7188 7190 7191 7194 7678 7678 7709 7713 7741 7775 7826 7827 7828* 7829 7831 7854 7861 7861 work_str 21 based char(4096) level 2 dcl 864 set ref 6059* 6061 6061 6061 6064 6526 6822 7641 7826* 7828 7829 8002* write_opr constant fixed bin(4,0) initial dcl 3-19 ref 970 1556 4769 x parameter float bin(27) dcl 7902 in procedure "input_piece_of_complex" set ref 7899 7912 7912 7916* x 001220 automatic float bin(27) dcl 4940 in procedure "formatted_io" set ref 5342* 5344* 5345 5345 x_float 001222 automatic structure level 1 dcl 4944 set ref 5336 5336 5342 x_flt based float dec(10) dcl 4948 ref 5342 zero_label 000342 automatic label variable dcl 741 set ref 929* 931 979* 1015* 1089* 1091 1114* 1116 6108* 6116* zerodivide 000346 stack reference condition dcl 742 ref 931 1091 1116 NAMES DECLARED BY DECLARE STATEMENT AND NEVER REFERENCED. Direct_input internal static fixed bin(17,0) initial dcl 12-15 Direct_output internal static fixed bin(17,0) initial dcl 12-15 Direct_update internal static fixed bin(17,0) initial dcl 12-15 ITP_MODIFIER internal static bit(6) initial unaligned dcl 18-56 ITS_MODIFIER internal static bit(6) initial unaligned dcl 18-55 Keyed_sequential_input internal static fixed bin(17,0) initial dcl 12-15 Keyed_sequential_output internal static fixed bin(17,0) initial dcl 12-15 Keyed_sequential_update internal static fixed bin(17,0) initial dcl 12-15 RETURN_PTR_MASK internal static bit(72) initial unaligned dcl 7-19 Sequential_input internal static fixed bin(17,0) initial dcl 12-15 Sequential_output internal static fixed bin(17,0) initial dcl 12-15 Stream_input internal static fixed bin(17,0) initial dcl 12-15 Stream_input_output internal static fixed bin(17,0) initial dcl 12-15 Stream_output internal static fixed bin(17,0) initial dcl 12-15 TRANSLATOR_ID_ALM internal static bit(18) initial unaligned dcl 7-25 TRANSLATOR_ID_PL1V1 internal static bit(18) initial unaligned dcl 7-26 TRANSLATOR_ID_PL1V2 internal static bit(18) initial unaligned dcl 7-24 TRANSLATOR_ID_SIGNALLER internal static bit(18) initial unaligned dcl 7-28 TRANSLATOR_ID_SIGNAL_CALLER internal static bit(18) initial unaligned dcl 7-27 a_format internal static fixed bin(17,0) initial dcl 10-78 backspace_opr internal static fixed bin(4,0) initial dcl 3-19 binarystream_field internal static fixed bin(17,0) initial dcl 3-50 bn_format internal static fixed bin(17,0) initial dcl 10-78 bz_format internal static fixed bin(17,0) initial dcl 10-78 carriage_field internal static fixed bin(17,0) initial dcl 3-50 chars_per_halfword internal static fixed bin(8,0) initial dcl 10-100 chars_per_word internal static fixed bin(8,0) initial dcl 10-99 close_opr internal static fixed bin(4,0) initial dcl 3-19 closefile_opr internal static fixed bin(4,0) initial dcl 3-19 defer_field internal static fixed bin(17,0) initial dcl 3-50 direct_field internal static fixed bin(17,0) initial dcl 3-50 directory_type internal static bit(2) initial dcl 13-1 dp_flt_pic based picture(24) dcl 506 dp_fxd_pic based picture(41) dcl 507 e_format internal static fixed bin(17,0) initial dcl 10-78 encoded_value based structure level 1 dcl 17-70 end_of_format internal static fixed bin(17,0) initial dcl 10-78 endfile_opr internal static fixed bin(4,0) initial dcl 3-19 exist_field internal static fixed bin(17,0) initial dcl 3-50 flt_pic based picture(14) dcl 543 fmt_field internal static fixed bin(17,0) initial dcl 3-50 formatted internal static bit(2) initial dcl 3-8 formatted_field internal static fixed bin(17,0) initial dcl 3-50 fxd_pic based picture(21) dcl 641 g_format internal static fixed bin(17,0) initial dcl 10-78 hollerith_field internal static fixed bin(17,0) initial dcl 10-78 i_format internal static fixed bin(17,0) initial dcl 10-78 increment_table internal static fixed bin(17,0) initial array dcl 10-25 indx_info based structure level 1 unaligned dcl 11-33 iox_$iocb_version_sentinel external static char(4) dcl 9-51 itp based structure level 1 dcl 18-18 itp_unsigned based structure level 1 dcl 18-43 its based structure level 1 dcl 18-5 link_type internal static bit(2) initial dcl 13-1 margin_opr internal static fixed bin(4,0) initial dcl 3-19 max_value internal static fixed bin(8,0) initial dcl 10-98 msf_type internal static bit(2) initial dcl 13-1 name_field internal static fixed bin(17,0) initial dcl 3-50 named_field internal static fixed bin(17,0) initial dcl 3-50 namelist internal static bit(2) initial dcl 3-8 nextrec_field internal static fixed bin(17,0) initial dcl 3-50 number_field internal static fixed bin(17,0) initial dcl 3-50 old_endfile_opr internal static fixed bin(4,0) initial dcl 3-19 old_format based structure level 1 dcl 10-49 op_13 internal static fixed bin(4,0) initial dcl 3-19 op_5 internal static fixed bin(4,0) initial dcl 3-19 open_keyword_mask internal static bit(36) initial dcl 3-86 opened_field internal static fixed bin(17,0) initial dcl 3-50 prompt_field internal static fixed bin(17,0) initial dcl 3-50 quoted_string internal static fixed bin(17,0) initial dcl 10-78 rec_field internal static fixed bin(17,0) initial dcl 3-50 recl_field internal static fixed bin(17,0) initial dcl 3-50 rewind_opr internal static fixed bin(4,0) initial dcl 3-19 round builtin function dcl 716 rs_desc based structure level 1 packed unaligned dcl 8-32 rs_info_version_1 internal static fixed bin(17,0) initial dcl 8-43 runtime_block based structure level 1 dcl 17-38 runtime_bound based structure level 1 unaligned dcl 17-33 runtime_token based structure level 1 dcl 17-63 s_format internal static fixed bin(17,0) initial dcl 10-78 segment_type internal static bit(2) initial dcl 13-1 seq_desc based structure level 1 packed unaligned dcl 8-37 seq_info based structure level 1 unaligned dcl 11-11 sequential_field internal static fixed bin(17,0) initial dcl 3-50 short_iox_modes internal static char(4) initial array dcl 12-12 size builtin function dcl 1276 sp_format internal static fixed bin(17,0) initial dcl 10-78 ss_format internal static fixed bin(17,0) initial dcl 10-78 stack_frame_min_length internal static fixed bin(17,0) initial dcl 7-33 string builtin function dcl 6368 tr_format internal static fixed bin(17,0) initial dcl 10-78 unformatted_field internal static fixed bin(17,0) initial dcl 3-50 units_field internal static fixed bin(17,0) initial dcl 3-50 valid_close_keyword internal static bit(36) initial dcl 3-86 valid_inquire_keyword internal static bit(36) initial dcl 3-86 valid_open_keyword internal static bit(36) initial dcl 3-86 valid_read_keyword internal static bit(36) initial dcl 3-86 valid_write_keyword internal static bit(36) initial dcl 3-86 vbl_info based structure level 1 unaligned dcl 11-55 word_len automatic fixed bin(19,0) dcl 739 NAMES DECLARED BY EXPLICIT CONTEXT. action 000053 constant label array(0:19) dcl 1581 ref 1573 1575 1638 add_attach_option 017351 constant entry internal dcl 3484 ref 3058 3063 3067 3074 3076 3084 3128 3137 3138 advance_element_p 043026 constant entry internal dcl 8109 ref 5917 7104 7288 7590 7696 ansi66_format 036663 constant entry internal dcl 7112 ref 7050 7059 ansi66_output 036457 constant entry internal dcl 7023 ref 6494 6862 ansi77_format 037510 constant entry internal dcl 7295 ref 7201 7209 ansi77_output 037146 constant entry internal dcl 7172 ref 6492 6855 bad_char 025037 constant entry internal dcl 4545 ref 5431 5606 5705 6746 6786 6948 6982 7923 bad_subs 035325 constant label dcl 6684 ref 6632 6634 bound_error 035264 constant label dcl 6679 ref 7506 buffer_read 040327 constant entry internal dcl 7403 ref 6547 7424 7429 7975 build_binary 042173 constant label dcl 7847 ref 7756 7780 build_integer 042075 constant label dcl 7821 ref 7743 build_string 042577 constant entry internal dcl 7992 ref 6769 6977 7974 7978 7984 char_pos 042767 constant entry internal dcl 8077 ref 2003 4842 4879 7545 7545 7552 7552 check_attach_options 017551 constant entry internal dcl 3547 ref 3520 3535 check_end 040403 constant entry internal dcl 7442 ref 6563 6637 6732 6785 6947 6980 7012 7922 check_paren 035003 constant label dcl 6642 ref 6638 check_repetition 036351 constant entry internal dcl 6989 ref 6918 close_all_files 024102 constant entry internal dcl 4404 ref 1133 1145 1170 4389 close_file 005371 constant entry external dcl 1154 close_for_stop 024025 constant entry internal dcl 4366 ref 1135 4799 close_fortran_file 023674 constant entry internal dcl 4315 ref 1181 1647 2500 2914 3455 close_statement 017142 constant entry internal dcl 3441 ref 1651 conversion_error 025022 constant entry internal dcl 4540 ref 5625 5627 6310 6316 6348 6355 7739 7773 7824 7851 conversion_error_handler 005634 constant label dcl 1259 ref 977 1013 6107 convert_dfast_file 000077 constant label array(9) dcl 2532 ref 2529 convert_from_character 020717 constant entry internal dcl 3760 ref 2690 2697 2710 2717 2725 3447 convert_real_value 037221 constant label dcl 7201 ref 7225 7234 countdown_element 032304 constant label dcl 5915 ref 5070 5148 5275 5292 5318 5390 5409 5444 5474 5639 5662 5681 5718 5753 5772 5798 5820 6028 6038 6042 6046 create_decimal 033204 constant entry internal dcl 6207 ref 5112 5194 5367 decode_runtime 040500 constant entry internal dcl 7486 ref 6482 6695 6798 delete_file 024446 constant entry internal dcl 4488 ref 3466 3476 4476 dfast_openfile 012716 constant entry internal dcl 2476 ref 1835 e_fmt 027426 constant label dcl 5163 ref 5331 5338 5345 5370 element 004736 constant entry external dcl 1024 element_list_abort 005022 constant label dcl 1049 ref 6894 element_routine 000050 constant label array(0:2) dcl 1045 ref 1043 end_of_file 010343 constant label dcl 1933 ref 1872 1924 1928 2018 2024 error_handlers 024712 constant entry internal dcl 4523 exists_file 023044 constant entry internal dcl 4152 ref 2742 expand_buffer 033313 constant entry internal dcl 6250 ref 5010 5086 5161 5285 5302 5328 5763 5788 5829 5855 fake_complex 036517 constant label dcl 7050 ref 7072 7079 field_error 023240 constant entry internal dcl 4212 ref 2923 2923 2926 2926 2970 2970 2974 2974 2986 2986 2989 2989 3794 3794 file_control 005061 constant entry external dcl 1079 find_header 034254 constant label dcl 6536 ref 6548 finish_dfast_open 013316 constant label dcl 2602 ref 2537 2546 2555 2563 2569 2577 2585 2593 finish_float 031265 constant label dcl 5620 ref 5512 5523 5567 5582 5611 finish_handler 005345 constant entry external dcl 1142 ref 1346 1346 finish_line 023773 constant entry internal dcl 4351 ref 1634 1669 1694 1768 2078 4326 fixed_zero 030430 constant label dcl 5407 ref 5418 5424 5436 fmt_done 032357 constant label dcl 5958 ref 5005 5082 5155 5281 5298 5324 5397 5453 5645 5668 5736 5759 5779 5805 5925 5934 format_routine 000241 constant label array(0:59) dcl 5005 ref 4986 5922 formatted_io 027043 constant entry internal dcl 4897 ref 1056 fortran_io_ 004345 constant entry external dcl 30 free_delim 036344 constant label dcl 6980 ref 6928 6962 6966 free_input 000335 constant label array(6) dcl 6924 ref 6922 get_associated_unit 022474 constant entry internal dcl 4046 ref 3826 get_buffer_ptr 005674 constant entry internal dcl 1266 ref 1159 1207 1229 1439 get_error_message 000130 constant label array(13) dcl 4219 ref 4217 get_field 040340 constant entry internal dcl 7417 ref 6536 6569 6612 6620 6630 6646 6705 6883 7874 7881 get_io_area_ptr 005177 constant entry external dcl 1104 get_name 034364 constant label dcl 6569 ref 6621 6805 get_name_of_unit 022404 constant entry internal dcl 4037 ref 3902 4015 get_next_format 027061 constant label dcl 4990 ref 5832 5844 5859 5877 5886 5900 5903 5913 5920 5931 5951 5966 5974 5981 5988 5995 6002 6009 6118 get_open_field 023213 constant entry internal dcl 4193 ref 2921 2968 2984 3769 4164 get_record 012147 constant entry internal dcl 2332 ref 1884 2213 get_unique_id 022661 constant entry internal dcl 4100 ref 4069 4084 get_value 035365 constant label dcl 6705 ref 6758 i_format_common 027076 constant label dcl 5003 ref 5000 implicit_open 014242 constant entry internal dcl 2824 ref 1589 1613 initialize_formatted_io 032531 constant entry internal dcl 6050 ref 1005 initialize_fortran_io 006274 constant entry internal dcl 1454 ref 972 1096 initialize_list_input 036103 constant entry internal dcl 6869 ref 996 initiate_common 004703 constant label dcl 1008 ref 999 1003 initiate_routine 000044 constant label array(0:3) dcl 977 ref 975 6083 input_charstr 042525 constant entry internal dcl 7961 ref 6713 6970 input_complex 042261 constant entry internal dcl 7869 ref 6717 6933 input_float 041475 constant entry internal dcl 7704 ref 6631 6725 6741 6924 7004 7905 input_logical 042433 constant entry internal dcl 7931 ref 6723 6737 6964 input_piece_of_complex 042322 constant entry internal dcl 7899 ref 6952 7876 7883 inquire_statement 021262 constant entry internal dcl 3801 ref 1655 internal_file_overflow 025007 constant entry internal dcl 4536 ref 1959 2063 6253 label_for_entry 000015 constant label array(0:22) dcl 912 ref 912 1420 left_justify 033376 constant entry internal dcl 6289 ref 5510 5561 legal_symbol 034732 constant label dcl 6610 ref 6605 list_input 036110 constant entry internal dcl 6880 ref 6828 list_input_retry 036111 constant label dcl 6883 ref 6905 list_io 035764 constant entry internal dcl 6812 ref 1045 ln_error 012640 constant label dcl 2455 ref 2469 make_null 000365 constant label array(6) dcl 7568 ref 7566 make_static_frame 006203 constant entry internal dcl 1399 ref 924 1084 1109 merge_attributes 017570 constant entry internal dcl 3563 ref 3387 3404 minus_sign 033267 constant entry internal dcl 6228 ref 5134 5207 5374 6013 missing_header 034275 constant label dcl 6545 ref 6539 6553 6555 6564 namelist_io 033671 constant entry internal dcl 6365 ref 1017 no_handler 005647 constant label dcl 1263 ref 928 929 979 1015 1088 1089 1113 1114 6108 no_line 025675 constant label dcl 4729 ref 4704 4709 not_supported 010105 constant label dcl 1849 ref 1643 1832 1842 null_bump 041104 constant label dcl 7590 ref 7563 7570 7577 7581 7585 open_common 014323 constant label dcl 2856 ref 2821 2847 open_fortran_file 014315 constant entry internal dcl 2850 ref 2607 open_statement 013335 constant entry internal dcl 2610 ref 1838 output_format 000343 constant label array(6) dcl 7037 in procedure "ansi66_output" ref 7035 output_format 000354 constant label array(6) dcl 7188 in procedure "ansi77_output" ref 7186 output_return 037506 constant label dcl 7288 in procedure "ansi77_output" ref 7196 7215 7242 7252 output_return 036661 constant label dcl 7104 in procedure "ansi66_output" ref 7043 7062 7085 7095 print_blanks 032522 constant label dcl 6044 print_error 025112 constant entry internal dcl 4556 ref 33 1034 1261 1263 1347 1527 1529 1559 1563 1636 1640 1666 1670 1679 1691 1695 1709 1720 1759 1764 1769 1774 1782 1787 1805 1817 1904 1939 1961 2027 2074 2079 2085 2243 2286 2296 2303 2311 2315 2321 2325 2341 2414 2430 2434 2437 2440 2455 2485 2496 2733 2739 2743 2746 2760 2769 2772 2783 2786 2799 2803 2807 2811 2868 2923 2926 2943 2970 2974 2986 2989 3097 3130 3140 3164 3227 3257 3267 3279 3296 3323 3352 3409 3420 3461 3472 3491 3508 3540 3572 3579 3583 3586 3589 3600 3606 3660 3666 3713 3717 3737 3741 3794 4020 4024 4041 4260 4297 4304 4526 4530 4534 4538 4543 4547 4551 4861 4870 5722 5895 5938 5961 6061 6087 6111 6545 6580 6585 6592 6642 6651 6660 6679 6684 6750 6753 6763 6772 6907 7006 7521 7629 7635 7682 7689 7919 8131 print_stars 032513 constant label dcl 6040 ref 5038 5181 5186 5188 5205 6115 6116 6194 6216 print_zero 032425 constant label dcl 6013 ref 6221 process_vfile_status 017422 constant entry internal dcl 3502 ref 3116 read 034233 constant label dcl 6526 ref 6451 read_a_record 010137 constant entry internal dcl 1863 ref 4865 5945 7406 read_a_record_label 010173 constant label dcl 1878 ref 1609 read_buffer 033350 constant entry internal dcl 6270 ref 5402 5465 5649 5672 5740 5811 5841 5874 read_or_write 004403 constant entry external dcl 919 real_part 000351 constant label array(3) dcl 7074 in procedure "ansi66_output" ref 7054 real_part 000362 constant label array(3) dcl 7227 in procedure "ansi77_output" ref 7207 release_buffer_ptr 006134 constant entry internal dcl 1375 ref 1146 reopen_for_input 023304 constant entry internal dcl 4237 ref 2300 3426 3644 reopen_for_output 023451 constant entry internal dcl 4269 ref 1772 2306 3428 3648 retry_non_vfile_opening 016507 constant label dcl 3304 ref 3320 return_error_code 005051 constant label dcl 1071 ref 1944 4624 4647 right_justify 033536 constant entry internal dcl 6328 ref 5440 5616 save_attach_desc 024646 constant entry internal dcl 4514 ref 3452 4039 4083 4451 set_BOR_store_op_and_return 007266 constant label dcl 1724 ref 1683 1830 set_cc 005461 constant entry external dcl 1201 set_cc_defer 005517 constant entry external dcl 1221 set_count 042726 constant label dcl 8057 ref 8035 8040 8049 set_max_recl 012473 constant entry internal dcl 2421 ref 1846 3729 set_return_value 023016 constant entry internal dcl 4128 ref 3905 3919 3932 3945 3966 3981 3994 4003 set_size 000437 constant label array(6) dcl 8031 ref 8029 set_size_and_count 042665 constant entry internal dcl 8013 ref 4827 4976 6818 single_space 011422 constant label dcl 2181 ref 2122 start_floating 033153 constant entry internal dcl 6182 ref 5107 5119 5176 5363 stop 005315 constant entry external dcl 1126 store 041106 constant entry internal dcl 7598 ref 6779 6802 6833 store_bump 041473 constant label dcl 7696 ref 7610 7616 7621 7627 7647 7655 7663 7668 7674 7680 store_count 035737 constant label dcl 6793 ref 6735 6772 store_null 041052 constant entry internal dcl 7560 ref 6710 6831 store_op_and_return 007270 constant label dcl 1727 ref 1632 1836 1840 store_zero 030571 constant label dcl 5470 ref 5483 5489 5495 5620 strip_line_no 012634 constant entry internal dcl 2450 ref 5949 6079 6104 7408 symbol_abort 034560 constant label dcl 6592 ref 6600 6608 syntax_error 025076 constant entry internal dcl 4549 ref 5579 5590 5597 6721 6939 7715 7756 7787 7797 7801 7815 7840 7878 7885 7888 7939 7948 terminate 004725 constant entry external dcl 1024 terminate_no_list 005043 constant label dcl 1066 ref 1008 1018 too_much_input 024743 constant entry internal dcl 4528 ref 4836 6276 too_much_output 024756 constant entry internal dcl 4532 ref 991 4873 6256 6273 6464 6470 6484 6498 6514 6850 7037 7047 7056 7066 7087 7097 7192 7203 7211 7219 7227 7236 7244 7257 7272 7281 unformatted_io 026573 constant entry internal dcl 4822 ref 1052 unknown_type 040664 constant label dcl 7521 ref 7518 unpack_format 000145 constant label array(0:59) dcl 4998 ref 4995 unpack_four 033107 constant entry internal dcl 6159 ref 5151 5321 unpack_one 033003 constant entry internal dcl 6122 ref 5847 5880 5889 unpack_three 033050 constant entry internal dcl 6143 ref 5001 5073 5447 unpack_two 033021 constant entry internal dcl 6129 ref 4998 5278 5295 5393 5642 5665 5733 5756 5775 5801 5823 5835 5862 validate_mode_and_access 012003 constant entry internal dcl 2291 ref 1596 1616 validate_store 000373 constant label array(0:35) dcl 7605 set ref 7603 version 005562 constant entry external dcl 1245 write_a_record 010722 constant entry internal dcl 2039 ref 1069 5970 write_stream 011707 constant label dcl 2252 ref 2219 zero_field 041550 constant label dcl 7725 ref 7821 7847 NAMES DECLARED BY CONTEXT OR IMPLICATION. before builtin function ref 1791 3339 3360 6309 6347 low builtin function ref 2232 max builtin function ref 5873 reverse builtin function ref 5537 6347 STORAGE REQUIREMENTS FOR THIS PROGRAM. Object Text Link Symbol Defs Static Start 0 0 50156 50552 46117 50166 Length 52102 46117 374 1314 2037 0 BLOCK NAME STACK SIZE TYPE WHY NONQUICK/WHO SHARES STACK FRAME fortran_io_ 2600 external procedure is an external procedure. on unit on line 930 64 on unit on unit on line 931 64 on unit on unit on line 1090 64 on unit on unit on line 1091 64 on unit on unit on line 1115 64 on unit on unit on line 1116 64 on unit get_buffer_ptr internal procedure shares stack frame of external procedure fortran_io_. make_static_frame internal procedure shares stack frame of external procedure fortran_io_. initialize_fortran_io internal procedure shares stack frame of external procedure fortran_io_. validate_mode_and_access internal procedure shares stack frame of external procedure fortran_io_. get_record internal procedure shares stack frame of external procedure fortran_io_. set_max_recl internal procedure shares stack frame of external procedure fortran_io_. strip_line_no internal procedure shares stack frame of external procedure fortran_io_. dfast_openfile internal procedure shares stack frame of external procedure fortran_io_. open_statement internal procedure shares stack frame of external procedure fortran_io_. add_attach_option internal procedure shares stack frame of external procedure fortran_io_. process_vfile_status internal procedure shares stack frame of external procedure fortran_io_. check_attach_options internal procedure shares stack frame of external procedure fortran_io_. merge_attributes internal procedure shares stack frame of external procedure fortran_io_. convert_from_character internal procedure shares stack frame of external procedure fortran_io_. inquire_statement internal procedure shares stack frame of external procedure fortran_io_. get_name_of_unit internal procedure shares stack frame of external procedure fortran_io_. get_associated_unit 218 internal procedure is called during a stack extension. get_unique_id internal procedure shares stack frame of internal procedure get_associated_unit. set_return_value internal procedure shares stack frame of external procedure fortran_io_. exists_file internal procedure shares stack frame of external procedure fortran_io_. get_open_field internal procedure shares stack frame of external procedure fortran_io_. field_error internal procedure shares stack frame of external procedure fortran_io_. reopen_for_input internal procedure shares stack frame of external procedure fortran_io_. close_fortran_file internal procedure shares stack frame of external procedure fortran_io_. finish_line internal procedure shares stack frame of external procedure fortran_io_. close_for_stop 74 internal procedure is called by several nonquick procedures. close_all_files 160 internal procedure is called by several nonquick procedures. delete_file 126 internal procedure is called by several nonquick procedures. save_attach_desc 65 internal procedure is called by several nonquick procedures. error_handlers internal procedure shares stack frame of external procedure fortran_io_. print_error 504 internal procedure is called during a stack extension, and is declared options(variable). unformatted_io internal procedure shares stack frame of external procedure fortran_io_. formatted_io internal procedure shares stack frame of external procedure fortran_io_. unpack_one internal procedure shares stack frame of external procedure fortran_io_. unpack_two internal procedure shares stack frame of external procedure fortran_io_. unpack_three internal procedure shares stack frame of external procedure fortran_io_. unpack_four internal procedure shares stack frame of external procedure fortran_io_. start_floating internal procedure shares stack frame of external procedure fortran_io_. create_decimal internal procedure shares stack frame of external procedure fortran_io_. minus_sign internal procedure shares stack frame of external procedure fortran_io_. expand_buffer internal procedure shares stack frame of external procedure fortran_io_. read_buffer internal procedure shares stack frame of external procedure fortran_io_. left_justify internal procedure shares stack frame of external procedure fortran_io_. right_justify internal procedure shares stack frame of external procedure fortran_io_. namelist_io internal procedure shares stack frame of external procedure fortran_io_. list_input internal procedure shares stack frame of external procedure fortran_io_. check_repetition internal procedure shares stack frame of external procedure fortran_io_. ansi66_output internal procedure shares stack frame of external procedure fortran_io_. ansi66_format internal procedure shares stack frame of external procedure fortran_io_. ansi77_output internal procedure shares stack frame of external procedure fortran_io_. ansi77_format internal procedure shares stack frame of external procedure fortran_io_. buffer_read internal procedure shares stack frame of external procedure fortran_io_. get_field internal procedure shares stack frame of external procedure fortran_io_. check_end internal procedure shares stack frame of external procedure fortran_io_. decode_runtime internal procedure shares stack frame of external procedure fortran_io_. store_null internal procedure shares stack frame of external procedure fortran_io_. store internal procedure shares stack frame of external procedure fortran_io_. input_float internal procedure shares stack frame of external procedure fortran_io_. input_complex internal procedure shares stack frame of external procedure fortran_io_. input_piece_of_complex internal procedure shares stack frame of external procedure fortran_io_. input_logical internal procedure shares stack frame of external procedure fortran_io_. input_charstr internal procedure shares stack frame of external procedure fortran_io_. build_string internal procedure shares stack frame of external procedure fortran_io_. set_size_and_count internal procedure shares stack frame of external procedure fortran_io_. char_pos internal procedure shares stack frame of external procedure fortran_io_. advance_element_p internal procedure shares stack frame of external procedure fortran_io_. STORAGE FOR AUTOMATIC VARIABLES. STACK FRAME LOC IDENTIFIER BLOCK NAME close_all_files 000100 frn close_all_files 000101 fcode close_all_files 000102 p close_all_files 000104 killing_file close_all_files 000105 attach_description close_all_files close_for_stop 000100 buf_p close_for_stop 000102 ix close_for_stop fortran_io_ 000100 dummy_for_double_word_alignment fortran_io_ 000150 attach_desc_len fortran_io_ 000151 base fortran_io_ 000152 begin_index fortran_io_ 000153 bin_type fortran_io_ 000154 buffer_index fortran_io_ 000155 buffer_length fortran_io_ 000156 buffer_max_len fortran_io_ 000157 call_sw fortran_io_ 000160 ch fortran_io_ 000161 char_len fortran_io_ 000162 char_offset fortran_io_ 000163 chars_left fortran_io_ 000164 chars_per_item fortran_io_ 000165 code fortran_io_ 000166 column_one fortran_io_ 000167 count fortran_io_ 000170 current fortran_io_ 000171 dexp fortran_io_ 000172 dirname fortran_io_ 000244 data_type_of_prev_item fortran_io_ 000245 e fortran_io_ 000246 element_count fortran_io_ 000247 entry_point fortran_io_ 000250 entryname fortran_io_ 000260 exists fortran_io_ 000261 exists_file_code fortran_io_ 000270 have_runtime_format fortran_io_ 000271 i fortran_io_ 000272 in fortran_io_ 000273 interactive fortran_io_ 000274 internal_file_count fortran_io_ 000275 j fortran_io_ 000276 k fortran_io_ 000277 l fortran_io_ 000300 last fortran_io_ 000301 must_produce_plus fortran_io_ 000302 my_code fortran_io_ 000303 new_buffer_length fortran_io_ 000312 overflow_label fortran_io_ 000316 prec fortran_io_ 000317 process_type fortran_io_ 000320 sent fortran_io_ 000330 skip_line_numbers fortran_io_ 000331 str_len fortran_io_ 000332 suppress_final_newline fortran_io_ 000333 terminal_file fortran_io_ 000342 zero_label fortran_io_ 000354 fio_ps fortran_io_ 000370 fortran_buffer_ptr fortran_io_ 000372 ptr_array fortran_io_ 000374 sp fortran_io_ 000376 rs_info_ptr fortran_io_ 000406 create_sw get_buffer_ptr 000407 get_segment get_buffer_ptr 000424 unwritten_eofs initialize_fortran_io 000426 switch_for_endfile initialize_fortran_io 000430 unit_for_endfile initialize_fortran_io 000446 record_key get_record 000450 record_length get_record 000466 ln strip_line_no 000504 allow_default open_statement 000505 desired_file_type open_statement 000506 erasable_file open_statement 000507 file open_statement 000510 file_is_empty open_statement 000511 keep_status open_statement 000512 fio_vfile_attach open_statement 000513 i open_statement 000514 implicit_opening open_statement 000515 job_index open_statement 000516 len open_statement 000517 off open_statement 000520 open_index open_statement 000521 using_vfile open_statement 000546 adp check_attach_options 000556 actual_mode merge_attributes 000557 desired_mode merge_attributes 000566 i convert_from_character 000567 num_valid_values convert_from_character 000570 error_string convert_from_character 000611 given convert_from_character 000626 by_file inquire_statement 000627 in_range inquire_statement 000630 file_connected inquire_statement 000631 file_exists inquire_statement 000632 need_name inquire_statement 000633 unit_number inquire_statement 000634 return_string inquire_statement 000707 dir_name inquire_statement 000761 ent_name inquire_statement 001006 return_len set_return_value 001016 my_code exists_file 001017 file_type exists_file 001020 bit_count exists_file 001021 pathname exists_file 001073 off exists_file 001074 len exists_file 001120 new_opening reopen_for_input 001121 original_opening reopen_for_input 001122 code reopen_for_input 001123 tcode reopen_for_input 001162 op_offset formatted_io 001163 field formatted_io 001170 FORMAT formatted_io 001205 blanks_as_null formatted_io 001206 leading_sign formatted_io 001207 infinite_format formatted_io 001210 decimal_len formatted_io 001211 decimal_type formatted_io 001212 exponent formatted_io 001213 exp formatted_io 001214 negate formatted_io 001215 add_zero formatted_io 001216 effective_digits formatted_io 001217 digits_after_E formatted_io 001220 x formatted_io 001221 lied_about_sign formatted_io 001222 x_float formatted_io 001225 scale formatted_io 001226 element_v formatted_io 001230 bin_int formatted_io 001231 min_field_width formatted_io 001332 piece_len left_justify 001333 source_idx left_justify 001342 piece_len right_justify 001343 source_limit right_justify 001352 headings namelist_io 001353 rep_factor namelist_io 001354 namelist namelist_io 001355 comma_encountered namelist_io 001356 comma_required namelist_io 001357 legal_end namelist_io 001360 null_value namelist_io 001361 name_ln namelist_io 001362 dims namelist_io 001363 temp namelist_io 001364 c_temp namelist_io 001366 factor namelist_io 001367 namelist_name_len namelist_io 001370 data_type namelist_io 001371 constant_type namelist_io 001372 n namelist_io 001373 subscripts namelist_io 001374 subscript_array namelist_io 001403 repetition_count namelist_io 001440 number_string ansi66_output 001456 first_digit ansi66_format 001457 no_of_digits ansi66_format 001460 trailing_zeros ansi66_format 001461 precision ansi66_format 001462 exponent ansi66_format 001463 exp_char ansi66_format 001464 dec_num ansi66_format 001500 more_pieces ansi77_output 001501 num_sig_chars ansi77_output 001502 piece_idx ansi77_output 001503 piece_len ansi77_output 001504 piece_max_len ansi77_output 001505 number_string ansi77_output 001515 number_length ansi77_output 001524 precision ansi77_format 001525 first_digit ansi77_format 001526 no_of_digits ansi77_format 001527 no_of_zeros ansi77_format 001530 dpt ansi77_format 001531 chars_in_exp ansi77_format 001532 exponent ansi77_format 001533 dec_num ansi77_format 001562 ii check_end 001654 len2 build_string 001664 data_type set_size_and_count 001674 source_position char_pos 001676 source_ptr char_pos 001706 bits_before_element advance_element_p 001707 bits_in_element advance_element_p get_associated_unit 000100 file_uid get_associated_unit 000101 uid get_associated_unit 000102 dname get_associated_unit 000154 ename get_associated_unit 000172 branch_status get_unique_id 000204 my_status get_unique_id 000216 status_ptr get_unique_id print_error 000100 comp_name print_error 000110 dir_name print_error 000162 ent_name print_error 000262 seg_name print_error 000272 std print_error 000273 op_name print_error 000304 start print_error 000305 num print_error 000306 line_no print_error 000307 offset print_error 000310 cur_op print_error 000311 bit_cnt print_error 000312 error_code print_error 000313 tcode print_error 000314 ap print_error 000316 err_point print_error 000320 seg_base print_error 000322 sym_tab print_error 000324 p print_error 000326 ci print_error 000376 oi print_error THE FOLLOWING EXTERNAL OPERATORS ARE USED BY THIS PROGRAM. r_e_as r_ne_as alloc_char_temp cat_realloc_chars call_ent_var call_ext_out_desc call_ext_out call_int_this_desc call_int_this call_int_other_desc call_int_other return_mac tra_ext_1 tra_ext_2 mpfx2 mdfx1 signal_op enable_op shorten_stack ext_entry int_entry int_entry_desc repeat reverse_cs set_chars_eis index_chars_eis real_to_real_round_ any_to_any_truncate_unpack_picture divide_fx3 set_support THE FOLLOWING EXTERNAL ENTRIES ARE CALLED BY THIS PROGRAM. add_char_offset_ assign_round_ com_err_ component_info_$offset cu_$arg_count cu_$arg_list_ptr cu_$arg_ptr cu_$cl cu_$gen_call cu_$stack_frame_ptr default_error_handler_$add_finish_handler delete_$path expand_pathname_ general_format_parse_$runtime get_entry_name_ get_pdir_ get_temp_segments_ hcs_$fs_get_path_name hcs_$status_long hcs_$status_minf hcs_$status_mins ioa_ ioa_$ioa_switch iox_$attach_iocb iox_$close iox_$control iox_$detach_iocb iox_$find_iocb iox_$get_chars iox_$get_line iox_$open iox_$position iox_$put_chars iox_$read_record iox_$rewrite_record iox_$seek_key iox_$write_record object_info_$brief release_temp_segments_ return_to_user return_to_user$special_return stack_frame_exit_ stop_run stu_$decode_runtime_value stu_$find_runtime_symbol stu_$get_line_no stu_$get_runtime_address stu_$get_runtime_line_no unique_chars_ user_info_$process_type vfile_status_ THE FOLLOWING EXTERNAL VARIABLES ARE USED BY THIS PROGRAM. error_table_$asynch_deletion error_table_$boundviol error_table_$end_of_info error_table_$moderr error_table_$no_file error_table_$no_operation error_table_$no_record error_table_$noentry error_table_$pathlong error_table_$short_record fast_related_data_$fortran_buffer_p fast_related_data_$fortran_io_initiated fast_related_data_$in_dfast fast_related_data_$in_fast_or_dfast fast_related_data_$terminate_run fort_version_info$greeting fort_version_info$version_number fortran_buffer_$ fortran_io_error_$access_field_error fortran_io_error_$already_connected fortran_io_error_$already_opened fortran_io_error_$attach_desc_field_error fortran_io_error_$bad_char fortran_io_error_$blank_field_error fortran_io_error_$cannot_position fortran_io_error_$cannot_read fortran_io_error_$cannot_reopen fortran_io_error_$cannot_truncate fortran_io_error_$cannot_write fortran_io_error_$close_attr_error fortran_io_error_$conversion_error fortran_io_error_$dnumeric_file fortran_io_error_$filename_field_error fortran_io_error_$fio_sys_error fortran_io_error_$form_field_error fortran_io_error_$format_error fortran_io_error_$format_is_infinite fortran_io_error_$formatted_file fortran_io_error_$incompatible_opening fortran_io_error_$internal_file_oflow fortran_io_error_$invalid_file0_attr fortran_io_error_$invalid_file0_type fortran_io_error_$invalid_for_file0 fortran_io_error_$io_switch_field_error fortran_io_error_$long_record fortran_io_error_$missing_header fortran_io_error_$mode_field_error fortran_io_error_$must_be_empty fortran_io_error_$namelist_error fortran_io_error_$not_blocked fortran_io_error_$not_direct fortran_io_error_$not_open fortran_io_error_$not_scratch_file fortran_io_error_$not_sequential fortran_io_error_$open_attr_conflict fortran_io_error_$open_attr_incomplete fortran_io_error_$parens_too_deep fortran_io_error_$read_after_eof fortran_io_error_$short_record fortran_io_error_$status_field_error fortran_io_error_$syntax_error fortran_io_error_$unformatted_file fortran_io_error_$unknown_filetype fortran_io_error_$write_after_eof fortran_io_error_$wrong_mode iox_$error_output iox_$user_input iox_$user_io iox_$user_output pl1_operators_$VLA_words_per_seg_ sys_info$max_seg_size LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC LINE LOC 30 004344 33 004353 912 004376 919 004400 922 004411 924 004415 928 004416 929 004421 930 004424 931 004463 933 004503 944 004505 946 004515 947 004520 948 004522 950 004532 952 004537 954 004547 955 004550 957 004553 960 004564 962 004571 964 004576 968 004601 970 004607 972 004611 973 004612 974 004613 975 004614 977 004620 979 004623 981 004626 984 004635 988 004637 991 004656 993 004662 994 004667 996 004670 998 004675 999 004677 1001 004700 1003 004701 1005 004702 1008 004703 1011 004706 1013 004713 1015 004716 1017 004721 1018 004722 1024 004723 1028 004744 1029 004750 1030 004752 1031 004754 1032 004762 1034 004766 1041 005011 1043 005012 1045 005016 1049 005022 1052 005027 1054 005030 1056 005035 1059 005036 1066 005043 1069 005045 1071 005051 1079 005056 1082 005067 1084 005073 1088 005074 1089 005077 1090 005102 1091 005141 1093 005161 1095 005162 1096 005166 1098 005167 1104 005174 1107 005205 1109 005211 1113 005212 1114 005215 1115 005220 1116 005257 1118 005277 1120 005300 1121 005304 1122 005306 1126 005313 1133 005323 1135 005337 1137 005343 1142 005344 1145 005353 1146 005363 1147 005364 1154 005365 1159 005377 1161 005401 1163 005404 1164 005406 1168 005407 1170 005412 1171 005422 1172 005424 1175 005425 1177 005431 1178 005432 1179 005435 1181 005437 1183 005440 1184 005442 1187 005443 1189 005445 1190 005450 1193 005451 1195 005454 1201 005455 1207 005467 1209 005471 1212 005502 1213 005510 1216 005511 1221 005512 1229 005525 1231 005527 1234 005540 1235 005546 1237 005557 1240 005560 1245 005561 1253 005570 1254 005632 1259 005634 1261 005636 1263 005647 8140 005673 1266 005674 1279 005676 1280 005701 1284 005704 1286 005706 1292 005711 1294 005715 1297 005723 1298 005725 1301 005726 1303 005740 1305 005741 1306 005745 1309 005746 1314 005753 1319 005756 1321 005762 1323 005763 1324 005765 1325 005772 1329 005773 1331 005775 1332 005776 1335 005777 1337 006001 1340 006022 1342 006024 1346 006032 1347 006046 1354 006073 1356 006074 1358 006102 1361 006114 1364 006121 1366 006123 1367 006125 1368 006127 1371 006131 1372 006133 1375 006134 1378 006135 1381 006141 1384 006144 1387 006150 1388 006152 1389 006172 1391 006175 1392 006176 1394 006201 1395 006202 1399 006203 1405 006204 1406 006213 1410 006216 1411 006221 1412 006223 1417 006225 1420 006226 1422 006232 1426 006234 1428 006241 1430 006243 1435 006245 1439 006246 1441 006251 1442 006254 1446 006255 1447 006264 1449 006272 1451 006273 1454 006274 1511 006275 1513 006300 1515 006305 1516 006310 1518 006312 1522 006325 1524 006331 1527 006333 1529 006346 1533 006375 1535 006376 1537 006400 1538 006402 1540 006407 1543 006420 1544 006422 1546 006425 1551 006432 1554 006445 1556 006446 1559 006456 1561 006473 1563 006474 1568 006505 1573 006512 1575 006515 1581 006525 1588 006526 1589 006533 1590 006534 1592 006542 1594 006545 1596 006551 1598 006552 1603 006555 1609 006570 1611 006571 1613 006576 1614 006577 1616 006605 1619 006606 1620 006611 1625 006615 1627 006624 1628 006630 1629 006633 1630 006634 1632 006635 1634 006636 1636 006637 1638 006651 1640 006652 1643 006676 1647 006701 1649 006702 1651 006703 1653 006704 1655 006705 1657 006706 1659 006707 1662 006723 1664 006726 1666 006731 1669 006753 1670 006754 1673 006766 1674 007006 1676 007014 1679 007047 1683 007062 1685 007063 1687 007070 1689 007073 1691 007076 1694 007120 1695 007121 1699 007133 1700 007153 1702 007161 1704 007163 1705 007212 1708 007217 1709 007230 1712 007243 1713 007246 1714 007250 1716 007252 1720 007253 1724 007266 1727 007270 1730 007277 1731 007302 1756 007303 1759 007321 1762 007352 1764 007355 1766 007371 1768 007374 1769 007375 1771 007407 1772 007410 1774 007415 1775 007426 1776 007427 1777 007431 1779 007435 1780 007445 1781 007450 1782 007471 1784 007525 1786 007532 1787 007561 1789 007603 1790 007605 1791 007606 1793 007621 1795 007624 1796 007626 1798 007627 1800 007634 1802 007655 1805 007700 1807 007722 1811 007724 1812 007756 1814 007760 1816 007765 1817 010015 1820 010030 1824 010040 1826 010047 1827 010060 1830 010062 1832 010063 1835 010066 1836 010067 1838 010070 1840 010071 1842 010072 1846 010075 1847 010104 1849 010105 1852 010136 1863 010137 1866 010140 1868 010150 1869 010163 1871 010166 1872 010170 1875 010172 1878 010173 1880 010175 1884 010177 1889 010206 1894 010214 1896 010222 1901 010227 1903 010232 1904 010252 1909 010264 1913 010303 1916 010310 1922 010314 1924 010317 1927 010327 1928 010330 1931 010337 1933 010343 1939 010367 1940 010377 1942 010402 1944 010406 1948 010411 1954 010426 1957 010435 1959 010437 1961 010446 1965 010457 1966 010461 1968 010462 1970 010466 1971 010505 1973 010506 1979 010510 1981 010513 1984 010515 1986 010523 1987 010525 1989 010526 1991 010530 1992 010531 1993 010532 1997 010533 2000 010535 2003 010560 2004 010570 2007 010611 2008 010627 2010 010631 2013 010662 2018 010664 2024 010671 2027 010676 2030 010706 2031 010710 2032 010721 2039 010722 2052 010723 2054 010733 2056 010735 2060 010754 2061 010756 2063 010763 2067 010767 2068 010770 2069 011003 2074 011004 2078 011026 2079 011027 2081 011041 2082 011047 2083 011070 2085 011113 2087 011125 2088 011136 2093 011137 2098 011142 2100 011151 2102 011152 2103 011160 2108 011165 2112 011176 2115 011211 2117 011214 2118 011215 2120 011222 2122 011223 2126 011232 2128 011234 2131 011241 2132 011246 2133 011247 2134 011252 2135 011253 2137 011257 2143 011306 2144 011313 2146 011314 2148 011315 2150 011317 2153 011324 2154 011331 2155 011332 2156 011335 2157 011336 2159 011342 2165 011371 2166 011376 2168 011377 2170 011400 2172 011402 2174 011407 2175 011411 2176 011415 2177 011416 2178 011421 2181 011422 2184 011427 2185 011431 2186 011435 2187 011436 2188 011441 2193 011442 2195 011447 2196 011450 2197 011455 2200 011457 2202 011461 2203 011466 2211 011467 2213 011474 2214 011476 2215 011477 2219 011500 2222 011506 2224 011510 2226 011521 2230 011526 2232 011540 2233 011546 2235 011550 2237 011571 2238 011606 2239 011607 2241 011610 2243 011612 2245 011626 2246 011643 2247 011644 2249 011706 2252 011707 2258 011711 2265 011722 2267 011727 2268 011730 2271 011736 2272 011740 2273 011741 2276 011746 2277 011763 2278 011764 2281 011765 2282 011767 2286 011770 2289 012002 2291 012003 2296 012004 2300 012027 2301 012030 2303 012031 2306 012051 2311 012052 2314 012073 2315 012074 2321 012110 2324 012131 2325 012132 2327 012146 2332 012147 2341 012151 2344 012167 2345 012176 2349 012201 2351 012207 2353 012216 2354 012240 2357 012247 2359 012250 2369 012252 2371 012255 2372 012260 2373 012263 2374 012265 2375 012270 2376 012272 2377 012322 2380 012333 2383 012334 2384 012355 2387 012361 2389 012362 2391 012364 2392 012406 2395 012407 2398 012431 2400 012433 2404 012444 2406 012450 2409 012453 2411 012460 2414 012462 2417 012472 2421 012473 2426 012475 2427 012500 2428 012502 2430 012535 2434 012553 2437 012567 2440 012610 2445 012633 2450 012634 2455 012635 2460 012664 2462 012702 2464 012703 2465 012705 2466 012707 2469 012710 2472 012711 2473 012713 2474 012715 2476 012716 2482 012717 2485 012737 2488 012774 2490 012776 2493 013004 2496 013011 2497 013022 2500 013023 2503 013027 2505 013031 2506 013033 2507 013035 2508 013037 2509 013041 2510 013043 2511 013045 2513 013047 2514 013051 2516 013053 2517 013054 2518 013055 2520 013056 2524 013060 2526 013065 2529 013114 2532 013120 2535 013122 2536 013134 2537 013136 2540 013137 2542 013141 2544 013143 2545 013155 2546 013157 2549 013160 2551 013162 2553 013164 2554 013176 2555 013200 2558 013201 2561 013203 2562 013215 2563 013217 2566 013220 2568 013232 2569 013234 2572 013235 2575 013237 2576 013251 2577 013253 2580 013254 2583 013256 2584 013270 2585 013272 2588 013273 2591 013275 2592 013307 2593 013311 2596 013312 2599 013314 2602 013316 2605 013330 2607 013332 2608 013334 2610 013335 2688 013336 2690 013344 2691 013347 2692 013356 2693 013357 2695 013363 2697 013371 2699 013374 2701 013405 2703 013415 2705 013420 2706 013421 2708 013423 2710 013427 2711 013432 2715 013440 2717 013444 2719 013447 2723 013455 2725 013463 2726 013466 2727 013476 2728 013477 2733 013504 2736 013543 2739 013547 2742 013577 2743 013601 2746 013631 2754 013657 2760 013662 2767 013720 2769 013731 2772 013761 2775 014010 2781 014011 2783 014013 2786 014043 2789 014071 2796 014072 2799 014074 2803 014123 2807 014156 2811 014206 2819 014236 2820 014240 2821 014241 2824 014242 2827 014243 2829 014245 2830 014247 2831 014251 2833 014253 2835 014260 2837 014270 2839 014272 2842 014301 2845 014310 2846 014312 2847 014314 2850 014315 2853 014317 2854 014322 2856 014323 2860 014333 2862 014335 2868 014343 2869 014354 2872 014355 2875 014365 2878 014375 2881 014405 2882 014412 2888 014413 2889 014423 2891 014426 2895 014432 2900 014435 2903 014444 2909 014453 2914 014456 2919 014457 2921 014463 2923 014465 2926 014524 2930 014553 2931 014562 2934 014563 2935 014567 2938 014571 2941 014613 2943 014615 2944 014650 2947 014651 2952 014654 2957 014660 2965 014715 2968 014722 2970 014724 2974 014763 2978 015012 2979 015021 2981 015022 2984 015025 2986 015027 2989 015066 2993 015116 2994 015122 2995 015130 2997 015133 2998 015135 3001 015136 3003 015146 3004 015152 3006 015154 3007 015156 3009 015157 3012 015160 3014 015170 3015 015174 3017 015176 3018 015200 3020 015201 3023 015202 3025 015207 3030 015323 3031 015334 3032 015336 3033 015340 3037 015341 3038 015345 3039 015351 3041 015353 3047 015355 3050 015364 3055 015366 3058 015371 3063 015400 3065 015407 3067 015420 3072 015427 3074 015432 3076 015441 3078 015450 3082 015451 3084 015455 3085 015464 3093 015466 3095 015510 3097 015512 3098 015522 3101 015523 3108 015525 3111 015542 3114 015545 3115 015547 3116 015602 3124 015603 3127 015614 3128 015625 3129 015634 3130 015656 3132 015670 3134 015671 3136 015677 3137 015710 3138 015717 3139 015726 3140 015750 3143 015762 3147 015763 3150 015773 3152 015777 3153 016001 3154 016003 3155 016004 3160 016013 3162 016021 3164 016031 3167 016071 3169 016072 3175 016073 3183 016100 3186 016111 3187 016114 3189 016125 3191 016127 3201 016134 3208 016154 3210 016156 3211 016163 3218 016177 3220 016201 3221 016206 3227 016207 3229 016242 3232 016243 3234 016262 3239 016264 3249 016303 3250 016305 3253 016312 3257 016330 3264 016342 3266 016345 3267 016365 3274 016377 3276 016402 3278 016410 3279 016430 3284 016442 3289 016443 3291 016446 3293 016453 3295 016455 3296 016474 3298 016506 3304 016507 3306 016511 3307 016523 3308 016526 3310 016545 3319 016561 3320 016563 3322 016564 3323 016566 3327 016615 3328 016617 3337 016620 3339 016622 3341 016631 3343 016647 3347 016651 3352 016664 3354 016714 3358 016715 3359 016721 3360 016724 3368 016742 3370 016745 3372 016751 3374 016767 3376 016770 3379 016777 3383 017005 3387 017015 3389 017016 3390 017020 3400 017021 3402 017026 3404 017035 3405 017036 3409 017037 3414 017053 3419 017074 3420 017115 3422 017127 3426 017130 3428 017135 3435 017136 3436 017141 3441 017142 3447 017143 3449 017153 3451 017155 3452 017161 3455 017203 3459 017204 3461 017211 3466 017251 3467 017266 3469 017271 3470 017272 3472 017275 3476 017330 3477 017345 3480 017350 3484 017351 3489 017353 3491 017362 3492 017406 3495 017407 3496 017416 3497 017421 3502 017422 3505 017423 3508 017433 3509 017462 3512 017463 3515 017467 3517 017472 3520 017500 3524 017506 3528 017517 3530 017520 3532 017523 3533 017526 3535 017530 3537 017536 3540 017537 3541 017547 3558 017550 3547 017551 3552 017552 3554 017555 3557 017567 3563 017570 3569 017571 3572 017606 3574 017632 3579 017633 3583 017667 3586 017720 3589 017753 3595 020005 3598 020015 3600 020023 3601 020047 3604 020050 3606 020053 3607 020101 3625 020102 3627 020112 3629 020121 3632 020125 3634 020142 3637 020153 3644 020156 3648 020166 3650 020167 3652 020174 3660 020175 3666 020236 3669 020262 3671 020276 3675 020303 3682 020307 3684 020323 3688 020345 3689 020350 3694 020352 3697 020363 3698 020365 3701 020412 3704 020413 3705 020415 3706 020417 3713 020421 3716 020455 3717 020456 3723 020507 3729 020533 3732 020550 3736 020556 3737 020564 3740 020617 3741 020631 3746 020663 3749 020676 3752 020706 3755 020716 3760 020717 3769 020723 3771 020736 3773 020755 3777 020762 3778 020771 3780 021011 3781 021013 3783 021014 3787 021016 3788 021017 3789 021027 3790 021077 3791 021102 3794 021203 3796 021260 3801 021262 3818 021263 3820 021270 3822 021273 3826 021274 3828 021345 3830 021350 3831 021352 3832 021353 3834 021355 3835 021360 3836 021361 3838 021364 3839 021365 3840 021366 3842 021367 3843 021370 3845 021372 3847 021373 3848 021376 3849 021400 3851 021404 3852 021405 3853 021410 3854 021412 3855 021416 3858 021417 3859 021420 3865 021421 3867 021427 3869 021435 3872 021440 3881 021446 3889 021462 3891 021465 3893 021473 3895 021506 3898 021510 3900 021513 3902 021527 3904 021532 3905 021610 3910 021624 3912 021630 3914 021634 3916 021644 3917 021650 3918 021651 3919 021655 3923 021667 3925 021673 3927 021677 3929 021707 3930 021713 3931 021714 3932 021720 3936 021732 3938 021736 3940 021742 3942 021752 3943 021756 3944 021757 3945 021763 3949 021775 3951 022001 3953 022003 3955 022013 3956 022017 3958 022020 3959 022023 3960 022052 3962 022062 3964 022075 3966 022101 3973 022114 3976 022117 3978 022123 3980 022135 3981 022141 3985 022153 3989 022164 3991 022167 3993 022200 3994 022205 3998 022217 4000 022223 4002 022236 4003 022243 4009 022255 4011 022261 4013 022264 4015 022274 4017 022277 4019 022302 4020 022331 4022 022344 4023 022351 4024 022352 4029 022363 4031 022371 4035 022403 4037 022404 4039 022405 4040 022416 4041 022444 4043 022471 4044 022472 4046 022473 4068 022522 4069 022524 4070 022550 4072 022552 4073 022556 4076 022557 4077 022566 4078 022571 4079 022573 4081 022576 4083 022601 4084 022613 4085 022641 4087 022644 4088 022650 4092 022651 4096 022654 4098 022660 4100 022661 4113 022704 4114 022734 4116 022737 4117 022741 4120 022742 4121 022744 4122 023004 4124 023012 4126 023015 4128 023016 4140 023020 4141 023026 4144 023031 4146 023043 4152 023044 4164 023046 4166 023050 4168 023052 4171 023060 4175 023065 4176 023072 4177 023116 4182 023124 4183 023204 4188 023212 4193 023213 4204 023215 4206 023222 4208 023237 4212 023240 4217 023242 4219 023244 4221 023250 4223 023254 4225 023260 4227 023264 4229 023270 4231 023274 4233 023300 4237 023304 4244 023305 4246 023311 4248 023322 4249 023324 4251 023331 4252 023336 4253 023355 4255 023364 4257 023365 4259 023367 4260 023406 4261 023435 4264 023436 4265 023442 4266 023450 4269 023451 4272 023452 4273 023456 4275 023457 4277 023470 4278 023472 4280 023477 4281 023504 4283 023533 4285 023535 4287 023541 4289 023546 4291 023547 4293 023551 4294 023570 4297 023575 4298 023623 4301 023624 4303 023627 4304 023647 4308 023661 4309 023665 4310 023673 4315 023674 4318 023675 4321 023701 4326 023706 4331 023712 4333 023727 4337 023752 4343 023766 4345 023772 4351 023773 4354 023774 4356 023775 4358 024000 4359 024021 4361 024023 4366 024024 4372 024033 4375 024035 4376 024040 4379 024044 4384 024050 4386 024055 4389 024061 4391 024072 4393 024075 4395 024076 4397 024100 4404 024101 4417 024110 4420 024112 4421 024115 4426 024121 4428 024125 4430 024151 4435 024154 4439 024206 4443 024210 4445 024215 4446 024222 4448 024227 4451 024244 4453 024256 4459 024264 4466 024322 4468 024341 4472 024365 4474 024404 4476 024406 4477 024423 4480 024430 4481 024437 4483 024441 4484 024444 4488 024445 4497 024462 4498 024520 4500 024524 4501 024554 4504 024555 4505 024610 4507 024613 4508 024643 4510 024644 4514 024645 4517 024662 4518 024677 4520 024703 4521 024711 4523 024712 4526 024713 4528 024742 4530 024744 4532 024755 4534 024757 4536 025006 4538 025010 4540 025021 4542 025023 4543 025025 4545 025036 4547 025040 4549 025075 4551 025077 4553 025110 4556 025111 4602 025120 4604 025137 4609 025143 4611 025151 4613 025154 4614 025156 4615 025160 4616 025162 4620 025164 4622 025167 4624 025171 4630 025177 4635 025215 4639 025240 4641 025241 4643 025245 4645 025250 4647 025253 4656 025256 4658 025262 4659 025303 4664 025307 4666 025316 4668 025321 4669 025330 4670 025345 4678 025346 4679 025353 4681 025406 4682 025410 4686 025414 4687 025452 4689 025457 4693 025462 4694 025501 4696 025503 4697 025505 4698 025507 4699 025514 4700 025517 4702 025520 4704 025536 4707 025540 4708 025542 4709 025561 4712 025563 4713 025565 4718 025571 4719 025573 4721 025616 4724 025645 4726 025647 4727 025660 4728 025674 4729 025675 4735 025702 4739 025734 4741 025745 4744 025757 4745 025764 4747 025775 4749 026002 4752 026064 4754 026145 4760 026146 4762 026153 4763 026155 4764 026156 4767 026157 4769 026165 4771 026167 4773 026214 4775 026232 4780 026244 4786 026340 4792 026433 4794 026441 4796 026476 4799 026525 4809 026535 4811 026552 4813 026562 4816 026566 4817 026571 4819 026572 4822 026573 4827 026574 4828 026576 4832 026601 4836 026611 4839 026616 4842 026631 4843 026641 4847 026653 4849 026661 4855 026703 4857 026705 4861 026706 4864 026725 4865 026727 4866 026730 4870 026731 4873 026750 4876 026755 4879 026770 4880 027000 4883 027012 4885 027020 4891 027040 4894 027042 4897 027043 4976 027044 4980 027046 4982 027051 4983 027054 4986 027057 4990 027061 4992 027064 4994 027065 4995 027072 4998 027073 5000 027074 5001 027075 5003 027076 5005 027077 5009 027101 5010 027103 5017 027104 5018 027106 5021 027112 5024 027124 5026 027127 5027 027145 5034 027154 5035 027156 5038 027164 5043 027167 5045 027171 5046 027176 5050 027177 5052 027202 5053 027207 5059 027210 5060 027213 5061 027220 5062 027221 5063 027223 5067 027224 5070 027235 5073 027236 5075 027237 5082 027240 5085 027242 5086 027244 5088 027245 5090 027257 5097 027261 5098 027262 5100 027265 5102 027273 5103 027274 5104 027276 5105 027277 5106 027301 5107 027303 5108 027304 5109 027307 5110 027313 5111 027317 5112 027321 5114 027322 5117 027324 5118 027326 5119 027330 5120 027331 5122 027333 5124 027341 5125 027343 5128 027345 5131 027356 5133 027360 5134 027363 5136 027364 5137 027371 5139 027372 5140 027401 5143 027402 5145 027407 5148 027416 5151 027417 5154 027420 5155 027421 5160 027423 5161 027425 5163 027426 5166 027432 5167 027434 5169 027436 5170 027440 5171 027442 5173 027443 5174 027444 5176 027446 5178 027447 5180 027451 5181 027453 5183 027454 5185 027455 5186 027460 5188 027462 5192 027464 5193 027465 5194 027467 5196 027470 5197 027507 5199 027513 5200 027534 5202 027546 5205 027564 5207 027603 5209 027604 5211 027606 5212 027614 5213 027615 5214 027616 5216 027617 5217 027620 5219 027622 5220 027627 5224 027630 5225 027635 5227 027636 5229 027640 5230 027645 5233 027647 5235 027661 5238 027665 5240 027701 5242 027711 5243 027715 5246 027716 5248 027727 5249 027733 5256 027734 5258 027740 5260 027743 5261 027750 5263 027754 5264 027760 5266 027761 5268 027764 5269 027771 5271 027775 5272 030002 5275 030014 5278 030015 5280 030016 5281 030017 5284 030021 5285 030023 5286 030024 5289 030035 5291 030045 5292 030052 5295 030053 5297 030054 5298 030055 5301 030057 5302 030061 5304 030062 5305 030065 5307 030067 5308 030076 5309 030077 5310 030100 5311 030101 5313 030105 5314 030117 5316 030132 5317 030133 5318 030136 5321 030137 5323 030140 5324 030141 5327 030143 5328 030145 5330 030146 5331 030150 5334 030155 5336 030160 5338 030205 5341 030217 5342 030221 5343 030237 5344 030240 5345 030244 5349 030255 5351 030261 5352 030263 5354 030265 5355 030267 5356 030271 5357 030273 5359 030274 5360 030276 5361 030301 5363 030303 5365 030304 5366 030306 5367 030310 5369 030311 5370 030327 5373 030332 5374 030340 5376 030341 5378 030343 5379 030352 5380 030353 5383 030354 5384 030361 5386 030362 5389 030374 5390 030402 5393 030403 5396 030404 5397 030405 5401 030407 5402 030411 5403 030412 5404 030414 5405 030427 5407 030430 5409 030431 5411 030432 5413 030433 5414 030437 5416 030446 5417 030450 5418 030451 5420 030454 5421 030455 5423 030457 5424 030460 5428 030463 5430 030477 5431 030500 5435 030501 5436 030516 5438 030517 5440 030520 5442 030536 5444 030543 5447 030544 5452 030545 5453 030546 5464 030550 5465 030552 5466 030553 5467 030555 5468 030570 5470 030571 5473 030601 5474 030603 5476 030604 5478 030605 5479 030611 5481 030620 5482 030622 5483 030623 5485 030626 5486 030627 5488 030631 5489 030632 5494 030635 5495 030651 5497 030652 5501 030653 5502 030655 5505 030657 5506 030674 5508 030675 5510 030701 5511 030713 5512 030715 5514 030720 5515 030721 5518 030722 5519 030730 5521 030733 5522 030734 5523 030735 5528 030740 5529 030752 5531 030753 5537 030757 5538 030770 5548 030771 5550 030773 5551 031006 5553 031012 5554 031013 5556 031023 5558 031034 5559 031036 5560 031037 5561 031040 5563 031064 5564 031066 5566 031067 5567 031071 5570 031074 5574 031102 5575 031103 5576 031106 5578 031117 5579 031120 5581 031124 5582 031142 5584 031143 5585 031146 5587 031152 5589 031155 5590 031156 5592 031162 5593 031163 5595 031165 5596 031167 5597 031170 5603 031174 5605 031211 5606 031223 5610 031224 5611 031241 5613 031242 5616 031243 5618 031262 5620 031265 5623 031267 5625 031274 5627 031300 5630 031303 5632 031307 5634 031315 5635 031317 5637 031323 5639 031351 5642 031352 5644 031353 5645 031354 5648 031356 5649 031360 5651 031361 5653 031376 5654 031377 5656 031400 5658 031416 5662 031440 5665 031441 5667 031442 5668 031443 5671 031445 5672 031447 5674 031450 5675 031452 5676 031465 5678 031466 5680 031476 5681 031477 5683 031500 5685 031501 5687 031510 5688 031511 5689 031513 5690 031514 5692 031516 5693 031517 5694 031520 5695 031521 5697 031522 5698 031526 5700 031535 5701 031545 5702 031552 5704 031555 5705 031565 5707 031567 5710 031602 5711 031604 5713 031606 5715 031617 5717 031632 5718 031635 5722 031636 5733 031663 5735 031664 5736 031665 5739 031667 5740 031671 5741 031672 5743 031676 5744 031677 5745 031701 5746 031702 5748 031703 5749 031705 5750 031713 5752 031716 5753 031726 5756 031727 5758 031730 5759 031731 5762 031733 5763 031735 5764 031736 5766 031742 5767 031747 5768 031750 5769 031751 5770 031752 5771 031755 5772 031773 5775 031774 5777 031775 5778 031777 5779 032000 5785 032002 5787 032006 5788 032010 5790 032011 5792 032015 5793 032022 5794 032023 5795 032025 5796 032026 5797 032030 5798 032036 5801 032037 5803 032040 5804 032042 5805 032043 5808 032045 5810 032051 5811 032053 5813 032054 5815 032060 5816 032061 5817 032063 5818 032064 5819 032066 5820 032076 5823 032077 5826 032100 5829 032102 5830 032103 5831 032114 5832 032116 5835 032117 5838 032120 5841 032122 5842 032123 5843 032134 5844 032136 5847 032137 5850 032140 5853 032142 5855 032147 5856 032150 5858 032156 5859 032160 5862 032161 5867 032162 5873 032176 5874 032204 5876 032212 5877 032214 5880 032215 5883 032216 5886 032220 5889 032221 5892 032222 5895 032223 5898 032261 5899 032264 5900 032266 5903 032267 5909 032271 5910 032274 5912 032301 5913 032303 5915 032304 5917 032306 5918 032307 5919 032311 5920 032313 5922 032315 5925 032317 5931 032321 5934 032322 5938 032324 5940 032337 5941 032341 5942 032345 5945 032346 5948 032347 5949 032351 5951 032354 5954 032355 5958 032357 5961 032360 5963 032373 5964 032375 5965 032401 5966 032402 5970 032404 5973 032405 5974 032410 5976 032411 5981 032413 5983 032414 5988 032415 5990 032416 5995 032417 5997 032420 6002 032422 6004 032423 6009 032424 6013 032425 6016 032426 6018 032430 6019 032435 6022 032436 6024 032443 6027 032451 6028 032453 6031 032456 6034 032466 6036 032477 6037 032504 6038 032512 6040 032513 6042 032521 6044 032522 6046 032530 6050 032531 6053 032532 6056 032536 6059 032546 6061 032570 6064 032640 6067 032644 6069 032646 6071 032652 6074 032657 6075 032660 6077 032664 6079 032667 6083 032675 6087 032676 6094 032715 6095 032716 6096 032717 6097 032721 6098 032722 6099 032723 6100 032724 6102 032725 6104 032730 6106 032733 6107 032735 6108 032740 6109 032743 6111 032744 6114 032772 6115 032774 6116 032777 6118 033002 6122 033003 6124 033004 6126 033014 6127 033020 6129 033021 6131 033022 6133 033025 6134 033026 6135 033032 6136 033036 6138 033037 6139 033043 6141 033047 6143 033050 6145 033051 6147 033054 6148 033055 6149 033061 6150 033065 6151 033071 6153 033072 6154 033076 6155 033102 6157 033106 6159 033107 6161 033110 6163 033113 6164 033114 6165 033120 6166 033124 6167 033130 6168 033134 6170 033135 6171 033141 6172 033145 6173 033151 6175 033152 6182 033153 6184 033154 6186 033161 6188 033163 6189 033165 6193 033167 6194 033173 6196 033175 6198 033176 6199 033200 6200 033201 6201 033202 6202 033203 6207 033204 6210 033205 6212 033213 6213 033215 6216 033221 6218 033225 6220 033252 6221 033265 6223 033266 6228 033267 6230 033270 6232 033274 6233 033301 6238 033302 6240 033304 6241 033311 6243 033312 6250 033313 6253 033314 6256 033330 6257 033331 6259 033334 6261 033345 6263 033347 6270 033350 6273 033351 6276 033360 6277 033361 6279 033365 6280 033373 6282 033375 6289 033376 6304 033400 6305 033401 6309 033430 6310 033445 6312 033451 6313 033464 6314 033466 6316 033516 6318 033522 6319 033533 6321 033535 6328 033536 6343 033540 6344 033541 6347 033562 6348 033577 6350 033604 6351 033607 6353 033627 6355 033646 6357 033652 6358 033666 6360 033670 6365 033671 6429 033672 6430 033675 6431 033700 6432 033703 6433 033706 6435 033707 6439 033711 6444 033720 6446 033732 6447 033737 6448 033744 6451 033745 6455 033750 6458 033762 6461 033763 6462 033771 6464 033774 6466 034001 6467 034035 6468 034041 6470 034042 6472 034046 6473 034053 6477 034054 6480 034063 6481 034075 6482 034077 6484 034100 6486 034106 6487 034131 6491 034135 6492 034145 6494 034152 6496 034153 6498 034161 6500 034166 6502 034176 6503 034203 6505 034211 6507 034212 6509 034214 6512 034216 6514 034220 6516 034224 6517 034231 6520 034232 6526 034233 6528 034236 6530 034240 6531 034246 6532 034251 6536 034254 6539 034255 6541 034270 6543 034271 6545 034275 6547 034327 6548 034330 6551 034331 6553 034340 6555 034343 6558 034356 6560 034357 6563 034361 6564 034362 6569 034364 6574 034365 6577 034404 6578 034406 6580 034407 6582 034436 6583 034453 6585 034460 6589 034505 6590 034550 6592 034555 6597 034630 6600 034675 6604 034702 6605 034711 6607 034727 6608 034731 6610 034732 6612 034734 6615 034735 6618 034744 6619 034746 6620 034747 6621 034750 6625 034751 6627 034754 6628 034756 6629 034757 6630 034765 6631 034766 6632 034767 6634 034772 6636 034774 6637 034776 6638 034777 6640 035001 6642 035003 6645 035037 6646 035040 6647 035041 6648 035042 6651 035043 6654 035073 6657 035074 6658 035102 6659 035105 6660 035111 6664 035150 6666 035152 6667 035163 6668 035166 6670 035170 6671 035201 6672 035205 6673 035213 6674 035215 6676 035217 6677 035227 6679 035262 6684 035321 6689 035351 6691 035353 6692 035354 6695 035356 6698 035357 6701 035360 6702 035362 6703 035364 6705 035365 6708 035366 6710 035401 6711 035402 6713 035405 6715 035420 6717 035422 6718 035423 6719 035424 6721 035426 6723 035433 6725 035450 6726 035451 6727 035452 6729 035463 6730 035465 6732 035466 6733 035467 6735 035471 6737 035473 6738 035474 6739 035475 6741 035506 6742 035507 6746 035524 6748 035527 6749 035531 6750 035533 6753 035560 6757 035617 6758 035620 6760 035621 6762 035632 6763 035634 6766 035661 6767 035662 6769 035663 6771 035665 6772 035666 6778 035714 6779 035723 6780 035724 6785 035726 6786 035727 6789 035732 6790 035734 6791 035736 6793 035737 6796 035743 6797 035745 6798 035747 6799 035750 6800 035752 6801 035756 6802 035760 6803 035761 6805 035763 6812 035764 6815 035765 6817 035766 6818 035772 6820 035774 6822 035777 6823 036002 6824 036004 6826 036006 6828 036010 6831 036011 6833 036015 6835 036016 6836 036020 6837 036022 6839 036023 6841 036025 6845 036026 6847 036031 6848 036041 6850 036047 6852 036053 6853 036060 6855 036061 6856 036062 6857 036064 6858 036066 6861 036067 6862 036077 6863 036100 6866 036102 6869 036103 6872 036104 6873 036105 6874 036106 6876 036107 6880 036110 6883 036111 6888 036112 6890 036117 6891 036121 6893 036124 6894 036126 6896 036127 6897 036131 6900 036132 6903 036137 6904 036140 6905 036141 6907 036142 6910 036166 6912 036171 6913 036172 6914 036174 6917 036175 6918 036176 6919 036177 6922 036202 6924 036204 6928 036205 6930 036206 6933 036214 6934 036215 6937 036216 6939 036223 6942 036227 6944 036235 6945 036240 6947 036241 6948 036242 6950 036245 6952 036246 6954 036261 6956 036265 6958 036267 6961 036273 6962 036275 6964 036276 6966 036277 6968 036300 6970 036306 6973 036321 6974 036335 6976 036341 6977 036342 6980 036344 6982 036345 6985 036350 6989 036351 6992 036352 6994 036354 6997 036366 6998 036404 7001 036406 7004 036415 7005 036416 7006 036420 7010 036445 7012 036446 7013 036447 7015 036451 7016 036453 7019 036456 7023 036457 7035 036460 7037 036462 7040 036467 7041 036500 7042 036505 7043 036507 7045 036510 7047 036512 7050 036517 7052 036521 7053 036527 7054 036531 7056 036533 7059 036540 7060 036542 7061 036550 7062 036552 7064 036553 7066 036555 7069 036563 7070 036570 7072 036572 7074 036573 7076 036577 7077 036601 7078 036604 7079 036605 7081 036606 7083 036612 7084 036613 7085 036616 7087 036617 7091 036624 7093 036634 7094 036641 7095 036643 7097 036644 7101 036651 7102 036660 7104 036661 7107 036662 7112 036663 7131 036665 7133 036673 7134 036675 7136 036702 7137 036704 7138 036706 7140 036707 7141 036711 7142 036712 7144 036714 7146 036742 7147 036755 7149 036760 7150 036762 7151 036766 7152 036767 7153 037020 7154 037024 7155 037027 7158 037035 7159 037042 7160 037053 7162 037100 7164 037126 7165 037145 7172 037146 7186 037147 7188 037151 7190 037162 7191 037174 7192 037200 7194 037204 7195 037214 7196 037216 7198 037217 7201 037221 7203 037223 7205 037230 7206 037236 7207 037240 7209 037242 7211 037244 7213 037251 7214 037257 7215 037261 7217 037262 7219 037264 7222 037270 7223 037275 7225 037276 7227 037277 7230 037303 7231 037310 7232 037311 7233 037314 7234 037315 7236 037316 7239 037322 7240 037327 7241 037330 7242 037333 7244 037334 7248 037340 7250 037350 7251 037355 7252 037356 7254 037357 7257 037361 7259 037365 7260 037372 7261 037373 7262 037407 7263 037411 7264 037413 7265 037416 7266 037422 7267 037435 7269 037436 7270 037440 7272 037441 7274 037446 7275 037456 7276 037463 7277 037465 7278 037467 7279 037470 7281 037471 7284 037476 7285 037505 7288 037506 7396 037507 7295 037510 7317 037512 7318 037513 7320 037523 7321 037525 7323 037532 7324 037534 7325 037535 7326 037536 7328 037543 7330 037545 7332 037573 7333 037606 7335 037611 7336 037613 7337 037615 7338 037621 7340 037622 7341 037642 7342 037670 7344 037674 7345 037702 7346 037703 7348 037704 7350 037722 7352 037737 7353 037741 7355 037747 7356 037751 7357 037767 7359 037777 7361 040012 7364 040040 7365 040057 7366 040064 7368 040065 7370 040071 7371 040106 7372 040137 7374 040152 7376 040160 7377 040161 7379 040165 7380 040171 7382 040202 7384 040231 7385 040240 7387 040241 7388 040250 7390 040275 7392 040320 7393 040324 7395 040326 7403 040327 7406 040330 7407 040331 7408 040332 7412 040337 7417 040340 7420 040341 7421 040342 7423 040344 7424 040347 7425 040350 7427 040351 7429 040367 7431 040371 7433 040372 7435 040375 7437 040402 7442 040403 7447 040404 7448 040406 7450 040407 7453 040413 7454 040430 7456 040431 7457 040433 7459 040434 7461 040435 7463 040442 7465 040445 7466 040447 7467 040450 7470 040451 7473 040465 7474 040466 7477 040474 7480 040477 7486 040500 7492 040501 7493 040507 7496 040512 7499 040541 7500 040545 7502 040547 7503 040555 7506 040611 7508 040613 7510 040615 7513 040646 7514 040647 7517 040651 7518 040655 7520 040661 7521 040663 7528 040725 7530 040734 7532 040743 7537 040745 7539 040765 7542 040767 7544 040775 7545 040777 7549 041035 7551 041036 7552 041040 7554 041051 7560 041052 7563 041053 7566 041056 7568 041060 7570 041061 7572 041062 7575 041065 7577 041067 7579 041070 7581 041074 7583 041075 7585 041076 7587 041077 7590 041104 7592 041105 7598 041106 7600 041107 7602 041115 7603 041117 7605 041123 7610 041125 7612 041126 7616 041134 7618 041135 7621 041157 7623 041160 7625 041161 7627 041203 7629 041204 7635 041230 7641 041254 7647 041263 7649 041264 7652 041267 7655 041311 7657 041312 7660 041315 7663 041337 7665 041340 7667 041343 7668 041345 7670 041346 7672 041347 7674 041371 7676 041372 7678 041373 7680 041422 7682 041423 7689 041447 7696 041473 7698 041474 7704 041475 7706 041476 7707 041500 7708 041501 7709 041503 7711 041507 7713 041521 7714 041522 7715 041523 7719 041527 7720 041544 7722 041545 7724 041546 7725 041550 7727 041551 7728 041553 7730 041554 7731 041555 7734 041557 7735 041573 7737 041574 7739 041600 7741 041603 7742 041612 7743 041614 7745 041617 7748 041621 7749 041622 7751 041625 7752 041633 7754 041636 7755 041640 7756 041641 7760 041647 7761 041664 7763 041665 7765 041671 7767 041673 7768 041705 7770 041710 7771 041711 7773 041712 7775 041720 7777 041735 7778 041737 7780 041741 7782 041744 7784 041746 7787 041754 7790 041757 7792 041770 7793 041771 7794 041773 7796 042006 7797 042007 7800 042013 7801 042031 7803 042033 7804 042037 7807 042044 7809 042046 7811 042057 7812 042060 7814 042065 7815 042066 7819 042072 7821 042075 7824 042077 7826 042102 7827 042110 7828 042113 7829 042115 7831 042123 7832 042127 7835 042130 7837 042132 7838 042147 7840 042153 7843 042155 7844 042171 7847 042173 7850 042175 7851 042205 7854 042212 7856 042216 7858 042224 7859 042226 7861 042232 7864 042260 7869 042261 7872 042262 7874 042263 7876 042264 7878 042270 7881 042273 7883 042274 7885 042300 7888 042303 7890 042312 7892 042313 7894 042317 7895 042321 7899 042322 7905 042324 7907 042325 7909 042330 7911 042336 7912 042340 7914 042364 7916 042365 7919 042373 7922 042417 7923 042420 7925 042432 7931 042433 7938 042434 7939 042436 7942 042454 7943 042462 7944 042463 7946 042473 7948 042501 7950 042502 7951 042517 7953 042523 7955 042524 7961 042525 7963 042526 7964 042527 7967 042530 7972 042544 7974 042545 7975 042552 7976 042553 7978 042554 7979 042556 7980 042557 7982 042563 7984 042571 7986 042575 7987 042576 7992 042577 7996 042601 7997 042603 7999 042606 8000 042633 8002 042636 8005 042655 8006 042657 8007 042662 8009 042664 8013 042665 8028 042667 8029 042673 8031 042674 8035 042677 8037 042700 8040 042703 8042 042704 8046 042715 8047 042721 8049 042725 8057 042726 8060 042733 8063 042745 8065 042752 8068 042761 8071 042763 8073 042764 8075 042766 8077 042767 8097 042771 8101 043000 8102 043005 8103 043021 8104 043022 8106 043023 8109 043026 8125 043027 8126 043032 8127 043044 8130 043054 8131 043060 8133 043073 8135 043103 8136 043114 ----------------------------------------------------------- Historical Background This edition of the Multics software materials and documentation is provided and donated to Massachusetts Institute of Technology by Group BULL including BULL HN Information Systems Inc. as a contribution to computer science knowledge. This donation is made also to give evidence of the common contributions of Massachusetts Institute of Technology, Bell Laboratories, General Electric, Honeywell Information Systems Inc., Honeywell BULL Inc., Groupe BULL and BULL HN Information Systems Inc. to the development of this operating system. Multics development was initiated by Massachusetts Institute of Technology Project MAC (1963-1970), renamed the MIT Laboratory for Computer Science and Artificial Intelligence in the mid 1970s, under the leadership of Professor Fernando Jose Corbato. Users consider that Multics provided the best software architecture for managing computer hardware properly and for executing programs. Many subsequent operating systems incorporated Multics principles. Multics was distributed in 1975 to 2000 by Group Bull in Europe , and in the U.S. by Bull HN Information Systems Inc., as successor in interest by change in name only to Honeywell Bull Inc. and Honeywell Information Systems Inc. . ----------------------------------------------------------- Permission to use, copy, modify, and distribute these programs and their documentation for any purpose and without fee is hereby granted,provided that the below copyright notice and historical background appear in all copies and that both the copyright notice and historical background and this permission notice appear in supporting documentation, and that the names of MIT, HIS, BULL or BULL HN not be used in advertising or publicity pertaining to distribution of the programs without specific prior written permission. Copyright 1972 by Massachusetts Institute of Technology and Honeywell Information Systems Inc. Copyright 2006 by BULL HN Information Systems Inc. Copyright 2006 by Bull SAS All Rights Reserved