Skip to content

Commit 559e706

Browse files
pmoczpmocz
committed
format cleanup of op routines as precursor to modernization
1 parent 54ba438 commit 559e706

File tree

9 files changed

+357
-340
lines changed

9 files changed

+357
-340
lines changed

‎kap/make/makefile_base‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -17,7 +17,7 @@ SRCS = \
1717
kap_def.f90 \
1818
op_def.f90 \
1919
op_load.f \
20-
op_load_master.f \
20+
op_load_master.f90 \
2121
op_common.f \
2222
op_ev.f \
2323
op_osc.f \
@@ -100,7 +100,7 @@ else
100100
$(COMPILE_NO_CHECKS) $(FCfree) $<
101101
endif
102102

103-
op_load.o op_common.o op_ev.o op_osc.o op_radacc.o op_load_master.o : %.o : %.f
103+
op_load.o op_common.o op_ev.o op_osc.o op_radacc.o : %.o : %.f
104104
ifneq ($(QUIET),)
105105
@echo COMPILE_LEGACY_NOCHECKS $<
106106
@$(COMPILE_LEGACY_NOCHECKS) $(FCfixed) $<

‎kap/private/op_common.f‎

Lines changed: 44 additions & 44 deletions
Original file line numberDiff line numberDiff line change
@@ -2,8 +2,8 @@ module op_common
22

33
use math_lib
44
use op_def
5-
6-
contains
5+
6+
contains
77
subroutine xindex(flt, ilab, xi, ih, i3, ierr)
88
implicit none
99
integer, intent(in) :: i3
@@ -30,26 +30,26 @@ subroutine xindex(flt, ilab, xi, ih, i3, ierr)
3030
do i = 1, 4
3131
ih(i) = ih2 + i - 2
3232
ilab(i) = i3*ih(i)
33-
enddo
33+
enddo
3434
xi = 2.*(x-ih2) - 1
3535

3636
return
3737
end subroutine xindex
3838

