PROGRAM create_input
!###
!*****************************************************************************
!                                                                            *
!     Program Name: create_input                                             *
!                                                                            *
!     File Name: create_input.f90                                            *
!                                                                            *
!     Purpose:  An interactive program used to create the input parameter    *
!               file for the thermodynamic equilibrium program.              *
!                                                                            *
!     Author:    Robert L. Reese                                             *
!                                                                            *
!     Date:      April 24, 2006                                              *
!                                                                            *
!     Language: Salford FORTRAN 95, Version 0.9.0                            *
!                                                                            *
!     Hardware: IBM Compatible PC                                            *
!                                                                            *
!     Operating System: Microsoft Windows XP                                 *
!                                                                            *
!     Update History:                                                        *
!                                                                            *
!     Name          Date        Revision        Changes                      *
!     ----          ----        ---------        -------                     *
!                                                                            *
!    R.L. Reese     04/24/06        0           Initial Release              *
!                                                                            *
!----------------------------------------------------------------------------*
!                                                                            *
!  Execution Command:                                                        *
!                                                                            *
!  create_input where:                                                       *
!                                                                            *
!     No Parameters                                                          *
!                                                                            *
!     Program will request name of output listing file which can be used as  *
!     the input parameter file to the thermodynamic program.                 *
!                                                                            *
!----------------------------------------------------------------------------*
!                                                                            *
!     Definitions:                                                           *
!                                                                            *
!     Local Variables:                                                       *
!     ---------------                                                        *
!                                                                            *
!     adata          - Character array used to get temperature or pressure   *
!                      values                                                *
!     add            - Real array of mole values increments                  *
!     answer         - Character used to get user's reply to questions       *
!     anum           - Real array of atom names for reactants                *
!     atom           - Character array atomic name of current input atom     *
!     base           - Real array of mole values starting value              *
!     found          - Logical value to test for finding atom in table       *
!     gas_input      - Logical value for testing for using gas input         *
!     i              - Integer value of loop index                           *
!     iatom          - Character array containing all atomic symbols         *
!     idata          - Character array used to read in temperature or        *
!                      pressure values                                       *
!     index_test     - Integer value of test to determine if blank record    *
!                      should be inserted after last pressure or temperature *
!                      values                                                *
!     j              - Integer value of loop index                           *
!     k              - Integer value of loop index                           *
!     kase           - Integer value of case number for current job          *
!     limit_test     - Logical value used to test for maximum omit and insert*
!                      names                                                 *
!     n              - Integer value of current set of values being output   *
!     name           - Character array used to read in input atomic names    *
!     new_thermo     - Character to set new_thermo value                     *
!     not_open       - Integer value of status of opening the output file    *
!     omit_count     - Integer value of number of omit records               *
!     omit_name_1    - Character array containing first omit and insert names*
!     omit_name_2    - Character array containing second omit and insert     *
!                      names                                                 *
!     react_count    - Integer value of number of total reactants            *
!     read_status    - Integer status of read operation                      *
!     rec_size       - Integer value of length of temperature or pressure    *
!                      input record                                          *
!     p              - Real array of pressure values                         *
!     p_index        - Integer value of index of current pressure value      *
!     p_index_save   - Integer value of index of current pressure value saved*
!                      at start of current record                            *
!     rsize          - Real value of value for scaling output values         *
!     skip_next      - Logical value of flag used to skip process if retry   *
!                      is being done                                         *
!     t              - Real array of temperature values                      *
!     t_index        - Integer value of index of current temperature value   *
!     t_index_save   - Integer value of index of current temperature value   *
!                      saved at start of current record                      *
!     tem            - Character to set tem value                            *
!     top            - Real array of mole values ending value                *
!     tri            - Real value of type of pressure/temperature pairs      *
!                                                                            *
!     Special variables for file_openr                                       *
!     --------------------------------                                       *
!                                                                            *
!     ifind - Integer containing file find results                           * 
!     winio@- Integer used for WIN32 applications                            *
!                                                                            *
!     Global Variables:                                                      *
!     ----------------                                                       *
!                                                                            *
!     None                                                                   *
!                                                                            *
!     Local Common Blocks:                                                   *
!     -------------------                                                    *
!                                                                            *
!     filenm       -  Character containing output file name in unlable common*
!                                                                            *
!     Constants:                                                             *
!     ---------                                                              *
!                                                                            *
!     file_length    - Integer value of maximum length of file name          *
!     iatom_length   - Integer value of length of atom names                 *
!     len_char       - Integer value of length of characters in species name *
!     max_atoms      - Integer value of maximum number of element names      *
!     max_elements   - Integer value of maximum elements in a current system *
!     max_species    - Integer value of maximum number of omit/insert names  *
!     max_tp_value   - Integer value of maximum value of temperature or      *
!                      pressure allowed                                      *
!     max_val_size   - Integer value of maximum number of digits in a value  *
!                      for temperatures or pressures                         *
!     omit_length    - Integer length of the specie to be omitted            *
!     output_unit    - Integer value of the output unit number               *
!     pt_size        - Integer value of maximum number of temperature or     *
!                      pressure values allowed                               *
!     react_sets     - Integer value of maximum number of reactants allowed  *
!     react_values   - Integer value of maximum number of atoms per reactant *
!                      record                                                *
!     t_p_values     - Integer value of maximum number of temperature or     *
!                      pressure values per record                            *
!                                                                            *
!     Modules:                                                               *
!     --------                                                               *
!                                                                            *
!     WINAPP           - Windows 32 module containing the winio data         *
!                                                                            *
!     External Software:                                                     *
!     -----------------                                                      *
!                                                                            *
!     disp_name        - Routine to get the output file name.                *
!     file_openw       - Routine to open the output file.                    *
!     stop_go          - Routine to handle questions about stopping or       *
!                        continuing in event of error                        *
!                                                                            *
!     Files:                                                                 *
!     -----                                                                  *
!                                                                            *
!       Input Files:                                                         *
!                                                                            *
!       None                                                                 *
!                                                                            *
!       Intermediate Files:                                                  *
!                                                                            *
!       None                                                                 *
!                                                                            *
!       Output Files:                                                        *
!                                                                            *
!       outfile      - Output listing file                                   *
!                                                                            *
!*****************************************************************************
!###

  WINAPP

  IMPLICIT none

  INTEGER, PARAMETER                  :: max_species     = 100
  INTEGER, PARAMETER                  :: max_elements    = 15 
  INTEGER, PARAMETER                  :: file_length     = 1024
  INTEGER, PARAMETER                  :: iatom_length    = 2
  INTEGER, PARAMETER                  :: len_char        = 4
  INTEGER, PARAMETER                  :: max_atoms       = 102
  INTEGER, PARAMETER                  :: max_tp_value    = 9999.
  INTEGER, PARAMETER                  :: max_val_size    = 5
  INTEGER, PARAMETER                  :: omit_length     = 8
  INTEGER, PARAMETER                  :: output_unit     = 6
  INTEGER, PARAMETER                  :: pt_size         = 45
  INTEGER, PARAMETER                  :: react_sets      = max_elements
  INTEGER, PARAMETER                  :: react_values    = 5
  INTEGER, PARAMETER                  :: t_p_values      = 9

  INTEGER :: i
  INTEGER :: index_test
  INTEGER :: j
  INTEGER :: k
  INTEGER :: kase
  INTEGER :: n
  INTEGER :: not_open
  INTEGER :: omit_count
  INTEGER :: react_count
  INTEGER :: read_status
  INTEGER :: rec_size
  INTEGER :: p_index
  INTEGER :: p_index_save 
  INTEGER :: t_index
  INTEGER :: t_index_save 

  REAL,DIMENSION(react_sets)                 :: add
  REAL,DIMENSION(react_sets,react_values)    :: anum
  REAL,DIMENSION(react_sets)                 :: base
  REAL,DIMENSION(pt_size)                    :: p
  REAL,DIMENSION(pt_size)                    :: t
  REAL,DIMENSION(react_sets)                 :: top

  REAL :: rsize
  REAL :: tri

  LOGICAL :: found
  LOGICAL :: gas_input
  LOGICAL :: limit_test
  LOGICAL :: skip_next

