Skip to content

Commit 19a9eb6

Browse files
Bruno02468Bruno02468
committed
fix fort.4 (F04) tempfile due to CSHIFT being called by IS_THIS_A_RESTART
1 parent e77e204 commit 19a9eb6

1 file changed

Lines changed: 35 additions & 33 deletions

File tree

‎Source/LK1/L1A/CSHIFT.f90‎

Lines changed: 35 additions & 33 deletions
Original file line numberDiff line numberDiff line change
@@ -1,61 +1,63 @@
11
! ##################################################################################################################################
2-
! Begin MIT license text.
2+
! Begin MIT license text.
33
! _______________________________________________________________________________________________________
4-
5-
! Copyright 2022 Dr William R Case, Jr (mystransolver@gmail.com)
6-
7-
! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
4+
5+
! Copyright 2022 Dr William R Case, Jr (mystransolver@gmail.com)
6+
7+
! Permission is hereby granted, free of charge, to any person obtaining a copy of this software and
88
! associated documentation files (the "Software"), to deal in the Software without restriction, including
99
! without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
10-
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
11-
! the following conditions:
12-
13-
! The above copyright notice and this permission notice shall be included in all copies or substantial
14-
! portions of the Software and documentation.
15-
16-
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
17-
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18-
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
19-
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20-
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
21-
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
22-
! THE SOFTWARE.
10+
! copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to
11+
! the following conditions:
12+
13+
! The above copyright notice and this permission notice shall be included in all copies or substantial
14+
! portions of the Software and documentation.
15+
16+
! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
17+
! OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18+
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
19+
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20+
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
21+
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
22+
! THE SOFTWARE.
2323
! _______________________________________________________________________________________________________
24-
25-
! End MIT license text.
26-
24+
25+
! End MIT license text.
26+
2727
SUBROUTINE CSHIFT ( CARD_IN, CHAR, CARD_SHIFTED, CHAR_COL, IERR )
28-
28+
2929
! Shifts card string data on CARD_IN so that the data after character CHAR is shifted to start in col 1 (with blanks
3030
! between CHAR and data on CARD_IN deleted). An error is indicated if CHAR is not found. The special case of CHAR = ' '
3131
! input to this subr indicates we want to shift the card to begin in column 1
32-
32+
3333
USE PENTIUM_II_KIND, ONLY : BYTE, LONG, DOUBLE
34-
USE IOUNT1, ONLY : WRT_ERR, WRT_LOG, ERR, F04, F06
34+
USE IOUNT1, ONLY : WRT_ERR, WRT_LOG, ERR, F04, F06, F04FIL
3535
USE SCONTR, ONLY : BLNK_SUB_NAM
3636
USE TIMDAT, ONLY : TSEC
3737
USE SUBR_BEGEND_LEVELS, ONLY : CSHIFT_BEGEND
38-
38+
3939
USE CSHIFT_USE_IFs
4040

4141
IMPLICIT NONE
42-
42+
4343
CHARACTER(LEN=LEN(BLNK_SUB_NAM)) :: SUBR_NAME = 'CSHIFT'
4444
CHARACTER(LEN=*) , INTENT(IN) :: CARD_IN ! Input Case Control card
4545
CHARACTER(LEN=LEN(CARD_IN)) , INTENT(OUT):: CARD_SHIFTED ! C.C. card shifted to begin in 1st nonblank col after CHAR_COL
4646
CHARACTER(1*BYTE), INTENT(IN) :: CHAR ! Character to find in CARD
47-
47+
4848
INTEGER(LONG), INTENT(OUT) :: IERR ! Error indicator. If CHAR not found, IERR set to 1
4949
INTEGER(LONG), INTENT(OUT) :: CHAR_COL ! Column number on CARD where character CHAR is found
50-
INTEGER(LONG) :: CARD_IN_LEN ! Length of CARD
50+
INTEGER(LONG) :: CARD_IN_LEN ! Length of CARD
5151
INTEGER(LONG) :: I ! DO loop index
5252
INTEGER(LONG) :: ISTART ! The col on CARD where nonblank data begins after CHAR_COL
5353
INTEGER(LONG), PARAMETER :: SUBR_BEGEND = CSHIFT_BEGEND
54+
LOGICAL :: FILE_OPND
5455

5556
INTRINSIC INDEX
56-
57+
5758
! **********************************************************************************************************************************
58-
IF (WRT_LOG >= SUBR_BEGEND) THEN
59+
INQUIRE ( FILE=F04FIL, OPENED=FILE_OPND )
60+
IF (WRT_LOG >= SUBR_BEGEND .AND. FILE_OPND) THEN
5961
CALL OURTIM
6062
WRITE(F04,9001) SUBR_NAME,TSEC
6163
9001 FORMAT(1X,A,' BEGN ',F10.3)
@@ -69,7 +71,7 @@ SUBROUTINE CSHIFT ( CARD_IN, CHAR, CARD_SHIFTED, CHAR_COL, IERR )
6971
DO I=1,CARD_IN_LEN
7072
CARD_SHIFTED(I:I) = ' '
7173
ENDDO
72-
74+
7375
IERR = 0
7476
IF (CHAR == ' ') THEN ! Special case: shift card to begin in 1st nonblank col after col 1
7577
CHAR_COL = 0
@@ -93,7 +95,7 @@ SUBROUTINE CSHIFT ( CARD_IN, CHAR, CARD_SHIFTED, CHAR_COL, IERR )
9395
CARD_SHIFTED(1:) = CARD_IN(ISTART:CARD_IN_LEN)
9496

9597
! **********************************************************************************************************************************
96-
IF (WRT_LOG >= SUBR_BEGEND) THEN
98+
IF (WRT_LOG >= SUBR_BEGEND .AND. FILE_OPND) THEN
9799
CALL OURTIM
98100
WRITE(F04,9002) SUBR_NAME,TSEC
99101
9002 FORMAT(1X,A,' END ',F10.3)
@@ -102,5 +104,5 @@ SUBROUTINE CSHIFT ( CARD_IN, CHAR, CARD_SHIFTED, CHAR_COL, IERR )
102104
RETURN
103105

104106
! **********************************************************************************************************************************
105-
107+
106108
END SUBROUTINE CSHIFT

0 commit comments

Comments
 (0)