From b089208cd52717a4cb83fd4c2146d166763890df Mon Sep 17 00:00:00 2001 From: dylan-jayatilaka Date: Thu, 21 Mar 2024 05:04:21 +0800 Subject: [PATCH] Removed all PTRs from TEXTFILE; compiler bug (?) for embedded keywords; hard-coded Thankkar basis-layout; all tests except fragHAR & breakdown pass (4) failures; try slurp-mode for text files now? --- CMakeLists.txt | 6 +- basis_sets/Thakkar | 8 +- foofiles/archive.foo | 136 +- foofiles/atom.foo | 4 +- foofiles/basis.foo | 69 +- foofiles/buffer.foo | 16 +- foofiles/cif.foo | 53 +- foofiles/cluster.foo | 6 +- foofiles/command_line.foo | 4 +- foofiles/cpx.foo | 550 +++---- foofiles/crystal.foo | 28 +- foofiles/debug.foo | 252 ---- foofiles/diffraction_data.put.foo | 12 +- foofiles/diis.foo | 4 +- foofiles/isosurface.foo | 14 +- foofiles/json.foo | 342 ++--- foofiles/l_bfgs.foo | 4 +- foofiles/marchingcube.foo | 136 +- foofiles/mat{real}.foo | 4 +- foofiles/molecule.base.foo | 6 +- foofiles/molecule.ce.foo | 51 +- foofiles/molecule.fock.foo | 16 +- foofiles/molecule.har.foo | 2 +- foofiles/molecule.inq.foo | 2 - foofiles/molecule.ints.foo | 8 +- foofiles/molecule.main.foo | 6 +- foofiles/molecule.misc.foo | 74 +- foofiles/molecule.prop.foo | 4 +- foofiles/molecule.put.foo | 42 +- foofiles/molecule.read.foo | 41 +- foofiles/molecule.scf.foo | 4 +- foofiles/molecule.set.foo | 5 - foofiles/output_style.foo | 268 ++++ foofiles/plot_grid.foo | 16 +- foofiles/pointgroup.foo | 112 +- foofiles/reflection.foo | 2 +- foofiles/roby.foo | 74 +- foofiles/scfdata.foo | 22 +- foofiles/slaterbasis.foo | 14 +- foofiles/system.foo | 36 +- foofiles/table_column.foo | 15 +- foofiles/term_1d.foo | 4 +- foofiles/textfile.foo | 1328 +++++++---------- foofiles/types.foo | 164 +- foofiles/unit_cell.foo | 8 +- foofiles/vec{atom}.foo | 44 +- foofiles/vec{basis}.foo | 2 +- foofiles/vec{object}.foo | 42 +- foofiles/vec{reflection}.foo | 10 +- runfiles/run_har.foo | 11 +- runfiles/run_molecule.foo | 6 +- runfiles/run_mp2.foo | 12 +- runfiles/run_rgbi.foo | 6 +- runfiles/run_textfile.foo | 6 +- .../stdout | 12 +- .../stdout | 24 +- .../stdout | 12 +- .../stdout | 24 +- 58 files changed, 1882 insertions(+), 2301 deletions(-) delete mode 100644 foofiles/debug.foo create mode 100644 foofiles/output_style.foo diff --git a/CMakeLists.txt b/CMakeLists.txt index 3dbd5bcbf..1a6d62d56 100644 --- a/CMakeLists.txt +++ b/CMakeLists.txt @@ -196,6 +196,7 @@ set(FOO_SRC ${FOO_DIR}/becke_grid.foo # ${FOO_DIR}/breakdown_data.foo ${FOO_DIR}/buffer.foo + ${FOO_DIR}/output_style.foo ${FOO_DIR}/textfile.foo ${FOO_DIR}/datafile.foo ${FOO_DIR}/json.foo @@ -207,7 +208,6 @@ set(FOO_SRC ${FOO_DIR}/colour_function.foo ${FOO_DIR}/coppensbasis.foo ${FOO_DIR}/coppensorbital.foo - ${FOO_DIR}/debug.foo ${FOO_DIR}/dft_functional.foo ${FOO_DIR}/diffraction_data.inq.foo ${FOO_DIR}/diffraction_data.set.foo @@ -377,6 +377,7 @@ set(FORTRAN_SRC ${CMAKE_CURRENT_BINARY_DIR}/molecule.har.F90 ${CMAKE_CURRENT_BINARY_DIR}/molecule.misc.F90 ${CMAKE_CURRENT_BINARY_DIR}/molecule.main.F90 + ${CMAKE_CURRENT_BINARY_DIR}/output_style.F90 ${CMAKE_CURRENT_BINARY_DIR}/opmatrix.F90 ${CMAKE_CURRENT_BINARY_DIR}/opvector.F90 ${CMAKE_CURRENT_BINARY_DIR}/plot_grid.F90 @@ -465,6 +466,7 @@ set(RUN_SRC ${RUNFILE_DIR}/run_rgbi.foo ${RUNFILE_DIR}/run_least_squares.foo ${RUNFILE_DIR}/run_mpi_test.foo + ${RUNFILE_DIR}/run_textfile.foo ${RUNFILE_DIR}/run_vec{str}.foo ) @@ -534,6 +536,7 @@ add_executable(run_real EXCLUDE_FROM_ALL ${CMAKE_CURRENT_BINARY_DIR}/ru add_executable(run_rgbi ${CMAKE_CURRENT_BINARY_DIR}/run_rgbi.F90) add_executable(run_vec_str EXCLUDE_FROM_ALL ${CMAKE_CURRENT_BINARY_DIR}/run_vec_str.F90) add_executable(run_least_squares EXCLUDE_FROM_ALL ${CMAKE_CURRENT_BINARY_DIR}/run_least_squares.F90) +add_executable(run_textfile EXCLUDE_FROM_ALL ${CMAKE_CURRENT_BINARY_DIR}/run_textfile.F90) add_executable(run_mpi_test ${CMAKE_CURRENT_BINARY_DIR}/run_mpi_test.F90) # Link exectables @@ -559,6 +562,7 @@ target_link_libraries(run_rgbi tonto ${LAPACK_LIBRARIES} ${MPI_LIBRARIE target_link_libraries(run_vec_str tonto ${LAPACK_LIBRARIES} ${MPI_LIBRARIES}) target_link_libraries(run_least_squares tonto ${LAPACK_LIBRARIES} ${MPI_LIBRARIES}) target_link_libraries(run_mpi_test tonto ${LAPACK_LIBRARIES} ${MPI_LIBRARIES}) +target_link_libraries(run_textfile tonto ${LAPACK_LIBRARIES} ${MPI_LIBRARIES}) target_link_libraries(run_shell2 tonto ${LAPACK_LIBRARIES} ${MPI_LIBRARIES}) diff --git a/basis_sets/Thakkar b/basis_sets/Thakkar index 647687c35..ffbd0553a 100644 --- a/basis_sets/Thakkar +++ b/basis_sets/Thakkar @@ -7,11 +7,11 @@ ! T. Koga, K. Kanayama, T. Watanabe, T. Imai and A.J. Thakkar, ! Theor. Chem. Acc. 104, 411-413 (2000) - keys= { { shells= { keys= { l_chr= orb_kinds= n,z,c*= } } } } + ! keys= { { shells= { keys= { l_chr= orb_kinds= n,z,c*= } } } } + ! process_keys_once + ! keys= { label= configuration= shells= { analyze_configuration } } - process_keys_once - - keys= { label= configuration= shells= { analyze_configuration } } + keys= { tonto_style= } data= { diff --git a/foofiles/archive.foo b/foofiles/archive.foo index 2f8965e41..9b7302471 100644 --- a/foofiles/archive.foo +++ b/foofiles/archive.foo @@ -42,61 +42,27 @@ contains ! Allocation methods ! ================== - create ::: get_from(OBJECT), leaky - ! Create an object + create ::: get_from(OBJECT), leaky, PURE + ! Allocate an object end - destroy ::: get_from(OBJECT), leaky - ! Destroy an object - end - - nullify_ptr_part ::: PURE - ! Nullify the pointer parts - self :: INOUT - - nullify(.Afile) - - end - - destroy_ptr_part ::: leaky - ! Destroy the pointer parts - self :: INOUT - - .Afile.destroy - + destroy ::: get_from(OBJECT), leaky, PURE + ! Deallocate "self" end create(root_name,name,genre,format) - ! Reset an archive to have main name "root_name", sub name "name" - ! "genre" (if present) is used to identify components of OPMATRIX and - ! OPVECTOR objects. - ! "format" (if present) is used to identify file format (e.g. ascii). The - ! default is binary. - ! Otherwise use defaults. - self :: PTR + ! Reset an archive to have main name "root_name", sub name "name". + ! "genre" (if present) is used to identify OPVECTOR components. + ! "format" (if present) is used to identify file format (e.g. ascii). + ! The default is binary. + self :: allocatable, OUT root_name :: STR, IN - name,genre,format :: STR, optional, IN + name :: STR, optional, IN + genre :: STR, optional, IN + format :: STR, optional, IN + .create .set(root_name,name,genre,format) - end - -! ==== -! Copy -! ==== - - create_copy(object) ::: get_from(OBJECT), leaky - ! Create a copy of object - end - - copy(archive) ::: leaky - ! Make a copy - archive :: ARCHIVE - - self = archive - - .nullify_ptr_part - - if (archive.Afile.associated) .Afile.create_copy(archive.Afile) end @@ -104,18 +70,6 @@ contains ! Set methods ! =========== - set_defaults ::: PURE - ! Set up a default archive object - self :: INOUT - - .root_name = "unknown" - .name = " " - .genre = " " ! generic genre - .format = " " ! assume binary format - .use_all_commas = FALSE - - end - set(root_name,name,genre,format) ::: PURE ! Reset an archive to have main name "root_name", sub name "name" ! "genre" (if present) is used to identify components of OPMATRIX and @@ -129,8 +83,6 @@ contains genre :: STR, optional, IN format :: STR, optional, IN - .set_defaults - if (present(root_name)) .root_name = root_name if (present(name)) .name = name if (present(genre)) .genre = genre @@ -245,7 +197,7 @@ contains res :: BIN file_name :: STR - Afile :: TEXTFILE* + Afile :: TEXTFILE@ Bfile :: FILE@ file_name = .file_name(genre) @@ -292,7 +244,7 @@ contains .Afile.create(trim(file_name)) .Afile.open_for(action) .Afile.set_using_array_labels(FALSE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") else @@ -307,7 +259,7 @@ contains ! Close *and* destroy the archive file part. self :: INOUT - if (.Afile.associated) then + if (.Afile.allocated) then .Afile.close .Afile.destroy end @@ -669,7 +621,7 @@ contains .Afile.create(trim(file_name)) .Afile.open_for("write") .Afile.set_using_array_labels(FALSE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.put(item) .Afile.close .Afile.destroy @@ -737,7 +689,7 @@ contains .Afile.create(trim(file_name)) .Afile.open_for("write") .Afile.set_using_array_labels(FALSE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.put(item,by_row,by_column) .Afile.close .Afile.destroy @@ -794,7 +746,7 @@ contains .Afile.create(trim(file_name)) .Afile.set_using_array_labels(FALSE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.open_for("write") .Afile.set_using_array_labels(FALSE) .Afile.put(item1) @@ -938,7 +890,7 @@ contains .Afile.create(trim(file_name)) .Afile.open_for("write") - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.parallel_put(item) .Afile.close .Afile.destroy @@ -1034,7 +986,7 @@ contains n :: INT .open_for("writing",ascii=TRUE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(14) .Afile.set_real_precision(6) @@ -1058,7 +1010,7 @@ contains n :: INT .open_for("writing",ascii=TRUE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(14) .Afile.set_real_precision(6) @@ -1082,7 +1034,7 @@ contains n,x,y,z :: INT .open_for("writing",ascii=TRUE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(14) .Afile.set_real_precision(6) @@ -1187,7 +1139,7 @@ contains .open_for("writing",ascii=TRUE) ! Write gnuplot command file - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(16) .Afile.set_real_precision(8) @@ -1679,7 +1631,7 @@ contains ! Open the ASCII file .open_for("writing",ascii=TRUE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(14) .Afile.set_real_precision(6) @@ -1766,7 +1718,7 @@ contains ! Open the ASCII file .open_for("writing",ascii=TRUE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(14) .Afile.set_real_precision(6) @@ -1820,7 +1772,7 @@ contains d :: REAL .open_for("writing",ascii=TRUE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(14) .Afile.set_real_precision(6) .Afile.text("{") @@ -1881,7 +1833,7 @@ contains ! Open the file and set the output style .open_for("writing",ascii=TRUE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(14) .Afile.set_real_precision(6) @@ -2016,7 +1968,7 @@ contains v :: VEC{REAL}(3) .open_for("writing",ascii=TRUE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(14) .Afile.set_real_precision(6) @@ -2068,7 +2020,7 @@ contains vec :: VEC{REAL}(3) .open_for("writing",ascii=TRUE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(20) .Afile.set_real_precision(12) .Afile.text("Tonto output for the contour program used in Nancy ...") @@ -2123,7 +2075,7 @@ contains units :: STR .open_for("writing",ascii=TRUE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(13) .Afile.set_real_precision(5) @@ -2227,7 +2179,7 @@ contains .Afile.put(grid.n_z,width=15) .Afile.flush - .Afile.set_real_style("f") + .Afile.set_real_fortran_fmt("f") .Afile.set_real_width(11) .Afile.set_real_precision(4) vec = grid.width @@ -2245,7 +2197,7 @@ contains .Afile.flush .Afile.put(atom.dim,width=10) .Afile.flush - .Afile.set_real_style("f") + .Afile.set_real_fortran_fmt("f") .Afile.set_real_width(10) .Afile.set_real_precision(5) axes(1,:) = grid.x_axis @@ -2294,10 +2246,10 @@ contains .Afile.flush .Afile.set_using_array_labels(FALSE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(13) .Afile.set_real_precision(5) - .Afile.set_no_of_fields_per_line(6) + .Afile.set_n_fields_per_line(6) f = 1 l = grid.n_x do n = 1,grid.n_y*grid.n_z @@ -2329,7 +2281,7 @@ contains .Afile.put(grid.n_y,width=15) .Afile.put(grid.n_z,width=15) .Afile.flush - .Afile.set_real_style("f") + .Afile.set_real_fortran_fmt("f") .Afile.set_real_width(11) .Afile.set_real_precision(4) .Afile.put(HALF) @@ -2349,7 +2301,7 @@ contains .Afile.flush .Afile.put(0,width=10) .Afile.flush - .Afile.set_real_style("f") + .Afile.set_real_fortran_fmt("f") .Afile.set_real_width(10) .Afile.set_real_precision(5) @@ -2361,10 +2313,10 @@ contains .Afile.put("! Values",width=8) .Afile.flush .Afile.set_using_array_labels(FALSE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(13) .Afile.set_real_precision(5) - .Afile.set_no_of_fields_per_line(6) + .Afile.set_n_fields_per_line(6) f = 1 l = grid.n_x do n = 1,grid.n_y*grid.n_z @@ -2401,7 +2353,7 @@ contains reverse :: MAT3{REAL}@ .open_for("writing",ascii=TRUE) - .Afile.set_real_style("f") + .Afile.set_real_fortran_fmt("f") .Afile.set_real_width(12) .Afile.set_real_precision(6) @@ -2490,7 +2442,7 @@ contains end - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(13) .Afile.set_real_precision(5) @@ -2539,7 +2491,7 @@ contains reverse :: MAT3{REAL}@ .open_for("writing",ascii=TRUE) - .Afile.set_real_style("f") + .Afile.set_real_fortran_fmt("f") .Afile.set_real_width(12) .Afile.set_real_precision(6) @@ -2594,7 +2546,7 @@ contains end - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(13) .Afile.set_real_precision(5) @@ -2634,7 +2586,7 @@ contains if (grid.n_z<=1) return .open_for("writing",ascii=TRUE) - .Afile.set_real_style("e") + .Afile.set_real_fortran_fmt("e") .Afile.set_real_width(13) .Afile.set_real_precision(5) diff --git a/foofiles/atom.foo b/foofiles/atom.foo index 6ff5113a0..1c68b5f0c 100644 --- a/foofiles/atom.foo +++ b/foofiles/atom.foo @@ -3150,8 +3150,8 @@ contains end process_keyword(keyword) ::: leaky - ! Process command "keyword". Any required data needed by the "keyword" is - ! inputted from "stdin". + ! Process command "keyword". Any required data needed by the + ! "keyword" is inputted from "stdin". self :: INOUT keyword :: STR, IN diff --git a/foofiles/basis.foo b/foofiles/basis.foo index 2b25b1f85..59b10bb8e 100644 --- a/foofiles/basis.foo +++ b/foofiles/basis.foo @@ -116,7 +116,7 @@ contains case ("put_n_shells "); stdout.put(.n_shell) case ("put_n_bf "); stdout.put(.n_bf) case ("put_n_prim "); stdout.put(.n_prim) - case ("tonto-style= "); .read_tonto_style + case ("tonto_style= "); .read_tonto_style case ("turbomole= "); .read_turbomole case ("flush "); stdout.flush case default ; UNKNOWN(word) @@ -124,12 +124,26 @@ contains end - read_junk ::: get_from(OBJECT), private - ! Read in a junk string, useful for ignoring a field + read_gamess_us ::: leaky + ! Create and read a GAMESS-US style basis set + self :: INOUT + + the_keys :: VEC{STR}@ + + .read_label + + the_keys = ("l_chr= n_cc= junk,ex,cc=").split + .shell.set_keys(the_keys) + the_keys.destroy + + .shell.read_data + + .update + end - read_units ::: get_from(OBJECT), private - ! Read a string which describes the units to be used + read_junk ::: get_from(OBJECT), private + ! Read in a junk string, useful for ignoring a field end read_label @@ -144,68 +158,37 @@ contains .update end - read_tonto_style ::: leaky - ! Create and read a tonto style basis set - .read_label - .shell.set_keys(["l_chr=","n_cc= ","ex,cc="]) - .shell.read_data - .update + read_units ::: get_from(OBJECT), private + ! Read a string which describes the units to be used end - read_gamess_us ::: leaky - ! Create and read a GAMESS-US style basis set + read_tonto_style ::: leaky + ! Create and read a tonto style basis set self :: INOUT - - the_keys :: VEC{STR}@ - .read_label - - the_keys = ("l_chr= n_cc= junk,ex,cc=").split - .shell.set_keys(the_keys) - the_keys.destroy - + .shell.set_keys(["l_chr=","n_cc= ","ex,cc="]) .shell.read_data - .update - end read_turbomole ::: leaky ! Create and read a turbomole style basis set self :: INOUT - - the_keys :: VEC{STR}@ - .read_label - - the_keys = ("n_cc= l_chr= ex,cc=").split - .shell.set_keys(the_keys) - the_keys.destroy - + .shell.set_keys(["n_cc= ", "l_chr=", "ex,cc="]) .shell.read_data - .update - end read_molden ::: leaky ! Create and read a Molden style basis set self :: INOUT - - the_keys :: VEC{STR}@ - .read_junk .read_junk - - the_keys = ("l_chr= n_cc= junk= ex,cc=").split - .shell.set_keys(the_keys) - the_keys.destroy - + .shell.set_keys(["l_chr=", "n_cc= ", "junk= ", "ex,cc="]) ! Note BL termination .shell.read_data_BL_terminated - .update - end ! ==================== diff --git a/foofiles/buffer.foo b/foofiles/buffer.foo index 59cf62f64..444a48744 100644 --- a/foofiles/buffer.foo +++ b/foofiles/buffer.foo @@ -174,18 +174,19 @@ contains end - set_replacement_list(replacement_list) ::: leaky, PURE + set_replacement_list(replacement_list) ::: leaky, pure ! Define a "replacement_list" which replaces certain strings before ! the buffer is analyzed. self :: INOUT - replacement_list :: MAT{STR}@, IN - - ENSURE(replacement_list.allocated,"replacement_list destroyed") - + replacement_list :: MAT{STR}, IN .replacement_list = replacement_list - end +! =============== +! Clear & analyze +! =============== + + clear ::: PURE ! Clear the buffer string and reset the counters. Do not reset any ! optional control switches e.g. like the .comment_chars @@ -263,8 +264,7 @@ contains ! Get next item item = " " - .string(last+1:).get_next_item(item,f,l,.comment_chars,.quote_chars & - , .ignore_unmatched_quotes) + .string(last+1:).get_next_item(item,f,l,.comment_chars,.quote_chars,.ignore_unmatched_quotes) if (item==" ") exit diff --git a/foofiles/cif.foo b/foofiles/cif.foo index 82306c116..9e41b0572 100644 --- a/foofiles/cif.foo +++ b/foofiles/cif.foo @@ -58,17 +58,6 @@ contains end -! copy(cif) ::: leaky -! ! Set self to be "cif". -! cif :: CIF, IN -! -! self = cif -! -! .nullify_ptr_part -! if (cif.file.associated) .file.create_copy(cif.file) -! -! end - ! ============ ! Set routines ! ============ @@ -239,7 +228,7 @@ contains ! Create and open the CIF self :: INOUT - ENSURE(.file.associated,"file not created") + ENSURE(.file.allocated,"file not created") .file.open_for("read") @@ -249,7 +238,7 @@ contains ! Close the CIF, and destroy it self :: INOUT - ENSURE(.file.associated,"file not created") + ENSURE(.file.allocated,"file not created") .file.close @@ -605,7 +594,7 @@ contains self :: INOUT found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ! From line 1 @@ -633,7 +622,7 @@ contains name :: STR, IN found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ! From line 1 @@ -671,7 +660,7 @@ contains self :: INOUT ENSURE(.start_of_data>0,".start_of_data is 0") - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") .data_block_name = " " @@ -710,7 +699,7 @@ contains ! end of the file if no block terminator was found. self :: INOUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ! Find EOD @@ -750,7 +739,7 @@ contains self :: INOUT found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") there :: VEC{BIN}(4) @@ -830,7 +819,7 @@ contains self :: INOUT found :: BIN, OUT, optional - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") there :: VEC{BIN}(12) @@ -901,7 +890,7 @@ contains ! Move to the (previously found) end of a data block. self :: INOUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.end_of_data>0,"end_of_data is not set") @@ -932,7 +921,7 @@ contains ID :: STR, IN found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") ENSURE(.end_of_data>.start_of_data,"no data block found") @@ -962,7 +951,7 @@ contains item :: TYPE?, OUT found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") @@ -1004,7 +993,7 @@ contains itemvec :: VEC{STR}@ found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") @@ -1064,7 +1053,7 @@ contains error :: REAL, optional, OUT found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") @@ -1095,7 +1084,7 @@ contains item :: TYPE?, OUT found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") @@ -1146,7 +1135,7 @@ contains cl :: STR, IN found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") @@ -1185,7 +1174,7 @@ contains found :: BIN, optional, OUT ID_pos,n_labels :: INT, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") ENSURE(ID(1:1)=="_","ID list is not a looped datum") @@ -1275,7 +1264,7 @@ contains item :: VEC{TYPE?}@, OUT found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") ENSURE(ID(1:1)=="_","ID list is not a looped datum") @@ -1347,7 +1336,7 @@ contains error :: VEC{REAL}@, optional, OUT found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") ENSURE(ID(1:1)=="_","ID list is not a looped datum") @@ -1416,7 +1405,7 @@ contains ID_ind :: VEC{INT}, optional, OUT n_labels :: INT, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") ENSURE(ID.dim>0,"no items in ID list") @@ -1525,7 +1514,7 @@ contains mat :: MAT{STR}@, OUT found :: BIN, optional, OUT - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") @@ -1623,7 +1612,7 @@ contains found :: BIN, optional, OUT transpose :: BIN, optional, IN - ENSURE(.file.associated,"CIF file has not been created") + ENSURE(.file.allocated,"CIF file has not been created") ENSURE(.file.is_open,"CIF file has not been opened") ENSURE(.start_of_data>0,"no data block found") diff --git a/foofiles/cluster.foo b/foofiles/cluster.foo index f4f945ddb..17bb0f1bf 100644 --- a/foofiles/cluster.foo +++ b/foofiles/cluster.foo @@ -1670,8 +1670,6 @@ contains end - ! stdout.unsave - ! stdout.text("=============================") ! stdout.text("Occupation list AFTER unique") ! stdout.text("=============================") @@ -4914,7 +4912,7 @@ contains m,a,i :: INT first :: BIN - stdout.save + stdout.save_style stdout.set_int_width(5) stdout.flush @@ -4968,7 +4966,7 @@ contains stdout.dash(int_fields=8) - stdout.unsave + stdout.unsave_style end diff --git a/foofiles/command_line.foo b/foofiles/command_line.foo index acaaed554..8dcaddd75 100644 --- a/foofiles/command_line.foo +++ b/foofiles/command_line.foo @@ -286,12 +286,12 @@ contains self :: IN if (.n_items>0) then - stdout.save + stdout.save_style stdout.set_margin_width(2) stdout.set_using_array_labels(FALSE) stdout.clear_and_put_margin stdout.put(.command_optarg,by_column=TRUE,left=TRUE,width=STR_SIZE) - stdout.unsave + stdout.unsave_style end end diff --git a/foofiles/cpx.foo b/foofiles/cpx.foo index 6381324aa..366ecebb7 100644 --- a/foofiles/cpx.foo +++ b/foofiles/cpx.foo @@ -214,280 +214,280 @@ contains ! Complex gamma function ! ====================== - gamma(opt) result (res) ::: pure - ! Complex gamma function - ! - opt==0, res = gamma(self) - ! - opt/=0, res = ln(gamma(self)) - ! - ! BY ALFRED H. MORRIS, JR., - ! NAVAL SURFACE WARFARE CENTER, DAHLGREN, VIRGINIA - ! - ! This version, in a subset of Fortran 90, prepared by - ! Alan.Miller @ vic.cmis.csiro.au - ! http://www.ozemail.com.au/~milleraj - ! This version was is accurate to within 5 in the 14th significant - ! - ! Finally, foo-fied by Dylan Jayatilaka (2023) - self :: IN - opt :: INT, IN - res :: CPX - - w,z, eta,eta2, sum :: CPX - pi2, p2, alpi, hl2p :: REAL - a, a1, a2, c, cn, cut, d, eps, et, e2t, h1, h2, s, sn :: REAL - s1, s2, t, t1, t2, u, u1, u2, v1, v2, w1, w2, x, y, y2 :: REAL - j, k, l, m, max, n, nm1 :: INT - c0 :: VEC{REAL}(12) - - ! CONSTANTS - pi2 = TWO*PI - alpi = 1.14472988584940 ! ALPI = LOG(PI) - hl2p = 0.918938533204673 ! HL2P = 0.5 * LOG(2*PI) - - max = HUGE(3) ! MAX IS THE LARGEST POSITIVE INTEGER THAT MAY - eps = EPSILON(ONE) ! SMALLEST NUMBER SUCH THAT 1.0 + EPS > 1.0. - - !!!!!!!!! - z = self - x = RE(z) - y = IM(z) - !!!!!!!!! - - ! THIS IS THE FAILED VALUE - res = COMPLEXIFY(huge(ONE), huge(ONE)) - - ! SETUP ! - if (x < ZERO) then - - ! Negative case, but y -> |y| - y = abs(y) ! <--- NOTE - t = -PI * y - et = exp(t) - e2t = et * et - - a1 = HALF * (ONE + e2t) - t2 = t + t - if (t2 >= -0.15) then; a2 = -HALF * CPX::rexp(t2) - else; a2 = HALF * (HALF + (HALF - e2t)) - end - - ! Fail - if (abs(x) >= min(RE(max), ONE/eps)) return - - k = abs(x) - u = x + k - k = mod(k,2) - if (u <= -HALF) then - u = HALF + (HALF + u) - k = k + 1 - end - - u = PI * u - sn = sin(u) - cn = cos(u) - if (k == 1) then - sn = -sn - cn = -cn - end - - a1 = sn*a1 - a2 = cn*a2 - a = a1*a1 + a2*a2 - - ! Fail - if (a == ZERO) return - - if (opt==0) then - h1 = a1/a - h2 = -a2/a - c = PI* et - h1 = c * h1 - h2 = c * h2 - else - h1 = (alpi+t) - HALF*log(a) - h2 = -atan2(a2,a1) - end - - ! Change x, reset y back - x = ONE - x - if (IM(z) >= ZERO) then; y = -y - else; h2 = -h2 - end - - end - - ! y = Im(z) has correct value - w1 = ZERO - w2 = ZERO - n = 0 - t = x - y2 = y*y - a = t*t + y2 - - cut = 36.0e+00 - if (eps > 1.0e-08) cut = 16.0d0 - - if (a < cut) then - - ! Fail - if (a == ZERO) return - - do - n = n + 1 - t = t + ONE - a = t * t + y2 - if (a >= cut) return - end - - ! S1 + S2*I IS PRODUCT OF TERMS (Z+J)/(Z+N) - u1 = (x*t+y2) / a - u2 = y / a - s1 = u1 - s2 = n * u2 - if (n >= 2) then - u = t / a - nm1 = n - 1 - do j = 1, nm1 - v1 = u1 + j * u - v2 = (n-j) * u2 - c = s1*v1 - s2*v2 - d = s1*v2 + s2*v1 - s1 = c - s2 = d - end - end - - ! W1 + W2*I = LOG(S1 + S2*I) WHEN OPT/=0 - s = s1*s1 + s2*s2 - if (opt/=0) then - w1 = HALF * log(s) - w2 = atan2(s2,s1) - end - - end - - ! SET V1 + V2*I = (Z - 0.5) * LOG(Z + N) - Z - t1 = HALF*log(a) - ONE - t2 = atan2(y,t) - u = x - HALF - v1 = (u*t1 - HALF) - y * t2 - v2 = u*t2 + y*t1 - - ! A1 + A2*I IS THE ASYMPTOTIC SUM - c0 = [ 0.833333333333333e-01, & - -0.277777777777778e-02, & - 0.793650793650794e-03, & - -0.595238095238095e-03, & - 0.841750841750842e-03, & - -0.191752691752692e-02, & - 0.641025641025641e-02, & - -0.295506535947712e-01, & - 0.179644372368831e+00, & - -0.139243221690590e+01, & - 0.134028640441684e+02, & - -0.156848284626002e+03 ] - eta = COMPLEXIFY(t/a, -y/a) - eta2 = eta * eta - m = 12 - if (a >= 289.0 ) m = 6 - if (eps > 1.0e-08) m = m/2 - sum = COMPLEXIFY(c0(m), ZERO) - l = m - do j = 2, m - l = l - 1 - sum = COMPLEXIFY(c0(l), ZERO) + sum*eta2 - end - sum = sum*eta - a1 = RE(sum) - a2 = IM(sum) - - ! GATHER TOGETHER RESULTS - w1 = (((a1 + hl2p) - w1) + v1) - n - w2 = (a2 - w2) + v2 - ! END SETUP ! - - ! Cases RE(z) & opt - if (RE(z) < ZERO) then - - if (opt==0) then - a = exp(-w1) - t1 = a * cos(-w2) - t2 = a * sin(-w2) - w1 = h1*t1 - h2*t2 - w2 = h1*t2 + h2*t1 - if (n/=0) then - c = w1*s1 - w2*s2 - d = w1*s2 + w2*s1 - w1 = c - w2 = d - end - else ! opt/=0 - w1 = h1 - w1 - w2 = h2 - w2 - end - - else ! RE(z) >= 0 - - if (opt==0) then - a = exp(w1) - w1 = a * cos(w2) - w2 = a * sin(w2) - if (n/=0) then - c = (s1*w1 + s2*w2) / s - d = (s1*w2 - s2*w1) / s - w1 = c - w2 = d - end - end - - end - - if (opt/=0) then - ! THE ANGLE W2 IS PUT INTO INTERVAL -PI < W2 <= PI. - if (w2 <= PI) then - k = HALF - w2 / pi2 - w2 = w2 + pi2 * k - else - k = w2 / pi2 - HALF - w2 = w2 - pi2 * REALIFY(k+1) - if (w2 <= -PI) w2 = PI - end - end - - ! TERMINATION - res = COMPLEXIFY(w1,w2) - - end - - rexp(x) result (res) ::: selfless, private, pure - ! Evaluate exp(x) - 1 - x :: REAL, IN - res :: REAL - - p1,p2, q1,q2,q3,q4, e :: REAL - - if (abs(x) <= 0.15) then - ! Domain [-0.15,+0.15] - p1 = 0.914041914819518e-09 - p2 = 0.238082361044469e-01 - q1 = -0.499999999085958e+00 - q2 = 0.107141568980644e+00 - q3 = -0.119041179760821e-01 - q4 = 0.595130811860248e-03 - res = x * (((p2*x + p1)*x + ONE) / & - ((((q4*x + q3)*x + q2)*x + q1)*x + ONE)) - else if (x >= ZERO) then - ! Domain [+0.15,+inf] - e = exp(x) - res = e * (HALF + (HALF - ONE/e)) - else if (x >= -37.0) then - ! Domain [-37.0,-0.15] - res = (exp(x) - HALF) - HALF - else - ! Domain [-inf,-37.0] - res = -ONE - end - - end +! gamma_cpx(opt) result (res) ::: pure +! ! Complex gamma function +! ! - opt==0, res = gamma(self) +! ! - opt/=0, res = ln(gamma(self)) +! ! +! ! BY ALFRED H. MORRIS, JR., +! ! NAVAL SURFACE WARFARE CENTER, DAHLGREN, VIRGINIA +! ! +! ! This version, in a subset of Fortran 90, prepared by +! ! Alan.Miller @ vic.cmis.csiro.au +! ! http://www.ozemail.com.au/~milleraj +! ! This version was is accurate to within 5 in the 14th significant +! ! +! ! Finally, foo-fied by Dylan Jayatilaka (2023) +! self :: IN +! opt :: INT, IN +! res :: CPX +! +! w,z, eta,eta2, sum :: CPX +! pi2, p2, alpi, hl2p :: REAL +! a, a1, a2, c, cn, cut, d, eps, et, e2t, h1, h2, s, sn :: REAL +! s1, s2, t, t1, t2, u, u1, u2, v1, v2, w1, w2, x, y, y2 :: REAL +! j, k, l, m, max, n, nm1 :: INT +! c0 :: VEC{REAL}(12) +! +! ! CONSTANTS +! pi2 = TWO*PI +! alpi = 1.14472988584940 ! ALPI = LOG(PI) +! hl2p = 0.918938533204673 ! HL2P = 0.5 * LOG(2*PI) +! +! max = HUGE(3) ! MAX IS THE LARGEST POSITIVE INTEGER THAT MAY +! eps = EPSILON(ONE) ! SMALLEST NUMBER SUCH THAT 1.0 + EPS > 1.0. +! +! !!!!!!!!! +! z = self +! x = RE(z) +! y = IM(z) +! !!!!!!!!! +! +! ! THIS IS THE FAILED VALUE +! res = COMPLEXIFY(huge(ONE), huge(ONE)) +! +! ! SETUP ! +! if (x < ZERO) then +! +! ! Negative case, but y -> |y| +! y = abs(y) ! <--- NOTE +! t = -PI * y +! et = exp(t) +! e2t = et * et +! +! a1 = HALF * (ONE + e2t) +! t2 = t + t +! if (t2 >= -0.15) then; a2 = -HALF * CPX::rexp(t2) +! else; a2 = HALF * (HALF + (HALF - e2t)) +! end +! +! ! Fail +! if (abs(x) >= min(RE(max), ONE/eps)) return +! +! k = abs(x) +! u = x + k +! k = mod(k,2) +! if (u <= -HALF) then +! u = HALF + (HALF + u) +! k = k + 1 +! end +! +! u = PI * u +! sn = sin(u) +! cn = cos(u) +! if (k == 1) then +! sn = -sn +! cn = -cn +! end +! +! a1 = sn*a1 +! a2 = cn*a2 +! a = a1*a1 + a2*a2 +! +! ! Fail +! if (a == ZERO) return +! +! if (opt==0) then +! h1 = a1/a +! h2 = -a2/a +! c = PI* et +! h1 = c * h1 +! h2 = c * h2 +! else +! h1 = (alpi+t) - HALF*log(a) +! h2 = -atan2(a2,a1) +! end +! +! ! Change x, reset y back +! x = ONE - x +! if (IM(z) >= ZERO) then; y = -y +! else; h2 = -h2 +! end +! +! end +! +! ! y = Im(z) has correct value +! w1 = ZERO +! w2 = ZERO +! n = 0 +! t = x +! y2 = y*y +! a = t*t + y2 +! +! cut = 36.0e+00 +! if (eps > 1.0e-08) cut = 16.0d0 +! +! if (a < cut) then +! +! ! Fail +! if (a == ZERO) return +! +! do +! n = n + 1 +! t = t + ONE +! a = t * t + y2 +! if (a >= cut) return +! end +! +! ! S1 + S2*I IS PRODUCT OF TERMS (Z+J)/(Z+N) +! u1 = (x*t+y2) / a +! u2 = y / a +! s1 = u1 +! s2 = n * u2 +! if (n >= 2) then +! u = t / a +! nm1 = n - 1 +! do j = 1, nm1 +! v1 = u1 + j * u +! v2 = (n-j) * u2 +! c = s1*v1 - s2*v2 +! d = s1*v2 + s2*v1 +! s1 = c +! s2 = d +! end +! end +! +! ! W1 + W2*I = LOG(S1 + S2*I) WHEN OPT/=0 +! s = s1*s1 + s2*s2 +! if (opt/=0) then +! w1 = HALF * log(s) +! w2 = atan2(s2,s1) +! end +! +! end +! +! ! SET V1 + V2*I = (Z - 0.5) * LOG(Z + N) - Z +! t1 = HALF*log(a) - ONE +! t2 = atan2(y,t) +! u = x - HALF +! v1 = (u*t1 - HALF) - y * t2 +! v2 = u*t2 + y*t1 +! +! ! A1 + A2*I IS THE ASYMPTOTIC SUM +! c0 = [ 0.833333333333333e-01, & +! -0.277777777777778e-02, & +! 0.793650793650794e-03, & +! -0.595238095238095e-03, & +! 0.841750841750842e-03, & +! -0.191752691752692e-02, & +! 0.641025641025641e-02, & +! -0.295506535947712e-01, & +! 0.179644372368831e+00, & +! -0.139243221690590e+01, & +! 0.134028640441684e+02, & +! -0.156848284626002e+03 ] +! eta = COMPLEXIFY(t/a, -y/a) +! eta2 = eta * eta +! m = 12 +! if (a >= 289.0 ) m = 6 +! if (eps > 1.0e-08) m = m/2 +! sum = COMPLEXIFY(c0(m), ZERO) +! l = m +! do j = 2, m +! l = l - 1 +! sum = COMPLEXIFY(c0(l), ZERO) + sum*eta2 +! end +! sum = sum*eta +! a1 = RE(sum) +! a2 = IM(sum) +! +! ! GATHER TOGETHER RESULTS +! w1 = (((a1 + hl2p) - w1) + v1) - n +! w2 = (a2 - w2) + v2 +! ! END SETUP ! +! +! ! Cases RE(z) & opt +! if (RE(z) < ZERO) then +! +! if (opt==0) then +! a = exp(-w1) +! t1 = a * cos(-w2) +! t2 = a * sin(-w2) +! w1 = h1*t1 - h2*t2 +! w2 = h1*t2 + h2*t1 +! if (n/=0) then +! c = w1*s1 - w2*s2 +! d = w1*s2 + w2*s1 +! w1 = c +! w2 = d +! end +! else ! opt/=0 +! w1 = h1 - w1 +! w2 = h2 - w2 +! end +! +! else ! RE(z) >= 0 +! +! if (opt==0) then +! a = exp(w1) +! w1 = a * cos(w2) +! w2 = a * sin(w2) +! if (n/=0) then +! c = (s1*w1 + s2*w2) / s +! d = (s1*w2 - s2*w1) / s +! w1 = c +! w2 = d +! end +! end +! +! end +! +! if (opt/=0) then +! ! THE ANGLE W2 IS PUT INTO INTERVAL -PI < W2 <= PI. +! if (w2 <= PI) then +! k = HALF - w2 / pi2 +! w2 = w2 + pi2 * k +! else +! k = w2 / pi2 - HALF +! w2 = w2 - pi2 * REALIFY(k+1) +! if (w2 <= -PI) w2 = PI +! end +! end +! +! ! TERMINATION +! res = COMPLEXIFY(w1,w2) +! +! end +! +! rexp(x) result (res) ::: selfless, private, pure +! ! Evaluate exp(x) - 1 +! x :: REAL, IN +! res :: REAL +! +! p1,p2, q1,q2,q3,q4, e :: REAL +! +! if (abs(x) <= 0.15) then +! ! Domain [-0.15,+0.15] +! p1 = 0.914041914819518e-09 +! p2 = 0.238082361044469e-01 +! q1 = -0.499999999085958e+00 +! q2 = 0.107141568980644e+00 +! q3 = -0.119041179760821e-01 +! q4 = 0.595130811860248e-03 +! res = x * (((p2*x + p1)*x + ONE) / & +! ((((q4*x + q3)*x + q2)*x + q1)*x + ONE)) +! else if (x >= ZERO) then +! ! Domain [+0.15,+inf] +! e = exp(x) +! res = e * (HALF + (HALF - ONE/e)) +! else if (x >= -37.0) then +! ! Domain [-37.0,-0.15] +! res = (exp(x) - HALF) - HALF +! else +! ! Domain [-inf,-37.0] +! res = -ONE +! end +! +! end end diff --git a/foofiles/crystal.foo b/foofiles/crystal.foo index f8b9d7a1c..364b6b73e 100644 --- a/foofiles/crystal.foo +++ b/foofiles/crystal.foo @@ -4804,7 +4804,7 @@ contains n_k, u,f, k :: INT ff :: VEC{CPX}@ k_pt :: MAT{REAL}@ - arch :: ARCHIVE* + arch :: ARCHIVE@ ! Get the # of k points n_k = .n_unique_SF_k_pts @@ -5427,7 +5427,7 @@ contains ENSURE(.xray_data.allocated, "no x-ray reflection data") sf_u :: VEC{CPX}@ - arch :: ARCHIVE* + arch :: ARCHIVE@ adp2 :: MAT{REAL}(3,3) adp3 :: MAT3{REAL}(3,3,3) adp4 :: MAT4{REAL}(3,3,3,3) @@ -6040,7 +6040,7 @@ contains refine_ADPs,refine_ADP4s,refine_ADP3s :: BIN II,sfh,sf1,sf2,sf4,sf6,sf24 :: CPX tag :: STR - arch :: ARCHIVE* + arch :: ARCHIVE@ ! Is there a nothing list? has_skip = .xray_data.refine_nothing_for_atom.allocated @@ -7284,7 +7284,7 @@ contains cm :: MAT{REAL}@ name :: STR - save,file :: TEXTFILE* + save,file :: TEXTFILE@ ! Read the name stdin.read(name) @@ -7298,12 +7298,12 @@ contains .make_pos_covariance_mx(cm) ! Print out the tables with errors - save => TEXTFILE::stdout - stdout => file + save = TEXTFILE::stdout + stdout = file .fragment_atom.put_bond_length_table(cm,parentheses=FALSE) .fragment_atom.put_bond_angle_table(cm,parentheses=FALSE) .fragment_atom.put_torsion_angle_table(cm,parentheses=FALSE) - stdout => save + stdout = save ! Clean cm.destroy @@ -7451,7 +7451,7 @@ contains symop :: MAT3{REAL}@ - stdout.save + stdout.save_style stdout.set_using_array_labels(FALSE) stdout.set_real_precision(3) @@ -7465,7 +7465,7 @@ contains ! Clean symop.destroy - stdout.unsave + stdout.unsave_style end @@ -7592,11 +7592,11 @@ contains ! Put unit cell information ! CRYST1 31.595 32.369 24.219 90.00 90.00 90.00 P 21 21 21 8 self :: IN - pdbfile :: TEXTFILE* + pdbfile :: TEXTFILE@ factor :: REAL - pdbfile.save + pdbfile.save_style pdbfile.set_margin_width(0) pdbfile.put("CRYST1",width=6) pdbfile.set_real_precision(3) @@ -7645,7 +7645,7 @@ contains !SCALE1 0.1053741 0.0175390 0.0172991 0.0000000 !SCALE2 0.0000000 0.0601636 0.0076747 0.0000000 !SCALE3 0.0000000 0.0000000 0.0321397 0.0000000 - pdbfile.unsave + pdbfile.unsave_style end @@ -14412,7 +14412,7 @@ contains m,a,i :: INT first :: BIN - stdout.save + stdout.save_style stdout.set_int_width(5) stdout.flush @@ -14463,7 +14463,7 @@ contains stdout.dash(int_fields=8) - stdout.unsave + stdout.unsave_style end diff --git a/foofiles/debug.foo b/foofiles/debug.foo deleted file mode 100644 index e90109e76..000000000 --- a/foofiles/debug.foo +++ /dev/null @@ -1,252 +0,0 @@ -!--------------------------------------------------------------------------- -! -! DEBUG: Debug print options ... -! -! Copyright (C) Dylan Jayatilaka, 1997 -! -! This library is free software; you can redistribute it and/or -! modify it under the terms of the GNU Library General Public -! License as published by the Free Software Foundation; either -! version 2 of the License, or (at your option) any later version. -! -! This library is distributed in the hope that it will be useful, -! but WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -! Library General Public License for more details. -! -! You should have received a copy of the GNU Library General Public -! License along with this library; if not, write to the -! Free Software Foundation, Inc., 59 Temple Place - Suite 330, -! Boston, MA 02111-1307, USA. -! -! $Id: object.foo 3026 2007-03-04 10:45:02Z dylan_ $ -!--------------------------------------------------------------------------- - -virtual module DEBUG - - implicit none - -contains - -! ============== -! Debug printing -! ============== - - set_debug_on(name) ::: leaky - ! Add a debug descriptor to the list. - - name :: STR - - if (FALSE) self = self - - debug_list.append(name) - - end - - set_debug_off(name) ::: leaky - ! Remove a debug descriptor from the list. - - name :: STR - - if (FALSE) self = self - - debug_list.prune(name) - - end - - read_debug_on ::: leaky - ! Read a debug descriptor and add it to the list. - - name :: STR - - if (FALSE) self = self - - stdin.read(name) - - debug_list.append(name) - - end - - read_debug_off ::: leaky - ! Read a debug descriptor and remove it from the list. - - name :: STR - - if (FALSE) self = self - - stdin.read(name) - - debug_list.prune(name) - - end - - debugging(name) result (res) - ! Return TRUE if the debug switch "name" has been set. - name :: STR - res :: BIN - - if (FALSE) self = self - - res = FALSE - - if (debug_list.disassociated) return - - res = any(name==debug_list) - - end - - put_debug_list - ! Put of the list of debug switches - - if (FALSE) self = self - - if (debug_list.disassociated) return - - stdout.put(debug_list) - - end - - put_debug(X,name) ::: template - ! Put *number* "X" to output, with descriptor "name", if the debug switch for - ! it has been set. - X :: X? - name :: STR - - if (NOT .:debugging(name)) return - - stdout.save - - stdout.set_real_style("e") - stdout.show(trim(name)//" = ",X) - - stdout.unsave - - end - - put_debug(X,name) ::: template - ! Put *array* "X" to output, with descriptor "name", if the debug switch for - ! it has been set. - X :: X? - name :: STR - - if (NOT .:debugging(name)) return - - stdout.save - - stdout.set_real_style("e") - - stdout.flush - stdout.text(trim(name)//":") - stdout.put(X) - - stdout.unsave - - end - - put_debug_2D(X,name) ::: template - ! Put *matrix* "X" to output as a raw 2D array, with descriptor - ! "name", if the debug switch for it has been set. - X :: X? - name :: STR - - i,j,dim1,dim2 :: INT - fmt :: STR - - if (NOT .:debugging(name)) return - - dim1 = X.dim1 - dim2 = X.dim2 - - fmt.to_fortran_format(dim2,"e",stdout.real_width,stdout.real_precision) - - do i = 1,dim1 - write(stdout.unit,trim(fmt)) (X(i,j), j = 1,dim2) - end - - end - - put_debug(X,name) ::: template - ! Put *object* "X" to output, with descriptor "name", if the debug switch for - ! it has been set. - X :: X? - name :: STR - - if (NOT .:debugging(name)) return - - stdout.save - - stdout.set_real_style("e") - - stdout.text(trim(name)//":") - X.put - - stdout.unsave - - end - - put_debug(X,name) ::: template - ! Put *opmatrix* "X" to output, with descriptor "name", if the debug switch for - ! it has been set. - X :: OPMATRIX - name :: STR - - if (NOT .:debugging(name)) return - - stdout.save - - stdout.set_real_style("e") - - if (X.restricted.allocated) then - stdout.flush - stdout.text(trim(name)//", restricted:") - stdout.put(X.restricted) - end - - if (X.alpha.allocated) then - stdout.flush - stdout.text(trim(name)//", alpha:") - stdout.put(X.alpha) - end - - if (X.beta.allocated) then - stdout.flush - stdout.text(trim(name)//", beta:") - stdout.put(X.beta) - end - - if (X.general.allocated) then - stdout.flush - stdout.text(trim(name)//", general:") - stdout.put(X.general) - end - - if (X.restricted_complex.allocated) then - stdout.flush - stdout.text(trim(name)//", restricted_complex:") - stdout.put(X.restricted_complex) - end - - if (X.alpha_complex.allocated) then - stdout.flush - stdout.text(trim(name)//", alpha_complex:") - stdout.put(X.alpha_complex) - end - - if (X.beta_complex.allocated) then - stdout.flush - stdout.text(trim(name)//", beta_complex:") - stdout.put(X.beta_complex) - end - - if (X.general_complex.allocated) then - stdout.flush - stdout.text(trim(name)//", general_complex:") - stdout.put(X.general_complex) - end - - stdout.unsave - - end - -end - diff --git a/foofiles/diffraction_data.put.foo b/foofiles/diffraction_data.put.foo index d0f35abb2..28d32d79f 100644 --- a/foofiles/diffraction_data.put.foo +++ b/foofiles/diffraction_data.put.foo @@ -196,8 +196,8 @@ contains ENSURE(covariance_mx.is_square,"covariance is not square") ! Change defaults - stdout.save - stdout.set_real_style("e") + stdout.save_style + stdout.set_real_fortran_fmt("e") stdout.set_real_width(16) stdout.set_real_precision(8) @@ -236,7 +236,7 @@ contains end ! Put back defaults - stdout.unsave + stdout.unsave_style end @@ -474,10 +474,10 @@ contains stdout.flush stdout.text("Near-zero eigenvalues:") stdout.flush - stdout.save - stdout.set_real_style("e") + stdout.save_style + stdout.set_real_fortran_fmt("e") stdout.put(.near_0_evals) - stdout.unsave + stdout.unsave_style stdout.flush if (.near_0<=10 OR .show_near_0_eigenvectors) then diff --git a/foofiles/diis.foo b/foofiles/diis.foo index 6b57ea75b..ac2c23666 100644 --- a/foofiles/diis.foo +++ b/foofiles/diis.foo @@ -712,9 +712,9 @@ contains stdout.text("DIIS options: ") stdout.flush - stdout.set_real_style("e") + stdout.set_real_fortran_fmt("e") stdout.show("Convergence on max(abs(error)) =",.convergence_tolerance) - stdout.set_real_style("f") + stdout.set_real_fortran_fmt("f") stdout.show("Extrapolate from iteration =",.start_iteration) stdout.show("Save vectors from iteration =",.save_iteration) stdout.show("No. of vectors to keep =",.keep) diff --git a/foofiles/isosurface.foo b/foofiles/isosurface.foo index 36bd773d2..36815a404 100644 --- a/foofiles/isosurface.foo +++ b/foofiles/isosurface.foo @@ -5353,10 +5353,10 @@ contains ENSURE(.surface_iso_values.allocated,"no surface iso values") - stdout.save - stdout.set_real_style("e") + stdout.save_style + stdout.set_real_fortran_fmt("e") ISOSURFACE:put_vertex_property(.surface_iso_values,label,.surface_iso_values.dim) - stdout.unsave + stdout.unsave_style end @@ -5402,7 +5402,7 @@ contains ! We don't want to use labels on vectors ! We don't want blocking arrays - stdout.save + stdout.save_style stdout.set_using_array_labels(FALSE) stdout.set_using_fields(FALSE) @@ -5413,7 +5413,7 @@ contains stdout.text("end "//prop_name.trim) ! Restore - stdout.unsave + stdout.unsave_style end @@ -5440,7 +5440,7 @@ contains n_size1,n_size2 :: INT, IN ! We don't want to use labels on vectors - stdout.save + stdout.save_style stdout.set_using_array_labels(FALSE) stdout.set_using_fields(FALSE) @@ -5452,7 +5452,7 @@ contains stdout.text("end "//prop_name.trim) ! Restore - stdout.unsave + stdout.unsave_style end diff --git a/foofiles/json.foo b/foofiles/json.foo index fdbb4af6f..b6116344d 100644 --- a/foofiles/json.foo +++ b/foofiles/json.foo @@ -8,7 +8,7 @@ module JSON implicit none - out :: TEXTFILE*, public DEFAULT_NULL + out :: TEXTFILE@, public contains @@ -16,42 +16,49 @@ contains ! Allocation ! ========== - create(output_name) ::: leaky - ! create a JSON object with default filenames - self :: PTR - output_name :: STR, optional + create(file_name) ::: leaky, PURE + ! Allocate an object + self :: allocatable, OUT + file_name :: STR, optional, IN - allocate(self) - .nullify_ptr_part - .set_defaults +#ifdef USE_PRECONDITIONS + status :: INT +#endif - if(present(output_name)) .set_name(output_name) +#ifdef USE_PRECONDITIONS + allocate(self,stat=status) + ENSURE(status==0,"error in allocating memory") +#else + allocate(self) +#endif + + if (present(file_name)) .set_name(file_name) .out.create(.name) .out.set_column_spacing(1) .out.set_using_fields(FALSE) - - end - destroy ::: leaky, recursive - ! Destroy a textfile - self :: PTR - - if (.disassociated) return - - .destroy_ptr_part + end - deallocate(self) + destroy ::: get_from(OBJECT), leaky, PURE + ! Deallocate "self" + end + destroy ::: get_from(OBJECT), leaky, PURE + ! Deallocate "self" end - set_name(name) +! =========== +! Set methods +! =========== + + set_name(file_name) ! Set the file name - self :: PTR - name :: STR + self :: INOUT + file_name :: STR, IN - DIE_IF(name==" ","name is blank!") + ENSURE(file_name/=" ","name is blank!") - .name = name + .name = file_name end @@ -61,224 +68,183 @@ contains .margin = 0 end - destroy_ptr_part ::: leaky - .out.destroy - end - - nullify_ptr_part - nullify(.out) - end - - ! ===== ! Write ! ===== write_start - .out.open(for="write") - .out.text("{") - .margin = .margin + 2 - .out.set_margin_width(.margin) + ! Write opening brace + self :: INOUT + + .out.open(for="write") + .out.text("{") + .margin = .margin + 2 + .out.set_margin_width(.margin) + end write_end - .margin = .margin - 2 - .out.set_margin_width(.margin) - .out.flush - .out.text("}") - .out.close - end + ! Write closing brace + self :: INOUT - put_entry(name, value) ::: template - name :: STR - value :: T? - - .out.put('"') - .out.put(name) - .out.put('" : ') - .out.put(value) - .out.flush - end + .margin = .margin - 2 + .out.set_margin_width(.margin) + .out.flush + .out.text("}") + .out.close - print_cpx(c) - c :: CPX - s :: STR(16) - r, i :: REAL - r = real(c) - i = aimag(c) - write (s, '(1x, 1("(", F5.2) , 1(",", F5.2, ")"))') r, i - .out.put(s) end - put_entry(name, value) - name :: STR - value :: CPX - .out.put('"') - .out.put(name) - .out.put('" : ') - .print_cpx(value) - .out.flush - end + write_cpx(c) + ! Write a CPX "value" the right way. + self :: INOUT + value :: CPX, IN + s :: STR(16) + r, i :: REAL - put_entry(name, value) ::: get_from(JSON, T?=>STR, ARG?=>) - end + r = RE(value) + i = IM(value) + write (s, '(1x, 1("(", F5.2) , 1(",", F5.2, ")"))') r, i + .out.put(s) - - put_entry(name, value) ::: get_from(JSON, T?=>INT, ARG?=>) end - - put_entry(name, value) ::: get_from(JSON, T?=>REAL, ARG?=>) - end + write_vec(v, separator) ::: template + ! Write a vector "v" using a "separator" (if needed) + self :: INOUT + v :: V?, IN + separator :: STR, optional, IN + ! WARN_IF(v.dim == 0, "Zero sized dimension!") + i :: INT + sep :: STR - print_vec(v, separator) ::: template - v :: V?, IN - separator :: STR, optional - i, dim :: INT - sep :: STR - - sep = ', ' - dim = v.dim - if(present(separator)) sep = separator - WARN_IF(dim == 0, "Zero sized dimension!") - - .out.put('\[ ') - do i = 1, dim - if (i > 1) then - .out.put(sep) - end - if (mod(i, 7) == 0) then - .out.text(" ") - end - .out.put(v(i)) - end - .out.put('\]') - .out.flush - end - - - print_vec(v, separator) ::: get_from(JSON, V?=>VEC{STR}, ARG?=>) - end + sep = ', ' ! Magic constant + if (present(separator)) sep = separator + .out.put('\[ ') + do i = 1, v.dim + if (i>1) .out.put(sep) + if (mod(i,5)==0) .out.text(" ") ! Magic number + .out.put(v(i)) + end + .out.put('\]') + .out.flush - print_vec(v, separator) ::: get_from(JSON, V?=>VEC{REAL}, ARG?=>) end - - print_vec(v, separator) ::: get_from(JSON, V?=>VEC{INT}, ARG?=>) + write_vec(v, separator) ::: get_from(JSON, V?=>VEC{STR}) + ! Write a vector "v" using a "separator" (if needed) end + write_vec(v, separator) ::: get_from(JSON, V?=>VEC{REAL}) + ! Write a vector "v" using a "separator" (if needed) + end - print_vec(v, separator) - v :: VEC{CPX}, IN - separator :: STR, optional - i, dim :: INT - sep :: STR - - sep = ', ' - dim = v.dim - if(present(separator)) sep = separator - WARN_IF(dim == 0, "Zero sized dimension!") - - .out.put('\[ ') - do i = 1, dim - if (i > 1) then - .out.put(sep) - end - if (mod(i, 7) == 0) then - .out.text(" ") - end - .print_cpx(v(i)) - end - .out.put('\]') - .out.flush + write_vec(v, separator) ::: get_from(JSON, V?=>VEC{INT}) + ! Write a vector "v" using a "separator" (if needed) end + write_vec(v, separator) + ! Write a vector "v" using a "separator" (if needed) + self :: INOUT + v :: VEC{CPX}, IN + separator :: STR, optional, IN + ! WARN_IF(v.dim == 0, "Zero sized dimension!") + + i :: INT + sep :: STR - put_entry(name, value, separator) ::: template - name :: STR - value :: V?, IN - separator :: STR, optional - sep :: STR + sep = ', ' + if (present(separator)) sep = separator - sep = ', ' - if(present(separator)) sep = separator + .out.put('\[ ') + do i = 1, dim + if (i>1) .out.put(sep) + if (mod(i,7)==0) .out.text(" ") + end + .write_cpx(v(i)) + end + .out.put('\]') + .out.flush - .out.put('"') - .out.put(name) - .out.put('" : ') - .print_vec(value, sep) - .out.text(" ") end +! =========== +! Put entries +! =========== - put_entry(name, value, separator) ::: get_from(JSON, V?=>VEC{STR}, ARG?=>) - end + put_entry(name, value) ::: template + ! Put entry "name" to have "value" + self :: INOUT + value :: T? + name :: STR + .out.put('"') + .out.put(name) + .out.put('": ') + .out.put(value) + .out.flush - put_entry(name, value, separator) ::: get_from(JSON, V?=>VEC{REAL}, ARG?=>) end + put_entry(name, value) ::: get_from(JSON, T?=>STR) + ! Put entry "name" to have "value" + end - put_entry(name, value, separator) ::: get_from(JSON, V?=>VEC{INT}, ARG?=>) + put_entry(name, value) ::: get_from(JSON, T?=>INT) + ! Put entry "name" to have "value" + end + + put_entry(name, value) ::: get_from(JSON, T?=>REAL) + ! Put entry "name" to have "value" end + put_entry(name, value) + ! Put entry "name" to have CPX "value" + self :: INOUT + name :: STR + value :: CPX + + .out.put('"') + .out.put(name) + .out.put('" : ') + .write_cpx(value) + .out.flush - put_entry(name, value, separator) ::: get_from(JSON, V?=>VEC{CPX}, ARG?=>) end - put_entry(name, value, separator, order) ::: template - name :: STR - value :: MAT{T?}, IN - separator :: STR, optional - order :: BIN, optional - i, dim1, dim2 :: INT - sep :: STR - row :: VEC{T?}* - - sep = ', ' - dim1 = value.dim1 - dim2 = value.dim2 - if(present(separator)) sep = separator - if(present(order)) order = NOT order - - - WARN_IF(dim1 == 0, "Zero sized dimension!") - - .out.put('"') - .out.put(name) - .out.put('" :') - .out.text(" ") - .out.text('\[ ') - row.create(dim2) - do i = 1, dim1 - if (i > 1) then - .out.text(sep) - end - row = value(i, :) - .print_vec(row) - end - .out.text('\]') - .out.flush - end + put_entry(name, v, separator) ::: template + ! Put "name" to have vector value "v" with "separator" (if needed) + self :: INOUT + v :: V?, IN + name :: STR, IN + separator :: STR, optional, IN + .out.put('"') + .out.put(name) + .out.put('": ') + .write_vec(value, separator) + .out.text(" ") - put_entry(name, value, separator, order) ::: get_from(JSON, T?=>REAL, ARG?=>) end - - put_entry(name, value, separator, order) ::: get_from(JSON, T?=>INT, ARG?=>) + put_entry(name, v, separator) ::: get_from(JSON, V?=>VEC{STR}) + ! Put "name" to have vector value "v" with "separator" (if needed) end + put_entry(name, v, separator) ::: get_from(JSON, V?=>VEC{REAL}) + ! Put "name" to have vector value "v" with "separator" (if needed) + end - put_entry(name, value, separator, order) ::: get_from(JSON, T?=>CPX, ARG?=>) + put_entry(name, v, separator) ::: get_from(JSON, V?=>VEC{INT}) + ! Put "name" to have vector value "v" with "separator" (if needed) end - put_entry(name, value, separator, order) ::: get_from(JSON, T?=>STR, ARG?=>) + put_entry(name, v, separator) ::: get_from(JSON, V?=>VEC{CPX}) + ! Put "name" to have vector value "v" with "separator" (if needed) end - end diff --git a/foofiles/l_bfgs.foo b/foofiles/l_bfgs.foo index 9fcc8b4ec..9ece6ee4e 100644 --- a/foofiles/l_bfgs.foo +++ b/foofiles/l_bfgs.foo @@ -1072,9 +1072,9 @@ contains stdout.flush stdout.text("L_BFGS options: ") stdout.flush - stdout.set_real_style("e") + stdout.set_real_fortran_fmt("e") stdout.show("Convergence on max(abs(error)) =",.convergence_tolerance) - stdout.set_real_style("f") + stdout.set_real_fortran_fmt("f") stdout.show("Extrapolate from iteration =",.start_iteration) stdout.show("Save vectors from iteration =",.save_iteration) stdout.show("No. of vectors to keep =",.keep) diff --git a/foofiles/marchingcube.foo b/foofiles/marchingcube.foo index 1d48904f9..63fca5278 100644 --- a/foofiles/marchingcube.foo +++ b/foofiles/marchingcube.foo @@ -2508,110 +2508,90 @@ contains ! Output ! ====== - put(output) + put ! Put the list of vertices for the object self :: IN - output :: TEXTFILE, optional, INOUT - .put_bitmask_info(output) - .put_vertex_index_info(output) - .put_positional_info(output) + .put_bitmask_info + .put_vertex_index_info + .put_positional_info end - put_bitmask_info(output) + put_bitmask_info ! Put the bit mask related info for the object. self :: IN - output :: TEXTFILE, optional, target, INOUT - out :: TEXTFILE* - - if (present(output)) then; out => output - else; out => TEXTFILE::stdout - end - - out.flush - out.show("iso_value =",.iso_value) - out.show("accuracy =",.accuracy) - out.show("case # =",.case) - out.show_bit_string("case bit_string =",.case) - out.show_bit_string("edge_bit_string =",.edge_bit_string) - out.show_bit_string("cube_bit_string =",.cube_bit_string) - out.show_bit_string("skip_bit_string =",.skip_bit_string) - out.show("left face on? =",.has_left_face_on_surface) - out.show("right face on? =",.has_right_face_on_surface) - out.show("front face on? =",.has_front_face_on_surface) - out.show("back face on? =",.has_back_face_on_surface) - out.show("lower face on? =",.has_lower_face_on_surface) - out.show("upper face on? =",.has_upper_face_on_surface) - out.show("n_edge =",.no_of_edges) - out.show("n_active_edges =",.no_of_active_edges) - out.show("n_triangle =",.n_triangle) - out.show("no_of_triangles =",.no_of_triangles) - out.show("n_pt =",.n_pt) - - end - - put_vertex_index_info(output) + stdout.flush + stdout.show("iso_value =",.iso_value) + stdout.show("accuracy =",.accuracy) + stdout.show("case # =",.case) + stdout.show_bit_string("case bit_string =",.case) + stdout.show_bit_string("edge_bit_string =",.edge_bit_string) + stdout.show_bit_string("cube_bit_string =",.cube_bit_string) + stdout.show_bit_string("skip_bit_string =",.skip_bit_string) + stdout.show("left face on? =",.has_left_face_on_surface) + stdout.show("right face on? =",.has_right_face_on_surface) + stdout.show("front face on? =",.has_front_face_on_surface) + stdout.show("back face on? =",.has_back_face_on_surface) + stdout.show("lower face on? =",.has_lower_face_on_surface) + stdout.show("upper face on? =",.has_upper_face_on_surface) + stdout.show("n_edge =",.no_of_edges) + stdout.show("n_active_edges =",.no_of_active_edges) + stdout.show("n_triangle =",.n_triangle) + stdout.show("no_of_triangles =",.no_of_triangles) + stdout.show("n_pt =",.n_pt) + + end + + put_vertex_index_info ! Put the list of indexc related entites. self :: IN - output :: TEXTFILE, optional, target, INOUT - - out :: TEXTFILE* - - if (present(output)) then; out => output - else; out => TEXTFILE::stdout - end - - out.flush if (.n_triangle>0) then - out.text("Triangle edge index:") - out.put(.triangle_edge_index(:,1:.n_triangle),by_column=TRUE) - out.text("Triangle vertex index:") - out.put(.triangle_vertex_index(:,1:.n_triangle),by_column=TRUE) - out.text("Edge vertex indices:") - out.put(.edge_vertex_index) + stdout.flush + stdout.text("Triangle edge index:") + stdout.put(.triangle_edge_index(:,1:.n_triangle),by_column=TRUE) + stdout.text("Triangle vertex index:") + stdout.put(.triangle_vertex_index(:,1:.n_triangle),by_column=TRUE) + stdout.text("Edge vertex indices:") + stdout.put(.edge_vertex_index) end end - put_positional_info(output) + put_positional_info ! Put the list of position and function related entities. self :: IN - output :: TEXTFILE, optional, target, INOUT - out :: TEXTFILE* i :: INT - if (present(output)) then; out => output - else; out => TEXTFILE::stdout - end + stdout.flush + stdout.text("Vertex positons:") + stdout.put(.vertex_positions,by_column=TRUE) + stdout.text("Values at each vertex:") + stdout.put(.vertex_fn_value) + stdout.text("Vertex gradients:") + stdout.put(.vertex_gradient,by_column=TRUE) - out.flush - out.text("Vertex positons:") - out.put(.vertex_positions,by_column=TRUE) - out.text("Values at each vertex:") - out.put(.vertex_fn_value) - out.text("Vertex gradients:") - out.put(.vertex_gradient,by_column=TRUE) - out.text("Vertex hessians:") + stdout.text("Vertex hessians:") do i = 0,7 - out.show("edge =",i+1) - out.put(.vertex_hessian(:,:,i)) + stdout.show("edge =",i+1) + stdout.put(.vertex_hessian(:,:,i)) end + if (.n_triangle>0) then - out.text("Edge vertex positions:") - out.put(.edge_vertex_positions,by_column=TRUE) - out.text("Edge vertex values:") - out.put(.edge_vertex_value) - out.text("Edge vertex gradients:") - out.put(.edge_vertex_gradient,by_column=TRUE) - out.text("Edge vertex hessians:") - do i = 0,11 - out.show("edge =",i+1) - out.put(.edge_vertex_hessian(:,:,i)) - end + stdout.text("Edge vertex positions:") + stdout.put(.edge_vertex_positions,by_column=TRUE) + stdout.text("Edge vertex values:") + stdout.put(.edge_vertex_value) + stdout.text("Edge vertex gradients:") + stdout.put(.edge_vertex_gradient,by_column=TRUE) + stdout.text("Edge vertex hessians:") + do i = 0,11 + stdout.show("edge =",i+1) + stdout.put(.edge_vertex_hessian(:,:,i)) + end end end diff --git a/foofiles/mat{real}.foo b/foofiles/mat{real}.foo index f4714acb1..e3755deab 100644 --- a/foofiles/mat{real}.foo +++ b/foofiles/mat{real}.foo @@ -36,8 +36,8 @@ module MAT{REAL} end ! For getting rotation matrix to match vectors - saved_reference :: MAT{REAL}*, private DEFAULT_NULL - saved_actual :: MAT{REAL}*, private DEFAULT_NULL + ! saved_reference :: MAT{REAL}*, private DEFAULT_NULL + ! saved_actual :: MAT{REAL}*, private DEFAULT_NULL contains diff --git a/foofiles/molecule.base.foo b/foofiles/molecule.base.foo index 75589c6fe..5d29093fb 100644 --- a/foofiles/molecule.base.foo +++ b/foofiles/molecule.base.foo @@ -251,7 +251,7 @@ contains ENSURE(.MOs.is_allocated_with_genre("r "), "No orbitals") name :: STR - wfnfile :: TEXTFILE* + wfnfile :: TEXTFILE@ lvec :: VEC{INT}@ evec :: VEC{REAL}@ dmatrix, cc :: MAT{REAL}@ @@ -369,7 +369,7 @@ contains ENSURE(.MOs.is_allocated_with_genre("r "), "No orbitals") name :: STR - wfnfile :: TEXTFILE* + wfnfile :: TEXTFILE@ lvec :: VEC{INT}@ evec :: VEC{REAL}@ dmatrix, cc :: MAT{REAL}@ @@ -488,7 +488,7 @@ contains ENSURE(.MOs.is_allocated_with_genre("r "), "No orbitals") name :: STR - wfnfile :: TEXTFILE* + wfnfile :: TEXTFILE@ lvec :: VEC{INT}@ evec :: VEC{REAL}@ dmatrix, cc :: MAT{REAL}@ diff --git a/foofiles/molecule.ce.foo b/foofiles/molecule.ce.foo index 3e897669b..c32b159b4 100644 --- a/foofiles/molecule.ce.foo +++ b/foofiles/molecule.ce.foo @@ -96,7 +96,7 @@ contains ENSURE(.cif.file_name/=" ","no CIF file name specified") found,CX_uses_angstrom :: BIN - CX_file :: TEXTFILE* + CX_file :: TEXTFILE@ cif :: CIF@ CX_file.create(.CX_file_name) @@ -238,7 +238,7 @@ contains cif :: CIF found :: BIN, optional, OUT - ENSURE(cif.file.associated,"no CIF file name") + ENSURE(cif.file.allocated,"no CIF file name") ENSURE(cif.file.name/=" ","no CIF file name") fnd :: BIN @@ -344,7 +344,7 @@ contains self :: INOUT cif :: CIF@ - CX_file :: TEXTFILE* + CX_file :: TEXTFILE@ if (.CX_file_name/=" ") then @@ -362,17 +362,16 @@ contains end - serialize_isosurface_sbf(cif) + serialize_isosurface_sbf ! Output information that Crystal Explorer requires to the file ! with name ".CX_file_name". ! NOTE: Should "self" INOUT here? IDK about serialize. --dylan self :: INOUT - cif :: CIF@, INOUT - if(.CX_file_name /= " ") then - .:serialize_isosurface_sbf(trim(.CX_file_name),cif) + if (.CX_file_name /= " ") then + .:serialize_isosurface_sbf(trim(.CX_file_name)) else - .:serialize_isosurface_sbf(trim(.name)//"-hs.sbf",cif) + .:serialize_isosurface_sbf(trim(.name)//"-hs.sbf") end end @@ -383,13 +382,13 @@ contains ! NOTE: this requires a "cif" file to have been read, and a valid data block ! name to be stored in the "cif" object. self :: INOUT - CX_file :: TEXTFILE* + CX_file :: TEXTFILE, IN cif :: CIF@, IN ! ENSURE(cif.allocated,"no CIF object created") ! ENSURE(cif.data_block_name/=" ","no CIF data block name") - save :: TEXTFILE* + save :: TEXTFILE@ CX_label,CX_name,formula,spacegroup :: STR in, out :: VEC{INT}@ done :: BIN @@ -407,13 +406,13 @@ contains stdout.flush ! Redirect stdout to out - save => TEXTFILE::stdout - stdout => CX_file + save = TEXTFILE::stdout + stdout = CX_file ! Reset output format - stdout.save + stdout.save_style stdout.set_int_width(7) - stdout.set_real_style("f") + stdout.set_real_fortran_fmt("f") stdout.set_real_precision(5) stdout.set_real_width(12) stdout.set_using_fields(FALSE) @@ -535,41 +534,25 @@ contains end ! Put back stdout - stdout.unsave - stdout => save + stdout.unsave_style + stdout = save end - serialize_isosurface_sbf - ! Dump sbf file - self :: INOUT - .:serialize_isosurface_sbf(.cif) - end - - serialize_isosurface_sbf(filename, cif) - ! Output information that Crystal Explorer requires to file "CX_file". + serialize_isosurface_sbf(filename) + ! Output information that Crystal Explorer needs to sbf "filename". ! NOTE: this requires a "cif" file to have been read, and a valid data block ! name to be stored in the "cif" object. self :: INOUT filename :: STR, IN - cif :: CIF@, INOUT datafile :: DATAFILE - CX_label,CX_name :: STR points, normals :: MAT{REAL}@ values,d_e,d_i,d_norm_e,d_norm_i,d_norm,si,cn :: VEC{REAL}@ d_e_atoms, d_i_atoms :: VEC{INT}@ atoms_inside, atoms_outside :: MAT{INT}@ done,has_curvatures :: BIN - if (cif.allocated) then - CX_name = cif.file_name - CX_label = cif.data_block_name - else - CX_name = "unknown" - CX_label = "unknown" - end - stdout.flush stdout.text("Writing Crystal Explorer data file: " // filename.trim) stdout.flush diff --git a/foofiles/molecule.fock.foo b/foofiles/molecule.fock.foo index 3cb8383fd..f7a9fc9ae 100644 --- a/foofiles/molecule.fock.foo +++ b/foofiles/molecule.fock.foo @@ -2079,8 +2079,8 @@ contains ENSURE(.atom.allocated, "no atom list") I :: MAT4{REAL}@ - eri_archive :: ARCHIVE* - ind_archive :: ARCHIVE* + eri_archive :: ARCHIVE@ + ind_archive :: ARCHIVE@ n_quartets :: INT q, a,b,c,d :: INT fa,fb,fc,fd :: INT @@ -2477,8 +2477,8 @@ contains ENSURE(.atom.allocated, "no atom list") I :: MAT4{REAL}@ - eri_archive :: ARCHIVE* - ind_archive :: ARCHIVE* + eri_archive :: ARCHIVE@ + ind_archive :: ARCHIVE@ n_quartets :: INT q, a,b,c,d :: INT fa,fb,fc,fd :: INT @@ -5202,9 +5202,9 @@ contains if (.scfdata.output) then - stdout.set_real_style("e") + stdout.set_real_fortran_fmt("e") stdout.show("Skipping electron repulsion integrals less than ",.scfdata.ERI_disk_cutoff) - stdout.set_real_style("f") + stdout.set_real_fortran_fmt("f") end @@ -5654,7 +5654,7 @@ contains P,H,S :: MAT{REAL}@ a,b,c,d :: INT core :: BIN - in :: TEXTFILE* + in :: TEXTFILE@ if (present(new_n_bf)) then P.create(.n_bf,new_n_bf) @@ -5954,7 +5954,7 @@ contains v, new_v :: MAT4{REAL}@ P, Dx,Dy,Dz,S :: MAT{REAL}@ n_bf, a,b,c,d :: INT - in :: TEXTFILE* + in :: TEXTFILE@ if (present(new_n_bf)) then P.create(.n_bf,new_n_bf) diff --git a/foofiles/molecule.har.foo b/foofiles/molecule.har.foo index eb98d14f9..a895f42e2 100644 --- a/foofiles/molecule.har.foo +++ b/foofiles/molecule.har.foo @@ -665,7 +665,7 @@ contains skipab,skipb :: VEC{BIN}@ overlapping_atom, pi,pj,pn :: VEC{INT}@ pt,grida,gridb,bf_save :: MAT{REAL}@ - arch :: ARCHIVE* + arch :: ARCHIVE@ sha :: SHELL1 bf_skip :: VEC{EVEC{BIN}}@ bf_grid :: VEC{EMAT{REAL}}@ diff --git a/foofiles/molecule.inq.foo b/foofiles/molecule.inq.foo index b320e84a4..d02ed72e3 100644 --- a/foofiles/molecule.inq.foo +++ b/foofiles/molecule.inq.foo @@ -608,7 +608,6 @@ contains archive :: ARCHIVE - archive.set_defaults archive.set(.name,archive_name,genre) res = archive.exists @@ -623,7 +622,6 @@ contains archive :: ARCHIVE - archive.set_defaults archive.set(.name,archive_name,genre) res = NOT archive.exists diff --git a/foofiles/molecule.ints.foo b/foofiles/molecule.ints.foo index 150a69455..b1bbd798b 100644 --- a/foofiles/molecule.ints.foo +++ b/foofiles/molecule.ints.foo @@ -24,7 +24,6 @@ module MOLECULE.INTS implicit none - num_dimensions :: INT = 3 contains @@ -111,11 +110,11 @@ contains stdout.text(" linear_dependence_tolerance are projected out of the AO basis") stdout.text(" leading to, in this case, some exact-zero MO eigenvalues.") stdout.flush - stdout.set_real_style("e") + stdout.set_real_fortran_fmt("e") stdout.show("Min. overlap matrix eigenvalue =", .scfdata.min_overlap_mx_eigenvalue) stdout.show("Linear dependence tolerance =", .scfdata.linear_dependence_tol) stdout.show("Linear dependence shift =", .scfdata.linear_dependence_shift) - stdout.set_real_style("f") + stdout.set_real_fortran_fmt("f") stdout.show("No. of small eigenvalues =", n_s) stdout.show("No. of negative eigenvalues =", n_n) @@ -1515,6 +1514,9 @@ contains ! pos :: MAT{REAL}* ! field_mx :: MAT3{REAL}* !Indexing: component-orbital-orbital ! i, k :: INT +! num_dimensions :: INT +! +! num_dimensions = 3 ! ! e_field.create(atom.dim, .n_atom, num_dimensions) ! e_field = ZERO diff --git a/foofiles/molecule.main.foo b/foofiles/molecule.main.foo index 87277faae..2721188fc 100644 --- a/foofiles/molecule.main.foo +++ b/foofiles/molecule.main.foo @@ -1188,7 +1188,7 @@ contains ! i :: INT ! ub :: REAL ! formula, name :: STR -! CX_file :: TEXTFILE* +! CX_file :: TEXTFILE@ ! ! ! Defragment any molecules in the CIF ! .cluster.create(.crystal) @@ -1309,7 +1309,7 @@ contains ! ! mol :: MOLECULE@ ! formula, name :: STR -! CX_file :: TEXTFILE* +! CX_file :: TEXTFILE@ ! ! ! Make the i-th cluster molecule "mol" ! mol.SET:create @@ -1531,7 +1531,7 @@ contains ! Read new output style options, for example change the ! width and number of field, or precision of output. self :: INOUT - stdout.read_keywords(TEXTFILE::stdin) + stdout.read_keywords end ! P diff --git a/foofiles/molecule.misc.foo b/foofiles/molecule.misc.foo index d7ba9c4d1..2fee4e832 100644 --- a/foofiles/molecule.misc.foo +++ b/foofiles/molecule.misc.foo @@ -1859,7 +1859,7 @@ contains ! ! ! S :: MAT{REAL}@ ! mo,Smo :: MAT{REAL}@ -! in :: TEXTFILE* +! in :: TEXTFILE@ ! k_pts :: MAT{REAL}@ ! ftnew,ft :: MAT3{CPX}@ ! W :: MAT{CPX}@ @@ -1947,7 +1947,7 @@ contains ! mo,Smo :: MAT{REAL}@ ! Lx,Ly,Lz :: MAT{REAL}@ ! Lxmo,Lymo,Lzmo :: MAT{REAL}@ -! in :: TEXTFILE* +! in :: TEXTFILE@ ! mo.create(160,4) ! in.create("mo35") ! in.open_for("read") @@ -2077,7 +2077,7 @@ contains ! p35,p48,p49,p50 :: VEC{REAL}@ ! g35,g48,g49,g50 :: MAT{REAL}@ ! j,s :: MAT{REAL}@ -! in :: TEXTFILE* +! in :: TEXTFILE@ ! n_pt,k :: INT ! mu,nu,rt3,fac :: REAL ! archive :: ARCHIVE @@ -2163,7 +2163,7 @@ contains ! ! They are complex matrices in the block order: ! ! alpha-alpha, beta-alpha, alpha-beta, beta-beta. ! -! textfile :: TEXTFILE* +! textfile :: TEXTFILE@ ! dens :: MAT3{CPX}@ ! val :: CPX ! name :: STR @@ -2807,7 +2807,7 @@ contains ! Pa.create(.n_atom); Pb.create(.n_atom) ! Na.create(.n_atom,3); Nb.create(.n_atom,3) ! I = (ZERO,ONE) -! stdout.set_real_style("d") +! stdout.set_real_fortran_fmt("d") ! ! x = 1 ! y = 2 @@ -2842,7 +2842,7 @@ contains ! .atom.get_mean_neutron_numbers(NN) ! PV = PV*NN ! -! stdout.set_real_style("d") +! stdout.set_real_fortran_fmt("d") ! stdout.flush ! stdout.text("Contributions (by nucleus) to the parity-violating weak force energy shift term:") ! stdout.flush @@ -2853,7 +2853,7 @@ contains ! stdout.text("Neutron numbers:") ! stdout.flush ! stdout.put(NN) -! stdout.set_real_style("f") +! stdout.set_real_fortran_fmt("f") ! ! NN.destroy ! PV.destroy @@ -3024,7 +3024,7 @@ contains Tz_ppm = Tz*4000000/m TT_net = Tx_ppm*quantization_axis(1) + Ty_ppm*quantization_axis(2) + Tz_ppm*quantization_axis(3) - stdout.set_real_style("d") + stdout.set_real_fortran_fmt("d") int_width = TRUE stdout.flush stdout.text("Contribution to g-tensor shift:") @@ -3035,50 +3035,50 @@ contains stdout.dash(int_fields=1,real_fields=2) stdout.text("Spin term:") stdout.put("S_x",int_width) - stdout.set_real_style("d"); stdout.put(Sx) - stdout.set_real_style("f"); stdout.put(Sx_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(Sx) + stdout.set_real_fortran_fmt("f"); stdout.put(Sx_ppm); stdout.flush stdout.put("S_y",int_width) - stdout.set_real_style("d"); stdout.put(Sy) - stdout.set_real_style("f"); stdout.put(Sy_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(Sy) + stdout.set_real_fortran_fmt("f"); stdout.put(Sy_ppm); stdout.flush stdout.put("S_z",int_width) - stdout.set_real_style("d"); stdout.put(Sz); - stdout.set_real_style("f"); stdout.put(Sz_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(Sz); + stdout.set_real_fortran_fmt("f"); stdout.put(Sz_ppm); stdout.flush stdout.put("Net",int_width); stdout.tab(real_fields=1); stdout.put(SS_net); stdout.flush stdout.text("Angular momentum term:") stdout.put("L_x",int_width) - stdout.set_real_style("d"); stdout.put(Mx); - stdout.set_real_style("f"); stdout.put(Mx_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(Mx); + stdout.set_real_fortran_fmt("f"); stdout.put(Mx_ppm); stdout.flush stdout.put("L_y",int_width) - stdout.set_real_style("d"); stdout.put(My); - stdout.set_real_style("f"); stdout.put(My_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(My); + stdout.set_real_fortran_fmt("f"); stdout.put(My_ppm); stdout.flush stdout.put("L_z",int_width) - stdout.set_real_style("d"); stdout.put(Mz); - stdout.set_real_style("f"); stdout.put(Mz_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(Mz); + stdout.set_real_fortran_fmt("f"); stdout.put(Mz_ppm); stdout.flush stdout.put("Net",int_width); stdout.tab(real_fields=1); stdout.put(MM_net); stdout.flush stdout.text("1-electron L:S gauge term:") stdout.put("Q_x",int_width) - stdout.set_real_style("d"); stdout.put(Qx); - stdout.set_real_style("f"); stdout.put(Qx_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(Qx); + stdout.set_real_fortran_fmt("f"); stdout.put(Qx_ppm); stdout.flush stdout.put("Q_y",int_width) - stdout.set_real_style("d"); stdout.put(Qy); - stdout.set_real_style("f"); stdout.put(Qy_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(Qy); + stdout.set_real_fortran_fmt("f"); stdout.put(Qy_ppm); stdout.flush stdout.put("Q_z",int_width) - stdout.set_real_style("d"); stdout.put(Qz); - stdout.set_real_style("f"); stdout.put(Qz_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(Qz); + stdout.set_real_fortran_fmt("f"); stdout.put(Qz_ppm); stdout.flush stdout.put("Net",int_width); stdout.tab(real_fields=1); stdout.put(QQ_net); stdout.flush stdout.text("Relativistic B:S kinetic term:") stdout.put("T_x",int_width) - stdout.set_real_style("d"); stdout.put(Tx) - stdout.set_real_style("f"); stdout.put(Tx_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(Tx) + stdout.set_real_fortran_fmt("f"); stdout.put(Tx_ppm); stdout.flush stdout.put("T_y",int_width) - stdout.set_real_style("d"); stdout.put(Ty); - stdout.set_real_style("f"); stdout.put(Ty_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(Ty); + stdout.set_real_fortran_fmt("f"); stdout.put(Ty_ppm); stdout.flush stdout.put("T_z",int_width) - stdout.set_real_style("d"); stdout.put(Tz); - stdout.set_real_style("f"); stdout.put(Tz_ppm); stdout.flush + stdout.set_real_fortran_fmt("d"); stdout.put(Tz); + stdout.set_real_fortran_fmt("f"); stdout.put(Tz_ppm); stdout.flush stdout.put("Net",int_width); stdout.tab(real_fields=1); stdout.put(TT_net); stdout.flush total = SS_net + MM_net + QQ_net + TT_net @@ -3086,7 +3086,7 @@ contains stdout.put("Total:",int_width); stdout.tab(real_fields=1); stdout.put(total) stdout.flush stdout.dash(int_fields=1,real_fields=2) - stdout.set_real_style("f") + stdout.set_real_fortran_fmt("f") end @@ -3195,13 +3195,13 @@ contains .INTS:make_overlap_mx - stdout.save - stdout.set_real_style("e") + stdout.save_style + stdout.set_real_fortran_fmt("e") stdout.set_real_width(20) stdout.set_real_precision(10) stdout.text("Overlap matrix eigenvalues:") stdout.put(.overlap_eigenvalues) - stdout.unsave + stdout.unsave_style end @@ -4799,7 +4799,7 @@ contains ! ENSURE(.crystal.allocated, "No crystal") ! ENSURE(.atom.allocated, "No atom") ! -! pdbfile :: TEXTFILE* +! pdbfile :: TEXTFILE@ ! ! pdbfile.create("stdout.pdb") ! pdbfile.open_for("write") diff --git a/foofiles/molecule.prop.foo b/foofiles/molecule.prop.foo index aaae61fdc..441693b82 100644 --- a/foofiles/molecule.prop.foo +++ b/foofiles/molecule.prop.foo @@ -138,7 +138,9 @@ contains eval.create(n3n) eval = .normal_mode_eigenvalues eval = sqrt(abs(eval)) * WAVENUMBER_PER_HARTREE - ewav = eval.to_str(stdout.real_style,stdout.real_width,stdout.real_precision) + ewav = eval.to_str(stdout.style.real_fortran_fmt & + ,stdout.style.real_width & + ,stdout.style.real_precision) eval.destroy ! Set table data diff --git a/foofiles/molecule.put.foo b/foofiles/molecule.put.foo index 26ebcadf7..2a4337a54 100644 --- a/foofiles/molecule.put.foo +++ b/foofiles/molecule.put.foo @@ -99,7 +99,7 @@ contains self :: IN name :: STR - xyzfile :: TEXTFILE* + xyzfile :: TEXTFILE@ i :: INT atomnumber :: STR, parameter = "(I3)" @@ -136,7 +136,7 @@ contains self :: IN name :: STR - xyzfile :: TEXTFILE* + xyzfile :: TEXTFILE@ i :: INT n_atom :: INT @@ -539,9 +539,10 @@ contains i,j,k :: INT - stdout.save + stdout.save_style + stdout.set_int_width(4) - stdout.set_no_of_fields_per_line(25) + stdout.set_n_fields_per_line(25) stdout.set_using_array_labels(FALSE) stdout.text(" ") @@ -560,7 +561,7 @@ contains if (mod(k,25)/=0) stdout.flush end - stdout.unsave + stdout.unsave_style end @@ -573,9 +574,9 @@ contains i,j,k :: INT - stdout.save + stdout.save_style stdout.set_int_width(4) - stdout.set_no_of_fields_per_line(25) + stdout.set_n_fields_per_line(25) stdout.set_using_array_labels(FALSE) stdout.text(" ") @@ -593,7 +594,7 @@ contains if (mod(k,25)/=0) stdout.flush end - stdout.unsave + stdout.unsave_style end @@ -766,7 +767,7 @@ contains ENSURE(.atom.allocated,"no atom list!") - out :: TEXTFILE* + out :: TEXTFILE@ out.create(trim(.name)//achar(46)//"wrl") out.open_for("write") @@ -1271,12 +1272,12 @@ contains end ! Fragment - stdout.save + stdout.save_style stdout.redirect(trim(.name)//".archive.fcf") .PUT:put_CIF_banner(.cif.use_CIF2) .crystal.put_tonto_fcf stdout.revert - stdout.unsave + stdout.unsave_style ! Clean up if (clean) then @@ -1310,7 +1311,7 @@ contains end ! Fragment - stdout.save + stdout.save_style if (.scfdata.do_outputs) then if (NOT .scfdata.exceeded_lambda_max) then stdout.redirect(trim(.name)//",lambda="//trim(.scfdata.lambda.to_str("f9.6"))//".archive.fcf") @@ -1323,7 +1324,7 @@ contains .PUT:put_CIF_banner(.cif.use_CIF2) .crystal.put_tonto_fcf stdout.revert - stdout.unsave + stdout.unsave_style ! Clean up if (clean) then @@ -1357,7 +1358,7 @@ contains end ! Fragment - stdout.save + stdout.save_style if (.scfdata.do_outputs) then if (NOT .scfdata.exceeded_lambda_max) then stdout.redirect(trim(.name)//",lambda="//trim(.scfdata.lambda.to_str("f9.6"))//".olex.fcf") @@ -1370,7 +1371,7 @@ contains .PUT:put_CIF_banner(.cif.use_CIF2) .crystal.put_Olex2_fcf("'all reflections are used'") stdout.revert - stdout.unsave + stdout.unsave_style ! Clean up if (clean) then @@ -1397,7 +1398,7 @@ contains end ! Fragment - stdout.save + stdout.save_style stdout.redirect(trim(.name)//".archive.fco") stdout.set_int_width(5) stdout.set_real_precision(4) @@ -1405,7 +1406,7 @@ contains .PUT:put_CIF_banner(.cif.use_CIF2) .crystal.put_xd_fco stdout.revert - stdout.unsave + stdout.unsave_style ! Clean up if (clean) then @@ -1440,7 +1441,7 @@ contains end ! Fragment - stdout.save + stdout.save_style if (.scfdata.do_outputs) then if (NOT .scfdata.exceeded_lambda_max) then stdout.redirect(trim(.name)//",lambda="//trim(.scfdata.lambda.to_str("f9.6"))//".archive.fco") @@ -1456,7 +1457,7 @@ contains .PUT:put_CIF_banner(.cif.use_CIF2) .crystal.put_xd_fco stdout.revert - stdout.unsave + stdout.unsave_style ! Clean up if (clean) then @@ -1699,7 +1700,6 @@ contains avec_lambda = FALSE if (present(with_lambda)) avec_lambda = with_lambda - archive.set_defaults archive.set(.name,archive_name) archive.write(opmatrix,genre) @@ -1733,7 +1733,6 @@ contains avec_lambda = FALSE if (present(with_lambda)) avec_lambda = with_lambda - archive.set_defaults archive.set(.name,archive_name) archive.write(opvector,genre) if (avec_lambda) then @@ -1762,7 +1761,6 @@ contains avec_lambda = FALSE if (present(with_lambda)) avec_lambda = with_lambda - archive.set_defaults archive.set(.name,archive_name) archive.write(item,genre) diff --git a/foofiles/molecule.read.foo b/foofiles/molecule.read.foo index 090b1952d..cbf482603 100644 --- a/foofiles/molecule.read.foo +++ b/foofiles/molecule.read.foo @@ -69,7 +69,7 @@ contains file_name :: STR, optional, IN print_output :: BIN, optional, IN - molden_file,save :: TEXTFILE* + molden_file, save :: TEXTFILE@ archive :: ARCHIVE pos :: VEC{REAL}(3) orb :: VEC{REAL}@ @@ -175,13 +175,13 @@ contains molden_file.read_line ! Read basis - save => stdin - stdin => molden_file + save = stdin + stdin = molden_file do a = 1,.n_atom .basis(a).read_molden .basis(a).set_label(.atom(a).basis_label) end - stdin => save + stdin = save ! Remove repetitions .basis.remove_repetitions @@ -414,8 +414,6 @@ contains ! endif ! Save data in archive files - archive.set_defaults - archive.set(.name,"density_mx") archive.write(.density_mx) @@ -444,7 +442,7 @@ contains ENSURE(NOT .use_spherical_basis,"not implemented") - molden_file,save :: TEXTFILE* + molden_file, save :: TEXTFILE@ archive :: ARCHIVE pos :: VEC{REAL}(3) orb :: VEC{REAL}@ @@ -536,14 +534,14 @@ contains molden_file.read_line ! Read basis - save => stdin - stdin => molden_file + save = stdin + stdin = molden_file do a = 1,.n_atom .basis(a).read_molden .basis(a).put .basis(a).set_label(.atom(a).basis_label) end - stdin => save + stdin = save ! Find [MO] tag molden_file.look_for(op//"MO"//cl,found=found) @@ -725,8 +723,6 @@ contains ! stdout.put(.NOs) ! ! Save data in archive files - ! archive.set_defaults - ! archive.set(.name,"density_mx") ! archive.write(.density_mx) @@ -962,15 +958,15 @@ contains base,tmp :: STR replace :: MAT{STR}@ - S,W :: MAT{REAL}@ + W :: MAT{REAL}@ igv :: VEC{INT}(3) pos :: VEC{REAL}(3) tuc,cuc,dm :: MAT{REAL}(3,3) av,bv,cv :: VEC{REAL}(3) - XMLfile :: TEXTFILE* + XMLfile :: TEXTFILE@ cif_atom :: VEC{ATOM}@ !kang i,j :: INT - n_g,n_bf,n_atom,n_tri :: INT + n_g,n_bf,n_atom :: INT a,g :: INT same :: BIN xml_pos, tmp_vec :: VEC{REAL}(3) @@ -1267,7 +1263,7 @@ contains DIE_IF(NOT .basis_info_made,"must be a tonto basis set!") - chkfile :: TEXTFILE* + chkfile :: TEXTFILE@ fchk :: STR ! Get FChk file name @@ -1317,8 +1313,8 @@ contains DIE_IF(.use_spherical_basis,"spherical basis not implemented") - fchk,label :: STR - chkfile :: TEXTFILE* + fchk,label :: STR + chkfile :: TEXTFILE@ fbf,lbf,ang :: VEC{INT}@ shell_l,n_prim_for_shell,atom_for_shell,atom_p :: VEC{INT}@ G_n_prim_for_shell,G_atom_for_shell,G_shell_type :: VEC{INT}@ @@ -1639,8 +1635,6 @@ contains ! Save data in archive files ! NOTE: MO's & density matrix are wrt unnormalized basis fn's - archive.set_defaults - archive.set(.name,"density_mx") archive.write(.density_mx) @@ -1661,7 +1655,8 @@ contains ! Read a gaussian density matrix with TAG? which may be ! "r " (or not) from "chkfile". Archive it as NAME?. ! If "dm" is present it is created to be the density matrix. - chkfile :: TEXTFILE* + self :: INOUT + chkfile :: TEXTFILE, INOUT restricted :: BIN, IN dm :: OPMATRIX@, optional @@ -1731,7 +1726,6 @@ contains end ! Archive the density "D" - archive.set_defaults archive.set(.name,NAME?) archive.write(D) @@ -2129,7 +2123,6 @@ contains archive :: ARCHIVE - archive.set_defaults archive.set(.name,archive_name) archive.read(opmatrix,genre) @@ -2147,7 +2140,6 @@ contains archive :: ARCHIVE - archive.set_defaults archive.set(.name,archive_name) archive.read(opvector,genre) @@ -2162,7 +2154,6 @@ contains archive :: ARCHIVE - archive.set_defaults archive.set(.name,archive_name) archive.read(item,genre) diff --git a/foofiles/molecule.scf.foo b/foofiles/molecule.scf.foo index 62b38ad2e..5516ae666 100644 --- a/foofiles/molecule.scf.foo +++ b/foofiles/molecule.scf.foo @@ -199,7 +199,6 @@ contains ! end ! ! ! Read density or make it from MO's -! archive.set_defaults ! archive.set(.name,"density_mx",genre) ! if (archive.exists) then ! archive.read(.density_mx) @@ -1249,7 +1248,7 @@ contains a,b,i,j,k,n,p :: INT n_unique :: INT spin :: BIN - arch :: ARCHIVE* + arch :: ARCHIVE@ n_unique = .crystal.n_unique_frag_atoms if (present(n_last)) n_unique = n_last @@ -7337,7 +7336,6 @@ contains ! Archive as the density_mx P.create(.n_bf) - archive.set_defaults archive.set(.name,"group_density_mx", genre="r ") archive.read(P, genre="r ") archive.set(.name,"density_mx", genre="r ") diff --git a/foofiles/molecule.set.foo b/foofiles/molecule.set.foo index 1e4e6a86f..911836de4 100644 --- a/foofiles/molecule.set.foo +++ b/foofiles/molecule.set.foo @@ -2651,7 +2651,6 @@ contains archive :: ARCHIVE - archive.set_defaults archive.set(.name,name) archive.delete_all_genres @@ -2674,8 +2673,6 @@ contains delete_DM = TRUE if (present(keep_DM)) delete_DM = NOT keep_DM - archive.set_defaults - if (delete_MOs) then archive.set(.name,"MOs"); archive.delete_all_genres archive.set(.name,"MO_energies"); archive.delete_all_genres @@ -2728,7 +2725,6 @@ contains if (.scfdata.deallocated) return if (NOT .scfdata.is_constrained_scf) return - archive.set_defaults l = .scfdata.initial_lambda l_max = .scfdata.lambda_max + l @@ -2787,7 +2783,6 @@ contains self :: IN archive :: ARCHIVE - archive.set_defaults archive.set(.name,"MOs"); archive.delete_all_genres archive.set(.name,"MO_energies"); archive.delete_all_genres diff --git a/foofiles/output_style.foo b/foofiles/output_style.foo new file mode 100644 index 000000000..0c9b8844d --- /dev/null +++ b/foofiles/output_style.foo @@ -0,0 +1,268 @@ +!===================================================================== +! +! OUTPUT_STYLE +! +! Style parameters used for writing TEXTFILE output. +! This is a very basic module. +! +! Copyright (C) Dylan Jayatilaka, 2024 +! +! This library is free software; you can redistribute it and/or +! modify it under the terms of the GNU Library General Public +! License as published by the Free Software Foundation; either +! version 2 of the License, or (at your option) any later version. +! +! This library is distributed in the hope that it will be useful, +! but WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +! Library General Public License for more details. +! +! You should have received a copy of the GNU Library General Public +! License along with this library; if not, write to the +! Free Software Foundation, Inc., 59 Temple Place - Suite 330, +! Boston, MA 02111-1307, USA. +!====================================================================== + +module OUTPUT_STYLE + + implicit none + +contains + +! === +! Set +! === + + set_from(saved) ::: pure + ! Set style options from a "saved", including any default units. + self :: INOUT + saved :: OUTPUT_STYLE, IN + + ! Format options + .using_fields = saved.using_fields + .spacing = saved.spacing + .n_fields_per_line = saved.n_fields_per_line + .int_width = saved.int_width + .real_width = saved.real_width + .real_precision = saved.real_precision + .real_fortran_fmt = saved.real_fortran_fmt + .margin_width = saved.margin_width + .using_array_labels = saved.using_array_labels + .default_units = saved.default_units + + ! Buffer parsing style ... + .comment_chars = saved.comment_chars + .quote_chars = saved.quote_chars + .list_delimiters = saved.list_delimiters + .ignore_unmatched_quotes = saved.ignore_unmatched_quotes + .eliminate_specials = saved.eliminate_specials + .replacement_list = saved.replacement_list + + end + +! ================== +! Set format options +! ================== + + set_using_fields(val) ::: PURE + ! Set whether to use fields of fixed width or not. + self :: INOUT + val :: BIN, IN + .using_fields = val + .set_n_fields_per_line(0) + end + + set_spacing(val) ::: PURE + ! Set the spacing between fields. + self :: INOUT + val :: INT, IN + + ENSURE(val>=0,"must be non-negative") + + .spacing = val + + end + + set_n_fields_per_line(val) ::: PURE + ! Set the number of fields per file. + self :: INOUT + val :: INT, IN + + ENSURE(val>=0,"not enough fields") + + .n_fields_per_line = val + + end + + set_int_width(val) ::: PURE + ! Set the width of an integer field. + self :: INOUT + val :: INT, IN + + ENSURE(val>=0,"width less than zero") + + .int_width = val + + end + + set_real_width(val) ::: PURE + ! Set the width of an real-number field. + self :: INOUT + val :: INT, IN + + ENSURE(val>=0,"width less than zero") + ENSURE(val>=.real_precision,"width smaller than precision") + + .real_width = val + + end + + set_real_precision(val) ::: PURE + ! Set the real-number precision i.e. no of decimal places. + self :: INOUT + val :: INT, IN + + ENSURE(val>=0,"precision less than zero") + ENSURE(val<=.real_width,"precision greater than field width") + + .real_precision = val + + end + + set_real_fortran_fmt(val) ::: PURE + ! Set the real-number fortran format string. + self :: INOUT + val :: STR, IN + + ENSURE(val.is_one_of(["f ","d ","e ","es","en","g "]),"unrecognized fortran style: "//trim(val)) + + .real_fortran_fmt = val + + end + + set_line_fortran_fmt(fmt) ::: PURE + ! Set the line format from fortran format string "fmt". + ! It should include the number of fields e.g. "5f10.3". + ! The style must be an allowed fortran real style like "f". + self :: INOUT + fmt :: STR, IN + + f,l,s :: INT + tmp :: STR + + ! First and last character + tmp = adjustl(fmt) + tmp.get_next_item_position(f,l) + ENSURE(l/=0, "fmt is blank") + tmp = tmp(1:l) + + ! Get the number of columns + s = tmp.index_of_character_not_in("0123456789") + ENSURE(s/=0, "fmt has no # of fields") + .set_n_fields_per_line(tmp(1:s-1).to_int) + + ! Get the style + tmp = tmp(s:) + s = tmp.index_of_character_in("0123456789") + ENSURE(s/=0, "fmt has no real style") + .set_real_fortran_fmt(tmp(1:s-1)) + + ! Get the width + tmp = tmp(s:) + s = tmp.index_of_character_not_in("0123456789") + ENSURE(s/=0, "fmt has no width") + ENSURE(tmp(s:s)==".", "fmt has no dot before precision") + .set_real_precision(0) + .set_real_width(tmp(1:s-1).to_int) + + ! Get the precision + tmp = tmp(s+1:) + .set_real_precision(tmp.to_int) + + end + + set_margin_width(val) ::: PURE + ! Set the width of the margin in the buffer. + self :: INOUT + val :: INT, IN + + ENSURE(val>=0,"margin width less than zero") + ENSURE(val<=STR_SIZE,"margin width too large") + + .margin_width = val + + end + + set_using_array_labels(val) ::: pure + ! Set whether to use numbered columns, or row labels, on matrix or + ! vector output. + self :: INOUT + val :: BIN, IN + .using_array_labels = val + end + + set_default_units(units) ::: PURE + ! Set the .default_units to "units". NOTE: This is reset back to + ! ONE after a numerical quantity has been read and converted. + self :: INOUT + units :: STR, IN + + ENSURE(units==" " OR units.is_known_unit,"Unknown units!") + + .default_units = units + + end + +! ========================== +! Set buffer parsing options +! ========================== + + set_comment_chars(val) ::: pure + ! Set the characters which represent comment characters. + self :: INOUT + val :: STR, IN + .comment_chars = val + end + + set_quote_chars(val) ::: pure + ! Set the characters which represent the quotes. + self :: INOUT + val :: STR, IN + .quote_chars = val + end + + set_list_delimiters(val) ::: pure + ! Set the two open- and close- characters which delimit a list. + self :: INOUT + val :: STR(len=2), IN + .list_delimiters = val(1:2) + end + + set_ignore_unmatched_quotes(val) ::: pure + ! Set whether to ignore unmatched quotes when processing input. + self :: INOUT + val :: BIN, IN + .ignore_unmatched_quotes = val + end + + set_eliminate_specials(val) ::: pure + ! Set the list of characters which should be treated as whitespace. + self :: INOUT + val :: BIN, IN + .eliminate_specials = val + end + + set_replacement_list(list) ::: leaky, PURE + ! Set the characters which should be replaced. + ! The first column in "list" is the character to be replaced, and + ! the second column is the character it should be replaced with. + self :: INOUT + list :: MAT{STR}, IN + + ENSURE(list.dim2==2,"second dimension must be 2") + + .replacement_list = list + + end + +end diff --git a/foofiles/plot_grid.foo b/foofiles/plot_grid.foo index a4f4ba418..2163541dd 100644 --- a/foofiles/plot_grid.foo +++ b/foofiles/plot_grid.foo @@ -1258,16 +1258,16 @@ contains ! "pos0" in cube file format ... stdout.text("Scaled, rotated reference positions (R N0) which match original positions (N')") stdout.text("Place these in the cube file") - stdout.save ! Save settings - stdout.set_real_style("e") ! Gaussian format + stdout.save_style ! Save settings + stdout.set_real_fortran_fmt("e") ! Gaussian format stdout.set_real_width(13) stdout.set_real_precision(5) dist2 = ZERO do i = 1,Z.dim - stdout.put(Z0(i)) ! Z + stdout.put(Z0(i)) ! Z an = Z0(i) - stdout.put(an,precision=1) ! Charge - stdout.put(pos0(1,i)) ! Pos in plot grid axis system + stdout.put(an,precision=1) ! Charge + stdout.put(pos0(1,i)) ! Pos in plot grid axis system stdout.put(pos0(2,i)) stdout.put(pos0(3,i)) stdout.flush @@ -1275,7 +1275,7 @@ contains dist2 = dist2 + VEC{REAL}:sum_elements((pos0r(:,i) - pos_keep(:,i))*(pos0r(:,i)-pos_keep(:,i))) end end - stdout.unsave ! Put back settings + stdout.unsave_style ! Put back settings stdout.show("distance2 (should be smaller than above) =",dist2) ! Clean up @@ -2267,7 +2267,7 @@ contains self :: IN pt :: MAT{REAL}@, OUT - textfile :: TEXTFILE* + textfile :: TEXTFILE@ i :: INT ! Open the file for reading @@ -3120,7 +3120,7 @@ contains ! Nice width axes = .plot_axes - wid = maxval(len_trim(axes.to_str("f",50,stdout.real_precision))) + 1 + wid = maxval(len_trim(axes.to_str("f",50,stdout.style.real_precision))) + 1 axes = .plot_axes ! Centering diff --git a/foofiles/pointgroup.foo b/foofiles/pointgroup.foo index fb966fcd0..a3644b175 100644 --- a/foofiles/pointgroup.foo +++ b/foofiles/pointgroup.foo @@ -1256,86 +1256,80 @@ contains ! Output ! ====== - put(output) + put ! Display the pointgroup data to output file "out". self :: IN - output :: TEXTFILE, optional, target, INOUT - out :: TEXTFILE* - i,n,dim :: INT - block,n_fields,n_block,f,l :: INT - - if (present(output)) then; out => output - else; out => TEXTFILE::stdout - end - - out.flush - out.text("POINTGROUP output:") - out.flush - out.show("Symbol =",.symbol) - out.show("ID_symbol =",.ID_symbol) - out.show("ID_number =",.ID_number) - out.show("Principal axis order =",.axis_order) - out.show("Order =",.order) - out.show("No. of Irreps =",.n_irrep) - out.show("No. of Irrep generators =",.n_gen) - out.show("Has complex irreps? =",.has_complex_irreps) - - out.flush - out.text("List of inverse group elements :") - out.flush - out.put(.inverse) - - out.flush - out.text("Group multiplication table :") - out.flush - out.put(.table) - - out.flush - out.text("Character Table :") - n_fields = out.n_fields_per_line + i,n,dim, f,l :: INT + block,n_fields,n_block :: INT + + stdout.flush + stdout.text("POINTGROUP output:") + stdout.flush + stdout.show("Symbol =",.symbol) + stdout.show("ID_symbol =",.ID_symbol) + stdout.show("ID_number =",.ID_number) + stdout.show("Principal axis order =",.axis_order) + stdout.show("Order =",.order) + stdout.show("No. of Irreps =",.n_irrep) + stdout.show("No. of Irrep generators =",.n_gen) + stdout.show("Has complex irreps? =",.has_complex_irreps) + + stdout.flush + stdout.text("List of inverse group elements :") + stdout.flush + stdout.put(.inverse) + + stdout.flush + stdout.text("Group multiplication table :") + stdout.flush + stdout.put(.table) + + stdout.flush + stdout.text("Character Table :") + n_fields = stdout.style.n_fields_per_line n_block = (.order-1)/n_fields + 1 do block = 1,n_block f = 1 + (block-1)*n_fields l = min(f+n_fields-1,.order) - out.flush ! Banner - out.dash(int_fields=1,real_fields=min(n_fields,.order)) - out.tab(int_fields=1) + stdout.flush ! Banner + stdout.dash(int_fields=1,real_fields=min(n_fields,.order)) + stdout.tab(int_fields=1) do n = f,l - out.put(n,real_width=TRUE) + stdout.put(n,real_width=TRUE) end - out.flush - out.dash(int_fields=1,real_fields=min(n_fields,.order)) + stdout.flush + stdout.dash(int_fields=1,real_fields=min(n_fields,.order)) do i = 1,.n_irrep ! The actual table - out.put(.irrep(i).label,int_width=TRUE) + stdout.put(.irrep(i).label,int_width=TRUE) do n = f,l - out.put(.irrep(i).character(n)) + stdout.put(.irrep(i).character(n)) end - out.flush + stdout.flush end - out.dash(int_fields=1,real_fields=min(n_fields,.order)) + stdout.dash(int_fields=1,real_fields=min(n_fields,.order)) end - out.flush - out.text("3x3 Representation matrices :") - out.flush - out.put(.mx,by_dim3_matrices=TRUE) + stdout.flush + stdout.text("3x3 Representation matrices :") + stdout.flush + stdout.put(.mx,by_dim3_matrices=TRUE) - out.flush - out.text("Irrep matrices :") - out.flush + stdout.flush + stdout.text("Irrep matrices :") + stdout.flush do i = 1,.n_irrep - out.flush + stdout.flush dim = .irrep(i).dimension - out.text("Irrep " // trim( .irrep(i).label) // ", dimension " // trim( dim.to_str) // ":" ) - out.flush + stdout.text("Irrep " // trim( .irrep(i).label) // ", dimension " // trim( dim.to_str) // ":" ) + stdout.flush if (dim==1) then - out.put(.irrep(i).mx(1,1,:)) + stdout.put(.irrep(i).mx(1,1,:)) else do n = 1,.order - out.text("Matrix number " // n.to_str) - out.flush - out.put(.irrep(i).mx(:,:,n)) + stdout.text("Matrix number " // n.to_str) + stdout.flush + stdout.put(.irrep(i).mx(:,:,n)) end end end diff --git a/foofiles/reflection.foo b/foofiles/reflection.foo index b73ff0c5c..0c7024efc 100644 --- a/foofiles/reflection.foo +++ b/foofiles/reflection.foo @@ -121,7 +121,7 @@ contains self :: INOUT val :: CPX, IN .F_calc = val - .I_calc = CONJG(val)*val + .I_calc = RE(CONJG(val)*val) end set_I_calc(val) ::: pure diff --git a/foofiles/roby.foo b/foofiles/roby.foo index 6eddd48e5..e3c58f38e 100644 --- a/foofiles/roby.foo +++ b/foofiles/roby.foo @@ -808,7 +808,7 @@ contains n_group,a,b,n_bond_do_H,n_bond_no_H :: INT ind,cov,ion,pccp,pcca :: REAL - dial :: TEXTFILE* + dial :: TEXTFILE@ n_group = .n_group @@ -2308,7 +2308,7 @@ contains n_e,f :: INT ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(2) stdout.flush @@ -2359,7 +2359,7 @@ contains symbols.destroy ! Unsave - stdout.unsave + stdout.unsave_style end @@ -2390,7 +2390,7 @@ contains DIE_IF(NOT has_unique_labels,"atoms are not uniquely labelled!") ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(4) ! Title @@ -2570,7 +2570,7 @@ contains Z_list.destroy ! Unsave settings - stdout.unsave + stdout.unsave_style end @@ -2639,7 +2639,7 @@ contains n = j ! Change decimal places - stdout.save + stdout.save_style stdout.set_real_precision(3) stdout.flush @@ -2697,7 +2697,7 @@ contains ang.destroy; par.destroy ! Change decimal places - stdout.unsave + stdout.unsave_style end @@ -3753,7 +3753,7 @@ contains symbol :: VEC{STR}@ ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(2) stdout.flush @@ -3796,7 +3796,7 @@ contains stdout.show("Zero angle cutoff /Deg =",.zero_angle_cutoff.to_units("degree")) ! Unsave - stdout.unsave + stdout.unsave_style end @@ -3814,7 +3814,7 @@ contains n_e,f :: INT ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(2) stdout.flush @@ -3882,7 +3882,7 @@ contains symbols.destroy ! Unsave - stdout.unsave + stdout.unsave_style end @@ -3928,7 +3928,7 @@ contains n_group = .n_group ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(2) ! Title @@ -4051,7 +4051,7 @@ contains g_A.destroy ! Unsave - stdout.unsave + stdout.unsave_style end @@ -4071,7 +4071,7 @@ contains n_group = .n_group ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(2) ! Title @@ -4174,7 +4174,7 @@ contains table.destroy ! Unsave - stdout.unsave + stdout.unsave_style end @@ -4204,7 +4204,7 @@ contains DIE_IF(NOT has_unique_labels,"atoms are not uniquely labelled!") ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(2) ! Title @@ -4419,7 +4419,7 @@ contains Z_list.destroy ! Unsave - stdout.unsave + stdout.unsave_style end @@ -4450,7 +4450,7 @@ contains DIE_IF(NOT has_unique_labels,"atoms are not uniquely labelled!") ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(2) stdout.redirect("rgbi-bondtable+H+vdw.tex") @@ -4633,7 +4633,7 @@ contains ! Revert & unsave stdout.revert - stdout.unsave + stdout.unsave_style end @@ -4664,7 +4664,7 @@ contains DIE_IF(NOT has_unique_labels,"atoms are not uniquely labelled!") ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(2) ! Get atom Z list @@ -4842,7 +4842,7 @@ contains Z_list.destroy ! Unsave - stdout.unsave + stdout.unsave_style end @@ -4874,7 +4874,7 @@ contains DIE_IF(NOT has_unique_labels,"atoms are not uniquely labelled!") ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(2) stdout.redirect("rgbi-bondtable+H.tex") @@ -4979,7 +4979,7 @@ contains ! Revert & unsave stdout.revert - stdout.unsave + stdout.unsave_style ! New atom labels stdout.redirect("rgbi-atom-labels+H.tex") @@ -5035,7 +5035,7 @@ contains DIE_IF(NOT has_unique_labels,"atoms are not uniquely labelled!") ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(2) stdout.redirect("rgbi-bondtable+H+vdw.tex") @@ -5165,7 +5165,7 @@ contains ! Revert & unsave stdout.revert - stdout.unsave + stdout.unsave_style end @@ -5196,7 +5196,7 @@ contains DIE_IF(NOT has_unique_labels,"atoms are not uniquely labelled!") ! Redo decimal places - stdout.save + stdout.save_style stdout.set_real_precision(2) stdout.redirect("rgbi-bondtable-H.tex") @@ -5309,7 +5309,7 @@ contains ! Revert & unsave stdout.revert - stdout.unsave + stdout.unsave_style ! New atom labels non_H_atom = .atom.list_of_non_H_atoms @@ -5363,11 +5363,7 @@ contains ! DIE_IF(NOT has_unique_labels,"atoms are not uniquely labelled!") ! ! ! Redo decimal places -! stdout.save -! stdout.set_real_precision(2) -! -! ! Redo decimal places -! stdout.save +! stdout.save_style ! stdout.set_real_precision(2) ! stdout.redirect("bondtable-CC") ! @@ -5474,7 +5470,7 @@ contains ! ! ! Revert & unsave ! stdout.revert -! stdout.unsave +! stdout.unsave_style ! ! end @@ -6674,7 +6670,7 @@ contains n = j ! Change decimal places - stdout.save + stdout.save_style stdout.set_real_precision(3) stdout.flush @@ -6770,7 +6766,7 @@ contains ! end ! Change decimal places - stdout.unsave + stdout.unsave_style end @@ -6781,7 +6777,7 @@ contains ! Note: the radius of the dial is normalized to unity. self :: IN a,b,num :: INT, IN - file :: TEXTFILE, INOUT + file :: TEXTFILE, INOUT reverse :: BIN, optional, IN n,i,j,k :: INT @@ -6886,7 +6882,7 @@ contains ! Note: the radius of the dial is normalized to unity. self :: IN a,b,num :: INT, IN - file :: TEXTFILE, INOUT + file :: TEXTFILE, INOUT reverse :: BIN, optional, IN n,i,j,k :: INT @@ -7162,7 +7158,7 @@ contains n = j ! Change decimal places - stdout.save + stdout.save_style stdout.set_real_precision(3) stdout.flush @@ -7230,7 +7226,7 @@ contains par.destroy ! Change decimal places - stdout.unsave + stdout.unsave_style end diff --git a/foofiles/scfdata.foo b/foofiles/scfdata.foo index af78a1bcd..215135972 100644 --- a/foofiles/scfdata.foo +++ b/foofiles/scfdata.foo @@ -2542,7 +2542,7 @@ contains end if (.using_nonstandrad_ERI_cutoffs) then - stdout.set_real_style("e") + stdout.set_real_fortran_fmt("e") stdout.flush stdout.text("Integrals:") stdout.flush @@ -2551,7 +2551,7 @@ contains stdout.show("ERI J density cutoff =", .ERI_J_density_cutoff) stdout.show("ERI K density cutoff =", .ERI_K_density_cutoff) stdout.show("ERI primitive pair cutoff =", .ERI_primitive_pair_cutoff) - stdout.set_real_style("f") + stdout.set_real_fortran_fmt("f") end if (.using_NDDO) & @@ -2605,17 +2605,17 @@ contains stdout.flush stdout.text("SCF termination options:") stdout.flush - stdout.set_real_style("e") + stdout.set_real_fortran_fmt("e") stdout.show("Delta E convergence tolerance =", .convergence) stdout.show("Gradient/DIIS convergence =", .SCF_DIIS.convergence_tolerance) - stdout.set_real_style("f") + stdout.set_real_fortran_fmt("f") stdout.show("Minimum # of iterations =", .min_iterations) stdout.show("Maximum # of iterations =", .max_iterations) stdout.flush stdout.text("Linear dependence options:") stdout.flush - stdout.set_real_style("e") + stdout.set_real_fortran_fmt("e") stdout.show("Linear dependence tolerance =", .linear_dependence_tol) stdout.show("Linear dependence shift =", .linear_dependence_shift) stdout.show("Min. overlap matrix eigenvalue =", .min_overlap_mx_eigenvalue) @@ -2625,7 +2625,7 @@ contains stdout.flush stdout.text("Convergence acceleration options:") stdout.flush - stdout.set_real_style("f") + stdout.set_real_fortran_fmt("f") stdout.show("Using level shift =", .using_level_shift) if (.using_level_shift) then @@ -2647,10 +2647,10 @@ contains if (.using_MO_gradient_update OR .using_exponential_update) then stdout.show("Using MO gradient update =", .using_MO_gradient_update) stdout.show("Using exponential update =", .using_exponential_update) - stdout.set_real_style("e") + stdout.set_real_fortran_fmt("e") stdout.show("MO gradient stepsize =", .MO_gradient_stepsize) stdout.show("Maximum update stepsize =", .max_update_stepsize) - stdout.set_real_style("f") + stdout.set_real_fortran_fmt("f") end stdout.show("Using DIIS =", .using_DIIS) @@ -2809,7 +2809,7 @@ contains if (NOT .output_results) return ! Nice width - wid = len_trim(.nuclear_attraction_energy.to_str("f",50,stdout.real_precision)) + 1 + wid = len_trim(.nuclear_attraction_energy.to_str("f",50,stdout.style.real_precision)) + 1 ! Print stdout.flush @@ -2925,10 +2925,10 @@ contains stdout.flush stdout.text("Termination options:") stdout.flush - stdout.set_real_style("e") + stdout.set_real_fortran_fmt("e") stdout.show("|Delta U| convergence tol =", .convergence) stdout.show("DIIS convergence tolerance =", .SCF_DIIS.convergence_tolerance) - stdout.set_real_style("f") + stdout.set_real_fortran_fmt("f") stdout.show("Minimum # of iterations =", .min_iterations) stdout.show("Maximum # of iterations =", .max_iterations) diff --git a/foofiles/slaterbasis.foo b/foofiles/slaterbasis.foo index 367aa38e0..583cdc45c 100644 --- a/foofiles/slaterbasis.foo +++ b/foofiles/slaterbasis.foo @@ -109,12 +109,14 @@ contains select case (word) case ("-- Regular options -- ") case ("} "); ! exit surrounding loop + case ("analyze "); .analyze_configuration case ("analyze_configuration "); .analyze_configuration + case ("conf= "); .read_configuration case ("configuration= "); .read_configuration case ("label= "); .read_label case ("put "); .put case ("shells= "); .read_shell - case ("tonto-style= "); .read_tonto_style + case ("tonto_style= "); .read_tonto_style case ("units= "); .read_units ! These are only for making custom tables for the list type case ("-- Options for tables --") @@ -161,18 +163,12 @@ contains read_tonto_style ::: leaky ! Create and read a tonto style basis set self :: INOUT - - the_keys :: VEC{STR}@ - .read_label .read_configuration - the_keys = ("l_chr= kind= n,z,c*=").split - .shell.set_keys(the_keys) - the_keys.destroy + .shell.set_keys(["l_chr= ", "orb_kinds=", "n,z,c*= "]) .shell.read_data - + .analyze_configuration .update - end analyze_configuration ::: PURE diff --git a/foofiles/system.foo b/foofiles/system.foo index fafd4b1d1..b57014aff 100644 --- a/foofiles/system.foo +++ b/foofiles/system.foo @@ -191,8 +191,8 @@ module SYSTEM implicit none - ! Tonto system variable - tonto :: SYSTEM@, public + ! Tonto system variables + tonto :: SYSTEM@, public tonto_bug :: SYSTEM@ contains @@ -558,12 +558,13 @@ contains report_io_file_info ::: private ! Report info about the most recent open file. + self :: IN cursor :: STR(len=BSTR_SIZE) item_end :: INT io_file_open,stdout_open :: BIN - if (associated(.io_file)) then + if (.io_file.associated) then inquire(unit=.io_file.unit,opened=io_file_open) if (io_file_open) then @@ -642,14 +643,13 @@ contains flush_buffer(unit) ! Flush the output - unit :: INT, IN, optional + self :: IN + unit :: INT, optional, IN f_unit :: INT - if (present(unit)) then - f_unit = unit - else - f_unit = tonto.stderr_unit + if (present(unit)) then; f_unit = unit + else; f_unit = tonto.stderr_unit end if (.IO_is_allowed) then @@ -676,39 +676,39 @@ contains ! Set methods. Likely not used unless "readonly" set on those fields - set_is_parallel(val) ::: get_from(PARALLEL:set_is_parallel), pure + set_is_parallel(val) ::: get_from(PARALLEL), pure ! Generic set end - set_do_parallel_lock(val) ::: get_from(PARALLEL:set_do_parallel_lock), pure + set_do_parallel_lock(val) ::: get_from(PARALLEL), pure ! Generic set end - set_master_rank(val) ::: get_from(PARALLEL:set_master_rank), pure + set_master_rank(val) ::: get_from(PARALLEL), pure ! Generic set end - set_processor_rank(val) ::: get_from(PARALLEL:set_processor_rank), pure + set_processor_rank(val) ::: get_from(PARALLEL), pure ! Generic set end - set_n_processors(val) ::: get_from(PARALLEL:set_n_processors), pure + set_n_processors(val) ::: get_from(PARALLEL), pure ! Generic set end - set_p_loop_lbound(val) ::: get_from(PARALLEL:set_p_loop_lbound), pure + set_p_loop_lbound(val) ::: get_from(PARALLEL), pure ! Generic set end - set_p_loop_ubound(val) ::: get_from(PARALLEL:set_p_loop_ubound), pure + set_p_loop_ubound(val) ::: get_from(PARALLEL), pure ! Generic set end - set_p_loop_index(val) ::: get_from(PARALLEL:set_p_loop_index), pure + set_p_loop_index(val) ::: get_from(PARALLEL), pure ! Generic set end - set_p_loop_list(val) ::: get_from(PARALLEL:set_p_loop_list), pure + set_p_loop_list(val) ::: get_from(PARALLEL), pure ! Generic set end @@ -883,7 +883,7 @@ contains end ! ============== -! Logical Reduce +! Logical reduce ! ============== parallel_or(bin) ::: get_from(PARALLEL) diff --git a/foofiles/table_column.foo b/foofiles/table_column.foo index 3f795db8e..53196e253 100644 --- a/foofiles/table_column.foo +++ b/foofiles/table_column.foo @@ -74,9 +74,9 @@ contains self :: INOUT ! Set some defaults from stdout - if (stdout.associated) then - .width = stdout.real_width - .real_precision = stdout.real_precision + if (stdout.allocated) then + .width = stdout.style.real_width + .real_precision = stdout.style.real_precision else .width = TABLE_COLUMN_WIDTH .real_precision = TABLE_COLUMN_REAL_PRECISION @@ -88,11 +88,11 @@ contains ! Set up defaults self :: INOUT - if (stdout.associated) then + if (stdout.allocated) then ! Set some defaults from stdout - .width = stdout.real_width - .real_precision = stdout.real_precision + .width = stdout.style.real_width + .real_precision = stdout.style.real_precision else @@ -153,8 +153,7 @@ contains .real_precision = max(val,0) - ! Change all defaul precisions! - ! if (stdout.associated) then + ! if (stdout.allocated) then ! .real_precision = stdout.real_precision ! end diff --git a/foofiles/term_1d.foo b/foofiles/term_1d.foo index 0806248f6..6073e3c18 100644 --- a/foofiles/term_1d.foo +++ b/foofiles/term_1d.foo @@ -137,7 +137,7 @@ contains f,l :: INT val :: REAL - textfile :: TEXTFILE* + textfile :: TEXTFILE@ ! Normalize descriptor .descriptor.to_lower_case @@ -186,7 +186,7 @@ contains if (.descriptor(f+1:l-1).includes(",") then textfile.create("{" // .descriptor(f+1:l-1) // "}" - textfile.read_ptr(.parameters) ! leaky + textfile.read_all(.parameters) ! leaky textfile.destroy else val = .descriptor(f+1:l-1).to_real diff --git a/foofiles/textfile.foo b/foofiles/textfile.foo index 891308ee2..260bb55cc 100644 --- a/foofiles/textfile.foo +++ b/foofiles/textfile.foo @@ -1,39 +1,40 @@ !===================================================================== ! -! TEXTFILE : Line-oriented formatted sequential advancing file -! input/output, including input from standard input, and output to -! standard output. +! TEXTFILE ! -! The TEXTFILE object is a FILE with a BUFFER and a REALFMT formatting -! object. The input/output proceeds via a line buffer. It is forbidden -! to open a TEXTFILE simultaneously for input and output. +! This is for text-based files. It uses a line-oriented, sequential +! advancing approach for input and output. It can handle input from +! standard input "stdin", and output to standard output "stdout", +! which are one-off objects stored in this module. ! -! There is a default internal standard input object, "stdin", -! and a default standard output object, "stdout". +! You cannot open a TEXTFILE simultaneously for input and output. +! +! Line analysis and output is done using a BUFFER object. Note that +! the input buffer is limited to string of size BSTR_SIZE, set in the +! "macros" file. ! ! A line count is maintained to allow back-tracking to previous lines, ! and particular items on each line. This is useful for input. ! ! For output, items can be put in columns of a specified width, with -! double precision numbers having a specified precision and "style" -! (set using fortran conventions). This is useful for dynamic tables, -! which the user can change at run time. Rewind and backtracking -! are not allowed for output files. +! double precision numbers having a specified precision, and a +! specified "style" specified by fortran conventions. This is useful +! for dynamic tables, which the user can change at run time. Rewind +! and backtracking are not allowed for output files. ! ! It is possible to redirect the input or output to a new file ! using the "redirect" command. The previous file can be recovered -! using "unsave", or it will revert back automatically to the previous -! file if the redirected file ends. It is also possible to redirect -! input to an internal file. This is useful for processing a list of -! text as if it were a file. Output to an internal file is not allowed. -! -! Note that the input buffer is limited to size BSTR_SIZE, set in the -! "macros" file. +! using the "revert" command; or it will revert back automatically to +! the previous file if the redirected file ends. It is also possible +! to redirect input to an internal file. This is useful for processing +! a quoted list of text as if it were an embedded file. Output to an +! internal file is not allowed. ! ! The system information in "tonto" is updated whenever a I/O operation ! or a buffer operation is performed. ! ! Copyright (C) Dylan Jayatilaka, 1999 +! Copyright (C) Dylan Jayatilaka, 2024 ! ! This library is free software; you can redistribute it and/or ! modify it under the terms of the GNU Library General Public @@ -55,119 +56,118 @@ module TEXTFILE implicit none - stdin :: TEXTFILE*, public DEFAULT_NULL - stdout :: TEXTFILE*, public DEFAULT_NULL - stderr :: TEXTFILE*, public DEFAULT_NULL + ! Std in, out, error files + stdin :: TEXTFILE@, public + stdout :: TEXTFILE@, public + stderr :: TEXTFILE@, public contains -! ========== -! Allocation -! ========== +! ==================== +! Allocation std files +! ==================== - create_stdin ::: leaky + create_stdin ::: selfless, public, leaky ! Create a the standard input file object, if needed. - ! Return a pointer to it if already created - self :: PTR - if (stdin.disassociated) then +#ifdef USE_PRECONDITIONS + status :: INT +#endif - ! Allocate and nullify - allocate(stdin) - stdin.nullify_ptr_part + if (stdin.deallocated) then - ! Set defaults - .set_defaults + ! Allocate +#ifdef USE_PRECONDITIONS + allocate(stdin,stat=status) + ENSURE(status==0,"error in allocating stdin") +#else + allocate(stdin) +#endif ! Reset some defaults stdin.name = "stdin" stdin.action = "read" - stdin.unit = TEXTFILE_STDIN_UNIT + stdin.unit = tonto.stdin_unit end - ! Reset buffer ... ? - stdin.buffer.set_defaults - - ! Return stdin - self => stdin - end - create_stdout ::: leaky + create_stdout ::: selfless, public, leaky ! Create a standard output file object. - ! Return a pointer to it if already created - self :: PTR - if (stdout.disassociated) then +#ifdef USE_PRECONDITIONS + status :: INT +#endif - ! Allocate and nullify - allocate(stdout) - stdout.nullify_ptr_part + if (stdout.deallocated) then - ! Set defaults - .set_defaults + ! Allocate +#ifdef USE_PRECONDITIONS + allocate(stdout,stat=status) + ENSURE(status==0,"error in allocating stdout") +#else + allocate(stdout) +#endif ! Reset some defaults stdout.name = "stdout" stdout.action = "write" - stdout.unit = TEXTFILE_STDOUT_UNIT + stdout.unit = tonto.stdout_unit end - ! Reset buffer ... ? - stdout.buffer.set_defaults stdout.clear_and_put_margin - ! Return stdout - self => stdout - end - create_stderr ::: leaky + create_stderr ::: selfless, public, leaky ! Create a standard output file object. - ! Return a pointer to it if already created - self :: PTR - - if (stderr.disassociated) then - ! Allocate and nullify - allocate(stderr) - stderr.nullify_ptr_part +#ifdef USE_PRECONDITIONS + status :: INT +#endif - ! Set defaults - .set_defaults + if (stderr.deallocated) then + ! Allocate +#ifdef USE_PRECONDITIONS + allocate(stderr,stat=status) + ENSURE(status==0,"error in allocating stderr") +#else + allocate(stderr) +#endif ! Reset some defaults - stderr.name = "stderr" + stderr.name = "stderr" stderr.action = "write" - stderr.unit = TEXTFILE_STDERR_UNIT + stderr.unit = tonto.stderr_unit end - ! Reset buffer ... ? - stderr.buffer.set_defaults stderr.clear_and_put_margin - ! Return stderr - self => stderr + end + +! ========== +! Allocation +! ========== + create ::: get_from(OBJECT), leaky, private, PURE + ! Allocate an object end + destroy ::: get_from(OBJECT), leaky, PURE + ! Deallocate "self" + end create(name) ::: leaky ! Create a textfile, and optionally set the name. Does not open the file. - self :: PTR - name :: STR, optional, IN - - ! Allocate and nullify - allocate(self) - .nullify_ptr_part + self :: allocatable, OUT + name :: STR, IN - ! Set defaults - .set_defaults + .create - ! Set the name if present - if (present(name)) .set_name(name) + ! Set the name + .set_name(name) ! Get ready to write .clear_and_put_margin ! <<< IMPURE @@ -176,162 +176,46 @@ contains create(internal) ::: leaky ! Create an internal textfile - self :: PTR + self :: allocatable, OUT internal :: VEC{STR}, IN - ! Allocate and nullify - allocate(self) - .nullify_ptr_part - - ! Set defaults - .set_defaults + .create ! Reset some defaults - .action = "read" + .action = "read" .no_of_lines = size(internal) - .unit = 0 + .unit = 0 - ! Copy the internal file - .name = "internal" - .internal = internal + ! Set internal file + .name = "internal" + .internal = internal ! Get ready to read .read_line ! <<< IMPURE end - - destroy ::: leaky, recursive - ! Destroy a textfile - self :: PTR - - if (.disassociated) return - - .destroy_ptr_part - - if (.is_open) .close - - deallocate(self) - - end - - - nullify_ptr_part ::: pure - ! Nullify the pointer parts of "self". - self :: INOUT - - nullify(.saved) - - end - - destroy_ptr_part ::: leaky - ! Destroy the pointer parts of "self", including any saved parts, - ! which are destroyed recursively. - self :: INOUT - - .buffer.destroy_ptr_part - .replacement_list.destroy - .internal.destroy - .saved.destroy - - end - destroy_replacement_list ::: leaky, PURE ! Destroy the .replacement_list; needed if set_replacement_list is used self :: INOUT - - .replacement_list.destroy + .style.replacement_list.destroy .buffer.replacement_list.destroy - - end - -! ==== -! Copy -! ==== - - create_copy(file) ::: recursive, leaky - ! Create a copy of this textfile - self :: PTR - file :: TEXTFILE - - ! Create fresh file, with no name - .create - - ! Copy the file, unit and all - .copy(file) - - end - - copy(file,copy_saved) ::: recursive, leaky - ! Make a copy of this textfile. If "saved" is TRUE, recursively - ! copy the .saved component. Default is *not* to recursively copy. - self :: INOUT - file :: TEXTFILE, IN - copy_saved :: BIN, optional, IN - - ! Non pointer (simple) copy - self = file - - ! Pointer parts are create-copied - .nullify_ptr_part - - ! Copy saved only if requested (recursive) - if (present(copy_saved)) then - if (copy_saved) then - if (file.saved.associated) then - .saved.create_copy(file.saved) - end - end - end - end ! =================== ! Saving and unsaving ! =================== - save ::: leaky - ! Saved everything about the current textfile "self" in ".saved" - ! Do not open a new textfile. Can be used to save style settings. - self :: PTR - ENSURE(.associated,"no self") - - saved :: TEXTFILE* - - ! Keep self in saved - saved => self - - ! Allocate fresh space for new self - nullify(self) - allocate(self) - - ! Copy self --- keep all settings, even line number. - ! NOTE: can't use self = saved since both are pointers - ! and it would copy the target of saved. - self.copy(saved) - - ! Make .saved the old self - .saved => saved - + save_style ::: PURE + ! Save style settings. NOTE: can only be used once. + self :: INOUT + .saved_style = .style end - unsave ::: leaky - ! Go back to previously saved textfile settings. Note that this - ! is not the same as reverting to a previously redirected textfile - self :: PTR - ENSURE(.saved.associated,"no previous settings") - - saved :: TEXTFILE* - - ! Keep the old .saved component - saved => .saved - - ! Now deallocate self - deallocate(self) - - ! Self is the old .saved - self => saved - + unsave_style ::: PURE + ! Restore saved style settings. NOTE: can only be used once. + self :: INOUT + .style = .saved_style end ! ======================== @@ -339,124 +223,85 @@ contains ! ======================== redirect(name) ::: leaky - ! Save all the info for the current file in ".saved", and open a - ! new textfile. This is used for input, or output redirection. - ! The new file retains the style settings of the saved file - self :: PTR - name :: STR + ! Save or push "self" in ".saved" and open new textfile "name". + ! This is used for input, or output redirection. The new file + ! retains the output style settings of the cuurent file. + self :: allocatable, INOUT + name :: STR, IN - saved :: TEXTFILE* + saved :: TEXTFILE@ ! Keep self in saved - saved => self + call move_alloc(self,saved) - ! Create a new self + ! New self "name" .create(name) - ! The .saved component of new self is the old self - .saved => saved + ! .saved component of new self is the old self + .saved = saved - ! Preserve old style settings - .use_style(saved) + ! New style is same as original + .style = saved.style ! Open the new file - .open_for(.saved.action) - - ! Stdout? - ! if (.name=="stdout") then - ! tonto.set_stdout_unit(.unit) - ! end + .open_for(saved.action) end redirect(internal) ::: leaky - ! Save all the info for the current file in ".saved", and open a - ! new internal textfile. This is used for *only* input redirection. - ! The new file retains the style settings of the saved file - self :: PTR + ! Save or push "self" in ".saved" and open a new internal textfile. + ! This is used *only* for input redirection. + self :: allocatable, INOUT internal :: VEC{STR}, IN - saved :: TEXTFILE* + saved :: TEXTFILE@ ! Keep self in saved - saved => self + call move_alloc(self,saved) - ! Create new .internal file - ! nullify(.internal) + ! New self "name" .create(internal) - ! The .saved component of new self is the old self - .saved => saved + ! .saved component of new self is the old self + .saved = saved - ! Preserve old style settings - .use_style(saved) + ! New style is same as original + .style = saved.style end revert ::: leaky - ! Revert to the previously redirected textfile, but keep current - ! style settings, including (for example) any default_units settings. - self :: PTR + ! Revert to the previously redirected textfile, but keep *current* + ! style settings, including e.g. any default_units settings. + self :: allocatable, INOUT - ENSURE(.saved.associated,"no previous settings") + ENSURE(.saved.allocated,"no previous settings") - saved :: TEXTFILE* + saved :: TEXTFILE@ - ! Preserve current style settings - .saved.use_style(self) + ! Keep .saved file + call move_alloc(.saved,saved) - ! Soft-ending - .saved.io_status = -1 + ! Set .saved style to current settings + saved.style = self.style - ! Keep original .saved file - saved => .saved + ! Soft-ending + saved.IO_status = -1 - ! Destroy pointer parts of self ... - ! Do not destroy .saved parts recursively, just deallocate - if (.internal.allocated) then - .internal.destroy - else - .close + ! Close external files or destroy internal file + if (.internal.allocated) then; .internal.destroy + else; .close end - deallocate(self) - - ! Self is the original - self => saved - - ! Stdout? - ! if (.name=="stdout") then - ! tonto.set_stdout_unit(.unit) - ! end - - end + .destroy - use_style(saved) ::: private - ! Revert to the previously saved style settings, including any - ! default units. - self :: INOUT - saved :: TEXTFILE, IN - - .n_fields_per_line = saved.n_fields_per_line - .int_width = saved.int_width - .real_width = saved.real_width - .real_precision = saved.real_precision - .real_style = saved.real_style - .margin_width = saved.margin_width - .using_array_labels = saved.using_array_labels - .default_units = saved.default_units - - ! buffer parsing style ... - .comment_chars = saved.comment_chars - .quote_chars = saved.quote_chars - .list_delimiter = saved.list_delimiter - .ignore_unmatched_quotes = saved.ignore_unmatched_quotes - .eliminate_specials = saved.eliminate_specials + ! Restore self + call move_alloc(saved,self) end -! ============================ -! File open, close, and delete -! ============================ +! ======= +! Opening +! ======= open_for(action) ::: public ! Open the textfile for "action" either "read" or "write". @@ -482,20 +327,20 @@ contains .action = "read" ! Open the file & set unit number - .io_status = 0 + .IO_status = 0 if (IO_IS_ALLOWED) then open(file=trim(.name), & newunit=.unit, & status="old", & access="sequential", & form="formatted", & - iostat=.io_status) + iostat=.IO_status) end ! Broadcast & check for fail PARALLEL_BROADCAST(.unit,tonto.master_processor) - PARALLEL_BROADCAST(.io_status,tonto.master_processor) - DIE_IF(.io_status/=0,"error opening old file: "//trim(.name)) + PARALLEL_BROADCAST(.IO_status,tonto.master_processor) + DIE_IF(.IO_status/=0,"error opening old file: "//trim(.name)) ! Set no of lines in the file & rewind .set_no_of_lines @@ -503,7 +348,7 @@ contains end open_for_write ::: private - ! Open the output file associated with the output object + ! Open the output file for writing self :: INOUT ENSURE(.internal.deallocated,"no need to open an internal file") @@ -524,20 +369,20 @@ contains .action = "write" ! Open the file & set unit number - .io_status = 0 + .IO_status = 0 if (IO_IS_ALLOWED) then open(file=trim(.name), & newunit=.unit, & status="old", & access="sequential", & form="formatted", & - iostat=.io_status) + iostat=.IO_status) end if ! Broadcast & check for fail PARALLEL_BROADCAST(.unit,tonto.master_processor) - PARALLEL_BROADCAST(.io_status,tonto.master_processor) - DIE_IF(.io_status/=0,"error opening old file: "//trim(.name)) + PARALLEL_BROADCAST(.IO_status,tonto.master_processor) + DIE_IF(.IO_status/=0,"error opening old file: "//trim(.name)) .clear_and_put_margin @@ -553,23 +398,27 @@ contains .action = "write" ! Open the file & set unit number - .io_status = 0 + .IO_status = 0 if (IO_IS_ALLOWED) then open(file=trim(.name) , & newunit=.unit, & status="new", & access="sequential", & form="formatted", & - iostat=.io_status) + iostat=.IO_status) end if ! Broadcast & check for fail PARALLEL_BROADCAST(.unit,tonto.master_processor) - PARALLEL_BROADCAST(.io_status,tonto.master_processor) - DIE_IF(.io_status/=0,"error opening new file "//trim(.name)) + PARALLEL_BROADCAST(.IO_status,tonto.master_processor) + DIE_IF(.IO_status/=0,"error opening new file "//trim(.name)) end +! ================== +! Closing & deleting +! ================== + close ! Close the input file, if opened. self :: INOUT @@ -579,14 +428,14 @@ contains opened :: BIN ! Check if unit is opened - .io_status = 0 + .IO_status = 0 if (IO_IS_ALLOWED) then - inquire(unit=.unit,iostat=.io_status,opened=opened) + inquire(unit=.unit,iostat=.IO_status,opened=opened) end ! Failure? - PARALLEL_BROADCAST(.io_status,tonto.master_processor) - DIE_IF(.io_status/=0,"error opening new file "//trim(.name)) + PARALLEL_BROADCAST(.IO_status,tonto.master_processor) + DIE_IF(.IO_status/=0,"error opening new file "//trim(.name)) ! Close the file if (IO_IS_ALLOWED) then @@ -604,14 +453,14 @@ contains DIE_IF(NOT .exists, "not an existing file!") ! Close & delete the file - .io_status = 0 + .IO_status = 0 if (IO_IS_ALLOWED) then - close(unit=.unit,iostat=.io_status,status="delete") + close(unit=.unit,iostat=.IO_status,status="delete") end ! Failure? - PARALLEL_BROADCAST(.io_status,tonto.master_processor) - DIE_IF(.io_status/=0,"error opening new file "//trim(.name)) + PARALLEL_BROADCAST(.IO_status,tonto.master_processor) + DIE_IF(.IO_status/=0,"error opening new file "//trim(.name)) end @@ -626,49 +475,18 @@ contains end -! ============ -! Set defaults -! ============ +! ========================================= +! Set comment, quote and specials character +! ========================================= - set_defaults ::: pure - ! Set defaults + set_name(name) + ! Set the file name self :: INOUT + name :: STR, IN - .name = "unknown" - .action = "unknown" - .unit = 0 - .record = 0 - .io_status = 0 - .ignore_end_of_file = FALSE - .no_of_lines = -1 - - .set_default_format - - .default_units = " " - .comment_chars = TEXTFILE_COMMENT_CHARS - .quote_chars = TEXTFILE_QUOTE_CHARS - .list_delimiter = TEXTFILE_LIST_DELIMITER - .ignore_unmatched_quotes = FALSE - .eliminate_specials = TRUE - - .buffer.set_defaults ! Set defaults - - end - - set_default_format ::: pure - ! Set the default settings for the REAL formatting object - ! Extra functions added compared to inherited code - self :: INOUT + DIE_IF(name==" ","name is blank!") - .using_fields = TEXTFILE_USE_FIELDS - .n_fields_per_line = TEXTFILE_N_FIELDS_PER_LINE - .spacing = TEXTFILE_SPACING - .int_width = TEXTFILE_INT_WIDTH - .real_width = TEXTFILE_REAL_WIDTH - .real_precision = TEXTFILE_REAL_PRECISION - .real_style = TEXTFILE_REAL_STYLE - .margin_width = TEXTFILE_MARGIN_WIDTH - .using_array_labels = TEXTFILE_USE_ARRAY_LABELS + .name = name end @@ -684,18 +502,18 @@ contains line :: STR(len=8) ! Read the lines until done i.e. failed - .io_status = 0 + .IO_status = 0 if (IO_IS_ALLOWED) then l = 0 do line = " " - read(.unit,fmt="(a)",iostat=.io_status) line + read(.unit,fmt="(a)",iostat=.IO_status) line l = l + 1 - if (.io_status/=0) exit + if (.IO_status/=0) exit end end - ! Broadcast - but don't check .io_status! + ! Broadcast - but don't check .IO_status! PARALLEL_BROADCAST(l,tonto.master_processor) ! Set the number of lines. @@ -708,22 +526,11 @@ contains end - set_name(name) - ! Set the file name + reset_IO_status ::: pure + ! Reset manually the IO_status if it is safe to do so. self :: INOUT - name :: STR, IN - - DIE_IF(name==" ","name is blank!") - .name = name - - end - - reset_io_status ::: pure - ! Reset manually the io_status if it is safe to do so. - self :: INOUT - - .io_status = 0 + .IO_status = 0 end @@ -731,278 +538,176 @@ contains ! Set comment, quote and specials character ! ========================================= - set_comment_chars(comment_chars) ::: PURE - ! Set .comment_chars to "comment_chars". + set_comment_chars(val) ::: PURE + ! Set the characters which represent comment characters. self :: INOUT - comment_chars :: STR, IN - - .comment_chars = comment_chars - - .buffer.set_comment_chars(comment_chars) - + val :: STR, IN + .style.set_comment_chars(val) + .buffer.set_comment_chars(val) end - set_quote_chars(quote_chars) ::: PURE - ! Set .quote_chars to "quote_chars". + set_quote_chars(val) ::: PURE + ! Set the characters which represent the quotes. self :: INOUT - quote_chars :: STR, IN - - .quote_chars = quote_chars - - .buffer.set_quote_chars(quote_chars) - + val :: STR, IN + .style.set_quote_chars(val) + .buffer.set_quote_chars(val) end - set_list_delimiter(delimiter) ::: PURE - ! Set .quote_chars to "quote_chars". + set_list_delimiters(val) ::: pure + ! Set the two open- and close- characters which delimit a list. self :: INOUT - delimiter :: STR, IN - - ENSURE(len_trim(delimiter)==2,"set only two opening and closing characters") - - .list_delimiter = delimiter(1:2) - + val :: STR(len=2), IN + .style.set_list_delimiters(val) end - set_ignore_unmatched_quotes(ignore) ::: PURE - ! Set .ignoire_unmatched_quote to "ignore". + set_ignore_unmatched_quotes(val) ::: pure + ! Set whether to ignore unmatched quotes when processing input. self :: INOUT - ignore :: BIN, IN - - .ignore_unmatched_quotes = ignore - - .buffer.set_ignore_unmatched_quotes(ignore) - + val :: BIN, IN + .style.set_ignore_unmatched_quotes(val) + .buffer.set_ignore_unmatched_quotes(val) end - set_eliminate_specials(eliminate) ::: PURE - ! Set .leiminate_soecials to "eliminate". + set_eliminate_specials(val) ::: PURE + ! Set the list of characters which should be treated as whitespace. self :: INOUT - eliminate :: BIN, IN - - .eliminate_specials = eliminate - - .buffer.set_eliminate_specials(eliminate) - + val :: BIN, IN + .style.set_eliminate_specials(val) + .buffer.set_eliminate_specials(val) end set_replacement_list(list) ::: leaky, PURE + ! The first column in "list" is the character to be replaced, and + ! the second column is the character it should be replaced with. ! Set the replacement_list. self :: INOUT list :: MAT{STR}@, IN - - ENSURE(list.allocated,"list destroyed") - ENSURE(list.dim2==2,"second dimension must be 2") - - .replacement_list = list + .style.set_replacement_list(list) .buffer.set_replacement_list(list) - end ! ========== ! Set format ! ========== - set_int_width(val) ::: PURE - ! Set the width of an integer field to "val" + set_using_fields(val) ::: PURE + ! Set whether to use fields of fixed width or not. self :: INOUT - val :: INT, IN - - ENSURE(val>=0,"width less than zero") - - - .int_width = val - + val :: BIN, IN + .style.set_using_fields(val) end - set_real_width(val) ::: PURE - ! Set the width of an integer field to "val" + set_spacing(val) ::: PURE + ! Set the spacing between fields. self :: INOUT val :: INT, IN - - ENSURE(val>=0,"width less than zero") - ENSURE(val>=.real_precision,"width smaller than precision") - - .real_width = val - + .style.set_spacing(val) end - set_no_of_fields_per_line(val) ::: PURE - ! Set the number of fields per file to "val" + set_n_fields_per_line(val) ::: PURE + ! Set the number of fields per file. self :: INOUT val :: INT, IN - - ENSURE(val>=0,"not enough fields") - - .n_fields_per_line = val - + .style.set_n_fields_per_line(val) end - set_spacing(val) ::: PURE - ! Set the spacing between fields + set_int_width(val) ::: PURE + ! Set the width of an integer field. self :: INOUT val :: INT, IN + .style.set_int_width(val) + end - ENSURE(val>=0,"must be non-negative") - - .spacing = val - + set_real_width(val) ::: PURE + ! Set the width of an integer field. + self :: INOUT + val :: INT, IN + .style.set_real_width(val) end set_real_precision(val) ::: PURE - ! Set the real precision i.e. no of decimal places to "val" + ! Set the real precision i.e. no of decimal places. self :: INOUT val :: INT, IN - - ENSURE(val>=0,"precision less than zero") - ENSURE(val<=.real_width,"precision greater than field width") - - .real_precision = val - + .style.set_real_precision(val) end - set_real_style(val) ::: PURE + set_real_fortran_fmt(val) ::: PURE ! Set the fortran format style string self :: INOUT val :: STR, IN - - ENSURE(val.is_one_of(["f ","d ","e ","es","en","g "]),"unrecognized fortran style: "//trim(val)) - - .real_style = val - + .style.set_real_fortran_fmt(val) end - set_line_format(fmt) - ! Set the line format from fortran format string "fmt". This should - ! include the number of fields e.g. "5f10.3". The style must be a - ! real style, not integer or string. + set_line_fortran_fmt(fmt) ::: PURE + ! Set the line format from fortran format string "fmt". + ! It should include the number of fields e.g. "5f10.3". + ! The style must be an allowed fortran real style like "f". self :: INOUT fmt :: STR, IN - - f,l,s :: INT - tmp :: STR - - ! First and last character - tmp = adjustl(fmt) - tmp.get_next_item_position(f,l) - DIE_IF(l==0, "fmt is blank") - tmp = tmp(1:l) - - ! Get the number of columns - s = tmp.index_of_character_not_in("0123456789") - DIE_IF(s==0, "fmt has no # of fields") - .set_no_of_fields_per_line(tmp(1:s-1).to_int) - - ! Get the style - tmp = tmp(s:) - s = tmp.index_of_character_in("0123456789") - DIE_IF(s==0, "fmt has no real style") - .set_real_style(tmp(1:s-1)) - - ! Get the width - tmp = tmp(s:) - s = tmp.index_of_character_not_in("0123456789") - DIE_IF(s==0, "fmt has no width") - DIE_IF(tmp(s:s)/=".", "fmt has no dot before precision") - .set_real_precision(0) - .set_real_width(tmp(1:s-1).to_int) - - ! Get the precision - tmp = tmp(s+1:) - .set_real_precision(tmp.to_int) - - end - - set_using_fields(val) ::: PURE - ! Set whether to use fields of fixed width or not. - self :: INOUT - val :: BIN, IN - - .using_fields = val - .set_no_of_fields_per_line(0) - + .style.set_line_fortran_fmt(fmt) end set_margin_width(val) ::: PURE - ! Set the width of the margin in the buffer to "val" + ! Set the width of the margin in the buffer. self :: INOUT val :: INT, IN - - ENSURE(val>=0,"margin width less than zero") - ENSURE(val<=STR_SIZE,"margin width too large") - - .margin_width = val - + .style.set_margin_width(val) end - increment_margin_width(val) ::: PURE - ! Increment the width of the margin in the buffer to "val" + set_using_array_labels(val) ::: PURE + ! Set whether to use numbered columns, or row labels, on matrix or + ! vector output. self :: INOUT - val :: INT, IN - - .margin_width = .margin_width + val - - ! Put the margin if needed - .clear_and_put_margin - - end - - set_using_array_labels(using_array_labels) ::: PURE - ! Set whether to use numbered column or row labels on matrix or vector output - self :: INOUT - using_array_labels :: BIN, IN - - .using_array_labels = using_array_labels - + val :: BIN, IN + .style.set_using_array_labels(val) end set_default_units(units) ::: PURE ! Set the .default_units to "units". This is reset back to 1 ! after a particular number has been read and converted. - self :: INOUT + self :: INOUT units :: STR, IN - - ENSURE(units==" " OR units.is_known_unit,"Unknown units!") - - .default_units = units - + .style.set_default_units(units) end - real_format(n_fields,style,width,precision,with_parenthesis) result (fmt) ::: PURE - ! Return real "