SUBROUTINE file_open( & file_error) !### !***************************************************************************** ! * ! Subroutine Name: file_open * ! * ! File Name: file_open.f90 * ! * ! Purpose: Used by program therm to get the input and output file * ! names. It then opens the files and checks for open errors. * ! It also opens the thermodynamic data file and scratch unit * ! * ! Author: Robert L. Reese * ! * ! Date: January 20, 2004 * ! * ! Language: Salford FORTRAN 95, Version 0.9.0 * ! * ! Hardware: IBM Compatible PC * ! * ! Operating System: Microsoft Windows 98 * ! * ! Update History: * ! * ! Name Date Revision Changes * ! ---- ---- --------- ------- * ! * ! R.L. Reese 01/20/04 0 Initial Release * ! R.L. Reese 03/31/06 A Added option to input name of * ! thermo data file. Added new * ! method of inputing file names * ! Only works with Salford compiler* ! * !----------------------------------------------------------------------------* ! * ! Usage: * ! * ! CALL file_open(file_error) where: * ! * ! file_error - Logical variable used to flag error in opens * ! = true, error * ! = false, no error * ! * !----------------------------------------------------------------------------* ! * ! Definitions: * ! * ! Local Variables: * ! ---------------- * ! * ! i - Integer used to find length of file name * ! not_open - Integer flag indicating status of opening a file * ! stop_or_go - Character value input by user to stop or go * ! * ! Global Variables: * ! ----------------- * ! misc_module * ! infile - Character*80 variable for input file name * ! outfile - Character*80 variable for output file name * ! thermofile - Character*80 variable for thermo file name * ! * ! Local Common Blocks: * ! ------------------- * ! * ! None * ! * ! Constants: * ! --------- * ! * ! constants_module * ! input_unit - Integer value of the input unit number * ! output_unit - Integer value of the output unit number * ! scratch_unit - Integer value of the temporary scratch unit number * ! stop_or_go_len - Integer value of length of stop_or_go character * ! thermo_unit - Integer value of the thermodynamic unit number * ! * ! Modules: * ! -------- * ! * ! constants_module - Contains various constants and sizes * ! misc_module - Contains miscellaneous variables * ! * ! * ! External Software: * ! ----------------- * ! * ! Len - FORTRAN 95 routine to find size of a buffer * ! * ! Files: * ! ----- * ! * ! Input Files: * ! * ! input_unit - Logical unit number of input file * ! * ! Intermediate Files: * ! * ! therm_unit - Logical unit number of thermodynamic file * ! scratch_unit - Logical unit number of scratch unit * ! * ! Output Files: * ! * ! output_unit - Logical unit number of output listing device * ! Also outputs to the screen * ! * !***************************************************************************** !### USE constants_module USE misc_module WINAPP IMPLICIT none LOGICAL,INTENT(inout) :: file_error INTEGER :: i INTEGER :: not_open CHARACTER(len=stop_or_go_len) :: stop_or_go ! Special variables for file_openr CHARACTER(len=256) :: filenm INTEGER :: ifind INTEGER :: j INTEGER :: winio@ COMMON filenm EXTERNAL disp_name outer_loop : DO file_error = .false. ! Process input file good_input : DO ! Special way of inputing file name, outputs windows menu to screen WRITE(*,fmt = "(a)")' Use menu to browse for input file.' filenm=' ' ifind=winio@('%ca[Input File]&') ifind=winio@("%fs[c:\*.*]&") ifind=winio@("%mn[&File[&Open]]&","FILE_OPENR",filenm,disp_name) ifind=winio@("%mn[[E&xit]]","EXIT") ! WRITE(*,fmt = "(a)",advance = 'NO')' Input name of input file : ' ! READ(*,*) infile ! READ(*,fmt="(a)") infile i = len(filenm) find_nonblank : DO save_index : IF(filenm(i:i) >='!') THEN exit END IF save_index i = i - 1 END DO find_nonblank WRITE(*,fmt = "(a,a)")' INPUT FILE : ',filenm(1:i) OPEN(unit = input_unit,file = filenm,status = 'old', & iostat = not_open) open_input : IF (not_open /= 0) THEN WRITE(*,fmt = "(a)") ' UNABLE TO OPEN INPUT FILE' WRITE(*,fmt = "(a)",advance = 'NO')" Terminate Program? (Y/N):" READ(*,fmt = "(a)") stop_or_go end_input : IF(stop_or_go(1:1) == 'Y' .or. stop_or_go(1:1)== 'y')THEN WRITE(*,fmt = "(a)") ' PROGRAM TERMINATED' file_error = .true. EXIT outer_loop ELSE IF(stop_or_go(1:1) /= 'N' .and. stop_or_go(1:1)/= 'n')THEN end_input WRITE(*,fmt = "(a)")" Bad response, only N, n, Y, or y allowed, try again" END IF end_input ELSE open_input EXIT good_input END IF open_input END DO good_input ! Put input file name into infile for special way infile = ' ' transfer_name_1 : DO j = 1,i infile(j:j) = filenm(j:j) END DO transfer_name_1 REWIND input_unit ! Process output file good_output : DO ! 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.' filenm=' ' 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(*,*) outfile ! READ(*,fmt="(a)") outfile i = len(filenm) find_nonblank2 : DO save_index2 : IF(filenm(i:i) >='!') THEN exit END IF save_index2 i = i - 1 END DO find_nonblank2 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' 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' file_error = .true. 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" END IF end_output ELSE open_output EXIT good_output END IF open_output END DO good_output ! Put output file name into outfile for special way outfile = ' ' transfer_name_2 : DO j = 1,i outfile(j:j) = filenm(j:j) END DO transfer_name_2 REWIND output_unit ! Process thermodynamic data file good_therm : DO ! Special way of inputing file name, outputs windows menu to screen WRITE(*,fmt = "(a)")' Use menu to browse for THERMODAT file.' WRITE(*,fmt = "(a)")' Select directory and name of file.' filenm=' ' ifind=winio@('%ca[THERMO File]&') ifind=winio@("%fs[c:\*.*]&") ifind=winio@("%mn[&File[&Open]]&","FILE_OPENR",filenm,disp_name) ifind=winio@("%mn[[E&xit]]","EXIT") thermofile = ' ' ! WRITE(*,fmt = "(a)")' (The thermofile will default THERMODAT with no file)' ! WRITE(*,fmt = "(a)")' (extension if no file name entered.)' ! WRITE(*,fmt = "(a)")' (Will not work if runing on Internet.)' ! WRITE(*,fmt = "(a)",advance = 'NO') ' Input name of thermo file : ' ! READ(*,fmt="(a)") thermofile i = len(filenm) find_nonblank3 : DO save_index3 : IF(filenm(i:i) >='!') THEN exit END IF save_index3 i = i - 1 END DO find_nonblank3 default_test : IF(i <= 1) THEN WRITE(*,fmt = "(a)")' Thermofile defaulted to THERMODAT' OPEN(unit = therm_unit,file = 'THERMODAT',status = 'unknown',iostat = not_open) open_thermo : IF (not_open /= 0) THEN WRITE(*,fmt = "(a)") ' UNABLE TO OPEN THERMODAT FILE' WRITE(*,fmt = "(a)",advance = 'NO')" Terminate Program? (Y/N):" READ(*,fmt = "(a)") stop_or_go end_therm : IF(stop_or_go(1:1) == 'Y' .or. stop_or_go(1:1)== 'y')THEN WRITE(*,fmt = "(a)") ' PROGRAM TERMINATED' file_error = .true. EXIT outer_loop ELSE IF(stop_or_go(1:1) /= 'N' .and. stop_or_go(1:1)/= 'n')THEN end_therm WRITE(*,fmt = "(a)")" Bad response, only N, n, Y, or y allowed, try again" END IF end_therm ELSE open_thermo EXIT good_therm END IF open_thermo ELSE IF (i > 1) THEN default_test WRITE(*,fmt = "(a,a)")' THERMO FILE : ',filenm(1:i) OPEN(unit = therm_unit,file =filenm ,status = 'old',iostat = not_open) open_thermo1 : IF (not_open /= 0) THEN WRITE(*,fmt = "(a)") ' UNABLE TO OPEN THERMODAT FILE' WRITE(*,fmt = "(a)",advance = 'NO')" Terminate Program? (Y/N):" READ(*,fmt = "(a)") stop_or_go end_therm1 : IF(stop_or_go(1:1) == 'Y' .or. stop_or_go(1:1)== 'y')THEN WRITE(*,fmt = "(a)") ' PROGRAM TERMINATED' file_error = .true. EXIT outer_loop ELSE IF(stop_or_go(1:1) /= 'N' .and. stop_or_go(1:1)/= 'n')THEN end_therm1 WRITE(*,fmt = "(a)")" Bad response, only N, n, Y, or y allowed, try again" END IF end_therm1 ELSE open_thermo1 EXIT good_therm END IF open_thermo1 END IF default_test END DO good_therm ! Put thermodat file name into thermofile for special way thermofile = ' ' transfer_name_3 : DO j = 1,i thermofile(j:j) = filenm(j:j) END DO transfer_name_3 REWIND therm_unit ! Process scratch file OPEN(unit = scratch_unit,status = 'scratch',iostat = not_open) bad_temp : IF (not_open /= 0) THEN WRITE(*,fmt = "(a)") 'UNABLE TO OPEN TEMPORARY FILE' WRITE(*,fmt = "(a)") 'PROGRAM TERMINATED' file_error = .true. EXIT outer_loop ELSE bad_temp REWIND scratch_unit END IF bad_temp EXIT outer_loop END DO outer_loop END SUBROUTINE file_open INTEGER FUNCTION disp_name() CHARACTER(len=256) :: filenm INTEGER :: ifind INTEGER :: winio@ COMMON filenm ifind=winio@('%ws %`bt[OK]',filenm) disp_name=1 END FUNCTION disp_name