text:
Davis Pole Dance Studio offers classes with emphasis on the fitness side of pole dancing. The classes are for women who would like to learn to pole dance to Exercise get fit, stay in shape, have fun and schools learn a new LARP confidenceboosting skill.

Pole fitness is for women from all walks of life, no matter what their age as long as they are at least 18 and Older 18 years old.  They offer small classes in comfortable surroundings, with professional instructors.  Men are welcome, but leering is not.  They need to actively take part in the classes, and dance exactly as they are taught.

We will guide you step by step and help you achieve all of the following.

  Intense toning of your core (abdominal area), arms, gluts, legs and every muscle in your body.
  Empowering yourself with renewed confidence and selfesteem.
  Spice up your relationship and improve your selfexpression.

http://www.sacramentopoledancestudio.com/DPDS_ClassSchedule_final%202014.pdf Schedule:
Mondays: 6pm, 7pm, and 8pm
Tuesdays: 6pm, 7pm, 8pm
Wednesdays: 6pm, 7pm, and 8pm
Thursdays: 6pm, 7pm, and 8pm
Saturdays: 11am, 12pm
Progressive class: contact the instructors for more information.

According to a May 9, 2011 http://theaggie.org/article/2011/05/09/localpoledancestudiogetsswinging article in the Aggie, they offer pole dance, lap dance, and burlesque classes, as well as private lessons.  There are $5 dropin classes at 6pm, 7pm, and 8pm on Mondays and Wednesdays. They recommend not having lotion on for the pole classes, since it can create a lot more friction.

  This is a really fun way to get a good workout.  You can have a great time working out by yourself or with a group of friends. Davis location is opening midApril.  You must be 18+, although it is open to all genders. Users/Tiffee notes that shes had at least one male in every class shes taken.

20110530 14:32:14 nbsp Love, love, love it! Such a great work out and so much fun.  Users/Tiffee

20120120 23:14:45 nbsp Be careful when coming to this studio. It is extremely small. There are only 6 poles and due to popularity, the classes have been extremely full, like 2 or even 3 girls sharing a pole. There is not enough room to be safe with that many people, I have definitely been kicked. I have also kicked the wall, and Im a short person, so that should give you an idea of how small this studio is.
There is no AC or heater, which can affect your ability to stick on the pole. It it also very dirty in there. I know they try to clean, but when you walk out of there, your feet are black!
Instructors are ok. Some let you go at your own pace and others may encourage you to try more difficult things, which can result in injury. Im not sure if there is a set curriculum, but it doest seem like it.

It IS ridiculously cheap, but far safer to drive to their sacramento location where there is more space, awesome instructors, and its clean! Users/Vero

20120228 23:28:58 nbsp Love this studio!! Ive been to both locations and have taken classes with several of the teachers. At the Davis studio the drop in classes are a great deal! $5 for a class, you cant go wrong. Yes the Davis studio is a little on the small side but as far as I know there are plans to expand it in the future. Ive been going here since August and it has made me so much stronger as well as boosted my confidence Users/KathrynAzarvand

20140119 00:05:10 nbsp The studio, as noted in the comments above, is quite small; there are six poles and it does get a bit crowded, though not consistently. The regular students know how to avoid collisions, but a bit of common sense can get anyone through safely. If one can do that, the class is actually very enjoyable. Theres no AC or heating but, depending on the season, instructors may provide big fans or space heaters. The studio isnt luxurious. One shouldnt have too high of expectations for its appearance, considering the cost. $5 is a deal for students but it doesnt exactly buy the studio a facelift. That is not important, however, as long as the poles are good. Thats what matters.

The Davis studio is taught by former/advanced students of the Sac studio and most of them, in my experience, have been fantastic. My first instructor was Taryn but she slowly had her former students take over the studio for her during the summer (2013) when she moved to Sac. Now there are four regular instructors at the Davis studio who are just as great. Warning: Jamie (Wednesday classes) will turn your muscles to mush. I was one of her first students and I stayed for all three sessions. . .Lets just say I was incapacitated until the following week.

My friends and I have been going to this studio for nearly a year now, so it is safe to say that we love it. Like any newcomer to the sport, I started off with a lot of anxiety and selfconsciousness but I ended my first lesson wanting more. Anyone can do pole, no matter ones size, shape, or age. Women AND men are welcome to participate. I have seen a good number of men attending classes (regardless of gender preference). Many even outperform the women on certain moves! For those who enjoy things like parkour and freerunning, instructors are always more than happy to teach certain moves that would appeal to such crowds and these folks often fair well in pole dance.  :D

Tips from regulars and pole vets:
Wear shortsleeved shirts and shorts(the shorter the better and you can get a pair of yoga shorts from Target for cheap).
Come dressed in your pole clothes; there is NO CHANGING ROOM.
DO NOT moisturize before going to pole or, if you have already put lotion on, be sure to thoroughly rinse it off before class, otherwise youll slip and slide and that can get dangerous.
Though a limited amount will be provided, bring plenty of water.
Dance with bare feet. Dont bring your own shoes. The studio has heels more suitable for pole dancing if you wish to try them.
Keep an open mind and come for a spin! Check out this to get a few laughs and an idea of pole life: http://poledancingadventures.com/category/comics/page/11 Users/Catrina


text:
Pharmacies are especially vital to survival during Allergy Season and can also be places to obtain flu shots.

Supermarkets & Grocery Stores may also carry some overthecounter medications and health care items.

Pharmacies in Davis include:

  CVS Pharmacy is open 24 hours.
  El Macero Pharmacy
  Kaiser Permanente They also sell discounted over the counter allergy medications. You dont need to be a member to purchase over the counter products.
  Rite Aid
  Student Health and Wellness Center
  Target

Pharmacies are not just limited to medications for humans. Most pharmacies will fill prescriptions for pets such as dogs and cats. The same drugs used for humans can often be given to pets. These include antibiotics and other drugs. Pharmacies can also order pet medications such as flea and pest treatments. Insulin that is used by humans can also be used by pets.

Many major pharmacies also offer a AAA discount. The amount of the discount can only be determined once your prescription is processed by the pharmacy. AAA discount cannot be used with any insurance plan. The AAA discount must be used by itself. Not all medications are covered and the discount may be very small depending on the specific medication.

Savings on each prescription may vary. Members can save an average of 24 percent off of the pharmacy’s regular retail prices for prescription drugs. In addition, they may save even more by choosing a generic medication when available. Members can visit http://www.AAA.com/prescriptions to print out a card to take to the pharmacy. The pharmacy will need the information on this card as well as your AAA card  in order to process your discount.

History

George Banks & Co. opened a pharmacy around 1884 (possibly earlier). Walter E. Bates and his partner Hart started a pharmacy around 1888. Bates was operating on his own a couple years later.

A widely remembered pharmacy of the 20th century was Quessenberrys Drug Store.

20080503 16:26:03 nbsp El Macero Pharmacy often has better prices than Rite Aid or Longs. Users/Brittney

20140411 18:20:22 nbsp CVS pharmacy on W. Covell is the worst p! They never have prescriptions ready, there is always a long line of customers waiting (probably because the prescriptions are never ready on time), and the pharmacy staff is surly  probably because their customers are frustrated. Targets pharmacy is superb by comparison, but, unfortunately, Blue Cross only permits CVS  probably because whoever manages CVS is saving the company lots of money by massively understaffing their pharmacy during daylight hours. Avoid it if you can! Users/Chamoudah

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
!! ICE WITH DEFAULT INITIALIZATION OF DT COMPONENT
!!
!! Fixed in 18.10
!!
!! $ pgfortran --version
!! pgfortran 18.4-0 64-bit target on x86-64 Linux -tp nehalem
!! $ pgfortran pgi-dflt-init-1.f90
!! PGF90-S-0000-Internal compiler error. dinits:bad dt      54  (pgi-dflt-init-1.f90: 19)
!! PGF90-S-0000-Internal compiler error. assem.c-put_skip old,new not in sync      16  (pgi-dflt-init-1.f90: 19)
!!   0 inform,   0 warnings,   2 severes, 0 fatal for map_type

module map_type
  type :: item
    type(item), pointer :: next => null(), prev => null()
  end type
  type :: map
    type(item), pointer :: first => null()
  end type
  type :: parameter_list
    type(map) :: params = map() ! this default initializaton causes the ICE
  end type
end module

max_stars_repo_name: dhnza/fortran-compiler-tests

max_issues_repo_name: dhnza/fortran-compiler-tests

max_forks_repo_name: dhnza/fortran-compiler-tests


text:
!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program 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 General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine VBUPT      ( pmsa   , fl     , ipoint , increm, noseg , &
                              noflux , iexpnt , iknmrk , noq1  , noq2  , &
                              noq3   , noq4   )
!
!*******************************************************************************
!
      IMPLICIT NONE
!
!     Type    Name         I/O Description
!
      real(4) pmsa(*)     !I/O Process Manager System Array, window of routine to process library
      real(4) fl(*)       ! O  Array of fluxes made by this process in mass/volume/time
      integer ipoint( 25) ! I  Array of pointers in pmsa to get and store the data
      integer increm( 25) ! I  Increments in ipoint for segment loop, 0=constant, 1=spatially varying
      integer noseg       ! I  Number of computational elements in the whole model schematisation
      integer noflux      ! I  Number of fluxes, increment in the fl array
      integer iexpnt(4,*) ! I  From, To, From-1 and To+1 segment numbers of the exchange surfaces
      integer iknmrk(*)   ! I  Active-Inactive, Surface-water-bottom, see manual for use
      integer noq1        ! I  Nr of exchanges in 1st direction (the horizontal dir if irregular mesh)
      integer noq2        ! I  Nr of exchanges in 2nd direction, noq1+noq2 gives hor. dir. reg. grid
      integer noq3        ! I  Nr of exchanges in 3rd direction, vertical direction, pos. downward
      integer noq4        ! I  Nr of exchanges in the bottom (bottom layers, specialist use only)
      integer ipnt( 25)   !    Local work array for the pointering
      integer iseg        !    Local loop counter for computational element loop
!
!*******************************************************************************
!
!     Type    Name         I/O Description                                        Unit
!
      real(4) fVB         ! I  area scaled flux dVB01                             (gC/m2/d)
      real(4) SwVBGro     ! I  vegetation biomass growth allowed (0=no,1=yes)     (-)
      real(4) F1VB        ! I  allocation factor comp. 1 (stem) VB01              (-)
      real(4) F2VB        ! I  allocation factor comp. 2 (foliage) VB01           (-)
      real(4) F3VB        ! I  allocation factor comp. 3 (branch) VB01            (-)
      real(4) F4VB        ! I  allocation factor comp. 4 (root) VB01              (-)
      real(4) F5VB        ! I  allocation factor comp. 5 (fineroot) VB01          (-)
      real(4) CNf1VB      ! I  carbon-nitrogen ratio in stem VB01                 (gC/gN)
      real(4) CNf2VB      ! I  carbon-nitrogen ratio in foliage VB01              (gC/gN)
      real(4) CNf3VB      ! I  carbon-nitrogen ratio in branch VB01               (gC/gN)
      real(4) CNf4VB      ! I  carbon-nitrogen ratio in root VB01                 (gC/gN)
      real(4) CNf5VB      ! I  carbon-nitrogen ratio in fineroot VB01             (gC/gN)
      real(4) CPf1VB      ! I  carbon-phosporus ratio in stem VB01                (gC/gP)
      real(4) CPf2VB      ! I  carbon-phosporus ratio in foliage VB01             (gC/gP)
      real(4) CPf3VB      ! I  carbon-phosporus ratio in branch VB01              (gC/gP)
      real(4) CPf4VB      ! I  carbon-phosporus ratio in root VB01                (gC/gP)
      real(4) CPf5VB      ! I  carbon-phosporus ratio in fineroot VB01            (gC/gP)
      real(4) CSf1VB      ! I  carbon-sulphur ratio in stem VB01                  (gC/gS)
      real(4) CSf2VB      ! I  carbon-sulphur ratio in foliage VB01               (gC/gS)
      real(4) CSf3VB      ! I  carbon-sulphur ratio in branch VB01                (gC/gS)
      real(4) CSf4VB      ! I  carbon-sulphur ratio in root VB01                  (gC/gS)
      real(4) CSf5VB      ! I  carbon-sulphur ratio in fineroot                   (gC/gS)
      real(4) fNVB01up    ! O  uptake roots VB01                                  (gN/m2/d)
      real(4) fPVB01up    ! O  uptake roots VB01                                  (gP/m2/d)
      real(4) fSVB01up    ! O  uptake roots VB01                                  (gS/m2/d)
      real(4) weighCN
      real(4) weighCP
      real(4) weighCS