!  Special variables for file_openw

  CHARACTER(len=256) :: filenm
  INTEGER :: ifind 
  INTEGER :: winio@
  COMMON filenm
  EXTERNAL disp_name 

! Local character variables

  CHARACTER(len=max_val_size)                                     :: adata
  CHARACTER(len=1)                                                :: answer
  CHARACTER(len = iatom_length)                                   :: atom
  CHARACTER(len=file_length)                                      :: idata
  CHARACTER(len =iatom_length),DIMENSION(react_sets,react_values) :: name
  CHARACTER(len=1)                                                :: new_thermo
  CHARACTER(len = len_char),DIMENSION(omit_length)                :: omit_name_1
  CHARACTER(len = len_char),DIMENSION(omit_length)                :: omit_name_2
!  CHARACTER(len = file_length)                                    :: outfile
  CHARACTER(len=1)                                                :: tem

  CHARACTER(len = iatom_length),DIMENSION(max_atoms),PARAMETER  :: iatom = (/ &
       'H ', 'HE', 'LI', 'BE', 'B ', 'C ', 'N ', 'O ', 'F ', 'NE', 'NA', &
       'MG', 'AL', 'SI', 'P ', 'S ', 'CL', 'AR', 'K ', 'CA', 'SC', 'TI', &
       'V ', 'CR', 'MN', 'FE', 'CO', 'NI', 'CU', 'ZN', 'GA', 'GE', 'AS', &
       'SE', 'BR', 'KR', 'RB', 'SR', 'Y ', 'ZR', 'NB', 'MO', 'TC', 'RU', &
       'RH', 'PD', 'AG', 'CD', 'IN', 'SN', 'SB', 'TE', 'I ', 'XE', 'CS', &
       'BA', 'LA', 'CE', 'PR', 'ND', 'PM', 'SM', 'EU', 'GD', 'TB', 'DY', &
       'HO', 'ER', 'TM', 'YB', 'LU', 'HF', 'TA', 'W ', 'RE', 'OS', 'IR', &
       'PT', 'AU', 'HG', 'TL', 'PB', 'BI', 'PO', 'AT', 'RN', 'FR', 'RA', &
       'AC', 'TH', 'PA', 'U ', 'NP', 'PU', 'AM', 'CM', 'BK', 'CF', 'ES', &
       'FM', 'D ','E '/)

  outer_loop : DO
    read_status = 0

