Skip to content

Commit b5a120f

Browse files
author
Roberto Di Remigio
committed
Refactor output subroutine in pedra_print to remove gotos
1 parent 6f408b1 commit b5a120f

File tree

2 files changed

+82
-93
lines changed

2 files changed

+82
-93
lines changed

‎TODO‎

Lines changed: 0 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -6,15 +6,8 @@ the issue number.
66

77
10 December 2013
88
----------------
9-
3. Define which part of the documentation goes into a
10-
release (#578)
119
5. Draw a better logo for the library (both programmers'
1210
and users' manuals)
13-
6. Draw a diagram explaining the structure of the library
14-
and the relationships between different parts of it
15-
(programmers' manual only)
16-
7. Implementation of input management as asked by Andy
17-
and Daniel
1811

1912
10 April 2014
2013
-------------

‎src/pedra/pedra_print.F90‎

Lines changed: 82 additions & 86 deletions
Original file line numberDiff line numberDiff line change
@@ -21,118 +21,114 @@
2121
! PCMSolver API, see: <http://pcmsolver.github.io/pcmsolver-doc>
2222
!pcmsolver_copyright_end
2323

24-
module pedra_print
25-
26-
use pedra_precision
24+
module pedra_print
2725

28-
implicit none
26+
use pedra_precision
2927

30-
public output
28+
implicit none
3129

32-
private
30+
public output
3331

34-
contains
32+
private
3533

36-
!... Dalton, Release 2.0, pdpack/printpkg.F
37-
!...
38-
!... These routines are in the public domain and can be
39-
!... used freely in other programs.
40-
!...
34+
contains
4135

42-
SUBROUTINE OUTPUT(AMATRX,ROWLOW,ROWHI,COLLOW,COLHI,ROWDIM,COLDIM, &
43-
NCTL,LVPRI)
44-
!.......................................................................
45-
! Revised 15-Dec-1983 by Hans Jorgen Aa. Jensen.
46-
! 16-Jun-1986 hjaaj ( removed Hollerith )
47-
! OUTPUT PRINTS A REAL MATRIX IN FORMATTED FORM WITH NUMBERED ROWS
48-
! AND COLUMNS. THE INPUT IS AS FOLLOWS;
49-
! AMATRX(',').........MATRIX TO BE OUTPUT
50-
! ROWLOW..............ROW NUMBER AT WHICH OUTPUT IS TO BEGIN
51-
! ROWHI...............ROW NUMBER AT WHICH OUTPUT IS TO END
52-
! COLLOW..............COLUMN NUMBER AT WHICH OUTPUT IS TO BEGIN
53-
! COLHI...............COLUMN NUMBER AT WHICH OUTPUT IS TO END
54-
! ROWDIM..............ROW DIMENSION OF AMATRX(',')
55-
! COLDIM..............COLUMN DIMENSION OF AMATRX(',')
56-
! NCTL................CARRIAGE CONTROL FLAG; 1 FOR SINGLE SPACE
57-
! 2 FOR DOUBLE SPACE
58-
! 3 FOR TRIPLE SPACE
59-
! hjaaj: negative for 132 col width
60-
! THE PARAMETERS THAT FOLLOW MATRIX ARE ALL OF TYPE INTEGER*4. THE
61-
! PROGRAM IS SET UP TO HANDLE 5 COLUMNS/PAGE WITH A 1P,5D24.15 FORMAT
62-
! FOR THE COLUMNS. IF A DIFFERENT NUMBER OF COLUMNS IS REQUIRED,
63-
! CHANGE FORMATS 1000 AND 2000, AND INITIALIZE KCOL WITH THE NEW NUMBER
64-
! OF COLUMNS.
65-
! AUTHOR; NELSON H.F. BEEBE, QUANTUM THEORY PROJECT, UNIVERSITY OF
66-
! FLORIDA, GAINESVILLE
67-
! REVISED; FEBRUARY 26, 1971
68-
!.......................................................................
36+
! Dalton, Release 2.0, pdpack/printpkg.F
37+
!
38+
! These routines are in the public domain and can be
39+
! used freely in other programs.
40+
! Copied to PEDRA by Roberto Di Remigio, 2013
41+
subroutine output(amatrx, rowlow, rowhi, collow, colhi, rowdim, coldim, nctl, lvpri)
42+
!.......................................................................
43+
! Revised 15-Dec-1983 by Hans Jorgen Aa. Jensen.
44+
! 16-Jun-1986 hjaaj ( removed Hollerith )
45+
! OUTPUT PRINTS A REAL MATRIX IN FORMATTED FORM WITH NUMBERED ROWS
46+
! AND COLUMNS. THE INPUT IS AS FOLLOWS;
47+
! AMATRX(',').........MATRIX TO BE OUTPUT
48+
! ROWLOW..............ROW NUMBER AT WHICH OUTPUT IS TO BEGIN
49+
! ROWHI...............ROW NUMBER AT WHICH OUTPUT IS TO END
50+
! COLLOW..............COLUMN NUMBER AT WHICH OUTPUT IS TO BEGIN
51+
! COLHI...............COLUMN NUMBER AT WHICH OUTPUT IS TO END
52+
! ROWDIM..............ROW DIMENSION OF AMATRX(',')
53+
! COLDIM..............COLUMN DIMENSION OF AMATRX(',')
54+
! NCTL................CARRIAGE CONTROL FLAG; 1 FOR SINGLE SPACE
55+
! 2 FOR DOUBLE SPACE
56+
! 3 FOR TRIPLE SPACE
57+
! hjaaj: negative for 132 col width
58+
! THE PARAMETERS THAT FOLLOW MATRIX ARE ALL OF TYPE INTEGER*4. THE
59+
! PROGRAM IS SET UP TO HANDLE 5 COLUMNS/PAGE WITH A 1P,5D24.15 FORMAT
60+
! FOR THE COLUMNS. IF A DIFFERENT NUMBER OF COLUMNS IS REQUIRED,
61+
! CHANGE FORMATS 1000 AND 2000, AND INITIALIZE KCOL WITH THE NEW NUMBER
62+
! OF COLUMNS.
63+
! AUTHOR; NELSON H.F. BEEBE, QUANTUM THEORY PROJECT, UNIVERSITY OF
64+
! FLORIDA, GAINESVILLE
65+
! REVISED; FEBRUARY 26, 1971
66+
!.......................................................................
6967

7068
integer(kind=regint_k), intent(in) :: rowlow, rowhi
7169
integer(kind=regint_k), intent(in) :: collow, colhi
7270
integer(kind=regint_k), intent(in) :: rowdim, coldim
7371
integer(kind=regint_k), intent(in) :: nctl, lvpri
74-
real(kind=dp), intent(in) :: amatrx(rowdim, coldim)
72+
real(kind=dp), intent(in) :: amatrx(rowdim, coldim)
7573
integer(kind=regint_k) :: begin, kcol
76-
CHARACTER(1) :: ASA(3), BLANK, CTL
77-
CHARACTER PFMT*20, COLUMN*8
78-
real(kind=dp), parameter :: zero = 0.0d0, ffmin = 1.0d-03, ffmax = 1.0d03
74+
character(1) :: asa(3), blank, ctl
75+
character pfmt*20, column*8
76+
real(kind=dp), parameter :: zero = 0.0_dp, ffmin = 1.0e-3_dp, ffmax = 1.0e3_dp
7977
integer(kind=regint_k), parameter :: kcolp = 5, kcoln = 8
8078
DATA COLUMN/'Column '/, BLANK/' '/, ASA/' ', '0', '-'/
8179

8280
real(kind=dp) :: amax, thrpri
83-
integer(kind=regint_k) :: i, j, k, mctl, last
81+
integer(kind=regint_k) :: i, j, k, l, mctl, last
8482

85-
IF (ROWHI < ROWLOW) go to 3
86-
IF (COLHI < COLLOW) go to 3
83+
if (rowhi < rowlow) return
84+
if (colhi < collow) return
8785

88-
AMAX = ZERO
89-
DO J = COLLOW,COLHI
90-
DO I = ROWLOW,ROWHI
91-
AMAX = MAX( AMAX, ABS(AMATRX(I,J)) )
86+
amax = zero
87+
do j = collow,colhi
88+
do i = rowlow,rowhi
89+
amax = max(amax, abs(amatrx(i, j)))
9290
end do
9391
end do
94-
IF (AMAX == ZERO) THEN
95-
WRITE (LVPRI,'(/T6,A)') 'Zero matrix.'
96-
go to 3
92+
if (amax == zero) then
93+
write (lvpri,'(/t6,a)') 'Zero matrix'
94+
return
9795
end if
98-
IF (FFMIN <= AMAX .AND. AMAX < FFMAX) THEN
96+
if (ffmin <= amax .and. amax < ffmax) then
9997
! use F output format
100-
PFMT = '(A1,I7,2X,8F14.8)'
101-
thrpri = 0.5D-8
102-
ELSE
98+
pfmt = '(a1,i7,2x,8f14.8)'
99+
thrpri = 0.5e-8_dp
100+
else
103101
! use 1PD output format
104-
PFMT = '(A1,I7,2X,1P,8D14.6)'
105-
thrpri = 1.0D-8*AMAX
102+
pfmt = '(a1,i7,2x,1p,8d14.6)'
103+
thrpri = 1.0e-8_dp * amax
106104
end if
107105

108-
IF (NCTL < 0) THEN
109-
KCOL = KCOLN
110-
ELSE
111-
KCOL = KCOLP
106+
if (nctl < 0) then
107+
kcol = kcoln
108+
else
109+
kcol = kcolp
112110
end if
113-
MCTL = ABS(NCTL)
114-
IF ((MCTL <= 3) .AND. (MCTL > 0)) THEN
115-
CTL = ASA(MCTL)
116-
ELSE
117-
CTL = BLANK
111+
mctl = abs(nctl)
112+
if ((mctl <= 3) .and. (mctl > 0)) then
113+
ctl = asa(mctl)
114+
else
115+
ctl = blank
118116
end if
119117

120-
LAST = MIN(COLHI,COLLOW+KCOL-1_regint_k)
121-
DO 2 BEGIN = COLLOW,COLHI,KCOL
122-
WRITE (LVPRI,1000) (COLUMN,I,I = BEGIN,LAST)
123-
DO 1 K = ROWLOW,ROWHI
124-
DO 4 I = BEGIN,LAST
125-
IF (abs(AMATRX(K,I)) > thrpri) go to 5
126-
4 end do
127-
go to 1
128-
5 WRITE (LVPRI,PFMT) CTL,K,(AMATRX(K,I), I = BEGIN,LAST)
129-
1 end do
130-
LAST = MIN(LAST+KCOL,COLHI)
131-
2 end do
132-
3 RETURN
133-
1000 FORMAT (/10X,8(4X,A6,I4))
134-
! 2000 FORMAT (A1,'Row',I4,2X,1P,8D14.6)
135-
! 2000 FORMAT (A1,I7,2X,1P,8D14.6)
136-
END SUBROUTINE OUTPUT
118+
last = min(colhi, collow + kcol - 1_regint_k)
119+
do begin = collow,colhi,kcol
120+
write(lvpri, 1000) (column, i, i = begin, last)
121+
do k = rowlow, rowhi
122+
do i = begin, last
123+
if (abs(amatrx(k, i)) > thrpri) then
124+
write (lvpri, pfmt) ctl, k, (amatrx(k, l), l = begin, last)
125+
exit
126+
end if
127+
end do
128+
end do
129+
last = min(last + kcol, colhi)
130+
end do
131+
1000 format (/10x,8(4x,a6,i4))
132+
end subroutine output
137133

138-
end module
134+
end module

0 commit comments

Comments
 (0)