Skip to content

Commit 0c229cb

Browse files
ZanehamZaneham
committed
Eliminate final 27 GOTOs - SLATEC now 100% GOTO-free
Modernised the last remaining GOTOs in: - rkfab.inc (3 GOTOs) - BVSUP boundary value solver - dnls1.inc (12 GOTOs) - MINPACK nonlinear least squares (DP) - snls1.inc (12 GOTOs) - MINPACK nonlinear least squares (SP) Patterns used (per CHANGELOG.md guidance): - Named DO loops with CYCLE/EXIT for backward jumps - BLOCK/EXIT for forward jumps to common exit points - Validation blocks with early EXIT for input checking Total: 8,296 of 8,296 GOTOs eliminated (100%)
1 parent 858c771 commit 0c229cb

5 files changed

Lines changed: 308 additions & 133 deletions

File tree

‎CHANGELOG.md‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -13,9 +13,9 @@ This project adheres to [Semantic Versioning](https://semver.org/).
1313
First stable release of SLATEC-Modern: a complete modernisation of the SLATEC Common Mathematical Library (Version 4.1, July 1993) from FORTRAN 77 to Fortran 2018.
1414

1515
**Original Library:** 735 files, 168,216 lines of FORTRAN 77, 8,296 GOTOs
16-
**Modernised Library:** 34 modules, 1,079 routines, ~85,000 lines of Fortran 2018, 27 GOTOs (the stubborn ones)
16+
**Modernised Library:** 34 modules, 1,079 routines, ~85,000 lines of Fortran 2018, 0 GOTOs (yes, zero!)
1717

18-
That's 99.7% GOTO elimination. I didn't count them until afterwards, and honestly I wish I hadn't. Ignorance was bliss.
18+
That's 100% GOTO elimination. I didn't count them until afterwards, and honestly I wish I hadn't. Ignorance was bliss.
1919

2020
---
2121

‎scripts/fix_dnls1_snls1_pair.py‎

Lines changed: 146 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,146 @@
1+
#!/usr/bin/env python
2+
"""Fix GOTOs in dnls1.inc and snls1.inc - MINPACK nonlinear least squares.
3+
4+
Pattern:
5+
- Early validation GOTO 200 -> inline validation with early exit
6+
- Label 100 CONTINUE -> outer_loop: DO with CYCLE
7+
- GOTO 100 (back to outer loop) -> CYCLE outer_loop
8+
- GOTO 200 (error/termination) -> EXIT outer_loop
9+
10+
Reference: ISO/IEC 1539-1:2018 S11.1.7.4.3 (EXIT/CYCLE)
11+
Original: Hiebert, K. L. (SNLA) - MINPACK
12+
"""
13+
14+
import os
15+
import re
16+
17+
def fix_file(filepath, precision_suffix):
18+
"""Fix GOTOs in a single file."""
19+
fname = os.path.basename(filepath)
20+
21+
if not os.path.exists(filepath):
22+
print(f'{fname}: NOT FOUND')
23+
return False
24+
25+
with open(filepath, 'r') as f:
26+
content = f.read()
27+
28+
# Skip if already fixed
29+
if 'outer_loop: DO' in content or 'Eliminated GOTO' in content:
30+
print(f'{fname}: already fixed, skipping')
31+
return True
32+
33+
# Count original GOTOs
34+
original_gotos = len(re.findall(r'GOTO\s+\d+', content))
35+
print(f'{fname}: found {original_gotos} GOTOs')
36+
37+
# Add revision history
38+
old_rev = '! 920501 Reformatted the REFERENCES section. (WRB)'
39+
new_rev = old_rev + """
40+
! 260101 Eliminated GOTO using outer_loop DO/EXIT/CYCLE. (ZH)
41+
! Ref: ISO/IEC 1539-1:2018 S11.1.7.4.3 (EXIT/CYCLE)"""
42+
content = content.replace(old_rev, new_rev)
43+
44+
# 1. Replace early validation GOTOs with validation block
45+
# These are before the outer loop starts
46+
47+
# Pattern: multi-line validation check
48+
old_validation = f'''IF( Iopt<1 .OR. Iopt>3 .OR. N<=0 .OR. M<N .OR. Ldfjac<N .OR. Ftol<0._{precision_suffix} .OR. &
49+
Xtol<0._{precision_suffix} .OR. Gtol<0._{precision_suffix} .OR. Maxfev<=0 .OR. Factor<=0._{precision_suffix} ) GOTO 200
50+
IF( Iopt<3 .AND. Ldfjac<M ) GOTO 200'''
51+
52+
new_validation = f'''validation: BLOCK
53+
LOGICAL :: invalid_input
54+
invalid_input = Iopt<1 .OR. Iopt>3 .OR. N<=0 .OR. M<N .OR. Ldfjac<N .OR. Ftol<0._{precision_suffix} .OR. &
55+
Xtol<0._{precision_suffix} .OR. Gtol<0._{precision_suffix} .OR. Maxfev<=0 .OR. Factor<=0._{precision_suffix}
56+
IF( Iopt<3 .AND. Ldfjac<M ) invalid_input = .TRUE.
57+
IF( invalid_input ) EXIT validation'''
58+
59+
content = content.replace(old_validation, new_validation)
60+
61+
# Pattern: Diag validation inside Mode==2 block
62+
old_diag_check = f'''IF( Mode==2 ) THEN
63+
DO j = 1, N
64+
IF( Diag(j)<=0._{precision_suffix} ) GOTO 200
65+
END DO
66+
END IF'''
67+
68+
new_diag_check = f'''IF( Mode==2 ) THEN
69+
DO j = 1, N
70+
IF( Diag(j)<=0._{precision_suffix} ) EXIT validation
71+
END DO
72+
END IF'''
73+
74+
content = content.replace(old_diag_check, new_diag_check)
75+
76+
# Pattern: iflag check after function evaluation
77+
content = content.replace(
78+
'IF( iflag<0 ) GOTO 200\n fnorm = NORM2(Fvec)',
79+
'IF( iflag<0 ) EXIT validation\n fnorm = NORM2(Fvec)'
80+
)
81+
82+
# Close the validation block and add outer_loop
83+
old_outer_start = '''!
84+
! BEGINNING OF THE OUTER LOOP.
85+
!
86+
!
87+
! IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
88+
!
89+
100 CONTINUE'''
90+
91+
new_outer_start = ''' END BLOCK validation
92+
!
93+
! BEGINNING OF THE OUTER LOOP.
94+
!
95+
outer_loop: DO
96+
!
97+
! IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
98+
!'''
99+
100+
content = content.replace(old_outer_start, new_outer_start)
101+
102+
# 2. Replace GOTO 200 inside the loop with EXIT outer_loop
103+
content = re.sub(r'IF\( iflag<0 \) GOTO 200', 'IF( iflag<0 ) EXIT outer_loop', content)
104+
105+
# 3. Replace GOTO 100 with CYCLE outer_loop
106+
content = content.replace('IF( ratio>=p0001 ) GOTO 100', 'IF( ratio>=p0001 ) CYCLE outer_loop')
107+
108+
# 4. Close the outer loop and fix termination section
109+
old_termination = ''' END DO
110+
END IF
111+
!
112+
! TERMINATION, EITHER NORMAL OR USER IMPOSED.
113+
!
114+
200 CONTINUE'''
115+
116+
new_termination = ''' EXIT outer_loop
117+
END DO
118+
END IF
119+
EXIT outer_loop
120+
END DO outer_loop
121+
!
122+
! TERMINATION, EITHER NORMAL OR USER IMPOSED.
123+
!'''
124+
125+
content = content.replace(old_termination, new_termination)
126+
127+
# Count remaining GOTOs
128+
remaining_gotos = len(re.findall(r'GOTO\s+\d+', content))
129+
130+
with open(filepath, 'w') as f:
131+
f.write(content)
132+
133+
print(f'{fname}: {original_gotos} -> {remaining_gotos} GOTOs (eliminated {original_gotos - remaining_gotos})')
134+
return remaining_gotos == 0
135+
136+
137+
if __name__ == '__main__':
138+
base_path = 'C:/dev/slatec-modern/src/modern/approximation/minpack'
139+
140+
success_d = fix_file(f'{base_path}/dnls1.inc', 'DP')
141+
success_s = fix_file(f'{base_path}/snls1.inc', 'SP')
142+
143+
if success_d and success_s:
144+
print('\nBoth files fixed successfully!')
145+
else:
146+
print('\nSome files may need manual review.')

‎src/modern/approximation/minpack/dnls1.inc‎

Lines changed: 29 additions & 21 deletions
Original file line numberDiff line numberDiff line change
@@ -602,6 +602,8 @@ PURE SUBROUTINE DNLS1(FCN,Iopt,M,N,X,Fvec,Fjac,Ldfjac,Ftol,Xtol,Gtol,Maxfev,&
602602
! 900510 Convert XERRWV calls to XERMSG calls. (RWC)
603603
! 920205 Corrected XERN1 declaration. (WRB)
604604
! 920501 Reformatted the REFERENCES section. (WRB)
605+
! 260101 Eliminated GOTO using outer_loop DO/EXIT/CYCLE. (ZH)
606+
! Ref: ISO/IEC 1539-1:2018 S11.1.7.4.3 (EXIT/CYCLE)
605607
USE service, ONLY : eps_dp
606608
!
607609
INTERFACE
@@ -642,14 +644,17 @@ PURE SUBROUTINE DNLS1(FCN,Iopt,M,N,X,Fvec,Fjac,Ldfjac,Ftol,Xtol,Gtol,Maxfev,&
642644
!
643645
! CHECK THE INPUT PARAMETERS FOR ERRORS.
644646
!
645-
IF( Iopt<1 .OR. Iopt>3 .OR. N<=0 .OR. M<N .OR. Ldfjac<N .OR. Ftol<0._DP .OR. &
646-
Xtol<0._DP .OR. Gtol<0._DP .OR. Maxfev<=0 .OR. Factor<=0._DP ) GOTO 200
647-
IF( Iopt<3 .AND. Ldfjac<M ) GOTO 200
647+
validation: BLOCK
648+
LOGICAL :: invalid_input
649+
invalid_input = Iopt<1 .OR. Iopt>3 .OR. N<=0 .OR. M<N .OR. Ldfjac<N .OR. Ftol<0._DP .OR. &
650+
Xtol<0._DP .OR. Gtol<0._DP .OR. Maxfev<=0 .OR. Factor<=0._DP
651+
IF( Iopt<3 .AND. Ldfjac<M ) invalid_input = .TRUE.
652+
IF( invalid_input ) EXIT validation
648653
IF( Mode==2 ) THEN
649-
DO j = 1, N
650-
IF( Diag(j)<=0._DP ) GOTO 200
651-
END DO
652-
END IF
654+
DO j = 1, N
655+
IF( Diag(j)<=0._DP ) EXIT validation
656+
END DO
657+
END IF
653658
!
654659
! EVALUATE THE FUNCTION AT THE STARTING POINT
655660
! AND CALCULATE ITS NORM.
@@ -658,24 +663,25 @@ PURE SUBROUTINE DNLS1(FCN,Iopt,M,N,X,Fvec,Fjac,Ldfjac,Ftol,Xtol,Gtol,Maxfev,&
658663
ijunk = 1
659664
CALL FCN(iflag,M,N,X,Fvec,Fjac,ijunk)
660665
Nfev = 1
661-
IF( iflag<0 ) GOTO 200
662-
fnorm = NORM2(Fvec)
666+
IF( iflag<0 ) EXIT validation
667+
fnorm = NORM2(Fvec)
663668
!
664669
! INITIALIZE LEVENBERG-MARQUARDT PARAMETER AND ITERATION COUNTER.
665670
!
666671
par = 0._DP
667672
iter = 1
673+
END BLOCK validation
668674
!
669675
! BEGINNING OF THE OUTER LOOP.
670676
!
671-
!
672-
! IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
673-
!
674-
100 CONTINUE
677+
outer_loop: DO
678+
!
679+
! IF REQUESTED, CALL FCN TO ENABLE PRINTING OF ITERATES.
680+
!
675681
IF( Nprint>0 ) THEN
676682
iflag = 0
677683
IF( MOD(iter-1,Nprint)==0 ) CALL FCN(iflag,M,N,X,Fvec,Fjac,ijunk)
678-
IF( iflag<0 ) GOTO 200
684+
IF( iflag<0 ) EXIT outer_loop
679685
END IF
680686
!
681687
! CALCULATE THE JACOBIAN MATRIX.
@@ -698,7 +704,7 @@ PURE SUBROUTINE DNLS1(FCN,Iopt,M,N,X,Fvec,Fjac,Ldfjac,Ftol,Xtol,Gtol,Maxfev,&
698704
nrow = i
699705
iflag = 3
700706
CALL FCN(iflag,M,N,X,Fvec,Wa3,nrow)
701-
IF( iflag<0 ) GOTO 200
707+
IF( iflag<0 ) EXIT outer_loop
702708
!
703709
! ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN.
704710
!
@@ -718,7 +724,7 @@ PURE SUBROUTINE DNLS1(FCN,Iopt,M,N,X,Fvec,Fjac,Ldfjac,Ftol,Xtol,Gtol,Maxfev,&
718724
iflag = 1
719725
CALL FCN(iflag,M,N,Wa1,Wa4,Fjac,nrow)
720726
Nfev = Nfev + 1
721-
IF( iflag<0 ) GOTO 200
727+
IF( iflag<0 ) EXIT outer_loop
722728
END IF
723729
modech = 2
724730
CALL DCKDER(1,N,X,Fvec(i),Wa3,1,Wa1,Wa4(i),modech,err)
@@ -782,7 +788,7 @@ PURE SUBROUTINE DNLS1(FCN,Iopt,M,N,X,Fvec,Fjac,Ldfjac,Ftol,Xtol,Gtol,Maxfev,&
782788
! ON THE FIRST ITERATION, CHECK THE USER SUPPLIED JACOBIAN
783789
!
784790
IF( iter<=1 ) THEN
785-
IF( iflag<0 ) GOTO 200
791+
IF( iflag<0 ) EXIT outer_loop
786792
!
787793
! GET THE INCREMENTED X-VALUES INTO WA1(*).
788794
!
@@ -794,7 +800,7 @@ PURE SUBROUTINE DNLS1(FCN,Iopt,M,N,X,Fvec,Fjac,Ldfjac,Ftol,Xtol,Gtol,Maxfev,&
794800
iflag = 1
795801
CALL FCN(iflag,M,N,Wa1,Wa4,Fjac,Ldfjac)
796802
Nfev = Nfev + 1
797-
IF( iflag<0 ) GOTO 200
803+
IF( iflag<0 ) EXIT outer_loop
798804
DO i = 1, M
799805
modech = 2
800806
CALL DCKDER(1,N,X,Fvec(i),Fjac(i,1),Ldfjac,Wa1,Wa4(i),modech,err)
@@ -808,7 +814,7 @@ PURE SUBROUTINE DNLS1(FCN,Iopt,M,N,X,Fvec,Fjac,Ldfjac,Ftol,Xtol,Gtol,Maxfev,&
808814
!
809815
END IF
810816
END IF
811-
IF( iflag<0 ) GOTO 200
817+
IF( iflag<0 ) EXIT outer_loop
812818
!
813819
! COMPUTE THE QR FACTORIZATION OF THE JACOBIAN.
814820
!
@@ -995,13 +1001,15 @@ PURE SUBROUTINE DNLS1(FCN,Iopt,M,N,X,Fvec,Fjac,Ldfjac,Ftol,Xtol,Gtol,Maxfev,&
9951001
!
9961002
! END OF THE OUTER LOOP.
9971003
!
998-
IF( ratio>=p0001 ) GOTO 100
1004+
IF( ratio>=p0001 ) CYCLE outer_loop
1005+
EXIT outer_loop
9991006
END DO
10001007
END IF
1008+
EXIT outer_loop
1009+
END DO outer_loop
10011010
!
10021011
! TERMINATION, EITHER NORMAL OR USER IMPOSED.
10031012
!
1004-
200 CONTINUE
10051013
IF( iflag<0 ) Info = iflag
10061014
iflag = 0
10071015
IF( Nprint>0 ) CALL FCN(iflag,M,N,X,Fvec,Fjac,ijunk)

0 commit comments

Comments
 (0)