! Process output file

    good_output : DO
      filenm = ' '

! Special way of inputing file name, outputs windows menu to screen

      WRITE(*,fmt = "(a)")'Use menu to browse for output file.'
      WRITE(*,fmt = "(a)")'Select directory and enter name of file.'
!      outfile=' '
      ifind=winio@('%ca[Output File]&')
      ifind=winio@("%fs[c:\*.*]&")
      ifind=winio@("%mn[&File[&Open]]&","FILE_OPENW",filenm,disp_name)
      ifind=winio@("%mn[[E&xit]]","EXIT")
!      WRITE(*,fmt = "(a)",advance = 'NO')  ' Input name of output file : '
!      READ(*,fmt="(a)") outfile
!      i = len(outfile) 
      i = len(filenm) 
      find_length : DO 
!        find_end : IF(outfile(i:i) >='!') THEN
        find_end : IF(filenm(i:i) >='!') THEN
          EXIT find_length
        END IF find_end
        i = i - 1
      END DO find_length
!      WRITE(*,fmt = "(a,a)")' OUTPUT FILE : ',outfile(1:i)  
!      OPEN(unit = output_unit,file = outfile,status = 'unknown',iostat = not_open)
      WRITE(*,fmt = "(a,a)")'OUTPUT FILE : ',filenm(1:i)  
      OPEN(unit = output_unit,file = filenm,status = 'unknown',iostat = not_open)
      open_output : IF (not_open /= 0) THEN
        WRITE(*,fmt = "(a)") 'UNABLE TO OPEN OUTPUT FILE'
        CALL stop_go(read_status)
          IF(read_status /= 0)THEN
            EXIT outer_loop 
          END IF
      ELSE open_output
        EXIT good_output
      END IF open_output
    END DO good_output
    REWIND output_unit
    EXIT outer_loop

  END DO outer_loop 