3939
c**********************************************************************
40-
subroutine jrange(ih, jhmin, jhmax, i3)
40+
subroutine jrange(ih, jhmin, jhmax, i3)
4141
implicit none
4242
integer, intent(in) :: ih(4), i3
43-
integer, intent(out) :: jhmin, jhmax
43+
integer, intent(out) :: jhmin, jhmax
4444
integer :: i
45-
45+
4646
jhmin = 0
4747
jhmax = 1000
4848
do i = 1, 4
4949
jhmin = max(jhmin, js(ih(i)*i3)/i3)
5050
jhmax = min(jhmax, je(ih(i)*i3)/i3)
5151
enddo
52-
52+
5353
return
5454
end subroutine jrange
5555
c**********************************************************************
@@ -66,11 +66,11 @@ subroutine findne(ilab, fa, nel, nkz, jhmin, jhmax, ih,
6666
real, intent(inout) :: flrho
6767
c local variables
6868
integer :: i, j, n, jh, jm, itt, jne, jnn
69-
real :: flrmin, flrmax, flr(4,4), uyi(4), efa(4, 7:118),
69+
real :: flrmin, flrmax, flr(4,4), uyi(4), efa(4, 7:118),
7070
: flrh(4, 7:118), u(4), flnei(4), y, zeta, efa_temp
71-
c declare variables in common block, by default: real (a-h, o-z), integer (i-n)
71+
c declare variables in common block, by default: real (a-h, o-z), integer (i-n)
7272
! integer :: ite1, ite2, ite3, jn1, jn2, jne3, ntot, nc, nf, int,
73-
! : ne1, ne2, np, kp1, kp2, kp3, npp, mx, nx
73+
! : ne1, ne2, np, kp1, kp2, kp3, npp, mx, nx
7474
! real :: umin, umax, epatom, oplnck, fion, yy1, yy2, yx
7575
! common /atomdata/ ite1,ite2,ite3,jn1(91),jn2(91),jne3,umin,umax,ntot,
7676
! + nc,nf,int(17),epatom(17,91,25),oplnck(17,91,25),ne1(17,91,25),
@@ -82,20 +82,20 @@ subroutine findne(ilab, fa, nel, nkz, jhmin, jhmax, ih,
8282
c efa(i,jh)=sum_n epa(i,jh,n)*fa(n)
8383
c flrh(i,jh)=log10(rho(i,jh))
8484
c
85-
c Get efa
85+
c Get efa
8686
do i = 1, 4
8787
itt = (ilab(i)-ite1)/2 + 1
8888
do jne = jn1(itt), jn2(itt), i3
8989
jnn = (jne-jn1(itt))/2 + 1
9090
jh = jne/i3
9191
efa_temp = 0.
92-
do n = 1, nel
92+
do n = 1, nel
9393
efa_temp = efa_temp + epatom(nkz(n), itt, jnn)*fa(n)
94-
enddo !n
95-
efa(i, jh) = efa_temp
94+
enddo !n
95+
efa(i, jh) = efa_temp
9696
enddo !jne
97-
enddo !i
98-
c
97+
enddo !i
98+
c
9999
c Get range for efa.gt.0
100100
do i = 1, 4
101101
do jh = jhmin, jhmax
@@ -108,13 +108,13 @@ subroutine findne(ilab, fa, nel, nkz, jhmin, jhmax, ih,
108108
3 jhmax = MIN(jhmax, jm)
109109
4 continue
110110
enddo
111-
c
111+
c
112112
c Get flrh
113113
do jh=jhmin,jhmax
114114
do i=1,4
115115
flrh(i, jh) = flmu + 0.25*i3*jh - log10(dble(efa(i, jh)))
116116
end do
117-
end do
117+
end do
118118
c
119119
c Find flrmin and flrmax
120120
flrmin = -1000
@@ -123,7 +123,7 @@ subroutine findne(ilab, fa, nel, nkz, jhmin, jhmax, ih,
123123
flrmin = max(flrmin, flrh(i,jhmin))
124124
flrmax = min(flrmax, flrh(i,jhmax))
125125
enddo
126-
c
126+
c
127127
c Check range of flrho
128128
if(flrho .lt. flrmin .or. flrho .gt. flrmax)then
129129
write(*,*) "findne failed because density is out of range for logT, logRho", flt, flrho
@@ -144,7 +144,7 @@ subroutine findne(ilab, fa, nel, nkz, jhmin, jhmax, ih,
144144
stop
145145
5 jm=max(jm,jhmin+1)
146146
jm=min(jm,jhmax-2)
147-
c
147+
c
148148
do i = 1, 4
149149
do j = 1, 4
150150
u(j) = flrh(i, jm+j-2)
@@ -154,18 +154,18 @@ subroutine findne(ilab, fa, nel, nkz, jhmin, jhmax, ih,
154154
if (ierr /= 0) return
155155
y = jm + 0.5*(zeta+1)
156156
flnei(i) = .25*i3*y
157-
enddo
157+
enddo
158158
c
159159
c Interpolations in i
160160
flne = fint(flnei, xi)
161161
uy = fint(uyi, xi)
162-
c Get epa
162+
c Get epa
163163
epa = exp10(dble(flne + flmu - flrho))
164-
c
164+
c
165165
return
166-
c
166+
c
167167
601 format(' For flt=',1p,e11.3,', flrho=',e11.3,' is out of range'/
168-
+ ' Allowed range for flrho is ',e11.3,' to ',e11.3)
168+
+ ' Allowed range for flrho is ',e11.3,' to ',e11.3)
169169
end subroutine findne
170170

171171
c***********************************************************************
@@ -175,7 +175,7 @@ subroutine yindex(jhmin, jhmax, flne, jh, i3, eta)
175175
real, intent(in) :: flne
176176
integer, intent(out) :: jh(4)
177177
real, intent(out) :: eta
178-
c local variables
178+
c local variables
179179
integer :: j, k
180180
real :: y
181181
c
@@ -187,7 +187,7 @@ subroutine yindex(jhmin, jhmax, flne, jh, i3, eta)
187187
jh(k) = j + k - 2
188188
enddo
189189
eta = 2.*(y-j)-1
190-
c
190+
c
191191
return
192192
end subroutine yindex
193193

@@ -196,8 +196,8 @@ subroutine findux(flr, xi, eta, ux)
196196
implicit none
197197
real, intent(in) :: flr(4, 4), xi, eta
198198
real, intent(out) :: ux
199-
c local variables
200-
integer :: i, j
199+
c local variables
200+
integer :: i, j
201201
real :: uxj(4), u(4)
202202
c
203203
do j = 1, 4
@@ -209,7 +209,7 @@ subroutine findux(flr, xi, eta, ux)
209209
ux = fint(uxj, eta)
210210
c
211211
return
212-
end subroutine findux
212+
end subroutine findux
213213

214214
C**************************************
215215
function fint(u,r)
@@ -218,7 +218,7 @@ function fint(u,r)
218218
c If P(R) = u(1) u(2) u(3) u(4)
219219
c for R = -3 -1 1 3
220220
c then a cubic fit is:
221-
P(R)=(
221+
P(R)=(
222222
+ 27*(u(3)+u(2))-3*(u(1)+u(4)) +R*(
223223
+ 27*(u(3)-u(2))-(u(4)-u(1)) +R*(
224224
+ -3*(u(2)+u(3))+3*(u(4)+u(1)) +R*(
@@ -235,7 +235,7 @@ function fintp(u,r)
235235
c If P(R) = u(1) u(2) u(3) u(4)
236236
c for R = -3 -1 1 3
237237
c then a cubic fit to the derivative is:
238-
PP(R)=(
238+
PP(R)=(
239239
+ 27*(u(3)-u(2))-(u(4)-u(1)) +2.*R*(
240240
+ -3*(u(2)+u(3))+3*(u(4)+u(1)) +3.*R*(
241241
+ -3*(u(3)-u(2))+(u(4)-u(1)) )))/48.
@@ -245,14 +245,14 @@ function fintp(u,r)
245245
return
246246
end function fintp
247247
C
248-
c***********************************************************************
248+
c***********************************************************************
249249
subroutine scatt(ih, jh, rion, uf, f, umesh, semesh, dscat, ntot, epa, ierr)
250250
use op_load, only: BRCKR
251251
integer, intent(inout) :: ierr
252252
real :: umesh(:), semesh(:) ! (nptot)
253253
real :: f(:,:,:) ! (nptot,4,4)
254254
dimension rion(28, 4, 4),uf(0:100),
255-
+ fscat(0:100),p(nptot),rr(28),ih(4),jh(4)
255+
+ fscat(0:100),p(nptot),rr(28),ih(4),jh(4)
256256
integer i,j,k,n
257257
c HH: always use meshtype q='m'
258258
ite3=2
@@ -269,7 +269,7 @@ subroutine scatt(ih, jh, rion, uf, f, umesh, semesh, dscat, ntot, epa, ierr)
269269
enddo
270270
do m = 1, 28
271271
rr(m) = rion(m, i, j)
272-
enddo
272+
enddo
273273
CALL BRCKR(FT,FNE,RR,28,UF,100,FSCAT,ierr)
274274
if (ierr /= 0) return
275275
do n = 0, 100
@@ -290,20 +290,20 @@ subroutine scatt(ih, jh, rion, uf, f, umesh, semesh, dscat, ntot, epa, ierr)
290290
p(1)=p(1)+fscat(1)/(1.-.5*umin)
291291
do k=1,ntot
292292
f(k,i,j)=p(k)
293-
enddo
293+
enddo
294294
enddo
295-
enddo
295+
enddo
296296
C
297297
return
298298
end subroutine scatt
299-
c***********************************************************************
299+
c***********************************************************************
300300
subroutine screen1(ih,jh,rion,umesh,ntot,epa,f)
301301
use op_load, only: screen2
302302
real :: umesh(:) ! (nptot)
303303
real, pointer :: f(:,:,:) ! (nptot,4,4)
304-
dimension uf(0:100),
305-
+ fscat(0:100), ih(4), jh(4)
306-
real, target :: rion(28, 4, 4)
304+
dimension uf(0:100),
305+
+ fscat(0:100), ih(4), jh(4)
306+
real, target :: rion(28, 4, 4)
307307
integer i, j, k, m
308308
real, pointer :: p(:), rr(:)
309309
c
@@ -320,13 +320,13 @@ subroutine screen1(ih,jh,rion,umesh,ntot,epa,f)
320320
! enddo
321321
! do m=1,28
322322
rr => rion(1:28,i,j)
323-
! enddo
323+
! enddo
324324
call screen2(ft,fne,rr,epa,ntot,umin,umax,umesh,p)
325325
! do k=1,ntot
326326
! f(k,i,j)=p(k)
327-
! enddo
327+
! enddo
328328
enddo
329-
enddo
329+
enddo
330330
C
331331
return
332332
end subroutine screen1

‎kap/private/op_def.f90‎

Lines changed: 44 additions & 46 deletions
Original file line numberDiff line numberDiff line change
@@ -23,60 +23,58 @@
2323
!
2424
! ***********************************************************************
2525

26-
27-
MODULE op_def
28-
IMPLICIT NONE
26+
module op_def
27+
implicit none
2928

3029
integer, parameter :: nptot = 10000
3130
integer, parameter :: nrad = 17
3231
integer, parameter :: ipe = 17
3332

34-
integer,dimension(140:320),parameter :: JS=[14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 18, 19, 22, 23,&
35-
26, 27, 30, 31, 34, 34, 34, 34, 36, 36, 36, 36, 36, 36, 38, 38,&
36-
38, 38, 38, 39, 40, 40, 40, 40, 40, 41, 42, 42, 42, 42, 42, 43,&
37-
44, 44, 44, 44, 44, 45, 46, 46, 46, 46, 46, 47, 48, 48, 48, 48,&
38-
48, 49, 50, 50, 50, 50, 52, 52, 52, 52, 52, 52, 54, 54, 54, 54,&
39-
54, 54, 56, 56, 56, 56, 56, 56, 58, 58, 58, 58, 58, 58, 60, 60,&
40-
60, 60, 60, 60, 62, 62, 62, 62, 62, 63, 64, 64, 64, 64, 64, 65,&
41-
66, 66, 66, 66, 66, 67, 68, 68, 68, 68, 68, 69, 70, 70, 70, 70,&
42-
70, 71, 72, 72, 72, 72, 72, 73, 74, 74, 74, 74, 76, 76, 76, 76,&
43-
76, 76, 78, 78, 78, 78, 78, 78, 80, 80, 80, 80, 80, 80, 82, 82,&
44-
82, 82, 82, 82, 84, 84, 84, 84, 84, 84, 86, 86, 86, 86, 86, 87,&
45-
88, 88, 88, 88, 88]
33+
integer, dimension(140:320), parameter :: JS = [14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 14, 15, 18, 19, 22, 23, &
34+
26, 27, 30, 31, 34, 34, 34, 34, 36, 36, 36, 36, 36, 36, 38, 38, &
35+
38, 38, 38, 39, 40, 40, 40, 40, 40, 41, 42, 42, 42, 42, 42, 43, &
36+
44, 44, 44, 44, 44, 45, 46, 46, 46, 46, 46, 47, 48, 48, 48, 48, &
37+
48, 49, 50, 50, 50, 50, 52, 52, 52, 52, 52, 52, 54, 54, 54, 54, &
38+
54, 54, 56, 56, 56, 56, 56, 56, 58, 58, 58, 58, 58, 58, 60, 60, &
39+
60, 60, 60, 60, 62, 62, 62, 62, 62, 63, 64, 64, 64, 64, 64, 65, &
40+
66, 66, 66, 66, 66, 67, 68, 68, 68, 68, 68, 69, 70, 70, 70, 70, &
41+
70, 71, 72, 72, 72, 72, 72, 73, 74, 74, 74, 74, 76, 76, 76, 76, &
42+
76, 76, 78, 78, 78, 78, 78, 78, 80, 80, 80, 80, 80, 80, 82, 82, &
43+
82, 82, 82, 82, 84, 84, 84, 84, 84, 84, 86, 86, 86, 86, 86, 87, &
44+
88, 88, 88, 88, 88]
4645

47-
integer,dimension(140:320),parameter :: JE=[&
48-
52, 56, 56, 58, 58, 60, 60, 60, 60, 62, 62, 64, 64, 66, 66, 68,&
49-
68, 70, 70, 72, 72, 74, 74, 74, 74, 76, 76, 78, 78, 80, 80, 80,&
50-
80, 81, 82, 82, 82, 82, 82, 83, 84, 84, 84, 84, 84, 86, 86, 86,&
51-
86, 86, 86, 88, 88, 88, 88, 89, 90, 90, 90, 88, 88, 88, 88, 92,&
52-
92, 92, 92, 94, 94, 94, 94, 94, 94, 89, 90, 90, 90, 90, 90, 91,&
53-
92, 92, 92, 92, 92, 94, 94, 90, 90, 92, 92, 92, 92, 92, 92, 93,&
54-
94, 94, 94, 94, 94, 94, 94, 96, 96, 96, 96, 96, 96, 98, 98, 98,&
55-
98, 98, 98, 99,100,100,100,100,100,100,100,102,102,102,102,102,&
56-
102,103,104,104,104,104,104,104,104,106,106,106,106,106,106,107,&
57-
108,108,108,108,108,108,108,110,110,110,110,110,110,111,112,112,&
58-
112,112,112,112,112,114,114,114,114,114,114,115,116,116,116,116,&
59-
116,116,116,118,118]
46+
integer, dimension(140:320), parameter :: JE = [ &
47+
52, 56, 56, 58, 58, 60, 60, 60, 60, 62, 62, 64, 64, 66, 66, 68, &
48+
68, 70, 70, 72, 72, 74, 74, 74, 74, 76, 76, 78, 78, 80, 80, 80, &
49+
80, 81, 82, 82, 82, 82, 82, 83, 84, 84, 84, 84, 84, 86, 86, 86, &
50+
86, 86, 86, 88, 88, 88, 88, 89, 90, 90, 90, 88, 88, 88, 88, 92, &
51+
92, 92, 92, 94, 94, 94, 94, 94, 94, 89, 90, 90, 90, 90, 90, 91, &
52+
92, 92, 92, 92, 92, 94, 94, 90, 90, 92, 92, 92, 92, 92, 92, 93, &
53+
94, 94, 94, 94, 94, 94, 94, 96, 96, 96, 96, 96, 96, 98, 98, 98, &
54+
98, 98, 98, 99, 100, 100, 100, 100, 100, 100, 100, 102, 102, 102, 102, 102, &
55+
102, 103, 104, 104, 104, 104, 104, 104, 104, 106, 106, 106, 106, 106, 106, 107, &
56+
108, 108, 108, 108, 108, 108, 108, 110, 110, 110, 110, 110, 110, 111, 112, 112, &
57+
112, 112, 112, 112, 112, 114, 114, 114, 114, 114, 114, 115, 116, 116, 116, 116, &
58+
116, 116, 116, 118, 118]
6059

61-
!
62-
INTEGER,DIMENSION(17),parameter :: kz=[1,2,6,7,8,10,11,12,13,14,16,18,20,24,25,26,28]
63-
character(len=2), dimension(17),parameter :: name=['H ','He','C ','N ','O ','Ne','Na',&
64-
'Mg','Al','Si','S ','Ar','Ca','Cr','Mn',&
65-
'Fe','Ni']
66-
REAL,DIMENSION(17),PARAMETER :: AMASS=[1.0080,4.0026,12.0111,14.0067,15.9994,20.179,&
67-
22.9898,24.305,26.9815,28.086,32.06,39.948, &
68-
40.08,51.996,54.9380,55.847,58.71]
60+
integer, dimension(17), parameter :: kz = [1, 2, 6, 7, 8, 10, 11, 12, 13, 14, 16, 18, 20, 24, 25, 26, 28]
61+
character(len=2), dimension(17), parameter :: name = ['H ', 'He', 'C ', 'N ', 'O ', 'Ne', 'Na', &
62+
'Mg', 'Al', 'Si', 'S ', 'Ar', 'Ca', 'Cr', 'Mn', &
63+
'Fe', 'Ni']
64+
real, dimension(17), parameter :: AMASS = [1.0080, 4.0026, 12.0111, 14.0067, 15.9994, 20.179, &
65+
22.9898, 24.305, 26.9815, 28.086, 32.06, 39.948, &
66+
40.08, 51.996, 54.9380, 55.847, 58.71]
6967

70-
integer,save :: ite1, ite2, ite3, jne3 , ntotp, nc, nf
71-
integer,dimension(91),save :: jn1, jn2
72-
integer,dimension(17),save :: int
73-
real,save :: umin, umax
74-
real,dimension(17,91,25),save :: epatom, oplnck
75-
integer,dimension(17,91,25),save :: ne1p, ne2p,np,kp1,kp2,kp3,npp
76-
real,dimension(-1:28,28,91,25),save :: fionp
77-
real,allocatable,DIMENSION(:),save :: yy2,yx
78-
INTEGER,allocatable,DIMENSION(:),save :: nx
68+
integer, save :: ite1, ite2, ite3, jne3, ntotp, nc, nf
69+
integer, dimension(91), save :: jn1, jn2
70+
integer, dimension(17), save :: int
71+
real, save :: umin, umax
72+
real, dimension(17, 91, 25), save :: epatom, oplnck
73+
integer, dimension(17, 91, 25), save :: ne1p, ne2p, np, kp1, kp2, kp3, npp
74+
real, dimension(-1:28, 28, 91, 25), save :: fionp
75+
real, allocatable, dimension(:), save :: yy2, yx
76+
INTEGER, allocatable, dimension(:), save :: nx
7977

8078
integer, parameter :: op_cache_version = 1
8179

82-
END module op_def
80+
end module op_def

0 commit comments

Comments
 (0)