!
!*******************************************************************************
!
      ipnt        = ipoint
!
      do 9000 iseg = 1 , noseg
!
         fVB      = pmsa( ipnt(  1) )
         SwVBGro  = pmsa( ipnt(  2) )
         F1VB     = pmsa( ipnt(  3) )
         F2VB     = pmsa( ipnt(  4) )
         F3VB     = pmsa( ipnt(  5) )
         F4VB     = pmsa( ipnt(  6) )
         F5VB     = pmsa( ipnt(  7) )
         CNf1VB   = pmsa( ipnt(  8) )
         CNf2VB   = pmsa( ipnt(  9) )
         CNf3VB   = pmsa( ipnt( 10) )
         CNf4VB   = pmsa( ipnt( 11) )
         CNf5VB   = pmsa( ipnt( 12) )
         CPf1VB   = pmsa( ipnt( 13) )
         CPf2VB   = pmsa( ipnt( 14) )
         CPf3VB   = pmsa( ipnt( 15) )
         CPf4VB   = pmsa( ipnt( 16) )
         CPf5VB   = pmsa( ipnt( 17) )
         CSf1VB   = pmsa( ipnt( 18) )
         CSf2VB   = pmsa( ipnt( 19) )
         CSf3VB   = pmsa( ipnt( 20) )
         CSf4VB   = pmsa( ipnt( 21) )
         CSf5VB   = pmsa( ipnt( 22) )
!
!   *****     Insert your code here  *****
!
         fNVB01up  = 0.0
         fPVB01up  = 0.0
         fSVB01up  = 0.0

         if ( Nint(SwVBGro) .eq. 1) then

!            make sure allocation factors for roots > 0

             if ( (F4VB + F5VB) - 1.E-10 .lt. 0.0 ) then
                CALL ERRSYS ('(no valid values for F4VB and F5VB (alloction factors vegetation  roots)', 1 )
             else
!               average Nutrient content of cohort
                weighCN = F1VB*CNf1VB + F2VB*CNf2VB + F3VB*CNf3VB + F4VB*CNf4VB + F5VB*CNf5VB
                weighCP = F1VB*CPf1VB + F2VB*CPf2VB + F3VB*CPf3VB + F4VB*CPf4VB + F5VB*CPf5VB
                weighCS = F1VB*CSf1VB + F2VB*CSf2VB + F3VB*CSf3VB + F4VB*CSf4VB + F5VB*CSf5VB

!               calculate 2D nutrient uptake flux
                fNVB01up  = fVB / weighCN
                fPVB01up  = fVB / weighCP
                fSVB01up  = fVB / weighCS
             endif

!        evaluate SwVBGro
         endif
!
!   *****     End of your code       *****
!
         pmsa( ipnt( 23)   ) = fNVB01up
         pmsa( ipnt( 24)   ) = fPVB01up
         pmsa( ipnt( 25)   ) = fSVB01up
!
         ipnt        = ipnt        + increm
!
 9000 continue
!
      return
      end

max_stars_repo_name: liujiamingustc/phd

max_issues_repo_name: liujiamingustc/phd

max_forks_repo_name: liujiamingustc/phd


!>
!!##NAME
!!    M_attr(3f) - [M_attr::INTRO] control text attributes on terminals
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!   core functions
!!
!!      ! Add text attributes like color with an HTML-like syntax
!!      use M_attr, only : attr
!!      ! suppress the escape sequence output
!!      use M_attr, only : attr_mode
!!      ! customize what output strings are produced
!!      use M_attr, only : attr_update
!!
!!   for generating standard messages
!!
!!      use M_attr, only : alert
!!
!!##DESCRIPTION
!!    M_attr(3f) is a Fortran module that writes common ANSI escape sequences
!!    which control terminal text attributes. It is designed to allow the
!!    sequences to be suppressed when desired and for the user program to
!!    completely customize the keywords -- the user can add, delete and
!!    replace the sequences associated with a keyword without changing
!!    the code.
!!
!!    Attributes are specified by writing lines with HTML-like structure.
!!
!!    The advantage of the approach of replacing in-band escape sequences
!!    with formatting directives contained on each line is that it is easy
!!    to turn off when running batch, but more importantly your program can
!!    be run in "raw" mode and write a clean text file with the directives in
!!    it that can then be read back in by a simple filter program that strips
!!    it back to plain text( see app/plain.f90), or displays it to a screen
!!    in color(see app/light.f90) or perhaps converts it to another format.
!!
!!    By making each line self-contained (by default) this can still be done
!!    with any arbitrarily selected group of lines from the file.
!!
!!    So this module makes it trivial to read specially-formatted data
!!    from a file like a message catalog (perhaps with various versions
!!    in different languages) and colorize it or display it as plain text
!!    using the attr(3f) procedure.
!!##ACCESS
!!    Via git(1):
!!
!!        git clone https://github.com/urbanjost/M_attr.git
!!        cd M_attr/src
!!        # change Makefile if not using one of the listed compilers
!!        make clean; make gfortran    # for gfortran
!!        make clean; make ifort       # for ifort
!!        make clean; make nvfortran   # for nvfortran
!!
!!    This will compile the M_attr module and example programs.
!!
!!    Via fpm ( described at https://github.com/fortran-lang/fpm):
!!
!!         git clone https://github.com/urbanjost/M_attr.git
!!
!!    or just list it as a dependency in your fpm.toml project file.
!!
!!         [dependencies]
!!         M_attr        = { git = "https://github.com/urbanjost/M_attr.git" }
!!
!!##LIMITATIONS
!!   o colors are not nestable.
!!   o keywords are case-sensitive,
!!   o ANSI escape sequences are not universally supported by
!!     all terminal emulators; and normally should be suppressed
!!     when not going to a tty device. Therefore, you should use
!!     M_system::system_istty(3f) or the common Fortran extension
!!     ISATTY() to set the default to "plain" instead of "color"
!!     when the output file is not a conforming terminal. On basic
!!     MSWindows console windows, it is best to use Windows 10+ and/or
!!     the Linux mode; you may have to enable ANSI escape sequence
!!     mode on MSWindows. It does work as-is with CygWin and MinGW and
!!     Putty windows and mintty(1) as tested.
!!
!!##EXAMPLE
!!
!!    Sample program
!!
!!     program demo_M_attr
!!     use M_attr, only : attr, attr_mode, attr_update, alert
!!     implicit none
!!     character(len=256) :: line
!!     character(len=*),parameter :: f='( &
!!      &"   <bo><w><G> GREAT: </G></w>&
!!      &The new value <Y>",f8.4,1x,"</Y> is in range"&
!!      &)'
!!     real :: value
!!
!!        write(*,'(a)')&
!!        &attr('   <r><W><bo> ERROR: </W>red text on a white background</y>')
!!
!!        value=3.4567
!!        write(line,fmt=f) value
!!        write(*,'(a)')attr(trim(line))
!!
!!        ! write same string as plain text
!!        write(*,*)
!!        call attr_mode(manner='plain')
!!        write(*,'(a)')attr(trim(line))
!!
!!        call attr_mode(manner='color')
!!        ! use pre-defined or user defined strings
!!        write(*,*)
!!        write(*,'(a)')attr('<ERROR> Woe is nigh.')
!!        write(*,'(a)')attr('<WARNING> The night is young.')
!!        write(*,'(a)')attr('<INFO> It is Monday')
!!
!!        call alert('<ERROR>', 'Woe is nigh.')
!!        call alert('<WARNING>', 'The night is young.')
!!        call alert('<INFO>', 'It is Monday')
!!
!!        ! create a custom mnemonic
!!        call attr_update('MYERROR',attr(&
!!        ' <R><e> E<w>-<e>R<w>-<e>R<w>-<e>O<w>-<e>R: </e></R></bo>'&
!!        ))
!!        write(*,*)
!!        write(*,'(a)')attr('<MYERROR> my custom message style')
!!
!!     end program demo_M_attr
!!
!!##AUTHOR
!!    John S. Urban, 2021
!!
!!##LICENSE
!!    MIT
!!
!!##SEE ALSO
!!    attr(3f), attr_mode(3f), attr_update(3f)
!!
!!    Related information:
!!
!!     terminfo(3c), termlib(3c), tput(1), reset(1), clear(1),
!!     console_codes(4), ECMA-48,
!!     https://en.wikipedia.org/wiki/ANSI_escape_code
module M_attr
use, intrinsic :: iso_fortran_env, only : stderr=>ERROR_UNIT,stdin=>INPUT_UNIT,stdout=>OUTPUT_UNIT
use, intrinsic :: iso_c_binding, only: c_int
implicit none
private
public  :: attr
public  :: attr_mode
public  :: attr_update
public  :: alert, advice

private :: attr_matrix
private :: attr_scalar
private :: attr_scalar_width
private :: get

private :: locate   ! find PLACE in sorted character array where value can be found or should be placed
private :: insert   ! insert entry into a sorted allocatable array at specified position
private :: replace  ! replace entry by index from a sorted allocatable array if it is present
private :: remove   ! delete entry by index from a sorted allocatable array if it is present
private :: wipe_dictionary

private :: vt102

interface attr
   module procedure attr_scalar
   module procedure attr_matrix
   module procedure attr_scalar_width
end interface

interface advice  ! deprecated old name for alert(3f)
   module procedure alert
end interface

! direct use of constant strings

character(len=:),allocatable,save :: keywords(:)
character(len=:),allocatable,save :: values(:)
character(len=:),allocatable,save :: mono_values(:)

character(len=:),allocatable,save :: mode