! Process Reactant records

  n = 1 
  react_count = 0
  get_reacts : IF(read_status == 0)THEN
    WRITE(*,fmt="(a)")"Maximum of 15 elements allowed."
    WRITE(*,fmt="(a)")"Enter data for current reactant record."
    WRITE(*,fmt="(a)")"Maximum of 5 elements for each record."
    WRITE(*,fmt="(a)")"1 to 15 reactant records allowed depending on"
    WRITE(*,fmt="(a)")"number of elements per record."
    WRITE(unit = output_unit,fmt = "(a)",iostat = read_status)"REAC"
    outer_loop_1 : DO
      name = ' '
      anum = 0.0
      base = 0.0
      top  = 0.0
      add  = 0.0
      get_symbols : DO j = 1,react_values
        get_element : DO
          skip_next = .false.
          WRITE(*,fmt="(a)",advance = 'NO')"Enter element symbol: " 
          READ(*,fmt="(a2)",iostat = read_status) name(n,j)
          symbol_error : IF(read_status /= 0)THEN
            WRITE(*,fmt="(a)")"Error in element name."
            skip_next = .true.
            CALL stop_go(read_status)
            exit_get_1 : IF(read_status /= 0)THEN
              EXIT get_symbols
            END IF exit_get_1
          END IF symbol_error

          skip_next_1 : IF(.not.skip_next)THEN
            check_for_missing : IF(name(n,j) == '  ')THEN
              missing_first : IF (n == 1 .and. j == 1)THEN
                read_status = 1
                WRITE(*,fmt="(a)")"Error, first reactant record missing."
                skip_next = .true.
                CALL stop_go(read_status)
                exit_get_2 : IF(read_status /= 0)THEN
                  EXIT get_symbols
                END IF exit_get_2             
              END IF missing_first
              exit_get_3 : IF(.not. skip_next)THEN
                EXIT get_symbols 
              END IF exit_get_3
            END IF check_for_missing
          END IF skip_next_1

          skip_next_2 : IF(.not.skip_next)THEN
            found = .false.
            verify_name : DO k = 1,max_atoms 
              atom = name(n,j)
              found_good : IF(iatom(k) == atom) THEN 
                found = .true.
                EXIT verify_name
              END IF found_good
            END DO verify_name 
            invalid_name : IF(.not.found)THEN
              WRITE(*,fmt="(a)")"Element symbol not valid"
              skip_next = .true.
              CALL stop_go(read_status)
              exit_get_3 : IF(read_status /= 0)THEN
                EXIT get_symbols
              END IF exit_get_3             
              exit_get_4 : IF(.not. skip_next)THEN
                EXIT get_symbols 
              END IF exit_get_4
            END IF invalid_name
          END IF skip_next_2

          skip_test_1 : IF(.not.skip_next)THEN
            EXIT get_element
          END IF skip_test_1
        END DO get_element

        start_check : IF(read_status == 0)THEN
          react_count = react_count + 1
          max_element : IF(react_count > max_elements)THEN
            read_status = 1
            WRITE(*,fmt="(a,i4,a)")"Error, More than ",max_elements,",elements entered."
            EXIT get_symbols
          END IF max_element
        END IF start_check

        get_mole : DO
          skip_next = .false.
          WRITE(*,fmt="(a)",advance = 'NO')"Enter mole value: " 
          READ(*,fmt="(f7.0)",iostat = read_status) anum(n,j)
          mole_error : IF(read_status /= 0)THEN
            WRITE(*,fmt="(a)")"Error in mole value"
            skip_next = .true.
            CALL stop_go(read_status)
            exit_get_5 : IF(read_status /= 0)THEN
              EXIT get_symbols
            END IF exit_get_5
          END IF mole_error
          skip_next_3 : IF(.not.skip_next)THEN
            number_error : IF(anum(n,j) <= 0.0)THEN
              WRITE(*,fmt="(a)")"Error, mole value must be greater than zero."
              skip_next = .true.
              CALL stop_go(read_status)
              exit_get_6 : IF(read_status /= 0)THEN
                EXIT get_symbols
              END IF exit_get_6
            END IF number_error
            skip_test_2 : IF(.not.skip_next)THEN
              EXIT get_mole
            END IF skip_test_2
          END IF skip_next_3
        END DO get_mole
      END DO get_symbols

      reacts_ok : IF(read_status == 0)THEN
        mole_increments : DO

          get_base : DO
            WRITE(*,fmt="(a)",advance = 'NO')"Enter base value: " 
            READ(*,fmt="(f9.0)",iostat = read_status) base(n)
            bad_base : IF(read_status /= 0)THEN
              WRITE(*,fmt="(a)")"Error in base value"
              CALL stop_go(read_status)
              exit_get_7 : IF(read_status /= 0)THEN
                EXIT mole_increments
              END IF exit_get_7
            ELSE
              EXIT get_base 
            END IF bad_base
          END DO get_base

          get_top : DO
            WRITE(*,fmt="(a)",advance = 'NO')"Enter top value: " 
            READ(*,fmt="(f9.0)",iostat = read_status) top(n)
            bad_top : IF(read_status /= 0)THEN
              WRITE(*,fmt="(a)")"Error in top value"
              CALL stop_go(read_status)
              exit_get_8 : IF(read_status /= 0)THEN
                EXIT mole_increments
              END IF exit_get_8
            ELSE
              EXIT get_top 
            END IF bad_top
          END DO get_top

          get_add : DO
            WRITE(*,fmt="(a)",advance = 'NO')"Enter add value: " 
            READ(*,fmt="(f9.0)",iostat = read_status) add(n)
            bad_add : IF(read_status /= 0)THEN
              WRITE(*,fmt="(a)")"Error in add value"
              CALL stop_go(read_status)
              exit_get_9 : IF(read_status /= 0)THEN
                EXIT mole_increments
              END IF exit_get_9
            ELSE
              EXIT get_add 
            END IF bad_add
          END DO get_add

          EXIT mole_increments

        END DO mole_increments
        exit_increments : IF( read_status /= 0)THEN
          EXIT outer_loop_1
        END IF exit_increments
      END IF reacts_ok

      bad_increments : IF( read_status /= 0)THEN
        EXIT outer_loop_1
      END IF bad_increments
      output_increments : IF(read_status == 0)THEN
        WRITE(unit = output_unit,fmt = "(5(a2,f7.4),3f9.4)",iostat = read_status) &
        (name(n,i),anum(n,i),i = 1,react_values),base(n),top(n),add(n)
      END IF output_increments
      WRITE(*,fmt="(a)",advance = 'NO')"Another reactant record? ('Y' or 'N'): " 
      READ(*,fmt="(a)",iostat = read_status) answer
      bad_answer : IF(read_status /= 0)THEN
        WRITE(*,fmt="(a)")" Error in reply value"
        EXIT outer_loop_1
      END IF bad_answer
      good_answer : IF(answer == 'N' .or. answer == 'n')THEN
        EXIT outer_loop_1
      END IF good_answer
      n = n + 1
    END DO outer_loop_1 
  END IF get_reacts

! Process Omit records

  limit_test = .false.
  do_omits : IF(read_status == 0)THEN
    WRITE(*,fmt="(a)")"Maximum of 100 species allowed."
    WRITE(unit = output_unit,fmt = "(a)",iostat = read_status)"  " 
    omit_count = 0
    begin_omits : DO
      omit_name_1 = ' '
      omit_name_2 = ' '
      omit_limit_1 : IF(limit_test)THEN
        EXIT begin_omits
      END IF omit_limit_1
      WRITE(*,fmt="(a)",advance = 'NO')"Enter first omit name: " 
      READ(*,fmt="(8a4)",iostat = read_status) (omit_name_1(j),j=1,omit_length)
      bad_omit_1 : IF(read_status /= 0)THEN
        WRITE(*,fmt="(a)")"Error in first omit name"
        EXIT begin_omits
      END IF bad_omit_1
      no_omits : IF(omit_name_1(1) == '    ')THEN
        EXIT begin_omits
      END IF no_omits
      omit_count = omit_count + 1
      max_omits_1 : IF(omit_count == max_species)THEN
        limit_test = .true.
      END IF max_omits_1
      omit_limit_2 : IF(.not. limit_test)THEN
        WRITE(*,fmt="(a)",advance = 'NO')"Enter second omit name: " 
        READ(*,fmt="(8a4)",iostat = read_status) (omit_name_2(j),j=1,omit_length)
        bad_omit_2 : IF(read_status /= 0)THEN
          WRITE(*,fmt="(a)")" Error in second omit name"
          EXIT begin_omits
        END IF bad_omit_2
        increment_omit : IF(omit_name_2(1) /= "    ")THEN
          omit_count = omit_count + 1
          max_omits_2 : IF(omit_count == max_species)THEN
            limit_test = .true.
          END IF max_omits_2
        ELSE increment_omit
          limit_test = .true.
        END IF increment_omit
      END IF omit_limit_2
      WRITE(unit=output_unit,fmt="(a,4x,8a4,6x,8a4)")"OMIT",(omit_name_1(j),j=1,omit_length),(omit_name_2(j),j=1,omit_length)
      exit_omits : IF(limit_test)THEN
        EXIT begin_omits
      END IF exit_omits
    END DO begin_omits
  END IF do_omits

