Related
I have 4 .mtx files that I am reading the values from. Two of them run perfectly when read from with no issues and produce the correct outputs into a .DAT file. However, the last 2 are extremely large files; it appears the code correctly reads from the files and runs, but I get no outputs and no errors when reading from these 2...not even the code timer prints the time. Any help is much appreciated! Here is the code:
program proj2matrixC40
implicit none
integer,parameter::dp=selected_real_kind(15,307)
! Set Global Variables
real(kind=dp), allocatable::Ax(:,:),A(:,:),Iglobal(:,:)
integer::At(1,3)
integer::nnz,w,n,k,ii,ff,kk
real(kind=dp)::t1,t2
call cpu_time(t1)
open(unit=78,file="e40r5000.mtx",status='old')
read(78,*) At
close(unit=78)
nnz = At(1,3)
n = At(1,1)
k = 40
kk = 35
allocate(Ax(nnz+1,3),A(nnz,3),Iglobal(k,k))
open(unit=61,file="e40r5000.mtx",status='old')
do w=1,nnz+1
read(61,*) Ax(w,:)
end do
open (unit = 53, file = "proj2matrixC40points.dat")
do ff=1,k
do ii=1,k
Iglobal(ii,ff) = (ii/ff)*(ff/ii)
end do
end do
A(1:nnz,:) = Ax(2:nnz+1,:)
call Arno(A)
call cpu_time(t2)
print '("Time elapsed = ",f10.8," seconds")', (t2 - t1)
contains
subroutine Arno(a)
real(kind=dp), intent(in)::a(:,:)
real(kind=dp),dimension(k,k)::H
real(kind=dp),dimension(k,k+1)::u,q,qconj
real(kind=dp),dimension(k,1)::x0
integer::j,f
call random_number(x0)
q(:,1) = x0(:,1)/norm2(x0(:,1))
do f=1,k
call spmat(a,q(:,f),u(:,f))
do j=1,f
qconj(j,:) = (q(:,j))
H(j,f) = dot_product(qconj(j,:),u(:,f))
u(:,f) = u(:,f) - H(j,f)*q(:,j)
end do
if (f.lt.k) then
H(f+1,f) = norm2(u(:,f))
if (H(f+1,f)==0) then
print *, "Matrix is reducible"
stop
end if
q(:,f+1) = u(:,f)/H(f+1,f)
end if
if (f==k) then
call qrit(H)
end if
end do
end subroutine
! QR Iteration with Shifts Subroutine
subroutine qrit(a)
real(kind=dp), intent(in)::a(:,:)
real(kind=dp)::sigmak
real(kind=dp),dimension(kk,k)::dia
real(kind=dp),dimension(k,k)::Qfinal,Rfinal,HH
real(kind=dp),dimension(k,k,kk)::H0,needQR
integer::v,z
HH = a
H0(:,:,1) = HH
do v=1,kk
sigmak = H0(k,k,v)
if (v-1==0) then
needQR(:,:,v) = HH - sigmak*Iglobal
else
needQR(:,:,v) = H0(:,:,v-1) - sigmak*Iglobal
end if
call givens2(needQR(:,:,v),Rfinal,Qfinal)
H0(:,:,v) = matmul(Rfinal,Qfinal) + sigmak*Iglobal
do z = 1,k
dia(v,z) = H0(z,z,v)
write(53,*) v," ", dia(v,z) ! Write values to .DAT file
end do
end do
end subroutine
! Sparse Matrix Vector Multiplication Subroutine
subroutine spmat(a,b,c)
real(kind=dp), intent(in)::a(:,:)
real(kind=dp), intent(in), dimension(k,1)::b
real(kind=dp), intent(out), dimension(k,1)::c
integer::m,rowi,columni
real(kind=dp), dimension(k,1)::x,y
x = b
y(:,1) = 0
do m = 1,nnz
rowi = a(m,1)
columni = a(m,2)
y(rowi,1) = y(rowi,1) + a(m,3)*x(columni,1)
end do
c(:,1) = y(:,1)
end subroutine
! QR Factorization Givens Rotations Subroutine
subroutine givens2(a,Rfinal,Qfinal)
real(kind=dp), intent(in)::a(:,:)
real(kind=dp), dimension(k,k,(k*k))::G,QQ
real(kind=dp), dimension(k,k), intent(out)::Rfinal,Qfinal
real(kind=dp), dimension(k,k)::I2,y,aa
real(kind=dp), dimension(1,k)::ek1,ek2
real(kind=dp)::c,s
integer::kt,m,nn,j,i,l,p
m = size(a,1)
nn = size(a,2)
aa = a
i = 1
do kt=1,nn-1
do j=m,kt+1,-1
if (aa(j,kt).eq.0) then
continue
else
ek1(1,:) = 0
ek2(1,:) = 0
do p=1,m
do l=1,m
I2(l,p) = (l/p)*(p/l)
end do
end do
c = aa(kt,kt)/sqrt(aa(kt,kt)**2 + aa(j,kt)**2)
s = aa(j,kt)/sqrt(aa(kt,kt)**2 + aa(j,kt)**2)
ek1(1,kt) = c
ek1(1,j) = s
ek2(1,kt) = -s
ek2(1,j) = c
I2(kt,:) = ek1(1,:)
I2(j,:) = ek2(1,:)
G(:,:,i) = I2
if (i.eq.1) then
QQ(:,:,i) = G(:,:,i)
else
QQ(:,:,i) = matmul(G(:,:,i),QQ(:,:,i-1))
end if
y = matmul(G(:,:,i),aa)
aa = y
if (kt.eq.nn-1) then
if (j.eq.kt+1) then
Qfinal = transpose(QQ(:,:,i))
Rfinal = aa
end if
end if
i = i + 1
end if
end do
end do
end subroutine
end program proj2matrixC40
A couple notes. The line which I put asterisks around (for this question) call mat_print('H',H) can't be deleted otherwise I get the wrong answers (this is strange...thoughts?). Also so your computer won't freeze opening the big files, their names are 'e40r5000.mtx' and 's3dkt3m2.mtx' (these are the two I have issues with). I am using gfortran version 8.1.0
Here is the link to the files
https://1drv.ms/f/s!AjG0dE43DVddaJfY62ABE8Yq3CI
When you need to add a call to a subroutine that shouldn't actually change anything in order to get things working, you probably have a memory corruption. This happens most often when you access arrays outside of their boundaries.
I have compiled it with some run time checks:
gfortran -o p2m -g -O0 -fbacktrace -fcheck=all -Wall proj2mat.f90
And it's already giving me some issues:
It's warning me about implicit type conversions. That shouldn't be too much of an issue if you trust your data.
In line 46 you have an array length mismatch (x0(:, 1) has length 40, q(:,1) is 41)
Similarly on line 108 (x=b) x is really large, but b is only 41 long.
I have stopped now, but I implore you to go through your code and clean it up. Use the compiler options above which will let you know when and where there is an array bound violation.
So I'm trying to come up with a clever way to make this program read a catalog and take anything falling within specific spatial "grid" boxes and average the data in that box together. I'll paste my horrid attempt below and hopefully you'll see what I'm trying to do. I can't get the program to work correctly (it gets stuck in a loop somewhere that I haven't debugged), and before I bang my head against it anymore I want to know if this looks like a logical set of operations for what I'm looking to do, or if there is a better way to accomplish this.
Edit: To clarify, the argument section is for the trimming parameters---"lmin lmax bmin bmax" set the overall frame, and "deg" sets the square-degree increments.
program redgrid
implicit none
! Variable declarations and settings:
integer :: ncrt, c, i, j, k, count, n, iarg, D, db, cn
real :: dsun, pma, pmd, epma, epmd, ra, dec, degbin
real :: V, Per, Amp, FeH, EBV, Dm, Fi, FeHav, EBVav
real :: lmin, lmax, bmin, bmax, l, b, deg, lbin, bbin
real :: bbinmax, bbinmin, lbinmax, lbinmin
character(len=60) :: infile, outfile, word, name
parameter(D=20000)
dimension :: EBV(D), FeH(D), lbinmax(D), bbinmax(D)
dimension :: bbinmin(D), lbinmin(D)
103 format(1x,i6,4x,f6.2,4x,f6.2,4x,f7.2,3x,f6.2,4x,f5.2,4x,f5.2,4x,f5.2,4x,f6.4)
3 continue
iarg=iargc()
if(iarg.lt.7) then
print*, 'Usage: redgrid infile outfile lmin lmax bmin bmax square_deg'
stop
endif
call getarg(1, infile)
call getarg(2, outfile)
call getarg(3, word)
read(word,*) lmin
call getarg(4, word)
read(word,*) lmax
call getarg(5, word)
read(word,*) bmin
call getarg(6, word)
read(word,*) bmax
call getarg(7, word)
read(word,*) deg
open(unit=1,file=infile,status='old',err=3)
open(unit=2,file=outfile,status='unknown')
write(2,*)"| l center | b center | [Fe/H] avg | E(B-V) avg | "
FeHav = 0.0
EBVav = 0.0
lbinmin(1) = lmin
bbinmin(1) = bmin
degbin = (bmax-bmin)/deg
db = NINT(degbin)
do j = 1, db
bbinmax(j) = bbinmin(j) + deg
lbinmax(j) = lbinmin(j)*cos(bbinmax(j))
print*, lbinmin(j), bbinmin(j), db
cn = 1
7 continue
read(1,*,err=7,end=8) ncrt, ra, dec, l, b,&
V, dsun, FeH(cn), EBV(cn)
if(b.ge.bbinmin(j).and.b.lt.bbinmax(j)) then
if(l.ge.lbinmin(j).and.l.lt.lbinmax(j)) then
FeHav = FeHav + FeH(cn)
EBVav = EBVav + EBV(cn)
cn = cn + 1
end if
end if
goto 7
8 continue
FeHav = FeHav/cn
EBVav = EBVav/cn
write(2,*) lbinmax(j), bbinmax(j), FeHav, EBVav
bbinmin(j+1) = bbinmin(j) + deg
lbinmin(j+1) = lbinmin(j) + deg
end do
close(1)
close(2)
end program redgrid
Below is a small section of the table I'm working with. "l" and "b" are the two coordinates I am working with---they are angular, hence the need to make the grid components "b" and "l*cos(b)." For each 0.5 x 0.5 degree section, I need to have averages of E(B-V) and [Fe/H] within that block. When I write the file all I need are four columns: the two coordinates where the box is located, and the two averages for that box.
| Ncrt | ra | dec | l | b | V | dkpc | [Fe/H] | E(B-V) |
7888 216.53 -43.85 -39.56 15.78 15.68 8.90 -1.19 0.1420
7889 217.49 -43.13 -38.61 16.18 16.15 10.67 -1.15 0.1750
7893 219.16 -43.26 -37.50 15.58 15.38 7.79 -1.40 0.1580
Right now, the program gets stuck somewhere in the loop cycle. I've pasted the terminal output that happens when I run it, along with the command line I'm running it with. Please let me know if I can help clarify. This is a pretty complex problem for a Fortran rookie such as myself---perhaps I'm missing some fundamental knowledge that would make it much easier. Anyways, thanks in advance.
./redgrid table2.above redtest.trim -40 0 15 30 0.5
-40.0000000 15.0000000 30 0.00000000 0.00000000
-39.5000000 15.5000000 30 -1.18592596 0.353437036
^it gets stuck after two lines.
I assume that the program does what you want it to do, but you are looking for a few things to tidy the code up.
Well first up, I'd fix up the indentation.
Secondly, I'd not use unit numbers below 10.
INTEGER, PARAMETER :: in_unit = 100
INTEGER, PARAMETER :: out_unit = 101
...
OPEN(unit=in_unit, file=infile, status='OLD")
...
READ(in_unit, *) ...
...
CLOSE(in_unit)
Thirdly, I'd not use GOTOs and labels. You can do that in a loop far easier:
INTEGER :: read_status
DO j = 1, db
...
read_loop : DO
READ(in_unit, *, IOSTAT=read_status) ...
IF (read_status == -1) THEN ! EOF
EXIT read_loop
ELSEIF (read_status /= 0) THEN
CYCLE read_loop
ENDIF
...
END DO read_loop
...
END DO
There are a few dangers in your code, and even in this one above: It can lead to infinite loops. For example, if the opening of infile fails (e.g. the file doesn't exist), it loops back to label 3, but nothing changes, so it will eventually again try to open the same file, and probably have the same error.
Same above: If READ repeatedly fails without advancing, and without the error being an EOF, then the read loop will not terminate.
You have to think about what you want your program to do when something like this happens, and code it in. (For example: Print an error message and STOP if it can't open the file.)
You have a very long FORMAT statement. You can leave it like that, though I'd probably try to shorten it a bit:
103 FORMAT(I7, 2F10.2, F11.2, 4F9.2, F10.4)
This should be the same line, as numbers are usually right-aligned. You can also use strings as a format, so you could also do something like this:
CHARACTER(LEN=*), PARAMETER :: data_out_form = &
'(I7, 2F10.2, F11.2, 4F9.2, F10.4)'
WRITE(*, data_out_form) var1, var2, var3, ...
and again, that's one less label.
I receive the following error
Compiling file: tropic.f
Warning: Extension: Tab character in format at (1)
C:\Users\Marchant\Desktop\tropic.f(432) : error - Expected a right parenthesis in expression at column 72
Warning: Rank mismatch in argument 'tk' at (1) (scalar and rank-1)
Warning: Rank mismatch in argument 't' at (1) (scalar and rank-1)
Warning: Rank mismatch in argument 'tk' at (1) (scalar and rank-1)
Warning: Rank mismatch in argument 't' at (1) (scalar and rank-1)
Compilation failed.
in this program,
dimension ts1(3),ts2(3),ta1(3),ta2(3),out(14,300)
real lwc, lambda
common /params/xkap,pr,tr,xl,cp,rgas,grav,taue,taus,taup,tauc
common /param2/ pbot,ptop,dp,gam, bt,ct,tao,a21,lambda,lwc
common /heat/ beta,olr1,olr2,alb0,albgr,expo1,expo2,alb1,alb2
pbot=1.0e5
ptop=2.0e4
dp=pbot-ptop
open(12,file='tropic.in',form='formatted')
read(12,*) itermx, delt, iprint
read(12,*) lambda, gam, bt, ct, a1
read(12,*) beta,olr1,olr2,alb0,albgr,expo1,expo2
write(*,*) 'olr1=',olr1,', olr2=',olr2,', expo1=',expo1,', expo2='
1 ,expo2
c ** Set relative areas of convecting a1 and nonconvecting a2 regions.
c a1=.3
tao=265.
alpha=0.06
alpha2=alpha/2.
alpha1=1.-alpha
c expo1=80.
c expo2=80.
expa1=0.
expa2=0.
co=4.2e7
ca=1.0e7
xkap=0.288
rvap=461.
cp=1004.
rgas=287.
grav=9.81
c gam=1.0e-3
c lambda=1.0e3
pr=1.0e5
tr=300.
xl=2.5e6
write(*,*) ' gam=',gam
c** structure of output array
c out(1)=a1; 2=gam; 3=lambda
c 4=ts1 5=ts2 6=alb1 7=alb2
c 8=r1 9=r2 10=ts1tend 11=ts2tend
c 13=thet1 14=thet2
ikase=0
c ********* BIG LOOP ****************
do 888 nn=1,2
a1=0.1+0.2*nn
do 888 ll=1,7
c gam=1.0e-3*facg
gam=1/1024.*2.0**(ll-1)
do 888 mm=1,7
c lambda=1.0e+3*facl
lambda=64*2.0**(mm-1)
c write(*,*) '*******************************'
c write(*,*) 'GAM=',gam,', LAMBDA=',lambda,', A1=',a1
a2=1.-a1
a21=a2/a1
a12=a1/a2
c initialize variables
do i = 1,3
ts1(i)=301.
ts2(i)=300.
ta1(i)=302.
ta2(i)=300.
end do
is=1
js=2
tdelto=2.*delt/co
tdelta=2.*delt/ca
c write(*,999) ts1(js),ts2(js),ta1(js),ta2(js),r1,r2,ra1,ra2
999 format(1x,9f8.1)
c write(*,*) pbot,ptop,dp,pr,gam,bt,ct,tao,a21,lambda,lwc
ikase=ikase+1
c*** Time Loop *****
do 1000 it=1,itermx
dta=ta1(js)-ta2(js)
dto=ts1(js)-ts2(js)
call radiat(ts1(js),ts2(js),ta1(js),ta2(js),r1,r2,ra1,ra2)
call theta(ts1(js),ts2(js),ta1(js),ta2(js),demdp,demd2,deddp)
c** Note that demdp = del(theta)/grav
ts1(3)=ts1(is)+tdelto*(r1-gam*dto*cp*demdp-expo1)
ts2(3)=ts2(is)+tdelto*(r2+a12*gam*dto*cp*demdp-expo2)
c ta1(3)=ta1(is)+tdelta*(ra1-a21*gam*dto*cp*demdp-expa1)
c ta2(3)=ta2(is)+tdelta*(ra2+gam*dto*cp*deddp-expa2)
c apply Robert/Asselin filter
ts1(js)=ts1(js)*alpha1 +alpha2*(ts1(3)+ts1(is))
ts2(js)=ts2(js)*alpha1 +alpha2*(ts2(3)+ts2(is))
c if((it-1)/iprint*iprint.eq.it-1) then
if((it.eq.itermx)) then
time=(it-1)*delt/86400.
ts1tend=(r1-gam*dto*cp*demdp-expo1)*86400./co
ts2tend=(r2+a12*gam*dto*cp*demdp-expo2)*86400./co
c ta1tend=(-a21*gam*dto*cp*demdp)
c ta2tend=( gam*dto*cp*demdp)
thet1=thet(ts1,qsat(ts1,pbot),pbot)
thet2=thet(ts2,qsat(ts2,pbot),pbot)
c** structure of output array
c out(1)=a1; 2=gam; 3=lambda
c 4=ts1 5=ts2 6=alb1 7=alb2
c 8=r1 9=r2 10=ts1tend 11=ts2tend
c 12=thet1 13=thet2
c Set up array
out(1,ikase)=a1
out(2,ikase)=gam
out(3,ikase)=lambda
out(4,ikase)=ts1(js)
out(5,ikase)=ts2(js)
out(6,ikase)=alb1
out(7,ikase)=alb2
out(8,ikase)=r1
out(9,ikase)=r2
out(10,ikase)=ts1tend
out(11,ikase)=ts2tend
out(12,ikase)=thet1
out(13,ikase)=thet2
out(14,ikase)=qsat(ts1(js),pr)
c write(*,*) 'Day=',time, ', iter=',it
c write(*,*) a21,gam,dto,cp,demdp
c write(*,*) 'demdp, demd2,deddp', demdp, demd2,deddp
c write(*,*) 'lwc=',lwc,alb1, alb2
c*********x*********x*********x*********x*********x*********x*********x**********
c write(*,*) ' ts1, ts2, ta1, ta2, r1, r2, ra1,
c 1 ra2'
c write(*,999) ts1(3),ts2(3),ta1(3),ta2(3),r1,r2,ra1,ra2
c write(*,999) ts1(js),ts2(js),ta1(js),ta2(js),r1,r2,ra1,ra2
c write(*,998) ts1tend,ts2tend,ta1tend,ta2tend, thet1, thet2
998 format(1x,8f10.5)
endif
c ** Update Variables
is=3-is
js=3-js
ts1(js)=ts1(3)
ts2(js)=ts2(3)
ta1(js)=ta1(3)
ta2(js)=ta2(3)
1000 continue
888 continue
open(13,file='tropic.out',form='formatted')
c*********x*********x*********x*********x*********x*********x*********x**********
write(*,*) ' A1 gam lambda ts1 ts2 alb1
1alb2 r1 r2 ts1tend ts2tend thet1 thet2 qsat'
write(13,*) ' A1 gam lambda ts1 ts2 alb1
1alb2 r1 r2 ts1tend ts2tend thet1 thet2 qsat'
do ii=1,ikase
xkrap=out(2,ii)*out(3,ii)
write(*,789) (out(j,ii),j=1,14),xkrap
write(13,789) (out(j,ii),j=1,14),xkrap
789 format(1x,f6.1,f9.5,7f9.2,2f9.5,2f8.2,2f8.4)
enddo
stop
end
c ******************************************************
subroutine theta(ts1,ts2,ta1,ta2,demdp,demd2,deddp)
c ** This subroutine finds the theta gradients
real lwc, lambda
common /param2/ pbot,ptop,dp,gam, bt,ct,tao,a21,lambda,lwc
common /params/xkap,pr,tr,xl,cp,rgas,grav,taue,taus,taup,tauc
demdp=(thet(ts1,qsat(ts1,pbot),pbot)-thet(ts2,qsat(ts2,pbot),
1 pbot))/9.81
c 1 pbot))/dp
demd2=(thet(ta1,0.001,ptop)-thet(ts1,qsat(ts1,pbot),pbot))
1 /9.81
c 1 /dp
deddp=(thet(ts1,0.00001,ptop)-thet(ts2,0.00001,pbot))/9.81
c 1 /dp
return
end
c ******************************************************
subroutine radiat(ts1,ts2,ta1,ta2,r1,r2,ra1,ra2)
real lwc, lambda
common /param2/ pbot,ptop,dp,gam, bt,ct,tao,a21,lambda,lwc
common /params/xkap,pr,tr,xl,cp,rgas,grav,taue,taus,taup,tauc
common /heat/ beta,olr1,olr2,alb0,albgr,expo1,expo2,alb1,alb2
dta=ta1-ta2
dto=ts1-ts2
if(dto.gt.0.0) then
c ** radiation parameterization for atmosphere
ra1=-40-bt*(ta1-tao)+ct*(ts1-(ta1+29))
ra2=-200-bt*(ta2-tao)+ct*(ts2-(ta2+29))
c ** Get liquid water content
c lwc=lambda*a21*gam*abs(dto)*qsat(ts1,pr)
c ** Get albedo as function of LWC
alb2=alb0
alb1=alb0+lambda*gam*abs(dto)*qsat(ts1,pr)
if(alb1.gt.0.75) alb1=0.75
r1=400.*(1.-alb1)-olr1-beta*(ts1-300.)
r2=400.*(1.-alb2)-olr2-beta*(ts2-300.)
else
c ** here ts2 is hotter than ts1
c ** radiation parameterization for atmosphere
ra1=-200-bt*(ta1-tao)+ct*(ts1-(ta1+29))
ra2=-40-bt*(ta2-tao)+ct*(ts2-(ta2+29))
c ** Get liquid water content
c lwc=lambda*gam*abs(dto)*qsat(ts2,pr)
c ** Get albedo as function of LWC
alb1=alb0
alb2=alb0+lambda*gam*abs(dto)*qsat(ts2,pr)
if(alb2.gt.0.75) alb2=0.75
r1=400.*(1.-alb1)-olr2-beta*(ts1-300.)
r2=400.*(1.-alb2)-olr1-beta*(ts2-300.)
endif
c write(*,*) 'lwc=',lwc,', alb1,2=',alb1,alb2,', r,ra-',r1,r2,ra1,ra2
return
end
c*********x*********x*********x*********x*********x*********x*********x**********
c*************************************************************
function temp(the,rv,p)
c** Function calculates temperature given thetaE, rv and p
common /params/xkap,pr,tr,xl,cp,rgas,grav,taue,taus,taup,tauc
temp=the/((pr/p)**xkap*exp(xl*rv/(cp*tr)))
return
end
c*************************************************************
function thet(t,rv,p)
c** Function calculates thetaE given t, rv and p
common /params/xkap,pr,tr,xl,cp,rgas,grav,taue,taus,taup,tauc
thet=t*(pr/p)**xkap*exp(xl*rv/(cp*tr))
return
end
c*************************************************************
function thets(t,p)
c** Function calculates thetaEsaturate given t and p
common /params/xkap,pr,tr,xl,cp,rgas,grav,taue,taus,taup,tauc
if(t.lt.273.15) then
es=esice(t)
else
es=esat(t)
endif
rs=0.622*es/(p-es)
thets=t*(pr/p)**xkap*exp(xl*rs/(cp*tr))
return
end
c*************************************************************
subroutine plevs(p,xlp,dlp,dp)
c** Subroutine to set pressure levels
parameter(ilx=25)
dimension p(ilx),xlp(ilx),dlp(ilx),dp(ilx)
write(*,*) 'Setting Pressure Levels'
write(*,*) ' i p(i) dp(i) logp dlogp'
pmin=2000.
pmax=101300.
delpo=pmax-pmin
delp=delpo/(ilx-1)
do i=1,ilx
p(i)=pmin+(i-1.)*delp
xlp(i)=alog(p(i))
end do
do i=1,ilx-1
dlp(i)=xlp(i+1)-xlp(i)
dp(i)=p(i+1)-p(i)
end do
dlp(ilx)=0.0
do i=1,ilx
write(*,*) i,p(i),dp(i),xlp(i),dlp(i)
end do
return
end
c*************************************************************
subroutine radini(teq,p,t,sst)
c** Calculates variables needed by radiation relaxation code
parameter (ilx=25)
dimension p(ilx),t(ilx),teq(ilx)
do i=1,ilx
if(p(i).lt.12000.) then
teq(i)=t(i)
c elseif(p(i).gt.80000.) then
else
teq(i)=t(i)-10.
c teq(i)=t(i)-(p(ilx)/10000.)*2.
endif
end do
return
end
c*************************************************************
subroutine initlz(the,rt,rs,t,rv,p,sst)
c** Subroutine to set initial values of all variables
parameter (ilx=25)
dimension the(ilx),rt(ilx),rs(ilx),t(ilx),rv(ilx),
1 p(ilx)
common /params/xkap,pr,tr,xl,cp,rgas,grav,taue,taus,taup,tauc
ttrop=200.
tsurf=300.
ptrop=10000.
dtdp=(tsurf-ttrop)/(p(ilx)-ptrop)
relhum=0.80
c** Set T(p)
do i=1,ilx
if(p(i).lt.ptrop) then
t(i)=200.+10.*(ptrop-p(i))/(ptrop-p(1))
else
t(i)=200.+dtdp*(p(i)-ptrop)
endif
end do
c** Next calculate vapor mixing ratio and thetaE
write(*,*) 'index, pressure, temp., vapor mr, thetaE'
do i=1,ilx
if(p(i).lt.ptrop) then
rfrac=0.05
else
rfrac=relhum
endif
if(t(i).lt.273.) then
es=esice(t(i))
else
es=esat(t(i))
endif
rv(i)=rfrac*0.622*es/(p(i)-es)
rs(i)=0.622*es/(p(i)-es)
rt(i)=rv(i)
the(i)=t(i)*(pr/p(i))**xkap*exp(xl*rv(i)/(cp*tr))
write(*,100) i,p(i),t(i),rv(i),the(i)
100 format(1x,i3,f12.1,f7.1,e13.3,f7.1)
end do
return
end
c*************************************************************
function signum(x)
c** Hankel function
if(x.eq.0) then
signum=1.
else
signum=(abs(x)+x)*0.5/abs(x)
endif
return
end
c*************************************************************
subroutine zero(x,n)
dimension x(n)
do i=1,n
x(i)=0.0
end do
return
end
C#######################################################################
FUNCTION ESICE(TK)
C THIS FUNCTION RETURNS THE SATURATION VAPOR PRESSURE WITH RESPECT TO
C ICE ESICE (Pascals) GIVEN THE TEMPERATURE T (Kelvin). DLH 11.19.97
C THE FORMULA USED IS BASED UPON THE INTEGRATION OF THE CLAUSIUS-
C CLAPEYRON EQUATION BY GOFF AND GRATCH. THE FORMULA APPEARS ON P.350
C OF THE SMITHSONIAN METEOROLOGICAL TABLES, SIXTH REVISED EDITION,
C 1963.
DATA CTA,EIS/273.15,6.1071/
C CTA = DIFFERENCE BETWEEN KELVIN AND CELSIUS TEMPERATURE
C EIS = SATURATION VAPOR PRESSURE (MB) OVER A WATER-ICE MIXTURE AT 0C
DATA C1,C2,C3/9.09718,3.56654,0.876793/
C C1,C2,C3 = EMPIRICAL COEFFICIENTS IN THE GOFF-GRATCH FORMULA
c**** Convert to Celsius
c tc=t-273.15
IF (TK.LE.CTA) GO TO 5
ESICE = 99999.
WRITE(6,3)ESICE
3 FORMAT(' SATURATION VAPOR PRESSURE FOR ICE CANNOT BE COMPUTED',
1 /' FOR TEMPERATURE > 0C. ESICE =',F7.0)
RETURN
5 CONTINUE
C FREEZING POINT OF WATER (K)
TF = CTA
C GOFF-GRATCH FORMULA
RHS = -C1*(TF/TK-1.)-C2*ALOG10(TF/TK)+C3*(1.-TK/TF)+ALOG10(EIS)
ESI = 10.**RHS
IF (ESI.LT.0.) ESI = 0.
ESICE = ESI*100.
RETURN
END
C#######################################################################
FUNCTION ESAT(TK)
C THIS FUNCTION RETURNS THE SATURATION VAPOR PRESSURE OVER
C WATER (Pa) GIVEN THE TEMPERATURE (Kelvin). DLH 11.19.97
C THE ALGORITHM IS DUE TO NORDQUIST, W.S.,1973: "NUMERICAL APPROXIMA-
C TIONS OF SELECTED METEORLOLGICAL PARAMETERS FOR CLOUD PHYSICS PROB-
C LEMS," ECOM-5475, ATMOSPHERIC SCIENCES LABORATORY, U.S. ARMY
C ELECTRONICS COMMAND, WHITE SANDS MISSILE RANGE, NEW MEXICO 88002.
IF (TD.NE. 99999.0) THEN
C IF (TD.NE.-1001.0) THEN
c**** Convert to Celsius
c TK = TD+273.15
P1 = 11.344-0.0303998*TK
P2 = 3.49149-1302.8844/TK
C1 = 23.832241-5.02808*ALOG10(TK)
ESAT = 100.*10.**(C1-1.3816E-7*10.**P1+8.1328E-3*10.**P2-2949.076/TK)
else
esat = 0.
END IF
RETURN
END
C#######################################################################
function qsat(tk,p)
qsat=esat(tk)*0.622/p
return
end
Can someone show me how to fix this? its a fortran77 file being compiled in mingw gfortran
At least the line
ESAT = 100.*10.**(C1-1.3816E-7*10.**P1+8.1328E-3*10.**P2-2949.076/TK)
is too long for FORTRAN 77 standard. At least when the statement starts at column 7. In your code it appears to start earlier, but that is wrong.
Break it,
ESAT = 100.*10.**(C1-1.3816E-7*10.**P1+
* 8.1328E-3*10.**P2-2949.076/TK)
or use an option like
-ffixed-line-length-132
to make the limit larger (it is non-standard!).
Also many of your statements appear to start on earlier column than 7. This may be a copy-paste error to this page, it may be due to the non-conforming tab characters the compiler warns about. If it is not the case, correct it too, they must start at column 7 or further. For example, this is very strange:
IF (TD.NE. 99999.0) THEN
C IF (TD.NE.-1001.0) THEN
There may be other errors, but your code is simply too long and cannot be compiled by copy-paste.
I need to write a formated output to a string DTSTR. It use to work under layhe fortran but not gfortran
INTEGER*2 MON,DAY,YEAR,HR,MINUTE,SEC,HUND
CHARACTER DY*2
CHARACTER DTSTR*24
COMMON /RD/ DTSTR
...
...
WRITE(DTSTR,10)MON,DAY,YEAR,HR,MINUTE,DY,' ]'
10 FORMAT('[ ',I2,'-',I2.2,'-',I4,2X,I2,':',I2.2,1X,2A2)
it empty just a empty line. If i use following it correctly output. But i want to store this string. Is it possible to do that with gnu fortran.
WRITE(*,10)MON,DAY,YEAR,HR,MINUTE,DY,' ]'
update
I am trying to compile following file. I think the problem might be with the COMMON.
PROGRAM HELO
CALL DOTIME
WRITE(*,5700)DTSTR
5700 FORMAT(24X,A24/)
END
SUBROUTINE DOTIME
C
IMPLICIT NONE
INTEGER*2 MON,DAY,YEAR,HR,MINUTE,SEC,HUND
CHARACTER DY*2
CHARACTER DTSTR*24
COMMON /RD/ DTSTR
integer values(8)
call date_and_time(VALUES=values)
YEAR = values(1)
MON = values(2)
DAY = values(3)
HR = values(5)
MINUTE = values(6)
SEC = values(7)
HUND = values(8)
C =================================================
C
C Incompitable function => CALL GETDAT(YEAR,MON,DAY)
C Incompitable function => GETTIM(HR,MINUTE,SEC,HUND)
IF(HR .GE. 12)THEN
IF(HR .NE. 12)HR=HR-12
DY='PM'
ELSE
DY='AM'
ENDIF
WRITE(DTSTR,10)MON,DAY,YEAR,HR,MINUTE,DY,' ]'
10 FORMAT('[ ',I2,'-',I2.2,'-',I4,2X,I2,':',I2.2,1X,2A2)
RETURN
END
Hmm? It works just fine for me:
program testwrite
implicit none
INTEGER :: MON,DAY,YEAR,HR,MINUTE,SEC,HUND
CHARACTER(LEN=2) :: DY
CHARACTER(LEN=24) :: DTSTR
MON = 4
DAY = 27
YEAR= 2010
HR = 13
MINUTE = 27
SEC = 0
HUND = 0
DY ='WE'
WRITE(DTSTR,10)MON,DAY,YEAR,HR,MINUTE,DY,' ]'
10 FORMAT('[ ',I2,'-',I2.2,'-',I4,2X,I2,':',I2.2,1X,2A2)
print *,'<',trim(DTSTR),'>'
end program testwrite
gives
<[ 4-27-2010 13:27 WE ]>
just as one would expect. Works with several versions of gfortran I have kicking around.
Update: Yes, the problem is in your common block. The common block isn't declared in the main program. But really, it's much simpler and much, much better practice just to pass the string as an argument:
PROGRAM HELO
IMPLICIT NONE
CHARACTER(LEN=24) :: DTSTR
CALL DOTIME(DTSTR)
WRITE(*,5700)DTSTR
5700 FORMAT(24X,A24/)
END
SUBROUTINE DOTIME(DTSTR)
C
IMPLICIT NONE
INTEGER*2 MON,DAY,YEAR,HR,MINUTE,SEC,HUND
CHARACTER DY*2
CHARACTER(LEN=24), INTENT(OUT) :: DTSTR
i would like someone to assist in converting this code to C++
c ----------------------------------------------------------------------
c Calculate pressure based on the generalized Peng-Robinson equation of state.
c for water.
c Variables Used ...
c T ... temperature (K)
c P ... vapor pressure (MPa)
c V ... volume (m^3/kmol)
c ----------------------------------------------------------------------
c Instructor: Nam Sun Wang
c ----------------------------------------------------------------------
common /cblock/T
c Program Header -------------------------------------------------------
print *, 'This program calculates pressure based on the'
print *, 'generalized Peng-Robinson equation of state for water.'
print *, ' '
c Temperature ----------------------------------------------------------
print *, 'Enter temperature (K): '
read *, T
c Generate a table of P at different values of V in 0.5 increments.
print *, ' '
print *, '------------------------'
print *, ' Volume Pressure '
print *, '(m^3/kmol) (MPa) '
print *, '------------------------'
c xx.x123456789012345678 --- ruler
do i=1, 100
V = 0.5*float(i)
print 650, V, P(V)
end do
c Some formats ---------------------------------------------------------
650 format(f7.1, 1p, e18.6)
end
c ----------------------------------------------------------------------
function P(V)
c ----------------------------------------------------------------------
c Calculate pressure based on the generalized Peng-Robinson equation of state.
c for water.
c ----------------------------------------------------------------------
common /cblock/T
c Gas Constant ---------------------------------------------------------
R = 8.314E-3 ! (in MPa m3/kmol K)
c Critical parameters for water ----------------------------------------
Tc = 647.3 ! (critical temperature in K)
Pc = 22.048 ! (critical pressure in MPa)
w = 0.344 ! (acentric factor, dimensionless)
c Peng-Robinson EOS parameters -----------------------------------------
xk = 0.37464 + 1.54226*w - 0.26992*w*w
alpha = ( 1. + xk*(1.-sqrt(T/Tc)) )**2
a = 0.45724*R*R*Tc*Tc*alpha/Pc
b = 0.07780*R*Tc/Pc
P = R*T/(V-b) - a/(V*(V+b)+b*(V-b))
end
Here are Some conversions for you, have a go and then post your results. We can then help you complete it.
a message
print *, '...'
replace with
cout << "..."
a counted loop
do i=1, 100
...
end do
replace with
for(int i = 1; i <= 100; ++i) {
....
}
a comment
.... ! A comment
replace with
....; // a comment
a variable
X = 99.879
replace with
float X = 99.879
a function
function P(V)
.
.
.
P = .... ! the result
replace with
double P(double V){
.
.
.
return ....; // the result
}
I know this is late but I came here looking for an answer and found another solution.
Try the package f2c. I just used it on your code sample and it worked perfectly. Although it is a bit ugly as it links to libraries that emulate Fortran functions like print but you could just use the main logic part and do the I/O yourself.