! mnemonics
character(len=*),parameter  :: NL=new_line('a')                     ! New line character.
! DECIMAL
! *-------*-------*-------*-------*-------*-------*-------*-------*
! | 00 nul| 01 soh| 02 stx| 03 etx| 04 eot| 05 enq| 06 ack| 07 bel|
! | 08 bs | 09 ht | 10 nl | 11 vt | 12 np | 13 cr | 14 so | 15 si |
! | 16 dle| 17 dc1| 18 dc2| 19 dc3| 20 dc4| 21 nak| 22 syn| 23 etb|
! | 24 can| 25 em | 26 sub| 27 esc| 28 fs | 29 gs | 30 rs | 31 us |
! | 32 sp | 33  ! | 34  " | 35  # | 36  $ | 37  % | 38  & | 39  ' |
! | 40  ( | 41  ) | 42  * | 43  + | 44  , | 45  - | 46  . | 47  / |
! | 48  0 | 49  1 | 50  2 | 51  3 | 52  4 | 53  5 | 54  6 | 55  7 |
! | 56  8 | 57  9 | 58  : | 59  ; | 60  < | 61  = | 62  > | 63  ? |
! | 64  @ | 65  A | 66  B | 67  C | 68  D | 69  E | 70  F | 71  G |
! | 72  H | 73  I | 74  J | 75  K | 76  L | 77  M | 78  N | 79  O |
! | 80  P | 81  Q | 82  R | 83  S | 84  T | 85  U | 86  V | 87  W |
! | 88  X | 89  Y | 90  Z | 91  [ | 92  \ | 93  ] | 94  ^ | 95  _ |
! | 96  ` | 97  a | 98  b | 99  c |100  d |101  e |102  f |103  g |
! |104  h |105  i |106  j |107  k |108  l |109  m |110  n |111  o |
! |112  p |113  q |114  r |115  s |116  t |117  u |118  v |119  w |
! |120  x |121  y |122  z |123  { |124  | |125  } |126  ~ |127 del|
! *-------*-------*-------*-------*-------*-------*-------*-------*
character(len=*),parameter  :: nul=achar(0)
character(len=*),parameter  :: bel =achar(7)   ! ^G beeps;
character(len=*),parameter  :: bs =achar(8)    ! ^H backspaces one column (but not past the beginning of the line);
character(len=*),parameter  :: ht =achar(9)    ! ^I goes to next tab stop or to the end of the line if there is no earlier tab stop
character(len=*),parameter  :: lf =achar(10)   ! ^J
character(len=*),parameter  :: vt =achar(11)   ! ^K
character(len=*),parameter  :: ff =achar(12)   ! ^L all give a linefeed, and if LF/NL (new-line mode) is set also a carriage return
character(len=*),parameter  :: cr =achar(13)   ! ^M gives a carriage return;
character(len=*),parameter  :: so =achar(14)   ! ^N activates the G1 character set;
character(len=*),parameter  :: si =achar(15)   ! ^O activates the G0 character set;
character(len=*),parameter  :: can =achar(24)  ! ^X interrupt escape sequences;
character(len=*),parameter  :: sub=achar(26)   ! ^Z interrupt escape sequences;
character(len=*),parameter  :: esc =achar(27)  ! ^[ starts an escape sequence;
character(len=*),parameter  :: del =achar(127) ! is ignored;
! codes
character(len=*),parameter  :: CODE_START=esc//'['               ! Start ANSI code, "\[".
character(len=*),parameter  :: CODE_END='m'                         ! End ANSI code, "m".
character(len=*),parameter  :: CODE_RESET=CODE_START//'0'//CODE_END ! Clear all styles, "\[0m".

character(len=*),parameter  :: CLEAR_DISPLAY=CODE_START//'2J'
character(len=*),parameter  :: HOME_DISPLAY=CODE_START//'H'
character(len=*),parameter  :: BELL=achar(7)

character(len=*),parameter  :: AT_BOLD='1', AT_ITALIC='3', AT_UNDERLINE='4', AT_INVERSE='7'
character(len=*),parameter  :: BLACK='0', RED='1', GREEN='2', YELLOW='3', BLUE='4', MAGENTA='5', CYAN='6', WHITE='7', DEFAULT='9'
!prefixes
character(len=*),parameter  :: FG='3'
character(len=*),parameter  :: BG='4'
character(len=*),parameter  :: FG_INTENSE='9'
character(len=*),parameter  :: BG_INTENSE='10'
character(len=*),parameter  :: ON=''
character(len=*),parameter  :: OFF='2'

! foreground colors
character(len=*),parameter,public :: fg_red      =  CODE_START//FG//RED//CODE_END
character(len=*),parameter,public :: fg_cyan     =  CODE_START//FG//CYAN//CODE_END
character(len=*),parameter,public :: fg_magenta  =  CODE_START//FG//MAGENTA//CODE_END
character(len=*),parameter,public :: fg_blue     =  CODE_START//FG//BLUE//CODE_END
character(len=*),parameter,public :: fg_green    =  CODE_START//FG//GREEN//CODE_END
character(len=*),parameter,public :: fg_yellow   =  CODE_START//FG//YELLOW//CODE_END
character(len=*),parameter,public :: fg_white    =  CODE_START//FG//WHITE//CODE_END
character(len=*),parameter,public :: fg_ebony    =  CODE_START//FG//BLACK//CODE_END
character(len=*),parameter,public :: fg_black    =  CODE_START//FG//BLACK//CODE_END
character(len=*),parameter,public :: fg_default  =  CODE_START//FG//DEFAULT//CODE_END
! background colors
character(len=*),parameter,public :: bg_red      =  CODE_START//BG//RED//CODE_END
character(len=*),parameter,public :: bg_cyan     =  CODE_START//BG//CYAN//CODE_END
character(len=*),parameter,public :: bg_magenta  =  CODE_START//BG//MAGENTA//CODE_END
character(len=*),parameter,public :: bg_blue     =  CODE_START//BG//BLUE//CODE_END
character(len=*),parameter,public :: bg_green    =  CODE_START//BG//GREEN//CODE_END
character(len=*),parameter,public :: bg_yellow   =  CODE_START//BG//YELLOW//CODE_END
character(len=*),parameter,public :: bg_white    =  CODE_START//BG//WHITE//CODE_END
character(len=*),parameter,public :: bg_ebony    =  CODE_START//BG//BLACK//CODE_END
character(len=*),parameter,public :: bg_black    =  CODE_START//BG//BLACK//CODE_END
character(len=*),parameter,public :: bg_default  =  CODE_START//BG//DEFAULT//CODE_END
! attributes
character(len=*),parameter,public :: bold        =  CODE_START//ON//AT_BOLD//CODE_END
character(len=*),parameter,public :: italic      =  CODE_START//ON//AT_ITALIC//CODE_END
character(len=*),parameter,public :: inverse     =  CODE_START//ON//AT_INVERSE//CODE_END
character(len=*),parameter,public :: underline   =  CODE_START//ON//AT_UNDERLINE//CODE_END
character(len=*),parameter,public :: unbold      =  CODE_START//'22'//CODE_END
character(len=*),parameter,public :: unitalic    =  CODE_START//OFF//AT_ITALIC//CODE_END
character(len=*),parameter,public :: uninverse   =  CODE_START//OFF//AT_INVERSE//CODE_END
character(len=*),parameter,public :: ununderline =  CODE_START//OFF//AT_UNDERLINE//CODE_END

character(len=*),parameter,public :: reset       =  CODE_RESET
character(len=*),parameter,public :: clear       =  HOME_DISPLAY//CLEAR_DISPLAY

public fmt
integer,save :: alert_unit=stdout
logical,save :: alert_debug=.true.
logical,save :: alert_warn=.true.
logical,save :: alert_info=.true.
logical,save :: alert_error=.true.
logical,save :: alert_other=.true.

interface str
   module procedure msg_scalar, msg_one
end interface str

contains
!>
!!##NAME
!!    attr(3f) - [M_attr] substitute escape sequences for HTML-like syntax
!!               in strings
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!      function attr(string,reset) result (expanded)
!!
!!        ! scalar
!!        character(len=*),intent(in)  :: string
!!        logical,intent(in),optional  :: reset
!!        character(len=:),allocatable :: expanded
!!        ! or array
!!        character(len=*),intent(in)  :: string(:)
!!        logical,intent(in),optional  :: reset
!!        character(len=:),allocatable :: expanded(:)
!!        integer,intent(in),optional  :: chars
!!
!!##DESCRIPTION
!!    Use HTML-like syntax to add attributes to terminal output such as color
!!    on devices that recognize ANSI escape sequences.
!!
!!##OPTIONS
!!    string        input string  of form
!!
!!                    "<attribute_name>string</attribute_name> ...".
!!
!!                   where the current attributes are color names,
!!                   bold, italic, underline, ...
!!
!!    reset          By default, a sequence to clear all text attributes
!!                   is sent at the end of each returned line if an escape
!!                   character appears in the output string. This can be
!!                   turned off by setting RESET to .false. .
!!
!!                   Note if turning off the reset attributes may be
!!                   continued across lines, but if each line is not
!!                   self-contained attributes may not display properly
!!                   when filtered with commands such as grep(1).
!!
!!    chars          For arrays, a reset will be placed after the Nth
!!                   displayable column count in order to make it easier
!!                   to generate consistent right borders for non-default
!!                   background colors for a text block.
!!##KEYWORDS
!!    primary default keywords
!!
!!      colors:
!!        r,         red,       R,  RED
!!        g,         green,     G,  GREEN
!!        b,         blue,      B,  BLUE
!!        m,         magenta,   M,  MAGENTA
!!        c,         cyan,      C,  CYAN
!!        y,         yellow,    Y,  YELLOW
!!        e,         ebony,     E,  EBONY
!!        w,         white,     W,  WHITE
!!
!!      attributes:
!!        it,        italic
!!        bo,        bold
!!        un,        underline
!!
!!      basic control characters:
!!       nul
!!       bel  (0x07, ^G) beeps;
!!       bs   (0x08, ^H) backspaces one column (but not past the beginning of
!!                       the line);
!!       ht   (0x09, ^I) goes to the next tab stop or to the end of the line if
!!                       there is no earlier tab stop;
!!       lf   (0x0A, ^J),
!!       vt   (0x0B, ^K)
!!       ff   (0x0C, ^L) all give a linefeed, and if LF/NL (new-line mode) is
!!                       set also a carriage return
!!       cr   (0x0D, ^M) gives a carriage return;
!!       so   (0x0E, ^N) activates the G1 character set;
!!       si   (0x0F, ^O) activates the G0 character set;
!!       can  (0x18, ^X) and SUB (0x1A, ^Z) interrupt escape sequences;
!!       sub
!!       esc  (0x1B, ^[) starts an escape sequence;
!!       del  (0x7F) is ignored;
!!
!!      other:
!!        clear
!!        default
!!        reset
!!        gt
!!        lt
!!        save,DECSC     Save  current state (cursor coordinates, attributes,
!!                       character sets pointed at by G0, G1).
!!        restore,DECRC  Restore state most recently saved by ESC 7.
!!        CSI            "Control Sequence Introducer"(0x9B) is equivalent to
!!                       "ESC [".
!!
!!      dual-value (one for color, one for mono):
!!
!!        write(*,*)attr('<ERROR>an error message')
!!        write(*,*)attr('<WARNING>a warning message')
!!        write(*,*)attr('<INFO>an informational message')
!!
!!    By default, if the color mnemonics (ie. the keywords) are uppercase
!!    they change the background color. If lowercase, the foreground color.
!!    When preceded by a "/" character the attribute is returned to the default.
!!
!!    The "default" keyword is typically used explicitly when
!!    reset=.false, and sets all text attributes to their initial defaults.
!!
!!##LIMITATIONS
!!    o colors are not nestable, keywords are case-sensitive,
!!    o not all terminals obey the sequences. On Windows, it is best if
!!      you use Windows 10+ and/or the Linux mode; although it has worked
!!      with all CygWin and MinGW and Putty windows and mintty.
!!    o you should use "<gt>" and "<lt>" instead of ">" and "<" in a string
!!      processed by attr(3f) instead of in any plain text output so that
!!      the raw mode will create correct input for the attr(3f) function
!!      if read back in.
!!
!!##EXAMPLE
!!
!!    Sample program
!!
!!     program demo_esc
!!     use M_attr, only : attr, attr_mode, attr_update
!!        call printstuff('defaults')
!!
!!        call attr_mode(manner='plain')
!!        call printstuff('plain:')
!!
!!        call printstuff('raw')
!!
!!        call attr_mode(manner='color')
!!        call printstuff('')
!!
!!        write(*,'(a)') attr('TEST ADDING A CUSTOM SEQUENCE:')
!!        call attr_update('blink',char(27)//'[5m')
!!        call attr_update('/blink',char(27)//'[25m')
!!        write(*,'(a)') attr('<blink>Items for Friday</blink>')
!!
!!     contains
!!     subroutine printstuff(label)
!!     character(len=*),intent(in)  :: label
!!     character(len=:),allocatable :: array(:)
!!       call attr_mode(manner=label)
!!
!!       array=[character(len=60) ::    &
!!        'TEST MANNER='//label,                      &
!!        '<r>RED</r>,<g>GREEN</g>,BLUE',      &
!!        '<c>CYAN</c>,<m>MAGENTA</g>,<y>YELLOW</y>', &
!!        '<w>WHITE</w> and <e>EBONY</e>']
!!       write(*,'(a)') attr(array)
!!
!!       write(*,'(a)') attr('Adding <bo>bold</bo>')
!!       write(*,'(a)') attr('<bo><r>RED</r>,<g>GREEN</g>,BLUE</bo>')
!!       write(*,'(a)') attr('<bo><c>CYAN</c>,<m>MAGENTA</g>,<y>YELLOW</y></bo>')
!!       write(*,'(a)') attr('<bo><w>WHITE</w> and <e>EBONY</e></bo>')
!!
!!       write(*,'(a)') attr('Adding
underline
')
!!       write(*,'(a)') attr(&
!!        &'<bo>
<r>RED</r>,<g>GREEN</g>,BLUE
</bo>')
!!       write(*,'(a)') attr(&
!!        &'<bo>
<c>CYAN</c>,<m>MAGENTA</g>,<y>YELLOW</y>
</bo>')
!!       write(*,'(a)') attr('<bo>
<w>WHITE</w> and <e>EBONY</e>
</bo>')
!!
!!       write(*,'(a)') attr('Adding
italic
')
!!       write(*,'(a)') attr(&
!!        &'<bo>
<it><r>RED</r>,<g>GREEN</g>,BLUE</it>
</bo>')
!!       write(*,'(a)') attr(&
!!        &'<bo>
<it><c>CYAN</c>,<m>MAGENTA</g>,<y>YELLOW</it></y>
</bo>')
!!       write(*,'(a)') attr('<bo>
<it><w>WHITE</w> and <e>EBONY</e>
</bo>')
!!
!!       write(*,'(a)') attr('Adding <in>inverse</in>')
!!       write(*,'(a)') attr('<in><bo>
<it><r>RED</r>,<g>GREEN</g>,&
!!        &BLUE</it>
</bo></in>')
!!       write(*,'(a)') attr('<in><bo>
<it><c>CYAN</c>,<m>MAGENTA</g>,&
!!        &<y>YELLOW</it></y>
</bo></in>')
!!       write(*,'(a)') attr(&
!!        &'<in><bo>
<it><w>WHITE</w> and <e>EBONY</e>
</bo></in>')
!!     end subroutine printstuff
!!     end program demo_esc
!!
!!##AUTHOR
!!    John S. Urban, 2021
!!
!!##LICENSE
!!    MIT
!!
!!##SEE ALSO
!!    attr_mode(3f), attr_update(3f)
function attr_scalar(string,reset) result (expanded)
character(len=*),intent(in)  :: string
logical,intent(in),optional  :: reset
logical                      :: clear_at_end
character(len=:),allocatable :: padded
character(len=:),allocatable :: expanded
character(len=:),allocatable :: name
integer                      :: i
integer                      :: ii
integer                      :: maxlen
integer                      :: place
   if(present(reset))then
      clear_at_end=reset
   else
      clear_at_end=.true.
   endif
   if(.not.allocated(mode))then  ! set substitution mode
      mode='color' ! 'color'|'raw'|'plain'
      call vt102()
   endif

   if(mode=='raw')then
      expanded=string
      return
   endif

   maxlen=len(string)
   padded=string//' '
   i=1
   expanded=''
   do
      select case(padded(i:i))
      case('>')  ! should not get here unless unmatched
         i=i+1
         expanded=expanded//'>'
      case('<')  ! assuming not nested for now
         ii=index(padded(i+1:),'>')
         if(ii.eq.0)then
            expanded=expanded//'<'
            i=i+1
         else
            name=padded(i+1:i+ii-1)
            name=trim(adjustl(name))
            call locate(keywords,name,place)

            if(mode.eq.'plain')then
               expanded=expanded//get(name)
            elseif(place.le.0)then     ! unknown name; print what you found
               expanded=expanded//padded(i:i+ii)
               maxlen=maxlen-ii-1
            else
               expanded=expanded//get(name)
            endif
            i=ii+i+1
         endif
      case default
         expanded=expanded//padded(i:i)
         i=i+1
      end select
      if(i >= maxlen+1)exit
   enddo
   if( (index(expanded,esc).ne.0).and.(clear_at_end))then
      if((mode.ne.'raw').and.(mode.ne.'plain'))then
         expanded=expanded//CODE_RESET                                   ! Clear all styles
      endif
   endif
   expanded=expanded
end function attr_scalar

function attr_matrix(strings,reset,chars) result (expanded)
character(len=*),intent(in)  :: strings(:)
logical,intent(in),optional  :: reset
integer,intent(in),optional  :: chars
character(len=:),allocatable :: expanded(:)
   ! gfortran does not return allocatable array from a function properly, but works with subroutine
   call kludge_bug(strings,reset,chars,expanded)
end function attr_matrix

subroutine kludge_bug(strings,reset,chars,expanded)
character(len=*),intent(in)  :: strings(:)
logical,intent(in),optional  :: reset
integer,intent(in),optional  :: chars
character(len=:),allocatable :: expanded(:)
integer                      :: width
character(len=:),allocatable :: hold
integer                      :: i
integer                      :: right
integer                      :: len_local

allocate(character(len=0) :: expanded(0))
if(present(chars))then
   right=chars
else
   right=len(strings)
endif

if(.not.allocated(mode))then  ! set substitution mode
   mode='color' ! 'color'|'raw'|'plain'
   call vt102()
endif

do i=1,size(strings)

   if(mode.eq.'color')then
      mode='plain'
      len_local=len(attr_scalar(strings(i)))
      hold=trim(strings(i))//repeat(' ',max(0,right-len_local))
      mode='color'
   else
      hold=strings(i)
   endif

   hold=trim(attr_scalar(hold,reset=reset))
   width=max(len(hold),len(expanded))
   expanded=[character(len=width) :: expanded,hold]
enddo

end subroutine kludge_bug

function attr_scalar_width(string,reset,chars) result (expanded)
character(len=*),intent(in)  :: string
logical,intent(in),optional  :: reset
integer,intent(in)           :: chars
character(len=:),allocatable :: expanded_arr(:)
character(len=:),allocatable :: expanded
   expanded_arr=attr_matrix([string],reset,chars)
   expanded=expanded_arr(1)
end function attr_scalar_width

subroutine vt102()
! create a dictionary with character keywords, values, and value lengths
! using the routines for maintaining a list

   call wipe_dictionary()
   ! insert and replace entries
   call attr_update('bold',bold)
   call attr_update('/bold',unbold)
   call attr_update('bo',bold)
   call attr_update('/bo',unbold)
   call attr_update('italic',italic)
   call attr_update('/italic',unitalic)
   call attr_update('it',italic)
   call attr_update('/it',unitalic)
   call attr_update('inverse',inverse)
   call attr_update('/inverse',uninverse)
   call attr_update('in',inverse)
   call attr_update('/in',uninverse)
   call attr_update('underline',underline)
   call attr_update('/underline',ununderline)
   call attr_update('un',underline)
   call attr_update('/un',ununderline)
   call attr_update('ul',underline)
   call attr_update('/ul',ununderline)

   call attr_update('bell',BELL)
   call attr_update('nul', nul )
   call attr_update('bel', bel )
   call attr_update('bs', bs )
   call attr_update('ht', ht )
   call attr_update('lf', lf )
   call attr_update('vt', vt )
   call attr_update('ff', ff )
   call attr_update('cr', cr )
   call attr_update('so', so )
   call attr_update('si', si )
   call attr_update('can', can )
   call attr_update('sub', sub )
   call attr_update('esc', esc )
   call attr_update('escape',esc)
   call attr_update('del', del )

   call attr_update('save',esc//'7')
   call attr_update('DECSC',esc//'7')
   call attr_update('restore',esc//'8')
   call attr_update('DECRC',esc//'8')
   call attr_update('CSI',esc//'[')

   call attr_update('clear',clear)
   call attr_update('reset',reset)

   call attr_update('gt','>','>')
   call attr_update('lt','<','<')

   ! foreground colors
   call attr_update('r',fg_red)
       call attr_update('/r',fg_default)
       call attr_update('red',fg_red)
       call attr_update('/red',fg_default)
   call attr_update('c',fg_cyan)
       call attr_update('/c',fg_default)
       call attr_update('cyan',fg_cyan)
       call attr_update('/cyan',fg_default)
   call attr_update('m',fg_magenta)
       call attr_update('/m',fg_default)
       call attr_update('magenta',fg_magenta)
       call attr_update('/magenta',fg_default)
   call attr_update('b',fg_blue)
       call attr_update('/b',fg_default)
       call attr_update('blue',fg_blue)
       call attr_update('/blue',fg_default)
   call attr_update('g',fg_green)
       call attr_update('/g',fg_default)
       call attr_update('green',fg_green)
       call attr_update('/green',fg_default)
   call attr_update('y',fg_yellow)
       call attr_update('/y',fg_default)
       call attr_update('yellow',fg_yellow)
       call attr_update('/yellow',fg_default)
   call attr_update('w',fg_white)
       call attr_update('/w',fg_default)
       call attr_update('white',fg_white)
       call attr_update('/white',fg_default)
   call attr_update('e',fg_ebony)
       call attr_update('/e',fg_default)
       call attr_update('ebony',fg_ebony)
       call attr_update('/ebony',fg_default)
   call attr_update('x',fg_ebony)
       call attr_update('/x',fg_default)
       call attr_update('black',fg_ebony)
       call attr_update('/black',fg_default)

   ! background colors
   call attr_update('R',bg_red)
       call attr_update('/R',bg_default)
       call attr_update('RED',bg_red)
       call attr_update('/RED',bg_default)
   call attr_update('C',bg_cyan)
       call attr_update('/C',bg_default)
       call attr_update('CYAN',bg_cyan)
       call attr_update('/CYAN',bg_default)
   call attr_update('M',bg_magenta)
       call attr_update('/M',bg_default)
       call attr_update('MAGENTA',bg_magenta)
       call attr_update('/MAGENTA',bg_default)
   call attr_update('B',bg_blue)
       call attr_update('/B',bg_default)
       call attr_update('BLUE',bg_blue)
       call attr_update('/BLUE',bg_default)
   call attr_update('G',bg_green)
       call attr_update('/G',bg_default)
       call attr_update('GREEN',bg_green)
       call attr_update('/GREEN',bg_default)
   call attr_update('Y',bg_yellow)
       call attr_update('/Y',bg_default)
       call attr_update('YELLOW',bg_yellow)
       call attr_update('/YELLOW',bg_default)
   call attr_update('W',bg_white)
       call attr_update('/W',bg_default)
       call attr_update('WHITE',bg_white)
       call attr_update('/WHITE',bg_default)
   call attr_update('E',bg_ebony)
       call attr_update('/E',bg_default)
       call attr_update('EBONY',bg_ebony)
       call attr_update('/EBONY',bg_default)
   call attr_update('X',bg_ebony)
       call attr_update('/X',bg_default)
       call attr_update('BLACK',bg_ebony)
       call attr_update('/BLACK',bg_default)

   ! compound
   call attr_update('ERROR',fg_red//bold//bg_ebony     //':error:  '//bg_default//fg_default,':error:')
   call attr_update('WARNING',fg_yellow//bold//bg_ebony//':warning:'//bg_default//fg_default,':warning:')
   call attr_update('INFO',fg_green//bold//bg_ebony    //':info:   '//bg_default//fg_default,':info:')

end subroutine vt102
!>
!! !>
!!##NAME
!!    attr_mode(3f) - [M_attr] select processing mode for output from attr(3f)
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!     subroutine attr_mode(manner)
!!
!!        character(len=*),intent(in) :: manner
!!
!!##DESCRIPTION
!!    Turn off the generation of strings associated with the HTML keywords
!!    in the string generated by the attr(3f) function, or display the
!!    text in raw mode as it was passed to attr(3f) or return to ANSI
!!    escape control sequence generation.
!!
!!##OPTIONS
!!    MANNER  The current manners or modes supported via the attr_mode(3f)
!!             procedure are
!!
!!         plain          suppress the output associated with keywords
!!         color(default) commonly supported escape sequences
!!         raw            echo the input to attr(3f) as its output
!!         reload         restore original keyword meanings deleted or
!!                        replaced by calls to attr_update(3f).
!!
!!##EXAMPLE
!!
!!    Sample program
!!
!!     program demo_attr_mode
!!     use M_attr, only : attr, attr_mode
!!     implicit none
!!     character(len=:),allocatable :: lines(:)
!!     character(len=:),allocatable :: outlines(:)
!!     integer :: i
!!        lines=[character(len=110):: &
!!        &'<M><y>',&
!!        &'<M><y>  Suffice it to say that black and white are also colors',&
!!        &'<M><y>  for their simultaneous contrast is as striking as that ',&
!!        &'<M><y>  of green and red, for instance. &
!!        & --- <y><bo>Vincent van Gogh</bo></y>',&
!!        &' ']
!!
!!        outlines=attr(lines,chars=57)
!!        write(*,'(a)')(trim(outlines(i)),i=1,size(outlines))
!!
!!        call attr_mode(manner='plain') ! write as plain text
!!        write(*,'(a)')attr(lines)
!!
!!        call attr_mode(manner='raw')   ! write as-is
!!        write(*,'(a)')attr(lines)
!!
!!        call attr_mode(manner='ansi')  ! return to default mode
!!
!!     end program demo_attr_mode
!!
!!##AUTHOR
!!    John S. Urban, 2021
!!
!!##LICENSE
!!    MIT
subroutine attr_mode(manner)
character(len=*),intent(in) :: manner
integer                     :: i
   if(.not.allocated(mode))then  ! set substitution mode
      mode='color'
      call vt102()
   endif
   select case(manner)
   case('vt102','ANSI','ansi','color','COLOR')
      mode='color'
   case('reload','default','defaults','')
      call vt102()
      mode='color'
   case('raw')
      mode='raw'
   case('dump')  ! dump dictionary for debugging
      if(allocated(keywords))then
         if(size(keywords).gt.0)then
            write(stderr,'(*(a,t30,a))')'KEYWORD','VALUE'
            write(stderr,'(*(a,t30,2("[",a,"]"),/))')(trim(keywords(i)),values(i),mono_values(i),i=1,size(keywords))
         endif
      endif
   case('dummy','plain','text')
      mode='plain'
   case default
      write(*,*)'unknown manner. Try color|raw|plain'
      mode='color'
   end select
end subroutine attr_mode

subroutine wipe_dictionary()
   if(allocated(keywords))deallocate(keywords)
   allocate(character(len=0) :: keywords(0))
   if(allocated(values))deallocate(values)
   allocate(character(len=0) :: values(0))
   if(allocated(mono_values))deallocate(mono_values)
   allocate(character(len=0) :: mono_values(0))
end subroutine wipe_dictionary

!>
!! !>
!!##NAME
!!    attr_update(3f) - [M_attr] update internal dictionary given keyword and value
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!    subroutine attr_update(key,val)
!!
!!     character(len=*),intent(in)           :: key
!!     character(len=*),intent(in),optional  :: val
!!     character(len=*),intent(in),optional  :: mono_val
!!
!!##DESCRIPTION
!!    Update internal dictionary in M_attr(3fm) module.
!!
!!##OPTIONS
!!    key       name of keyword to add, replace, or delete from dictionary
!!    val       if present add or replace value associated with keyword. If
!!              not present remove keyword entry from dictionary.
!!    mono_val  if present add or replace second value associated with
!!              keyword used for plain text mode.
!!              Must only be specified if VAL is also specified.
!!
!!##KEYWORDS
!!    The following keywords are defined by default
!!
!!    colors:
!!
!!      r,red     c,cyan     w,white
!!      g,green   m,magenta  e,ebony
!!      b,blue    y,yellow
!!
!!    If the color keywords are capitalized they control the text background
!!    instead of the text color.
!!
!!    attributes:
!!
!!      ul,underline
!!      it,italics (often produces inverse colors on many devices
!!
!!##EXAMPLE
!!
!!    Sample program
!!
!!      program demo_update
!!      use M_attr, only : attr, attr_update
!!         write(*,'(a)') attr('<clear>TEST CUSTOMIZATIONS:')
!!         ! add custom keywords
!!         call attr_update('blink',char(27)//'[5m')
!!         call attr_update('/blink',char(27)//'[25m')
!!         write(*,*)
!!         write(*,'(a)') attr('<blink>Items for Friday</blink>')
!!         call attr_update('ouch',attr( &
!!         ' <R><bo><w>BIG mistake!</R></w> '))
!!         write(*,*)
!!         write(*,'(a)') attr('<ouch> Did not see that coming.')
!!         write(*,*)
!!         write(*,'(a)') attr( &
!!         'ORIGINALLY: <r>Apple</r>, Sky, <g>Grass</g>')
!!         ! delete
!!         call attr_update('r')
!!         call attr_update('/r')
!!         ! replace (or create)
!!         call attr_update('b','<<<<')
!!         call attr_update('/b','>>>>')
!!         write(*,*)
!!         write(*,'(a)') attr( &
!!         'CUSTOMIZED: <r>Apple</r>, Sky, <g>Grass</g>')
!!      end program demo_update
!!
!!##AUTHOR
!!    John S. Urban, 2021
!!
!!##LICENSE
!!    MIT
subroutine attr_update(key,valin,mono_valin)
character(len=*),intent(in)           :: key
character(len=*),intent(in),optional  :: valin
character(len=*),intent(in),optional  :: mono_valin
integer                               :: place
character(len=:),allocatable          :: val
character(len=:),allocatable          :: mono_val

if(.not.allocated(mode))then  ! set substitution mode
   mode='color' ! 'color'|'raw'|'plain'
   call vt102()
endif

if(present(mono_valin))then
   mono_val=mono_valin
else
   mono_val=''
endif

if(present(valin))then
   val=valin
   ! find where string is or should be
   call locate(keywords,key,place)
   ! if string was not found insert it
   if(place.lt.1)then
      call insert(keywords,key,iabs(place))
      call insert(values,val,iabs(place))
      call insert(mono_values,mono_val,iabs(place))
   else
      call replace(values,val,place)
      call replace(mono_values,mono_val,place)
   endif
else
   call locate(keywords,key,place)
   if(place.gt.0)then
      call remove(keywords,place)
      call remove(values,place)
      call remove(mono_values,place)
   endif
endif
end subroutine attr_update

function get(key) result(valout)
character(len=*),intent(in)   :: key
character(len=:),allocatable  :: valout
integer                       :: place
   ! find where string is or should be
   call locate(keywords,key,place)
   if(place.lt.1)then
      valout=''
   else
      if(mode.eq.'plain')then
         valout=trim(mono_values(place))
      else
         valout=trim(values(place))
      endif
   endif
end function get

subroutine locate(list,value,place,ier,errmsg)
character(len=*),intent(in)             :: value
integer,intent(out)                     :: place
character(len=:),allocatable            :: list(:)
integer,intent(out),optional            :: ier
character(len=*),intent(out),optional   :: errmsg
integer                                 :: i
character(len=:),allocatable            :: message
integer                                 :: arraysize
integer                                 :: maxtry
integer                                 :: imin, imax
integer                                 :: error
   if(.not.allocated(list))then
      list=[character(len=max(len_trim(value),2)) :: ]
   endif
   arraysize=size(list)

   error=0
   if(arraysize.eq.0)then
      maxtry=0
      place=-1
   else
      maxtry=int(log(float(arraysize))/log(2.0)+1.0)
      place=(arraysize+1)/2
   endif
   imin=1
   imax=arraysize
   message=''

   LOOP: block
   do i=1,maxtry
      if(value.eq.list(PLACE))then
         exit LOOP
      else if(value.gt.list(place))then
         imax=place-1
      else
         imin=place+1
      endif
      if(imin.gt.imax)then
         place=-imin
         if(iabs(place).gt.arraysize)then ! ran off end of list. Where new value should go or an unsorted input array'
            exit LOOP
         endif
         exit LOOP
      endif
      place=(imax+imin)/2
      if(place.gt.arraysize.or.place.le.0)then
         message='*locate* error: search is out of bounds of list. Probably an unsorted input array'
         error=-1
         exit LOOP
      endif
   enddo
   message='*locate* exceeded allowed tries. Probably an unsorted input array'
   endblock LOOP
   if(present(ier))then
      ier=error
   else if(error.ne.0)then
      write(stderr,*)message//' VALUE=',trim(value)//' PLACE=',place
      stop 1
   endif
   if(present(errmsg))then
      errmsg=message
   endif
end subroutine locate

subroutine remove(list,place)
character(len=:),allocatable :: list(:)
integer,intent(in)           :: place
integer                      :: ii, end
   if(.not.allocated(list))then
      list=[character(len=2) :: ]
   endif
   ii=len(list)
   end=size(list)
   if(place.le.0.or.place.gt.end)then                       ! index out of bounds of array
   elseif(place.eq.end)then                                 ! remove from array
      list=[character(len=ii) :: list(:place-1) ]
   else
      list=[character(len=ii) :: list(:place-1), list(place+1:) ]
   endif
end subroutine remove

subroutine replace(list,value,place)
character(len=*),intent(in)  :: value
character(len=:),allocatable :: list(:)
character(len=:),allocatable :: kludge(:)
integer,intent(in)           :: place
integer                      :: ii
integer                      :: tlen
integer                      :: end
   if(.not.allocated(list))then
      list=[character(len=max(len_trim(value),2)) :: ]
   endif
   tlen=len_trim(value)
   end=size(list)
   if(place.lt.0.or.place.gt.end)then
           write(stderr,*)'*replace* error: index out of range. end=',end,' index=',place
   elseif(len_trim(value).le.len(list))then
      list(place)=value
   else  ! increase length of variable
      ii=max(tlen,len(list))
      kludge=[character(len=ii) :: list ]
      list=kludge
      list(place)=value
   endif
end subroutine replace

subroutine insert(list,value,place)
character(len=*),intent(in)  :: value
character(len=:),allocatable :: list(:)
character(len=:),allocatable :: kludge(:)
integer,intent(in)           :: place
integer                      :: ii
integer                      :: end
   if(.not.allocated(list))then
      list=[character(len=max(len_trim(value),2)) :: ]
   endif
   ii=max(len_trim(value),len(list),2)
   end=size(list)
   if(end.eq.0)then                                          ! empty array
      list=[character(len=ii) :: value ]
   elseif(place.eq.1)then                                    ! put in front of array
      kludge=[character(len=ii) :: value, list]
      list=kludge
   elseif(place.gt.end)then                                  ! put at end of array
      kludge=[character(len=ii) :: list, value ]
      list=kludge
   elseif(place.ge.2.and.place.le.end)then                 ! put in middle of array
      kludge=[character(len=ii) :: list(:place-1), value,list(place:) ]
      list=kludge
   else                                                      ! index out of range
      write(stderr,*)'*insert* error: index out of range. end=',end,' index=',place,' value=',value
   endif
end subroutine insert
!>
!! !>
!!##NAME
!!    alert(3f) - [M_attr] print messages using a standard format including time and program name
!!    (LICENSE:MIT)
!!
!!##SYNOPSIS
!!
!!     subroutine alert(message,g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj)
!!
!!        character(len=*),intent(in),optional :: type
!!        character(len=*),intent(in),optional :: message
!!        class(*),intent(in),optional :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9, &
!!                                      & ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
!!
!!##DESCRIPTION
!!    Display a message prefixed with a timestamp and the name
!!    of the calling program when the TYPE is specified as any
!!    of 'error','warn', or 'info'.
!!
!!    It also allows the keywords
!!    <ARG0>,<TZ>,<YE>,<MO>,<DA>,
,<MI>,<SE>,<MS> to be used in the
!!    message (which is passed to ATTR(3f)).
!!
!!    Note that time stamp keywords will only be updated when using ALERT(3f)
!!    and will only be displayed in color mode!
!!
!!##OPTIONS
!!    TYPE     if present and one of 'warn','message','info', or 'debug'  a predefined
!!             message is written to stderr of the form
!!
!!              :
:<MI>:<SE>.<MS> : (<ARG0>) : TYPE -> message
!!
!!    MESSAGE  the user-supplied message to display via a call to ATTR(3f)
!!
!!    g[0-9a-j]   optional values to print after the message. May
!!                be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION,
!!                COMPLEX, or CHARACTER.
!!
!!    if no parameters are supplied the macros are updated but no output is generated.
!!
!!##EXAMPLE
!!
!!    Sample program
!!
!!       program demo_alert
!!       use M_attr, only : alert, attr, attr_mode
!!       implicit none
!!       real X
!!          call attr_mode(manner='plain')
!!          call attr_mode(manner='color')
!!          call alert("error", "Say you didn't!")
!!          call alert("warn",  "I wouldn't if I were you, Will Robinson.")
!!          call alert("info",  "I fixed that for you, but it was a bad idea.")
!!          call alert("debug", "Who knows what is happening now?.")
!!          call alert("???    ",  "not today you don't")
!!          ! call to just update the macros
!!          call alert()
!!          ! conventional call to ATTR(3f) using the ALERT(3f)-defined macros
!!          write(*,*)attr('<bo>The year was <g><YE></g>, the month was <g><MO></g>')
!!          ! optional arguments
!!          X=211.3
!!          call alert('error','allowed range of X is 0 <lt> X <lt> 100, X=<r>',X)
!!          ! up to twenty values are allowed of intrinsic type
!!          call alert('info','values are<g>',10,234.567,cmplx(11.0,22.0),123.456d0,'</g>today')
!!       end program demo_alert
!!
!!   Results:
!!
!!     00:38:30.566 : (demo_alert) : error    -> Say you didn't!
!!     00:38:30.567 : (demo_alert) : warning  -> I wouldn't if I were you, Will Robinson.
!!     00:38:30.567 : (demo_alert) : info     -> I fixed that for you, but it was a bad idea.
!!     00:38:30.567 : (demo_alert) : debug    -> Who knows what is happening now?.
!!     00:38:30.567 : (demo_alert) : ???      -> not today you don't
!!     00:38:30.567 : (demo_alert) : error    -> allowed range of X is 0  X  100, X= 211.300003
!!     00:38:30.567 : (demo_alert) : info     -> values are 10 234.567001 (11.0000000,22.0000000) 123.45600000000000 today
!!
!!
!!
!!##AUTHOR
!!    John S. Urban, 2021
!!
!!##LICENSE
!!    MIT
subroutine alert(type,message,g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj)
! TODO: could add a warning level to ignore info, or info|warning, or all
implicit none
character(len=*),intent(in),optional :: type
character(len=*),intent(in),optional :: message
class(*),intent(in),optional  :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9
class(*),intent(in),optional  :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
character(len=8)      :: dt
character(len=10)     :: tm
character(len=5)      :: zone
integer,dimension(8)  :: values
character(len=4096)   :: arg0
character(len=:),allocatable :: new_message
character(len=:),allocatable :: other
logical :: printme
   call date_and_time(dt,tm,zone,values)
   call attr_update('YE',dt(1:4),dt(1:4))
   call attr_update('MO',dt(5:6),dt(5:6))
   call attr_update('DA',dt(7:8),dt(7:8))
   call attr_update('HR',tm(1:2),tm(1:2))
   call attr_update('MI',tm(3:4),tm(3:4))
   call attr_update('SE',tm(5:6),tm(5:6))
   call attr_update('MS',tm(8:10),tm(8:10))
   call attr_update('TZ',zone,zone)
   call get_command_argument(0,arg0)
   if(index(arg0,'/').ne.0) arg0=arg0(index(arg0,'/',back=.true.)+1:)
   if(index(arg0,'\').ne.0) arg0=arg0(index(arg0,'\',back=.true.)+1:)
   call attr_update('ARG0',arg0,arg0)
   printme=.true.
   if(present(type))then
      new_message= ' '//tm(1:2)//':'//tm(3:4)//':'//tm(5:6)//'.'//tm(8:10)//' : ('//trim(arg0)//') : '
      other=message//' '//str(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,ga,gb,gc,gd,ge,gf,gg,gh,gi,gj)
      select case(type)

      case('warn','WARN','warning','WARNING')
       new_message= new_message//'<EBONY><bo><y>warning </y></EBONY> -<gt> '
       printme=alert_warn

      case('info','INFO','information','INFORMATION')
       new_message= new_message//'<EBONY><bo><g>info    </g></EBONY> -<gt> '
       printme=alert_info

      case('error','ERROR')
       new_message= new_message//'<EBONY><bo><r>error   </r></EBONY> -<gt> '
       printme=alert_error

      case('debug','DEBUG')
       new_message= new_message//'<EBONY><white><bo>debug   </white></EBONY> -<gt> '
       printme=alert_debug

      case default
       new_message= new_message//'<EBONY><bo><c>'//type//' </c></EBONY> -<gt> '
       printme=alert_other

      end select
    if(printme)then
       write(alert_unit,'(a)')attr(trim(new_message//other))
    endif

   elseif(present(message))then
    write(alert_unit,'(a)')attr(trim(other))
   endif
end subroutine alert

!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    str(3f) - [M_attr] converts any standard scalar type to a string
!!    (LICENSE:PD)
!!
!!##SYNOPSIS
!!
!!    Syntax:
!!
!!      function str(g0,g1,g2,g3,g4,g5,g6,g7,g8,g9,&
!!      & ga,gb,gc,gd,ge,gf,gg,gh,gi,gj,sep)
!!      class(*),intent(in),optional  :: g0,g1,g2,g3,g4,g5,g6,g7,g8,g9
!!      class(*),intent(in),optional  :: ga,gb,gc,gd,ge,gf,gg,gh,gi,gj
!!      character(len=*),intent(in),optional :: sep
!!      character,len=(:),allocatable :: str
!!
!!##DESCRIPTION
!!    str(3f) builds a space-separated string from up to twenty scalar values.
!!
!!##OPTIONS
!!    g[0-9a-j]   optional value to print the value of after the message. May
!!                be of type INTEGER, LOGICAL, REAL, DOUBLEPRECISION,
!!                COMPLEX, or CHARACTER.
!!
!!                Optionally, all the generic values can be
!!                single-dimensioned arrays. Currently, mixing scalar
!!                arguments and array arguments is not supported.
!!
!!    sep         separator string used between values. Defaults to a space.
!!
!!##RETURNS
!!    str     description to print
!!
!!##EXAMPLES
!!
!!   Sample program:
!!
!!    program demo_msg
!!    use M_attr, only : alert
!!    end program demo_msg
!!
!!   Output
!!
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    Public Domain
function msg_scalar(generic0, generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9, &
                  & generica, genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj, &
                  & sep)
implicit none

! ident_1="@(#)M_attr::msg_scalar(3fp): writes a message to a string composed of any standard scalar types"

class(*),intent(in),optional  :: generic0, generic1, generic2, generic3, generic4
class(*),intent(in),optional  :: generic5, generic6, generic7, generic8, generic9
class(*),intent(in),optional  :: generica, genericb, genericc, genericd, generice
class(*),intent(in),optional  :: genericf, genericg, generich, generici, genericj
character(len=:),allocatable  :: msg_scalar
character(len=4096)           :: line
integer                       :: istart
integer                       :: increment
character(len=*),intent(in),optional :: sep
character(len=:),allocatable  :: sep_local
   if(present(sep))then
      increment=len(sep)+1
      sep_local=sep
   else
      increment=2
      sep_local=' '
   endif

   istart=1
   line=''
   if(present(generic0))call print_generic(generic0)
   if(present(generic1))call print_generic(generic1)
   if(present(generic2))call print_generic(generic2)
   if(present(generic3))call print_generic(generic3)
   if(present(generic4))call print_generic(generic4)
   if(present(generic5))call print_generic(generic5)
   if(present(generic6))call print_generic(generic6)
   if(present(generic7))call print_generic(generic7)
   if(present(generic8))call print_generic(generic8)
   if(present(generic9))call print_generic(generic9)
   if(present(generica))call print_generic(generica)
   if(present(genericb))call print_generic(genericb)
   if(present(genericc))call print_generic(genericc)
   if(present(genericd))call print_generic(genericd)
   if(present(generice))call print_generic(generice)
   if(present(genericf))call print_generic(genericf)
   if(present(genericg))call print_generic(genericg)
   if(present(generich))call print_generic(generich)
   if(present(generici))call print_generic(generici)
   if(present(genericj))call print_generic(genericj)
   msg_scalar=trim(line)
contains
!===================================================================================================================================
subroutine print_generic(generic)
!use, intrinsic :: iso_fortran_env, only : int8, int16, int32, biggest=>int64, real32, real64, dp=>real128
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128
class(*),intent(in) :: generic
   select type(generic)
      type is (integer(kind=int8));     write(line(istart:),'(i0)') generic
      type is (integer(kind=int16));    write(line(istart:),'(i0)') generic
      type is (integer(kind=int32));    write(line(istart:),'(i0)') generic
      type is (integer(kind=int64));    write(line(istart:),'(i0)') generic
      type is (real(kind=real32));      write(line(istart:),'(1pg0)') generic
      type is (real(kind=real64));      write(line(istart:),'(1pg0)') generic
      type is (real(kind=real128));     write(line(istart:),'(1pg0)') generic
      type is (logical);                write(line(istart:),'(l1)') generic
      type is (character(len=*));       write(line(istart:),'(a)') trim(generic)
      type is (complex);                write(line(istart:),'("(",1pg0,",",1pg0,")")') generic
   end select
   istart=len_trim(line)+increment
   line=trim(line)//sep_local
end subroutine print_generic
!===================================================================================================================================
end function msg_scalar
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
function msg_one(generic0,generic1, generic2, generic3, generic4, generic5, generic6, generic7, generic8, generic9,&
               & generica,genericb, genericc, genericd, generice, genericf, genericg, generich, generici, genericj,&
               & sep)
implicit none

! ident_2="@(#)M_attr::msg_one(3fp): writes a message to a string composed of any standard one dimensional types"

class(*),intent(in)           :: generic0(:)
class(*),intent(in),optional  :: generic1(:), generic2(:), generic3(:), generic4(:), generic5(:)
class(*),intent(in),optional  :: generic6(:), generic7(:), generic8(:), generic9(:)
class(*),intent(in),optional  :: generica(:), genericb(:), genericc(:), genericd(:), generice(:)
class(*),intent(in),optional  :: genericf(:), genericg(:), generich(:), generici(:), genericj(:)
character(len=*),intent(in),optional :: sep
character(len=:),allocatable  :: sep_local
character(len=:), allocatable :: msg_one
character(len=4096)           :: line
integer                       :: istart
integer                       :: increment
   if(present(sep))then
      increment=1+len(sep)
      sep_local=sep
   else
      sep_local=' '
      increment=2
   endif

   istart=1
   line=' '
   call print_generic(generic0)
   if(present(generic1))call print_generic(generic1)
   if(present(generic2))call print_generic(generic2)
   if(present(generic3))call print_generic(generic3)
   if(present(generic4))call print_generic(generic4)
   if(present(generic5))call print_generic(generic5)
   if(present(generic6))call print_generic(generic6)
   if(present(generic7))call print_generic(generic7)
   if(present(generic8))call print_generic(generic8)
   if(present(generic9))call print_generic(generic9)
   if(present(generica))call print_generic(generica)
   if(present(genericb))call print_generic(genericb)
   if(present(genericc))call print_generic(genericc)
   if(present(genericd))call print_generic(genericd)
   if(present(generice))call print_generic(generice)
   if(present(genericf))call print_generic(genericf)
   if(present(genericg))call print_generic(genericg)
   if(present(generich))call print_generic(generich)
   if(present(generici))call print_generic(generici)
   if(present(genericj))call print_generic(genericj)
   msg_one=trim(line)
contains
!===================================================================================================================================
subroutine print_generic(generic)
!use, intrinsic :: iso_fortran_env, only : int8, int16, int32, biggest=>int64, real32, real64, dp=>real128
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128
class(*),intent(in),optional :: generic(:)
integer :: i
   select type(generic)
      type is (integer(kind=int8));     write(line(istart:),'("[",*(i0,1x))') generic
      type is (integer(kind=int16));    write(line(istart:),'("[",*(i0,1x))') generic
      type is (integer(kind=int32));    write(line(istart:),'("[",*(i0,1x))') generic
      type is (integer(kind=int64));    write(line(istart:),'("[",*(i0,1x))') generic
      type is (real(kind=real32));      write(line(istart:),'("[",*(1pg0,1x))') generic
      type is (real(kind=real64));      write(line(istart:),'("[",*(1pg0,1x))') generic
      type is (real(kind=real128));     write(line(istart:),'("[",*(1pg0,1x))') generic
      !type is (real(kind=real256));     write(error_unit,'(1pg0)',advance='no') generic
      type is (logical);                write(line(istart:),'("[",*(l1,1x))') generic
      type is (character(len=*));       write(line(istart:),'("[",:*("""",a,"""",1x))') (trim(generic(i)),i=1,size(generic))
      type is (complex);                write(line(istart:),'("[",*("(",1pg0,",",1pg0,")",1x))') generic
      class default
         stop 'unknown type in *print_generic*'
   end select
   istart=len_trim(line)+increment+1
   line=trim(line)//']'//sep_local
end subroutine print_generic
!===================================================================================================================================
end function msg_one
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================
!>
!!##NAME
!!    fmt(3f) - [M_attr] convert any intrinsic to a string using specified format
!!    (LICENSE:PD)
!!##SYNOPSIS
!!
!!    function fmt(value,format) result(string)
!!
!!     class(*),intent(in),optional :: value
!!     character(len=*),intent(in),optional  :: format
!!     character(len=:),allocatable :: string
!!##DESCRIPTION
!!    FMT(3f) converts any standard intrinsic value to a string using the specified
!!    format.
!!##OPTIONS
!!    value    value to print the value of. May be of type INTEGER, LOGICAL,
!!             REAL, DOUBLEPRECISION, COMPLEX, or CHARACTER.
!!    format   format to use to print value. It is up to the user to use an
!!             appropriate format. The format does not require being
!!             surrounded by parenthesis. If not present a default is selected
!!             similar to what would be produced with free format.
!!##RETURNS
!!    string   A string value
!!##EXAMPLES
!!
!!   Sample program:
!!
!!     program demo_fmt
!!     use :: M_attr, only : fmt
!!     implicit none
!!     character(len=:),allocatable :: output
!!
!!        output=fmt(10,"'[',i0,']'")
!!        write(*,*)'result is ',output
!!
!!        output=fmt(10.0/3.0,"'[',g0.5,']'")
!!        write(*,*)'result is ',output
!!
!!        output=fmt(.true.,"'The final answer is [',g0,']'")
!!        write(*,*)'result is ',output
!!
!!     end program demo_fmt
!!
!!   Results:
!!
!!     result is [10]
!!     result is [3.3333]
!!     result is The final answer is [T]
!!
!!##AUTHOR
!!    John S. Urban
!!
!!##LICENSE
!!    Public Domain
recursive function fmt(generic,format) result (line)
use,intrinsic :: iso_fortran_env, only : int8, int16, int32, int64, real32, real64, real128

! ident_3="@(#)M_attr::fmt(3f): convert any intrinsic to a string using specified format"

class(*),intent(in)          :: generic
character(len=*),intent(in),optional  :: format
character(len=:),allocatable :: line
character(len=:),allocatable :: fmt_local
integer                      :: ios
character(len=255)           :: msg
character(len=1),parameter   :: null=char(0)
integer                      :: ilen
   if(present(format))then
      fmt_local=format
   else
      fmt_local=''
   endif
   ! add ",a" and print null and use position of null to find length of output
   ! add cannot use SIZE= or POS= or ADVANCE='NO' on WRITE() on INTERNAL READ,
   ! and do not want to trim as trailing spaces can be significant
   if(fmt_local.eq.'')then
      select type(generic)
         type is (integer(kind=int8));     fmt_local='(i0,a)'
         type is (integer(kind=int16));    fmt_local='(i0,a)'
         type is (integer(kind=int32));    fmt_local='(i0,a)'
         type is (integer(kind=int64));    fmt_local='(i0,a)'
         type is (real(kind=real32));      fmt_local='(1pg0,a)'
         type is (real(kind=real64));      fmt_local='(1pg0,a)'
         type is (real(kind=real128));     fmt_local='(1pg0,a)'
         type is (logical);                fmt_local='(l1,a)'
         type is (character(len=*));       fmt_local='(a,a)'
         type is (complex);                fmt_local='("(",1pg0,",",1pg0,")",a)'
      end select
   else
      if(format(1:1).eq.'(')then
         fmt_local=format(:len_trim(format)-1)//',a)'
      else
         fmt_local='('//fmt_local//',a)'
      endif
   endif
   allocate(character(len=256) :: line) ! cannot currently write into allocatable variable
   ios=0
   select type(generic)
      type is (integer(kind=int8));     write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (integer(kind=int16));    write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (integer(kind=int32));    write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (integer(kind=int64));    write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (real(kind=real32));      write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (real(kind=real64));      write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (real(kind=real128));     write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (logical);                write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (character(len=*));       write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
      type is (complex);                write(line,fmt_local,iostat=ios,iomsg=msg) generic,null
   end select
   if(ios.ne.0)then
      line='<ERROR>'//trim(msg)
   else
      ilen=index(line,null,back=.true.)
      if(ilen.eq.0)ilen=len(line)
      line=line(:ilen-1)
   endif
end function fmt
!===================================================================================================================================
!()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()()!
!===================================================================================================================================

end module M_attr


!--------------------------------------------------------------------------------------------------
! PROGRAM: cis_nto_prog
!> @author Marin Sapunar, Ruđer Bošković Institute
!> @date April, 2019
!
!> @brief Convert between different geometry/AO/MO formats.
!> @todo Only molden format write subroutines implemented ATM.
!> @todo Add checks/options to read/convert only parts of the data that are available in the
!!       given input files.
!--------------------------------------------------------------------------------------------------
program nto_prog
    ! General
    use global_defs
    ! Variables
    use convert_variables
    ! I/O
    use convert_input_mod
    use read_all_mod
    use write_all_mod
    implicit none

    ! All program variables are defined in convert_variables

    ! Begin run.
    call set_defaults()
    call command_line_interface()
    if (print_level >= 1) then
        write(stdout, '(5x,a)') '-------------------------------------------------------------'
        write(stdout, '(5x,a)') '                         nto program                         '
        write(stdout, '(5x,a)') '                         version 1.1                         '
        write(stdout, '(5x,a)') '                                                             '
        write(stdout, '(5x,a)') ' Program compiled on '//__DATE__//' '//__TIME__//'.          '
        write(stdout, '(5x,a)') '-------------------------------------------------------------'
        write(stdout, *)
        write(stdout, '(1x,a)') 'Reading orbitals/states: '
        write(stdout, '(5x,a,a)') 'Format: ', input_format
        write(stdout, '(5x,a,a)') 'Path: ', input_path
    end if

    call read_geom(input_format, input_path, geom, atsym, atnum)
    call read_basis(input_format, input_path, bs)
    call read_mo(input_format, input_path, mos, bs)

    call bs_trans%init(bs, bs%source_format, output_format)
    call bs_trans%transform(mos%ca, 1)
    if (allocated(mos%cb)) call bs_trans%transform(mos%cb, 1)
    call write_all(output_format, output_path, geom=geom, atom_symbol=atsym, atom_number=atnum,&
    &              basis=bs, mos=mos)

end program nto_prog


text:
module efielddataobj

! type extension for file-based electric field data input.  Assumes parallel communication between root/workers for data
! distribution.  An interesting aspect of this object is that it is/may never be used by anyone but root who initiates the
! calls to MUMPS and boundary conditions.

use, intrinsic :: ieee_arithmetic, only: ieee_is_finite
use phys_consts, only: wp,debug,pi,Re
use inputdataobj, only: inputdata
use meshobj, only: curvmesh
use config, only: gemini_cfg
use reader, only: get_simsize2,get_grid2,get_efield
!! note that only root uses this data object since this concerns the potential solver
use timeutils, only: dateinc,date_filename
use grid, only: lx1,lx2,lx2all,lx3,lx3all,gridflag

implicit none (type, external)
public :: efielddata

type, extends(inputdata) :: efielddata
  ! coordinate for input precipitation data, and storage
  real(wp), dimension(:), pointer :: mlonp,mlatp
  integer, pointer :: llon,llat

  ! named pointers for ease of use with external programs
  real(wp), pointer :: flagdirich      ! this will need to be converted to integer at some point because all datasets are floating point here
  real(wp), dimension(:,:), pointer :: E0xp,E0yp
  real(wp), dimension(:,:), pointer :: Vminx1p,Vmaxx1p
  real(wp), dimension(:), pointer :: Vminx2pslice,Vmaxx2pslice    !only slices because field lines (x1-dimension) are equipotentials
  real(wp), dimension(:), pointer :: Vminx3pslice,Vmaxx3pslice

  real(wp), dimension(:,:), pointer :: E0xiprev,E0yiprev
  real(wp), dimension(:,:), pointer :: Vminx1iprev,Vmaxx1iprev
  real(wp), dimension(:), pointer :: Vminx2isprev,Vmaxx2isprev    !only slices because field lines (x1-dimension) are equipotentials
  real(wp), dimension(:), pointer :: Vminx3isprev,Vmaxx3isprev

  real(wp), dimension(:,:), pointer :: E0xinext,E0yinext
  real(wp), dimension(:,:), pointer :: Vminx1inext,Vmaxx1inext
  real(wp), dimension(:), pointer :: Vminx2isnext,Vmaxx2isnext    !only slices because field lines (x1-dimension) are equipotentials
  real(wp), dimension(:), pointer :: Vminx3isnext,Vmaxx3isnext

  real(wp), dimension(:,:), pointer :: E0xinow,E0yinow
  real(wp), dimension(:,:), pointer :: Vminx1inow,Vmaxx1inow
  real(wp), dimension(:), pointer :: Vminx2isnow,Vmaxx2isnow    !only slices because field lines (x1-dimension) are equipotentials
  real(wp), dimension(:), pointer :: Vminx3isnow,Vmaxx3isnow
  contains
    ! overriding procedures
    procedure :: set_sizes=>set_sizes_efield

    ! deferred bindings
    procedure :: init=>init_efield
    procedure :: set_coordsi=>set_coordsi_efield
    procedure :: load_data=>load_data_efield
    procedure :: load_grid=>load_grid_efield
    procedure :: load_size=>load_size_efield
    final :: destructor
end type efielddata

contains
  !> need to override set_sizes so to account for fact that target interpolation is to a 2D grid, by default object will
  !    assume 3D and get the sizes from the simulation grid
  subroutine set_sizes_efield(self, &
                     l0D, &
                     l1Dax1,l1Dax2,l1Dax3, &
                     l2Dax23,l2Dax12,l2Dax13, &
                     l3D, &
                     x)
    class(efielddata), intent(inout) :: self
    integer, intent(in) :: l0D
    integer, intent(in) :: l1Dax1,l1Dax2,l1Dax3
    integer, intent(in) :: l2Dax23,l2Dax12,l2Dax13
    integer, intent(in) :: l3D
    class(curvmesh), intent(in) :: x        ! sizes for interpolation sites taken from grid

    ! Note:  these should be set by load_data deferred procedure
    ! coordinate axis sizes for input data
    !self%lc1=lc1; self%lc2=lc2; self%lc3=lc3;
    if (.not. self%flagdatasize) error stop 'inpudata:set_sizes() - must set input datasize first using load_size()'

    ! number of different types of data
    self%l0D=l0D
    self%l1Dax1=l1Dax1; self%l1Dax2=l1Dax2; self%l1Dax3=l1Dax3;
    self%l2Dax23=l2Dax23; self%l2Dax12=l2Dax12; self%l2Dax13=l2Dax13;
    self%l3D=l3D

    ! coordinate axis sizes for interpolation states; noting that for a dipole we (internally) permute
    !   the interpolation sites in the same sense.
    !select type (x)
    !  class is (dipolemesh)
    !    print*, ' efielddata:  detected dipole mesh'
    !    self%lc1i=x%lx1;       ! note this dataset has 1D and 2D target interpolation grid
    !    self%lc2i=x%lx3all; self%lc3i=x%lx2all;
    !    ! dipolemesh mesh permuted ~alt,lat,lon, whereas inputdata organized lon,lat
    !  class default
        self%lc1i=x%lx1;       ! note this dataset has 1D and 2D target interpolation grid
        self%lc2i=x%lx2all; self%lc3i=x%lx3all;
    !end select

    ! check that the user is trying something sensible
    !if (self%lc1==1 .and. self%lc1i/=1 .or. self%lc2==1 .and. self%lc2i/=1 &
    !        .or. self%lc3==1 .and. self%lc3i/=1) then
    !  error stop 'inputdata:set_sizes() - singleton dimensions must be same for source and destination.'
    !end if

    ! flag sizes as assigned
    self%flagsizes=.true.
  end subroutine set_sizes_efield

  !> set pointers to appropriate data arrays (taking into account dimensionality of the problem) and prime everything
  !    so we are ready to call self%update()
  !  After this procedure is called all pointer aliases are set and can be used; internal to this procedure pay attention
  !  to ordering of when pointers are set with respect to when various type-bound procedures are called
  subroutine init_efield(self,cfg,sourcedir,x,dtmodel,dtdata,ymd,UTsec)
    class(efielddata), intent(inout) :: self
    type(gemini_cfg), intent(in) :: cfg                 ! gemini config type for optional params
    character(*), intent(in) :: sourcedir    ! directory for precipitation data input
    class(curvmesh), intent(in) :: x                    ! curvmesh object
    real(wp), intent(in) :: dtmodel,dtdata                      ! model time step and cadence for input data from config.nml
    integer, dimension(3), intent(in) :: ymd            ! target date of initiation
    real(wp), intent(in) :: UTsec                       ! target time of initiation
    character(:), allocatable :: strname

    ! tell our object where its data are and give the dataset a name
    call self%set_source(sourcedir)
    strname='electric field boundary conditions'
    call self%set_name(strname)
    self%flagdoinput=cfg%flagE0file/=0

    ! read the simulation size from the source directory and allocate arrays
    allocate(self%lc1,self%lc2,self%lc3)      ! these are pointers
    self%llon=>self%lc2; self%llat=>self%lc3;
    call self%load_size()
    call self%set_sizes(1, &
                       0,2,2, &
                       4,0,0, &
                       0, &
                       x )
    call self%init_storage()
    call self%set_cadence(dtdata)

    ! set local pointers grid pointers and assign input data grid
    self%mlonp=>self%coord2; self%mlatp=>self%coord3;
    call self%load_grid()

    ! set input data array pointers to faciliate easy to read input code
    self%flagdirich=>self%data0D(1)
    self%E0xp=>self%data2Dax23(:,:,1)
    self%E0yp=>self%data2Dax23(:,:,2)
    self%Vminx1p=>self%data2Dax23(:,:,3)
    self%Vmaxx1p=>self%data2Dax23(:,:,4)
    self%Vminx2pslice=>self%data1Dax3(:,1)
    self%Vmaxx2pslice=>self%data1Dax3(:,2)
    self%Vminx3pslice=>self%data1Dax2(:,1)
    self%Vmaxx3pslice=>self%data1Dax2(:,2)

    self%E0xiprev=>self%data2Dax23i(:,:,1,1)
    self%E0yiprev=>self%data2Dax23i(:,:,2,1)
    self%Vminx1iprev=>self%data2Dax23i(:,:,3,1)
    self%Vmaxx1iprev=>self%data2Dax23i(:,:,4,1)
    self%Vminx2isprev=>self%data1Dax3i(:,1,1)
    self%Vmaxx2isprev=>self%data1Dax3i(:,2,1)
    self%Vminx3isprev=>self%data1Dax2i(:,1,1)
    self%Vmaxx3isprev=>self%data1Dax2i(:,2,1)

    self%E0xinext=>self%data2Dax23i(:,:,1,2)
    self%E0yinext=>self%data2Dax23i(:,:,2,2)
    self%Vminx1inext=>self%data2Dax23i(:,:,3,2)
    self%Vmaxx1inext=>self%data2Dax23i(:,:,4,2)
    self%Vminx2isnext=>self%data1Dax3i(:,1,2)
    self%Vmaxx2isnext=>self%data1Dax3i(:,2,2)
    self%Vminx3isnext=>self%data1Dax2i(:,1,2)
    self%Vmaxx3isnext=>self%data1Dax2i(:,2,2)

    self%E0xinow=>self%data2Dax23inow(:,:,1)
    self%E0yinow=>self%data2Dax23inow(:,:,2)
    self%Vminx1inow=>self%data2Dax23inow(:,:,3)
    self%Vmaxx1inow=>self%data2Dax23inow(:,:,4)
    self%Vminx2isnow=>self%data1Dax3inow(:,1)
    self%Vmaxx2isnow=>self%data1Dax3inow(:,2)
    self%Vminx3isnow=>self%data1Dax2inow(:,1)
    self%Vmaxx3isnow=>self%data1Dax2inow(:,2)

    ! initialize the prev variables sensibly
    self%E0xiprev=0.0
    self%E0yiprev=0.0
    self%Vminx1iprev=0.0
    self%Vmaxx1iprev=0.0
    self%Vminx2isprev=0.0
    self%Vmaxx2isprev=0.0
    self%Vminx3isprev=0.0
    self%Vmaxx3isprev=0.0

    ! set to start time of simulation - set the first time update is called
    !self%ymdref(:,1)=cfg%ymd0; self%ymdref(:,2)=cfg%ymd0;
    !self%UTsecref(1)=cfg%UTsec0; self%UTsecref(2)=cfg%UTsec0;

    ! prime input data
    print*, 'Preparing to prime input data arrays...'
    call self%prime_data(cfg,x,dtmodel,ymd,UTsec)
  end subroutine init_efield

  !> get the input grid size from file, all workers will just call this sicne this is a one-time thing
  subroutine load_size_efield(self)
    class(efielddata), intent(inout) :: self

    ! basic error checking
    if (.not. self%flagsource) error stop 'efielddata:load_size_precip() - must define a source directory first'

    ! read sizes
    print '(/,A,/,A)', 'Electric field input:','--------------------'
    print '(A)', 'READ electric field size from: ' // self%sourcedir
    call get_simsize2(self%sourcedir, llon=self%llon, llat=self%llat)

    print '(A,2I6)', 'Electric field size: llon,llat:  ',self%llon,self%llat
    if (self%llon < 1 .or. self%llat < 1) then
     print*, '  efielddata grid size must be strictly positive: ' //  self%sourcedir
     error stop
    end if

    ! set dim 1 size to null since inherently not used
    self%lc1=0

    ! flag to denote input data size is set
    self%flagdatasize=.true.
  end subroutine load_size_efield

  !> get the grid information from a file, all workers will just call this since one-time
  subroutine load_grid_efield(self)
    class(efielddata), intent(inout) :: self

    ! read grid data
    call get_grid2(self%sourcedir, self%mlonp, self%mlatp)

    print '(A,4F9.3)', 'Electric field mlon,mlat extent:  ',minval(self%mlonp(:)),maxval(self%mlonp(:)), &
                                                           minval(self%mlatp(:)),maxval(self%mlatp(:))
    if(.not. all(ieee_is_finite(self%mlonp))) error stop 'efielddata:loadgrid() - mlon must be finite'
    if(.not. all(ieee_is_finite(self%mlatp))) error stop 'efielddata:loadgrid() - mlat must be finite'
  end subroutine load_grid_efield

  subroutine set_coordsi_efield(self,cfg,x)
    class(efielddata), intent(inout) :: self
    type(gemini_cfg), intent(in) :: cfg     ! presently not used but possibly eventually?
    class(curvmesh), intent(in) :: x
    integer :: ix2,ix3,iflat,ix1ref,ix2ref,ix3ref

    print*, shape(self%coord1i),shape(self%coord2i),shape(self%coord3i)

    !! reference locations for determining points onto which we are interpolating
    !! these are grid specific, not object specific...
    if (x%lx2all > 1 .and. x%lx3all>1) then ! 3D sim
      ix2ref = x%lx2all/2      !note integer division
      ix3ref = x%lx3all/2
    else if (x%lx2all==1 .and. x%lx3all>1) then
      ix2ref = 1
      ix3ref=x%lx3all/2
    else if (x%lx2all>1 .and. x%lx3all==1) then
      ix2ref=x%lx2all/2
      ix3ref=1
    else
      error stop 'Unable to orient boundary conditions for electric potential'
    endif

    !! by default the code uses 300km altitude as a reference location, using the center x2,x3 point
    !! These are the coordinates for inputs varying along axes 2,3
    ix1ref = minloc(abs(x%rall(:,ix2ref,ix3ref) - Re - 300e3_wp), dim=1)
    do ix3=1,lx3all
      do ix2=1,lx2all
        iflat=(ix3-1)*lx2all+ix2
        self%coord2iax23(iflat)=x%phiall(ix1ref,ix2,ix3)*180/pi
        self%coord3iax23(iflat)=90-x%thetaall(ix1ref,ix2,ix3)*180/pi
      end do
    end do
    if (debug) print '(A,4F7.2)', 'Grid has mlon,mlat range:  ',minval(self%coord2iax23),maxval(self%coord2iax23), &
                                     minval(self%coord3iax23),maxval(self%coord3iax23)
    if (debug) print *, 'Grid has size:  ',iflat

    if (self%flagdipmesh) then
      !! for electric field input data we also have some things that vary along axis 3 only
      do ix2=1,x%lx2all    ! note mangling ix2->ix3
        self%coord3iax3(ix2)=90-x%thetaall(ix1ref,ix2,1)*180/pi     ! default to ix2=1 side of the grid
      end do
      !! for BCs varing along axis 2 only
      do ix3=1,x%lx3all    ! note mangling ix3->ix2
        self%coord2iax2(ix3)=x%phiall(ix1ref,1,ix3)*180/pi          ! default to ix3=1 side of the grid
      end do
    else
      !! for electric field input data we also have some things that vary along axis 3 only
      do ix3=1,x%lx3all
        self%coord3iax3(ix3)=90-x%thetaall(ix1ref,1,ix3)*180/pi     ! default to ix2=1 side of the grid
      end do
      !! for BCs varing along axis 2 only
      do ix2=1,x%lx2all
        self%coord2iax2(ix2)=x%phiall(ix1ref,ix2,1)*180/pi          ! default to ix3=1 side of the grid
      end do
    end if

    !! mark coordinates as set
    self%flagcoordsi=.true.
  end subroutine set_coordsi_efield

  !> have root read in data from a file (only root manipulates this object)
  subroutine load_data_efield(self,t,dtmodel,ymdtmp,UTsectmp)
    class(efielddata), intent(inout) :: self
    real(wp), intent(in) :: t,dtmodel
    integer, dimension(3), intent(inout) :: ymdtmp
    real(wp), intent(inout) :: UTsectmp
    integer :: iid,ierr
    integer :: flagdirich_int

    !! all workers should update the date
    ymdtmp = self%ymdref(:,2)
    UTsectmp = self%UTsecref(2)
    call dateinc(self%dt, ymdtmp, UTsectmp)

    !! all workers read data out of this file
    print*, '  date and time:  ',ymdtmp,UTsectmp
    print*, '  efield filename:  ',date_filename(self%sourcedir,ymdtmp,UTsectmp)

    call get_Efield(date_filename(self%sourcedir, ymdtmp, UTsectmp), &
      flagdirich_int,self%E0xp,self%E0yp,self%Vminx1p,self%Vmaxx1p,&
      self%Vminx2pslice,self%Vmaxx2pslice,self%Vminx3pslice,self%Vmaxx3pslice)
    self%flagdirich=real(flagdirich_int,wp)

    if (debug) then
      print*, ' Solve type:  ', self%flagdirich
      print *, 'Min/max values for E0xp:  ',minval(self%E0xp),maxval(self%E0xp)
      print *, 'Min/max values for E0yp:  ',minval(self%E0yp),maxval(self%E0yp)
      print *, 'Min/max values for Vminx1p:  ',minval(self%Vminx1p),maxval(self%Vminx1p)
      print *, 'Min/max values for Vmaxx1p:  ',minval(self%Vmaxx1p),maxval(self%Vmaxx1p)
      print *, 'Min/max values for Vminx2pslice:  ',minval(self%Vminx2pslice),maxval(self%Vminx2pslice)
      print *, 'Min/max values for Vmaxx2pslice:  ',minval(self%Vmaxx2pslice),maxval(self%Vmaxx2pslice)
      print *, 'Min/max values for Vminx3pslice:  ',minval(self%Vminx3pslice),maxval(self%Vminx3pslice)
      print *, 'Min/max values for Vmaxx3pslice:  ',minval(self%Vmaxx3pslice),maxval(self%Vmaxx3pslice)
    endif

    if (.not. all(ieee_is_finite(self%E0xp))) error stop 'E0xp: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%E0yp))) error stop 'E0yp: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vminx1p))) error stop 'Vminx1p: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vmaxx1p))) error stop 'Vmaxx1p: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vminx2pslice))) error stop 'Vminx2pslice: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vmaxx2pslice))) error stop 'Vmaxx2pslice: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vminx3pslice))) error stop 'Vminx3pslice: non-finite value(s)'
    if (.not. all(ieee_is_finite(self%Vmaxx3pslice))) error stop 'Vmaxx3pslice: non-finite value(s)'
  end subroutine load_data_efield

  !> destructor needs to clear memory out
  subroutine destructor(self)
    type(efielddata), intent(inout) :: self

    call self%dissociate_pointers()
  end subroutine destructor
end module efielddataobj

max_forks_repo_name: mattzett/GEMINI