! Process Insert records

  limit_test = .false.
  do_inserts : IF(read_status == 0)THEN
    WRITE(*,fmt="(a)")"Maximum of 100 species allowed."
    omit_count = 0
    begin_inserts : DO
      omit_name_1 = ' '
      omit_name_2 = ' '
      insert_limit : IF(limit_test)THEN
        EXIT begin_inserts
      END IF insert_limit
      WRITE(*,fmt="(a)",advance = 'NO')"Enter first insert name: " 
      READ(*,fmt="(8a4)",iostat = read_status) (omit_name_1(j),j=1,omit_length)
      bad_insert_1 : IF(read_status /= 0)THEN
        WRITE(*,fmt="(a)")" Error in first insert name"
        EXIT begin_inserts
      END IF bad_insert_1
      no_inserts : IF(omit_name_1(1) == '    ')THEN
        EXIT begin_inserts
      END IF no_inserts
      omit_count = omit_count + 1
      max_insert_1 : IF(omit_count == max_species)THEN
        limit_test = .true.
      END IF max_insert_1
      insert_limit_2 : IF(.not. limit_test)THEN
        WRITE(*,fmt="(a)",advance = 'NO')"Enter second insert name: " 
        READ(*,fmt="(8a4)",iostat = read_status) (omit_name_2(j),j=1,omit_length)
        bad_insert_2 : IF(read_status /= 0)THEN
          WRITE(*,fmt="(a)")" Error in second insert name"
          EXIT begin_inserts
        END IF bad_insert_2
        increment_insert : IF(omit_name_2(1) /= "    ")THEN
          omit_count = omit_count + 1
          max_inserts_2 : IF(omit_count == max_species)THEN
            limit_test = .true.
          END IF max_inserts_2
        ELSE increment_insert
          limit_test = .true.
        END IF increment_insert
      END IF insert_limit_2
      WRITE(unit=output_unit,fmt="(a,4x,8a4,6x,8a4)")"INSE",(omit_name_1(j),j=1,omit_length),(omit_name_2(j),j=1,omit_length)
      exit_inserts : IF(limit_test)THEN
        EXIT begin_inserts
      END IF exit_inserts
    END DO begin_inserts
  END IF do_inserts

