diff --git a/Source/Interfaces/TO_UPPER_Interface.f90 b/Source/Interfaces/TO_UPPER_Interface.f90 new file mode 100644 index 00000000..84e23bbf --- /dev/null +++ b/Source/Interfaces/TO_UPPER_Interface.f90 @@ -0,0 +1,41 @@ +! ############################################################################################################################### +! Begin MIT license text. +! _______________________________________________________________________________________________________ + +! Copyright 2022 Dr William R Case, Jr (mystransolver@gmail.com) + +! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and +! associated documentation files (the "Software"), to deal in the Software without restriction, including +! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to +! the following conditions: + +! The above copyright notice and this permission notice shall be included in all copies or substantial +! portions of the Software and documentation. + +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +! THE SOFTWARE. +! _______________________________________________________________________________________________________ + +! End MIT license text. + + MODULE TO_UPPER_Interface + + INTERFACE + + FUNCTION TO_UPPER(IN_TEXT) RESULT(rslt) + IMPLICIT NONE + CHARACTER(LEN=*), INTENT (IN) :: IN_TEXT + CHARACTER(len=len(IN_TEXT)) :: rslt + + END FUNCTION TO_UPPER + + END INTERFACE + + END MODULE TO_UPPER_Interface + diff --git a/Source/LK1/L1A/EC_OUTPUT4.f90 b/Source/LK1/L1A/EC_OUTPUT4.f90 index 99722ac5..81840e6b 100644 --- a/Source/LK1/L1A/EC_OUTPUT4.f90 +++ b/Source/LK1/L1A/EC_OUTPUT4.f90 @@ -46,6 +46,7 @@ SUBROUTINE EC_OUTPUT4 ( CARD1, IERR, ANY_OU4_NAME_BAD ) USE TIMDAT, ONLY : TSEC USE EC_OUTPUT4_USE_IFs ! Added 2019/07/14 + USE TO_UPPER_Interface IMPLICIT NONE @@ -416,13 +417,21 @@ SUBROUTINE CHECK_MATRIX_NAME ( MYSTRAN_NAME, INDEX ) INTEGER(LONG), INTENT(OUT) :: INDEX ! Row in array ALLOW_OU4_MYSTRAN_NAMES where name was found INTEGER(LONG) :: JJ ! DO loop index + CHARACTER(16*BYTE) :: ALLOW_OU4_MYSTRAN_NAME_UPPER + CHARACTER(16*BYTE) :: ALLOW_OU4_OUTPUT_NAME_UPPER + ! ********************************************************************************************************************************** ! Check requested OUTPUT4 names to make sure they are in the list of valid names VALID_OU4_NAME = 'Y' DO JJ=1,NUM_OU4_VALID_NAMES FOUND = 'N' - IF ((MYSTRAN_NAME == ALLOW_OU4_MYSTRAN_NAMES(JJ)) .OR. (MYSTRAN_NAME == ALLOW_OU4_OUTPUT_NAMES(JJ))) THEN + ! MYSTRAN_NAME was upper-cased when reading the card. + ! Here, upper-case the allowed names so that comparison is case-insensitive + ! and thus allows KRRcb, MRRcb, KLR(t). + ALLOW_OU4_MYSTRAN_NAME_UPPER = TO_UPPER(ALLOW_OU4_MYSTRAN_NAMES(JJ)) + ALLOW_OU4_OUTPUT_NAME_UPPER = TO_UPPER(ALLOW_OU4_OUTPUT_NAMES(JJ)) + IF ((MYSTRAN_NAME == ALLOW_OU4_MYSTRAN_NAME_UPPER) .OR. (MYSTRAN_NAME == ALLOW_OU4_OUTPUT_NAME_UPPER)) THEN FOUND = 'Y' INDEX = JJ EXIT @@ -452,5 +461,6 @@ SUBROUTINE CHECK_MATRIX_NAME ( MYSTRAN_NAME, INDEX ) ! ********************************************************************************************************************************** END SUBROUTINE CHECK_MATRIX_NAME - + + END SUBROUTINE EC_OUTPUT4 diff --git a/Source/LK1/L1A/EC_PARTN.f90 b/Source/LK1/L1A/EC_PARTN.f90 index 621e3107..4a59bac9 100644 --- a/Source/LK1/L1A/EC_PARTN.f90 +++ b/Source/LK1/L1A/EC_PARTN.f90 @@ -38,20 +38,17 @@ SUBROUTINE EC_PARTN ( CARD1, IERR ) ! the OUTPUT4 matrix. PARTN must follow an OUTPUT4 requesting output of the matrix A USE PENTIUM_II_KIND, ONLY : BYTE, LONG - USE SCONTR, ONLY : BLNK_SUB_NAM, EC_ENTRY_LEN - USE IOUNT1, ONLY : ERR, F06, MOU4, OU4, OU4_ELM_OTM, OU4_GRD_OTM, SC1 + USE SCONTR, ONLY : EC_ENTRY_LEN + USE IOUNT1, ONLY : ERR, F06, MOU4, OU4, OU4_ELM_OTM, OU4_GRD_OTM USE DEBUG_PARAMETERS, ONLY : DEBUG USE OUTPUT4_MATRICES, ONLY : NUM_OU4_REQUESTS, NUM_PARTN_REQUESTS, OU4_PART_VEC_NAMES, OU4_PART_MAT_NAMES, & - ACT_OU4_MYSTRAN_NAMES, ACT_OU4_OUTPUT_NAMES, & - ALLOW_OU4_MYSTRAN_NAMES, ALLOW_OU4_OUTPUT_NAMES - - USE TIMDAT, ONLY : TSEC + ACT_OU4_MYSTRAN_NAMES, ACT_OU4_OUTPUT_NAMES USE EC_PARTN_USE_IFs ! Added 2019/07/14 + USE TO_UPPER_Interface IMPLICIT NONE - CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'EC_PARTN' CHARACTER(LEN=*), INTENT(IN) :: CARD1 ! Card read in LOADE and shifted to begin in col 1 CHARACTER(LEN=LEN(CARD1)) :: CARD2 ! CARD1 truncated at $ (trailing comment) if there is one CHARACTER(LEN=EC_ENTRY_LEN) :: DATA_80(3) ! Temp slot for holding data until lead/trail blanks stripped @@ -168,7 +165,10 @@ SUBROUTINE EC_PARTN ( CARD1, IERR ) FOUND = 'N' DO I=1,NUM_OU4_REQUESTS ! Set names of the matrix to be partitioned, the partitions and the vecs - IF (DATA_16(1) == ACT_OU4_MYSTRAN_NAMES(I)) THEN + ! DATA_16(1) was upper-cased when reading the card. + ! Here, upper-case the allowed names so that comparison is case-insensitive + ! and thus allows KRRcb, MRRcb, KLR(t). + IF (DATA_16(1) == TO_UPPER(ACT_OU4_MYSTRAN_NAMES(I))) THEN FOUND = 'Y' OU4_PART_MAT_NAMES(I,1) = DATA_16(1) OU4_PART_VEC_NAMES(I,1) = DATA_16(2) diff --git a/Source/LK1/L1A/LOADB.f90 b/Source/LK1/L1A/LOADB.f90 index 4865d718..1d8b5507 100644 --- a/Source/LK1/L1A/LOADB.f90 +++ b/Source/LK1/L1A/LOADB.f90 @@ -1112,48 +1112,23 @@ END SUBROUTINE CALC_MAX_GAUSS_POINTS END SUBROUTINE LOADB - - !function to_upper(in) result (out) - SUBROUTINE TO_UPPER_LINE(LINE) - ! it seems like there should be a better way to write an upper function... - ! https://en.wikibooks.org/wiki/Fortran/strings - implicit none - CHARACTER(256), intent (inout) :: LINE - integer :: I, J - CHARACTER(26), parameter :: UPP = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - CHARACTER(26), parameter :: LOW = 'abcdefghijklmnopqrstuvwxyz' - - DO I = 1,256 - ! remove $ - IF (LINE(I:I) == '$') THEN - LINE(I:) = ' ' - GOTO 100 ! break - ENDIF - - J = index(LOW, LINE(I:I)) ! Is ith character in LOW - IF (J>0) LINE(I:I) = UPP(J:J) ! Yes, then subst with UPP - 100 ENDDO - END SUBROUTINE TO_UPPER_LINE - !end function to_upper - !--------------------------------------------------------- SUBROUTINE READ_BDF_LINE(IN1, IOCHK, LINE) - ! it seems like there should be a better way to write an upper function... - ! https://en.wikibooks.org/wiki/Fortran/strings USE IOUNT1, ONLY : ERR, INFILE, F06 ! - USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE - implicit none - CHARACTER(256), intent (inout) :: LINE - CHARACTER(256) :: TRIM_LINE - integer, intent (in) :: IN1 - integer, intent (inout) :: IOCHK - integer :: I, J, FATAL_ERR - CHARACTER(26), parameter :: UPP = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' - CHARACTER(26), parameter :: LOW = 'abcdefghijklmnopqrstuvwxyz' - CHARACTER(24*BYTE) :: MESSAG ! Message for output error purposes - INTEGER(LONG) :: OUNT(2) ! File units to write messages to. Input to subr READERR - INTEGER(LONG) :: REC_NO ! Record number when reading a file. Input to subr READERR + USE PENTIUM_II_KIND, ONLY : BYTE, LONG + USE TO_UPPER_Interface + + IMPLICIT NONE + + CHARACTER(256), INTENT (INOUT) :: LINE + CHARACTER(256) :: TRIM_LINE + INTEGER, INTENT (IN) :: IN1 + INTEGER, INTENT (INOUT) :: IOCHK + INTEGER :: I, FATAL_ERR + CHARACTER(24*BYTE) :: MESSAG ! Message for output error purposes + INTEGER(LONG) :: OUNT(2) ! File units to write messages to. Input to subr READERR + INTEGER(LONG) :: REC_NO ! Record number when reading a file. Input to subr READERR ! Make units for writing errors the error file and output file OUNT(1) = ERR @@ -1178,12 +1153,12 @@ SUBROUTINE READ_BDF_LINE(IN1, IOCHK, LINE) ! remove $ IF (LINE(I:I) == '$') THEN LINE(I:) = ' ' - GOTO 100 ! break + EXIT ENDIF - - J = index(LOW, LINE(I:I)) ! Is ith character in LOW - IF (J>0) LINE(I:I) = UPP(J:J) ! Yes, then subst with UPP - 100 ENDDO + ENDDO + + LINE = TO_UPPER(LINE) + 101 FORMAT(A) END SUBROUTINE READ_BDF_LINE diff --git a/Source/LK1/L1A/LOADC.f03 b/Source/LK1/L1A/LOADC.f03 index 913a2e20..bf745678 100644 --- a/Source/LK1/L1A/LOADC.f03 +++ b/Source/LK1/L1A/LOADC.f03 @@ -43,7 +43,8 @@ SUBROUTINE LOADC USE CC_OUTPUT_DESCRIBERS, ONLY : STRN_LOC, STRE_LOC, FORC_LOC USE LOADC_USE_IFs - + USE TO_UPPER_Interface + IMPLICIT NONE CHARACTER(LEN=LEN(BLNK_SUB_NAM)):: SUBR_NAME = 'LOADC' @@ -169,7 +170,7 @@ SUBROUTINE LOADC ! so read all entries up to BEGIN BULK and then exit loop for CC entries inner: DO READ(IN1,101) CARD - CALL TO_UPPER_LINE(CARD) + CARD = TO_UPPER(CARD) IF (CARD(1:10) == 'BEGIN BULK') THEN WRITE(F06,101) CARD EXIT outer diff --git a/Source/UTIL/TO_UPPER.f90 b/Source/UTIL/TO_UPPER.f90 new file mode 100644 index 00000000..b080b6ab --- /dev/null +++ b/Source/UTIL/TO_UPPER.f90 @@ -0,0 +1,45 @@ +! ################################################################################################################################## +! Begin MIT license text. +! _______________________________________________________________________________________________________ + +! Copyright 2022 Dr William R Case, Jr (mystransolver@gmail.com) + +! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and +! associated documentation files (the "Software"), to deal in the Software without restriction, including +! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to +! the following conditions: + +! The above copyright notice and this permission notice shall be included in all copies or substantial +! portions of the Software and documentation. + +! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS +! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +! THE SOFTWARE. +! _______________________________________________________________________________________________________ + +! End MIT license text. + + FUNCTION TO_UPPER(IN_TEXT) RESULT(rslt) + + IMPLICIT NONE + CHARACTER(LEN=*), INTENT (IN) :: IN_TEXT + CHARACTER(len=len(IN_TEXT)) :: rslt + INTEGER :: I, J + CHARACTER(26), parameter :: UPP = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' + CHARACTER(26), parameter :: LOW = 'abcdefghijklmnopqrstuvwxyz' + + DO I = 1,len(IN_TEXT) + J = index(LOW, IN_TEXT(I:I)) + IF (J>0) THEN + rslt(I:I) = UPP(J:J) + ELSE + rslt(I:I) = IN_TEXT(I:I) + ENDIF + ENDDO + + END FUNCTION TO_UPPER \ No newline at end of file