! Process Name records

  do_name : IF(read_status == 0)THEN
    WRITE(unit = output_unit,fmt = "(a)",iostat = read_status)"NAME"
    gas_input = .true.
    start_record : DO

      kase_loop : DO 
        WRITE(*,fmt="(a)",advance = 'NO')"Enter Case value (Integers): " 
        READ(*,fmt="(i5)",iostat = read_status) kase
        kase_error : IF(read_status /= 0)THEN
          WRITE(*,fmt="(a)")"Error in Kase format"
          CALL stop_go(read_status)
          exit_get_10 : IF(read_status /= 0)THEN
            EXIT start_record
          END IF exit_get_10
        ELSE kase_error
          EXIT kase_loop 
        END IF kase_error
      END DO kase_loop

      tem_loop : DO 
        WRITE(*,fmt="(a)",advance = 'NO')"Enter Tem value (T or F): "
        tem = ' ' 
        READ(*,fmt="(a1)",iostat = read_status) tem
        tem_error : IF(read_status /= 0)THEN
          WRITE(*,fmt="(a)")"Error in Tem format"
          EXIT start_record
        END IF tem_error
        logical_test_1 : IF(tem == ' ')THEN
          tem = 'F'
        ELSE IF(tem == 't' )THEN logical_test_1
          tem = 'T'
        ELSE IF(tem == 'f' )THEN logical_test_1
          tem = 'F'
        END IF logical_test_1
        logical_test_2 : IF(tem /= 'T' .and. tem /= 'F')THEN
          WRITE(*,fmt="(a)")"Error in Tem format"
          WRITE(*,fmt="(a)")"Must be upper case T or F or blank"
          CALL stop_go(read_status)
          exit_get_11 : IF(read_status /= 0)THEN
            EXIT start_record
          END IF exit_get_11
        ELSE  logical_test_2
          EXIT tem_loop
        END IF logical_test_2
      END DO tem_loop

      tri_loop : DO 
        WRITE(*,fmt="(a)",advance = 'NO')"Enter TRI value (decimal): " 
        READ(*,fmt="(f11.0)",iostat = read_status) tri
        tri_error : IF(read_status /= 0)THEN
          WRITE(*,fmt="(a)")"Error in TRI format"
          CALL stop_go(read_status)
          exit_get_12 : IF(read_status /= 0)THEN
              EXIT start_record
          END IF exit_get_12
        ELSE tri_error
          EXIT tri_loop 
        END IF tri_error
      END DO tri_loop

      rsize_loop : DO 
        WRITE(*,fmt="(a)",advance = 'NO')"Enter RSIZE value (decimal): " 
        READ(*,fmt="(f9.0)",iostat = read_status) rsize
        rsize_error : IF(read_status /= 0)THEN
          WRITE(*,fmt="(a)")" Error in RSIZE format"
          CALL stop_go(read_status)
          exit_get_13 : IF(read_status /= 0)THEN
            EXIT start_record
          END IF exit_get_13
        ELSE rsize_error
          EXIT rsize_loop
        END IF rsize_error
      END DO rsize_loop

      new_thermo_loop : DO 
        WRITE(*,fmt="(a)",advance = 'NO')"Enter New Thermo value (T or F): " 
        READ(*,fmt="(a1)",iostat = read_status) new_thermo
        thermo_error : IF(read_status /= 0)THEN
          WRITE(*,fmt="(a)")"Error in New Thermo format"
          EXIT start_record
        END IF thermo_error
        logical_test_3 : IF(new_thermo == ' ')THEN
          new_thermo = 'F'
        ELSE IF(new_thermo == 't' )THEN logical_test_3
          new_thermo = 'T'
        ELSE IF(new_thermo == 'f' )THEN logical_test_3
          new_thermo = 'F'
        END IF logical_test_3
        logical_test_4 : IF(new_thermo /= 'T' .and. new_thermo /= 'F')THEN
          WRITE(*,fmt="(a)")"Error in New Thermo format"
          WRITE(*,fmt="(a)")"Must be upper case T or F or blank"
          CALL stop_go(read_status)
          exit_get_14 : IF(read_status /= 0)THEN
            EXIT start_record
          END IF exit_get_14
        ELSE  logical_test_4
          EXIT new_thermo_loop
        END IF logical_test_4
      END DO new_thermo_loop

      EXIT start_record
    END DO start_record
  END IF do_name

! Process temperature records

  do_temp : IF(read_status == 0)THEN
    WRITE(unit = output_unit,fmt = "(a1,l1,i5,f11.3,f9.1,2x,a1)") &
          tem,gas_input,kase,rsize,tri,new_thermo
    WRITE(*,fmt="(a,i3,a)")"Begin input of maximum of ",pt_size," temperature values: " 
    WRITE(*,fmt="(a)")"Leading blank or return key will terminate input: " 
    WRITE(*,fmt="(a,i2,a)")"Maximum of ",max_val_size," digits per value (Including decimal): "
    WRITE(*,fmt="(a)")"Separate each value with a blank: "
    t_index = 0
    t_index_save = 1
    t = 0.0 
    start_temp : DO
      t_retry : DO
        one_temp : DO
          WRITE(*,fmt="(a,i2,a)")"Enter maximum of ",t_p_values," temperature values (decimal): " 
          idata = ' '
          READ(*,fmt="(a)",iostat = read_status) idata 
          temp_read : IF(read_status /= 0)THEN
            WRITE(*,fmt="(a)")"Error in Temperature Values"
            EXIT start_temp
          END IF temp_read
          default_temp : IF(idata(1:1) == ' ')THEN
            zero_temps : IF(t_index == 0) THEN
              WRITE(*,fmt="(a)")"Error in Temperature Values, must enter minimum of one value." 
            ELSE zero_temps
              EXIT start_temp 
            END IF zero_temps
          ELSE default_temp
            EXIT one_temp
          END IF default_temp
        END DO one_temp
        rec_size = len(idata) 
        temp_length : DO 
          temp_end : IF(idata(rec_size:rec_size) >='!') THEN
            EXIT temp_length
          END IF temp_end 
          rec_size = rec_size - 1
        END DO temp_length
        adata = ' '
        j = 1
        k = 1
        get_t_values : DO i = 1,t_p_values
          store_t_values : DO
            no_t_blank : IF(idata(j:j) /= ' ')THEN 
              max_t_val_1 : IF(k > max_val_size) THEN
                WRITE(*,fmt="(a,i6)")"Error in Temperature Values, greater than ", max_tp_value
                CALL stop_go(read_status)
                t_error_1 : IF(read_status /= 0)THEN
                  EXIT start_temp
                ELSE t_error_1 
                  t_index = t_index_save - 1
                  EXIT t_retry
                END IF t_error_1
              END IF max_t_val_1
              adata(k:k) = idata(j:j)
              k = k + 1 
              j = j + 1
            ELSE no_t_blank
              j = j + 1
              next_t_value : IF(k /= 1)THEN
                EXIT store_t_values
              END IF next_t_value
            END IF no_t_blank
          END DO store_t_values
          exit_get_t : IF(read_status /= 0)THEN
            EXIT get_t_values
          END IF exit_get_t
          t_index = t_index + 1
          max_t_val_2 : IF(t_index > pt_size)THEN
            read_status = 1
            WRITE(*,fmt="(a,i3,a)")"Error in Temperature Values, more than",pt_size,"entered."
            EXIT get_t_values
          END IF max_t_val_2
          READ(unit = adata,fmt='(f5.0)',iostat = read_status)t(t_index)
          bad_t :IF(read_status /= 0) THEN
            WRITE(*,fmt="(a)")"Error in Temperature Values, not valid decimal value"
            CALL stop_go(read_status)
            t_error_3 : IF(read_status /= 0)THEN
              EXIT start_temp
            ELSE t_error_3 
              t_index = t_index_save - 1
              EXIT t_retry
            END IF t_error_3
          END IF bad_t
          max_t_val_3 : IF(t(t_index) > max_tp_value) THEN
            WRITE(*,fmt="(a,i6)")"Error in Temperature Values, greater than ",max_tp_value
            CALL stop_go(read_status)
            t_error_2 : IF(read_status /= 0)THEN
              EXIT start_temp
            ELSE t_error_2 
              t_index = t_index_save - 1
              EXIT t_retry
            END IF t_error_2
          END IF max_t_val_3
          k = 1
          add_t_j : IF(idata(j:j) == ' ')THEN
            j = j + 1 
          END IF add_t_j
          j_t_end : IF(j > rec_size)THEN
            EXIT get_t_values
          END IF j_t_end
        END DO get_t_values
        t_error_5 : IF(j <= rec_size)THEN
          WRITE(*,fmt="(a)") "Warning, too many values entered"
          WRITE(*,fmt="(a,i2,a)") "Warning, Only first ",t_p_values," will be used"
          CALL stop_go(read_status)
          t_error_4 : IF(read_status /= 0)THEN
            EXIT start_temp
          END IF t_error_4
        END IF t_error_5
        output_t : IF(read_status == 0)THEN
          WRITE(unit = output_unit,fmt="(9(f5.0))")(t(k),k = t_index_save,t_index)
          index_test = t_index/t_p_values
          test_partial_t : IF((index_test*t_p_values) /= t_index)THEN
            EXIT start_temp
          END IF test_partial_t
          test_full_t : IF( t_index >= pt_size )THEN
            EXIT start_temp
          END IF test_full_t
          t_index_save = t_index + 1
        ELSE output_t
          EXIT start_temp
        END IF output_t
        EXIT t_retry
      END DO t_retry      
    END DO start_temp
  END IF do_temp

  compute_t_index : IF(read_status == 0)THEN
    index_test = t_index/t_p_values
    output_t_blank : IF((index_test*t_p_values) == t_index)THEN
      WRITE(unit = output_unit,fmt = "(a)",iostat = read_status)"     "
    END IF output_t_blank
  END IF compute_t_index

! Process Pressure records

  do_press : IF(read_status == 0)THEN

    WRITE(*,fmt="(a,i3,a)")"Begin input of maximum of ",pt_size," pressure values: "
    WRITE(*,fmt="(a)")"Leading blank or return key will terminate input: " 
    WRITE(*,fmt="(a,i3,a)")"Maximum of ",max_val_size," digits per value (Including decimal): "
    WRITE(*,fmt="(a)")"Separate each value with a blank: "
    p_index = 0
    p_index_save = 1
    p = 0.0 
    start_press : DO
      p_retry : DO
        one_press : DO
          WRITE(*,fmt="(a,i2,a)")"Enter maximum of ",t_p_values," pressure values (decimal): " 
          idata = ' '
          READ(*,fmt="(a)",iostat = read_status) idata 
          press_read : IF(read_status /= 0)THEN
            WRITE(*,fmt="(a)")"Error in Pressure Values"
            EXIT start_press
          END IF press_read 
          default_press : IF(idata(1:1) == ' ')THEN
            zero_press : IF(p_index == 0) THEN
              WRITE(*,fmt="(a)")"Error in Pressure Values, must enter minimum of one value." 
            ELSE zero_press
              EXIT start_press 
            END IF zero_press
          ELSE default_press
            EXIT one_press
          END IF default_press
        END DO one_press
        rec_size = len(idata) 
        press_length : DO 
          press_end : IF(idata(rec_size:rec_size) >='!') THEN
            EXIT press_length
          END IF press_end
          rec_size = rec_size - 1
        END DO press_length
        adata = ' '
        j = 1
        k = 1
        get_p_values : DO i = 1,t_p_values
          store_p_values : DO
            no_p_blank : IF(idata(j:j) /= ' ')THEN 
              max_p_val_1 : IF(k > max_val_size) THEN
                WRITE(*,fmt="(a,i6)")"Error in Pressure Values, greater than ",max_tp_value
                CALL stop_go(read_status)
                p_error_1 : IF(read_status /= 0)THEN
                  EXIT start_press
                ELSE p_error_1 
                  p_index = p_index_save - 1
                  EXIT p_retry
                END IF p_error_1
              END IF max_p_val_1
              adata(k:k) = idata(j:j)
              k = k + 1 
              j = j + 1
            ELSE no_p_blank
              j = j + 1
              next_p_value : IF(k /= 1)THEN
                EXIT store_p_values
              END IF next_p_value
            END IF no_p_blank
          END DO store_p_values
          exit_get_p : IF(read_status /= 0)THEN
            EXIT get_p_values
          END IF exit_get_p
          p_index = p_index + 1
          max_p_val_2 : IF(p_index > pt_size)THEN
            read_status = 1
            WRITE(*,fmt="(a,i3,a)")"Error in Pressure Values, more than",t_index,"entered."
            EXIT get_p_values
          END IF max_p_val_2 
          READ(unit = adata,fmt='(f5.0)',iostat = read_status)p(p_index)
          bad_p :IF(read_status /= 0) THEN
            WRITE(*,fmt="(a)")"Error in Pressure Values, not valid decimal value"
            CALL stop_go(read_status)
            p_error_3 : IF(read_status /= 0)THEN
              EXIT start_press
            ELSE p_error_3 
              p_index = p_index_save - 1
              EXIT p_retry
            END IF p_error_3
          END IF bad_p
          max_p_val_3 : IF(p(p_index) > max_tp_value) THEN
            WRITE(*,fmt="(a,i6)")"Error in Pressure Values, greater than ",max_tp_value
            CALL stop_go(read_status)
            p_error_2 : IF(read_status /= 0)THEN
              EXIT start_press
            ELSE p_error_2 
              p_index = p_index_save - 1
              EXIT p_retry
            END IF p_error_2
          END IF max_p_val_3
          k = 1
          add_p_j : IF(idata(j:j) == ' ')THEN
            j = j + 1 
          END IF add_p_j 
          j_p_end : IF(j > rec_size)THEN
            EXIT get_p_values
          END IF j_p_end
        END DO get_p_values
        p_error_5 : IF(j <= rec_size)THEN
          WRITE(*,fmt="(a)") "Warning, too many values entered"
          WRITE(*,fmt="(a,i2,a)") "Warning, Only first ",t_p_values," will be used"
          CALL stop_go(read_status)
          p_error_4 : IF(read_status /= 0)THEN
            EXIT start_press
          END IF p_error_4
        END IF p_error_5
        output_p : IF(read_status == 0)THEN
          WRITE(unit = output_unit,fmt="(9(f5.0))")(p(k),k = p_index_save,p_index)
          index_test = p_index/t_p_values
          test_partial_p : IF((index_test*t_p_values) /= p_index)THEN
            EXIT start_press
          END IF test_partial_p
          test_full_p : IF( p_index >= pt_size )THEN
            EXIT start_press
          END IF test_full_p
          p_index_save = p_index + 1
        ELSE output_p
          EXIT start_press
        END IF output_p      
        EXIT p_retry
      END DO p_retry      
    END DO start_press
  END IF do_press

  compute_p_index : IF(read_status == 0)THEN
    index_test = p_index/t_p_values
    output_p_blank : IF((index_test*t_p_values) == p_index)THEN
      WRITE(unit = output_unit,fmt = "(a)",iostat = read_status)"     "
    END IF output_p_blank
    WRITE(unit = output_unit,fmt = "(a)",iostat = read_status)"STOP"
  END IF compute_p_index
  final_output : IF(read_status == 0)THEN
    WRITE(*,fmt = "(a)",iostat = read_status)"Program ended without errors.  Close this window." 
  ELSE final_output
    file_exist : IF (not_open == 0)THEN
      WRITE(unit = output_unit,fmt = "(a)",iostat = read_status)"Program aborted with errors." 
      WRITE(unit = output_unit,fmt = "(a)",iostat = read_status)"This file is no good."
    END IF file_exist
    WRITE(*,fmt = "(a)",iostat = read_status)"Program aborted with errors." 
    WRITE(*,fmt = "(a)",iostat = read_status)"Output file is no good.  Close this window." 
  ENDIF final_output
  CLOSE (output_unit)

END PROGRAM create_input

INTEGER FUNCTION disp_name()
  IMPLICIT none
  CHARACTER(len=256) :: filenm
  INTEGER :: ifind
  INTEGER :: winio@
  COMMON filenm
    ifind=winio@("%ws %`bt[OK]",filenm)
    disp_name=1
END FUNCTION disp_name

SUBROUTINE stop_go(read_status)
  IMPLICIT none

  INTEGER, PARAMETER                  :: stop_or_go_len  = 1024
  CHARACTER(len=stop_or_go_len)       :: stop_or_go
  INTEGER                             :: read_status

  outer_loop : DO
        WRITE(*,fmt = "(a)",advance = 'NO')"Terminate Program? (Y/N):"
        READ(*,fmt = "(a)") stop_or_go
        end_output : IF(stop_or_go(1:1) == 'Y' .or. stop_or_go(1:1)== 'y')THEN
          WRITE(*,fmt = "(a)") 'PROGRAM TERMINATED'
          read_status = 1
          EXIT outer_loop
        ELSE IF(stop_or_go(1:1) /= 'N' .and. stop_or_go(1:1)/= 'n')THEN end_output
          WRITE(*,fmt = "(a)")"Bad response, only N, n, Y, or y allowed, try again"
        ELSE IF(stop_or_go(1:1) == 'N' .or. stop_or_go(1:1)== 'n')THEN end_output
          read_status = 0
          EXIT outer_loop
        END IF end_output
  END DO outer_loop
  RETURN
END SUBROUTINE stop_go